main.mli

   1: val limit : int ref
   2: val string : string -> unit
   3: val file : string -> unit

main.ml

   1: let limit = ref 1000
   2: 
   3: let rec iter n e = (* 最適化処理をくりかえす *)
   4:   Format.eprintf "iteration %d@." n;
   5:   if n = 0 then e else
   6:   let e' = Elim.f (ConstFold.f (Inline.f (Assoc.f (Beta.f e)))) in
   7:   if e = e' then e else
   8:   iter (n - 1) e'
   9: 
  10: let lexbuf outchan l = (* バッファをコンパイルしてチャンネルへ出力する *)
  11:   Id.counter := 0;
  12:   Typing.extenv := M.empty;
  13:   Emit.f outchan
  14:     (RegAlloc.f
  15:        (Simm13.f
  16:           (Virtual.f
  17:              (Closure.f
  18:                 (iter !limit
  19:                    (Alpha.f
  20:                       (KNormal.f
  21:                          (Typing.f
  22:                             (Parser.exp Lexer.token l)))))))))
  23: 
  24: let string s = lexbuf stdout (Lexing.from_string s) (* 文字列をコンパイルして標準出力に表示する *)
  25: 
  26: let file f = (* ファイルをコンパイルしてファイルに出力する *)
  27:   let inchan = open_in (f ^ ".ml") in
  28:   let outchan = open_out (f ^ ".s") in
  29:   try
  30:     lexbuf outchan (Lexing.from_channel inchan);
  31:     close_in inchan;
  32:     close_out outchan;
  33:   with e -> (close_in inchan; close_out outchan; raise e)
  34: 
  35: let () = (* ここからコンパイラの実行が開始される *)
  36:   let files = ref [] in
  37:   Arg.parse
  38:     [("-inline", Arg.Int(fun i -> Inline.threshold := i), "maximum size of functions inlined");
  39:      ("-iter", Arg.Int(fun i -> limit := i), "maximum number of optimizations iterated")]
  40:     (fun s -> files := !files @ [s])
  41:     ("Mitou Min-Caml Compiler (C) Eijiro Sumii\n" ^
  42:      Printf.sprintf "usage: %s [-inline m] [-iter n] ...filenames without \".ml\"..." Sys.argv.(0));
  43:   List.iter
  44:     (fun f -> ignore (file f))
  45:     !files

id.ml

   1: type t = string (* 変数の名前 *)
   2: type l = L of string (* トップレベル関数やグローバル配列のラベル *)
   3: 
   4: let rec pp_list = function
   5:   | [] -> ""
   6:   | [x] -> x
   7:   | x :: xs -> x ^ " " ^ pp_list xs
   8: 
   9: let counter = ref 0
  10: let genid s =
  11:   incr counter;
  12:   Printf.sprintf "%s.%d" s !counter
  13: 
  14: let rec id_of_typ = function
  15:   | Type.Unit -> "u"
  16:   | Type.Bool -> "b"
  17:   | Type.Int -> "i"
  18:   | Type.Float -> "d"
  19:   | Type.Fun _ -> "f"
  20:   | Type.Tuple _ -> "t"
  21:   | Type.Array _ -> "a" 
  22:   | Type.Var _ -> assert false
  23: let gentmp typ =
  24:   incr counter;
  25:   Printf.sprintf "T%s%d" (id_of_typ typ) !counter

m.ml

   1: (* customized version of Map *)
   2: 
   3: module M =
   4:   Map.Make
   5:     (struct
   6:       type t = Id.t
   7:       let compare = compare
   8:     end)
   9: include M
  10: 
  11: let add_list xys env = List.fold_left (fun env (x, y) -> add x y env) env xys
  12: let add_list2 xs ys env = List.fold_left2 (fun env x y -> add x y env) env xs ys

s.ml

   1: (* customized version of Set *)
   2: 
   3: module S =
   4:   Set.Make
   5:     (struct
   6:       type t = Id.t
   7:       let compare = compare
   8:     end)
   9: include S
  10: 
  11: let of_list l = List.fold_left (fun s e -> add e s) empty l

syntax.ml

   1: type t = (* MinCamlの構文を表現するデータ型 *)
   2:   | Unit
   3:   | Bool of bool
   4:   | Int of int
   5:   | Float of float
   6:   | Not of t
   7:   | Neg of t
   8:   | Add of t * t
   9:   | Sub of t * t
  10:   | FNeg of t
  11:   | FAdd of t * t
  12:   | FSub of t * t
  13:   | FMul of t * t
  14:   | FDiv of t * t
  15:   | Eq of t * t
  16:   | NEq of t * t
  17:   | Lt of t * t
  18:   | LE of t * t
  19:   | If of t * t * t
  20:   | Let of (Id.t * Type.t) * t * t
  21:   | Var of Id.t
  22:   | LetRec of fundef list * t (* mutual recursion *)
  23:   | App of t * t list
  24:   | Tuple of t list
  25:   | LetTuple of (Id.t * Type.t) list * t * t
  26:   | Array of t * t
  27:   | Get of t * t
  28:   | Put of t * t * t
  29: and fundef = { name : Id.t * Type.t; args : (Id.t * Type.t) list; body : t }

type.ml

   1: type t = (* MinCamlの型を表現するデータ型 *)
   2:   | Unit
   3:   | Bool
   4:   | Int
   5:   | Float
   6:   | Fun of t list * t (* arguments are uncurried *)
   7:   | Tuple of t list
   8:   | Array of t
   9:   | Var of t option ref
  10: 
  11: let gentyp () = Var(ref None) (* 新しい型変数を作る *)

parser.mly

   1: %{
   2: (* parserが利用する変数、関数、型などの定義 *)
   3: open Syntax
   4: let addtyp x = (x, Type.gentyp ())
   5: %}
   6: 
   7: /* 字句を表すデータ型の定義 */
   8: %token <bool> BOOL
   9: %token <int> INT
  10: %token <float> FLOAT
  11: %token NOT
  12: %token MINUS
  13: %token PLUS
  14: %token MINUS_DOT
  15: %token PLUS_DOT
  16: %token AST_DOT
  17: %token SLASH_DOT
  18: %token EQUAL
  19: %token LESS_GREATER
  20: %token LESS_EQUAL
  21: %token GREATER_EQUAL
  22: %token LESS
  23: %token GREATER
  24: %token IF
  25: %token THEN
  26: %token ELSE
  27: %token <Id.t> IDENT
  28: %token LET
  29: %token IN
  30: %token REC
  31: %token AND
  32: %token COMMA
  33: %token ARRAY_CREATE
  34: %token DOT
  35: %token LESS_MINUS
  36: %token SEMICOLON
  37: %token LPAREN
  38: %token RPAREN
  39: %token EOF
  40: 
  41: /* 優先順位とassociativityの定義（低い方から高い方へ） */
  42: %right prec_let
  43: %right SEMICOLON
  44: %right prec_if
  45: %right LESS_MINUS
  46: %left COMMA
  47: %left EQUAL LESS_GREATER LESS GREATER LESS_EQUAL GREATER_EQUAL
  48: %left PLUS MINUS PLUS_DOT MINUS_DOT
  49: %left AST_DOT SLASH_DOT
  50: %right prec_unary_minus
  51: %left prec_app
  52: %left DOT
  53: 
  54: /* 開始記号の定義 */
  55: %type <Syntax.t> exp
  56: %start exp
  57: 
  58: %%
  59: 
  60: simple_exp: /* 括弧をつけなくても関数の引数になれる式 */
  61: | LPAREN exp RPAREN
  62:     { $2 }
  63: | LPAREN RPAREN
  64:     { Unit }
  65: | BOOL
  66:     { Bool($1) }
  67: | INT
  68:     { Int($1) }
  69: | FLOAT
  70:     { Float($1) }
  71: | IDENT
  72:     { Var($1) }
  73: | simple_exp DOT LPAREN exp RPAREN
  74:     { Get($1, $4) }
  75: 
  76: exp: /* 一般の式 */
  77: | simple_exp
  78:     { $1 }
  79: | NOT exp
  80:     %prec prec_app
  81:     { Not($2) }
  82: | MINUS exp
  83:     %prec prec_unary_minus
  84:     { Neg($2) }
  85: | exp PLUS exp /* 足し算を構文解析するルール */
  86:     { Add($1, $3) }
  87: | exp MINUS exp
  88:     { Sub($1, $3) }
  89: | exp EQUAL exp
  90:     { Eq($1, $3) }
  91: | exp LESS_GREATER exp
  92:     { NEq($1, $3) }
  93: | exp LESS exp
  94:     { Lt($1, $3) }
  95: | exp GREATER exp
  96:     { Lt($3, $1) }
  97: | exp LESS_EQUAL exp
  98:     { LE($1, $3) }
  99: | exp GREATER_EQUAL exp
 100:     { LE($3, $1) }
 101: | IF exp THEN exp ELSE exp
 102:     %prec prec_if
 103:     { If($2, $4, $6) }
 104: | MINUS_DOT exp
 105:     %prec prec_unary_minus
 106:     { FNeg($2) }
 107: | exp PLUS_DOT exp
 108:     { FAdd($1, $3) }
 109: | exp MINUS_DOT exp
 110:     { FSub($1, $3) }
 111: | exp AST_DOT exp
 112:     { FMul($1, $3) }
 113: | exp SLASH_DOT exp
 114:     { FDiv($1, $3) }
 115: | LET IDENT EQUAL exp IN exp
 116:     %prec prec_let
 117:     { Let(addtyp $2, $4, $6) }
 118: | LET REC fundefs IN exp
 119:     %prec prec_let
 120:     { LetRec($3, $5) }
 121: | exp actual_args
 122:     %prec prec_app
 123:     { App($1, $2) }
 124: | elems
 125:     { Tuple($1) }
 126: | LET LPAREN pat RPAREN EQUAL exp IN exp
 127:     { LetTuple($3, $6, $8) }
 128: | simple_exp DOT LPAREN exp RPAREN LESS_MINUS exp
 129:     { Put($1, $4, $7) }
 130: | exp SEMICOLON exp
 131:     { Let((Id.gentmp Type.Unit, Type.Unit), $1, $3) }
 132: | ARRAY_CREATE simple_exp simple_exp
 133:     %prec prec_app
 134:     { Array($2, $3) }
 135: | error
 136:     { failwith
 137:         (Printf.sprintf "parse error near characters %d-%d"
 138:            (Parsing.symbol_start ())
 139:            (Parsing.symbol_end ())) }
 140: 
 141: fundefs:
 142: | fundef AND fundefs
 143:     { $1 :: $3 }
 144: | fundef
 145:     { [$1] }
 146: 
 147: fundef:
 148: | IDENT formal_args EQUAL exp
 149:     { { name = addtyp $1; args = $2; body = $4 } }
 150: 
 151: formal_args:
 152: | IDENT formal_args
 153:     { addtyp $1 :: $2 }
 154: | IDENT
 155:     { [addtyp $1] }
 156: 
 157: actual_args:
 158: | actual_args simple_exp
 159:     %prec prec_app
 160:     { $1 @ [$2] }
 161: | simple_exp
 162:     %prec prec_app
 163:     { [$1] }
 164: 
 165: elems:
 166: | elems COMMA exp
 167:     { $1 @ [$3] }
 168: | exp COMMA exp
 169:     { [$1; $3] }
 170: 
 171: pat:
 172: | pat COMMA IDENT
 173:     { $1 @ [addtyp $3] }
 174: | IDENT COMMA IDENT
 175:     { [addtyp $1; addtyp $3] }

lexer.mll

   1: {
   2: (* lexerが利用する変数、関数、型などの定義 *)
   3: open Parser
   4: open Type
   5: }
   6: 
   7: (* 正規表現の略記 *)
   8: let space = [' ' '\t' '\n' '\r']
   9: let digit = ['0'-'9']
  10: let lower = ['a'-'z']
  11: let upper = ['A'-'Z']
  12: 
  13: rule token = parse
  14: | space+
  15:     { token lexbuf }
  16: | "(*"
  17:     { comment lexbuf; (* ネストしたコメントのためのトリック *)
  18:       token lexbuf }
  19: | '('
  20:     { LPAREN }
  21: | ')'
  22:     { RPAREN }
  23: | "true"
  24:     { BOOL(true) }
  25: | "false"
  26:     { BOOL(false) }
  27: | "not"
  28:     { NOT }
  29: | '-'? digit+ (* 整数を字句解析するルール *)
  30:     { INT(int_of_string (Lexing.lexeme lexbuf)) }
  31: | '-'? digit+ ('.' digit*)? (['e' 'E'] ['+' '-']? digit+)?
  32:     { FLOAT(float_of_string (Lexing.lexeme lexbuf)) }
  33: | '-' (* -.より後回しにしなくても良い? 最長一致? *)
  34:     { MINUS }
  35: | '+' (* +.より後回しにしなくても良い? 最長一致? *)
  36:     { PLUS }
  37: | "-."
  38:     { MINUS_DOT }
  39: | "+."
  40:     { PLUS_DOT }
  41: | "*."
  42:     { AST_DOT }
  43: | "/."
  44:     { SLASH_DOT }
  45: | '='
  46:     { EQUAL }
  47: | "<>"
  48:     { LESS_GREATER }
  49: | "<="
  50:     { LESS_EQUAL }
  51: | ">="
  52:     { GREATER_EQUAL }
  53: | '<'
  54:     { LESS }
  55: | '>'
  56:     { GREATER }
  57: | "if"
  58:     { IF }
  59: | "then"
  60:     { THEN }
  61: | "else"
  62:     { ELSE }
  63: | "let"
  64:     { LET }
  65: | "in"
  66:     { IN }
  67: | "rec"
  68:     { REC }
  69: | "and"
  70:     { AND }
  71: | ','
  72:     { COMMA }
  73: | '_'
  74:     { IDENT(Id.gentmp Type.Unit) }
  75: | "Array.create" (* [XX] ad hoc *)
  76:     { ARRAY_CREATE }
  77: | '.'
  78:     { DOT }
  79: | "<-"
  80:     { LESS_MINUS }
  81: | ';'
  82:     { SEMICOLON }
  83: | eof
  84:     { EOF }
  85: | lower (digit|lower|upper|'_')* (* 他の「予約語」より後でないといけない *)
  86:     { IDENT(Lexing.lexeme lexbuf) }
  87: | _
  88:     { failwith
  89:         (Printf.sprintf "unknown token %s near characters %d-%d"
  90:            (Lexing.lexeme lexbuf)
  91:            (Lexing.lexeme_start lexbuf)
  92:            (Lexing.lexeme_end lexbuf)) }
  93: and comment = parse
  94: | "*)"
  95:     { () }
  96: | "(*"
  97:     { comment lexbuf;
  98:       comment lexbuf }
  99: | eof
 100:     { Format.eprintf "warning: unterminated comment@." }
 101: | _
 102:     { comment lexbuf }

typing.mli

   1: exception Error of Syntax.t * Type.t * Type.t
   2: val extenv : Type.t M.t ref
   3: val f : Syntax.t -> Syntax.t

typing.ml

   1: (* type inference/reconstruction *)
   2: 
   3: open Syntax
   4: 
   5: exception Unify of Type.t * Type.t
   6: exception Error of t * Type.t * Type.t
   7: 
   8: let extenv = ref M.empty
   9: 
  10: (* for pretty printing (and type normalization) *)
  11: let rec deref_typ = function (* 型変数を中身でおきかえる関数 *)
  12:   | Type.Fun(t1s, t2) -> Type.Fun(List.map deref_typ t1s, deref_typ t2)
  13:   | Type.Tuple(ts) -> Type.Tuple(List.map deref_typ ts)
  14:   | Type.Array(t) -> Type.Array(deref_typ t)
  15:   | Type.Var({ contents = None } as r) ->
  16:       Format.eprintf "uninstantiated type variable detected; assuming int@.";
  17:       r := Some(Type.Int);
  18:       Type.Int
  19:   | Type.Var({ contents = Some(t) } as r) ->
  20:       let t' = deref_typ t in
  21:       r := Some(t');
  22:       t'
  23:   | t -> t
  24: let rec deref_id_typ (x, t) = (x, deref_typ t)
  25: let rec deref_term = function
  26:   | Not(e) -> Not(deref_term e)
  27:   | Neg(e) -> Neg(deref_term e)
  28:   | Add(e1, e2) -> Add(deref_term e1, deref_term e2)
  29:   | Sub(e1, e2) -> Sub(deref_term e1, deref_term e2)
  30:   | Eq(e1, e2) -> Eq(deref_term e1, deref_term e2)
  31:   | NEq(e1, e2) -> NEq(deref_term e1, deref_term e2)
  32:   | Lt(e1, e2) -> Lt(deref_term e1, deref_term e2)
  33:   | LE(e1, e2) -> LE(deref_term e1, deref_term e2)
  34:   | FNeg(e) -> FNeg(deref_term e)
  35:   | FAdd(e1, e2) -> FAdd(deref_term e1, deref_term e2)
  36:   | FSub(e1, e2) -> FSub(deref_term e1, deref_term e2)
  37:   | FMul(e1, e2) -> FMul(deref_term e1, deref_term e2)
  38:   | FDiv(e1, e2) -> FDiv(deref_term e1, deref_term e2)
  39:   | If(e1, e2, e3) -> If(deref_term e1, deref_term e2, deref_term e3)
  40:   | Let(xt, e1, e2) -> Let(deref_id_typ xt, deref_term e1, deref_term e2)
  41:   | LetRec(fundefs, e2) ->
  42:       LetRec(List.map
  43:                (fun { name = xt; args = yts; body = e1 } ->
  44:                  { name = deref_id_typ xt;
  45:                    args = List.map deref_id_typ yts;
  46:                    body = deref_term e1 })
  47:                fundefs,
  48:              deref_term e2)
  49:   | App(e, es) -> App(deref_term e, List.map deref_term es)
  50:   | Tuple(es) -> Tuple(List.map deref_term es)
  51:   | LetTuple(xts, e1, e2) -> LetTuple(List.map deref_id_typ xts, deref_term e1, deref_term e2)
  52:   | Array(e1, e2) -> Array(deref_term e1, deref_term e2)
  53:   | Get(e1, e2) -> Get(deref_term e1, deref_term e2)
  54:   | Put(e1, e2, e3) -> Put(deref_term e1, deref_term e2, deref_term e3)
  55:   | e -> e
  56: 
  57: let rec occur r1 = function (* occur check *)
  58:   | Type.Fun(t2s, t2) -> List.exists (occur r1) t2s || occur r1 t2
  59:   | Type.Tuple(t2s) -> List.exists (occur r1) t2s
  60:   | Type.Array(t2) -> occur r1 t2
  61:   | Type.Var(r2) when r1 == r2 -> true
  62:   | Type.Var({ contents = None }) -> false
  63:   | Type.Var({ contents = Some(t2) }) -> occur r1 t2
  64:   | _ -> false
  65: 
  66: let rec unify t1 t2 = (* 型が合うように、型変数への代入をする *)
  67:   match t1, t2 with
  68:   | Type.Unit, Type.Unit | Type.Bool, Type.Bool | Type.Int, Type.Int | Type.Float, Type.Float -> ()
  69:   | Type.Fun(t1s, t1'), Type.Fun(t2s, t2') ->
  70:       (try List.iter2 unify t1s t2s
  71:       with Invalid_argument("List.iter2") -> raise (Unify(t1, t2)));
  72:       unify t1' t2'
  73:   | Type.Tuple(t1s), Type.Tuple(t2s) ->
  74:       (try List.iter2 unify t1s t2s
  75:       with Invalid_argument("List.iter2") -> raise (Unify(t1, t2)))
  76:   | Type.Array(t1), Type.Array(t2) -> unify t1 t2
  77:   | Type.Var(r1), Type.Var(r2) when r1 == r2 -> ()
  78:   | Type.Var({ contents = Some(t1') }), _ -> unify t1' t2
  79:   | _, Type.Var({ contents = Some(t2') }) -> unify t1 t2'
  80:   | Type.Var({ contents = None } as r1), _ -> (* 一方が未定義の型変数の場合 *)
  81:       if occur r1 t2 then raise (Unify(t1, t2));
  82:       r1 := Some(t2)
  83:   | _, Type.Var({ contents = None } as r2) ->
  84:       if occur r2 t1 then raise (Unify(t1, t2));
  85:       r2 := Some(t1)
  86:   | _, _ -> raise (Unify(t1, t2))
  87: 
  88: let rec g env e = (* 型推論ルーチン *)
  89:   try
  90:     match e with
  91:     | Unit -> Type.Unit
  92:     | Bool(_) -> Type.Bool
  93:     | Int(_) -> Type.Int
  94:     | Float(_) -> Type.Float
  95:     | Not(e) ->
  96:         unify Type.Bool (g env e);
  97:         Type.Bool
  98:     | Neg(e) ->
  99:         unify Type.Int (g env e);
 100:         Type.Int
 101:     | Add(e1, e2) | Sub(e1, e2) -> (* 足し算（と引き算）の型推論 *)
 102:         unify Type.Int (g env e1);
 103:         unify Type.Int (g env e2);
 104:         Type.Int
 105:     | FNeg(e) ->
 106:         unify Type.Float (g env e);
 107:         Type.Float
 108:     | FAdd(e1, e2) | FSub(e1, e2) | FMul(e1, e2) | FDiv(e1, e2) ->
 109:         unify Type.Float (g env e1);
 110:         unify Type.Float (g env e2);
 111:         Type.Float
 112:     | Eq(e1, e2) | NEq(e1, e2) | Lt(e1, e2) | LE(e1, e2) ->
 113:         unify (g env e1) (g env e2);
 114:         Type.Bool
 115:     | If(e1, e2, e3) ->
 116:         unify (g env e1) Type.Bool;
 117:         let t2 = g env e2 in
 118:         let t3 = g env e3 in
 119:         unify t2 t3;
 120:         t2
 121:     | Let((x, t), e1, e2) -> (* letの型推論 *)
 122:         unify t (g env e1);
 123:         g (M.add x t env) e2
 124:     | Var(x) when M.mem x env -> M.find x env (* 変数の型推論 *)
 125:     | Var(x) when M.mem x !extenv -> M.find x !extenv
 126:     | Var(x) -> (* 外部変数の型推論 *)
 127:         Format.eprintf "free variable %s assumed as external@." x;
 128:         let t = Type.gentyp () in
 129:         extenv := M.add x t !extenv;
 130:         t
 131:     | LetRec(fundefs, e2) -> (* let recの型推論 *)
 132:         let env =
 133:           M.add_list
 134:             (List.map (fun fundef -> fundef.name) fundefs)
 135:             env in
 136:         List.iter
 137:           (fun { name = (x, t); args = yts; body = e1 } ->
 138:             unify t (Type.Fun(List.map snd yts, g (M.add_list yts env) e1)))
 139:           fundefs;
 140:         g env e2
 141:     | App(e, es) -> (* 関数適用の型推論 *)
 142:         let t = Type.gentyp () in
 143:         unify (g env e) (Type.Fun(List.map (g env) es, t));
 144:         t
 145:     | Tuple(es) -> Type.Tuple(List.map (g env) es)
 146:     | LetTuple(xts, e1, e2) ->
 147:         unify (Type.Tuple(List.map snd xts)) (g env e1);
 148:         g (M.add_list xts env) e2
 149:     | Array(e1, e2) -> (* must be a primitive for "polymorphic" typing *)
 150:         unify (g env e1) Type.Int;
 151:         Type.Array(g env e2)
 152:     | Get(e1, e2) ->
 153:         let t = Type.gentyp () in
 154:         unify (Type.Array(t)) (g env e1);
 155:         unify Type.Int (g env e2);
 156:         t
 157:     | Put(e1, e2, e3) ->
 158:         let t = g env e3 in
 159:         unify (Type.Array(t)) (g env e1);
 160:         unify Type.Int (g env e2);
 161:         Type.Unit
 162:   with Unify(t1, t2) -> raise (Error(deref_term e, deref_typ t1, deref_typ t2))
 163: 
 164: let f e =
 165:   extenv := M.empty;
 166: (*
 167:   (match deref_typ (g M.empty e) with
 168:   | Type.Unit -> ()
 169:   | _ -> Format.eprintf "warning: final result does not have type unit@.");
 170: *)
 171:   (try unify Type.Unit (g M.empty e)
 172:   with Unify _ -> failwith "top level does not have type unit");
 173:   extenv := M.map deref_typ !extenv;
 174:   deref_term e

kNormal.mli

   1: type t =
   2:   | Unit
   3:   | Int of int
   4:   | Float of float
   5:   | Neg of Id.t
   6:   | Add of Id.t * Id.t
   7:   | Sub of Id.t * Id.t
   8:   | FNeg of Id.t
   9:   | FAdd of Id.t * Id.t
  10:   | FSub of Id.t * Id.t
  11:   | FMul of Id.t * Id.t
  12:   | FDiv of Id.t * Id.t
  13:   | IfEq of Id.t * Id.t * t * t
  14:   | IfLE of Id.t * Id.t * t * t
  15:   | Let of (Id.t * Type.t) * t * t
  16:   | Var of Id.t
  17:   | LetRec of fundef list * t
  18:   | App of Id.t * Id.t list
  19:   | Tuple of Id.t list
  20:   | LetTuple of (Id.t * Type.t) list * Id.t * t
  21:   | Get of Id.t * Id.t
  22:   | Put of Id.t * Id.t * Id.t
  23:   | ExtArray of Id.t
  24:   | ExtFunApp of Id.t * Id.t list
  25: and fundef = { name : Id.t * Type.t; args : (Id.t * Type.t) list; body : t }
  26: 
  27: val fv : t -> S.t
  28: val f : Syntax.t -> t

kNormal.ml

   1: (* give names to intermediate values (K-normalization) *)
   2: 
   3: type t = (* K正規化後の式 *)
   4:   | Unit
   5:   | Int of int
   6:   | Float of float
   7:   | Neg of Id.t
   8:   | Add of Id.t * Id.t
   9:   | Sub of Id.t * Id.t
  10:   | FNeg of Id.t
  11:   | FAdd of Id.t * Id.t
  12:   | FSub of Id.t * Id.t
  13:   | FMul of Id.t * Id.t
  14:   | FDiv of Id.t * Id.t
  15:   | IfEq of Id.t * Id.t * t * t (* 比較 + 分岐 *)
  16:   | IfLE of Id.t * Id.t * t * t (* 比較 + 分岐 *)
  17:   | Let of (Id.t * Type.t) * t * t
  18:   | Var of Id.t
  19:   | LetRec of fundef list * t
  20:   | App of Id.t * Id.t list
  21:   | Tuple of Id.t list
  22:   | LetTuple of (Id.t * Type.t) list * Id.t * t
  23:   | Get of Id.t * Id.t
  24:   | Put of Id.t * Id.t * Id.t
  25:   | ExtArray of Id.t
  26:   | ExtFunApp of Id.t * Id.t list
  27: and fundef = { name : Id.t * Type.t; args : (Id.t * Type.t) list; body : t }
  28: 
  29: let rec fv = function (* 式に出現する（自由な）変数 *)
  30:   | Unit | Int(_) | Float(_) | ExtArray(_) -> S.empty
  31:   | Neg(x) | FNeg(x) -> S.singleton x
  32:   | Add(x, y) | Sub(x, y) | FAdd(x, y) | FSub(x, y) | FMul(x, y) | FDiv(x, y) | Get(x, y) -> S.of_list [x; y]
  33:   | IfEq(x, y, e1, e2) | IfLE(x, y, e1, e2) -> S.add x (S.add y (S.union (fv e1) (fv e2)))
  34:   | Let((x, t), e1, e2) -> S.union (fv e1) (S.remove x (fv e2))
  35:   | Var(x) -> S.singleton x
  36:   | LetRec(fundefs, e2) ->
  37:       let (xs, zs) =
  38:         List.fold_left
  39:           (fun (xs, zs) { name = (x, t); args = yts; body = e1 } ->
  40:             (S.add x xs,
  41:              S.union zs (S.diff (fv e1) (S.of_list (List.map fst yts)))))
  42:           (S.empty, S.empty)
  43:           fundefs in
  44:       S.diff (S.union zs (fv e2)) xs
  45:   | App(x, ys) -> S.of_list (x :: ys)
  46:   | Tuple(xs) | ExtFunApp(_, xs) -> S.of_list xs
  47:   | Put(x, y, z) -> S.of_list [x; y; z]
  48:   | LetTuple(xs, y, e) -> S.add y (S.diff (fv e) (S.of_list (List.map fst xs)))
  49: 
  50: let insert_let (e, t) k = (* letを挿入する補助関数 *)
  51:   match e with
  52:   | Var(x) -> k x
  53:   | _ ->
  54:       let x = Id.gentmp t in
  55:       let e', t' = k x in
  56:       Let((x, t), e, e'), t'
  57: 
  58: let rec g env = function (* K正規化ルーチン本体 *)
  59:   | Syntax.Unit -> Unit, Type.Unit
  60:   | Syntax.Bool(b) -> Int(if b then 1 else 0), Type.Int (* 論理値true, falseを整数1, 0に変換 *)
  61:   | Syntax.Int(i) -> Int(i), Type.Int
  62:   | Syntax.Float(d) -> Float(d), Type.Float
  63:   | Syntax.Not(e) -> g env (Syntax.If(e, Syntax.Bool(false), Syntax.Bool(true)))
  64:   | Syntax.Neg(e) ->
  65:       insert_let (g env e)
  66:         (fun x -> Neg(x), Type.Int)
  67:   | Syntax.Add(e1, e2) -> (* 足し算のK正規化 *)
  68:       insert_let (g env e1)
  69:         (fun x -> insert_let (g env e2)
  70:             (fun y -> Add(x, y), Type.Int))
  71:   | Syntax.Sub(e1, e2) ->
  72:       insert_let (g env e1)
  73:         (fun x -> insert_let (g env e2)
  74:             (fun y -> Sub(x, y), Type.Int))
  75:   | Syntax.FNeg(e) ->
  76:       insert_let (g env e)
  77:         (fun x -> FNeg(x), Type.Float)
  78:   | Syntax.FAdd(e1, e2) ->
  79:       insert_let (g env e1)
  80:         (fun x -> insert_let (g env e2)
  81:             (fun y -> FAdd(x, y), Type.Float))
  82:   | Syntax.FSub(e1, e2) ->
  83:       insert_let (g env e1)
  84:         (fun x -> insert_let (g env e2)
  85:             (fun y -> FSub(x, y), Type.Float))
  86:   | Syntax.FMul(e1, e2) ->
  87:       insert_let (g env e1)
  88:         (fun x -> insert_let (g env e2)
  89:             (fun y -> FMul(x, y), Type.Float))
  90:   | Syntax.FDiv(e1, e2) ->
  91:       insert_let (g env e1)
  92:         (fun x -> insert_let (g env e2)
  93:             (fun y -> FDiv(x, y), Type.Float))
  94:   | Syntax.Eq _ | Syntax.NEq _ | Syntax.Lt _ | Syntax.LE _ as cmp ->
  95:       g env (Syntax.If(cmp, Syntax.Bool(true), Syntax.Bool(false)))
  96:   | Syntax.If(Syntax.Not(e1), e2, e3) -> g env (Syntax.If(e1, e3, e2)) (* notによる分岐を変換 *)
  97:   | Syntax.If(Syntax.Eq(e1, e2), e3, e4) ->
  98:       insert_let (g env e1)
  99:         (fun x -> insert_let (g env e2)
 100:             (fun y ->
 101:               let e3', t3 = g env e3 in
 102:               let e4', t4 = g env e4 in
 103:               IfEq(x, y, e3', e4'), t3))
 104:   | Syntax.If(Syntax.NEq(e1, e2), e3, e4) -> g env (Syntax.If(Syntax.Eq(e1, e2), e4, e3))
 105:   | Syntax.If(Syntax.Lt(e1, e2), e3, e4) -> g env (Syntax.If(Syntax.LE(e2, e1), e4, e3))
 106:   | Syntax.If(Syntax.LE(e1, e2), e3, e4) ->
 107:       insert_let (g env e1)
 108:         (fun x -> insert_let (g env e2)
 109:             (fun y ->
 110:               let e3', t3 = g env e3 in
 111:               let e4', t4 = g env e4 in
 112:               IfLE(x, y, e3', e4'), t3))
 113:   | Syntax.If(e1, e2, e3) -> g env (Syntax.If(Syntax.NEq(e1, Syntax.Bool(false)), e2, e3)) (* 比較のない分岐を変換 *)
 114:   | Syntax.Let((x, t), e1, e2) ->
 115:       let e1', t1 = g env e1 in
 116:       let e2', t2 = g (M.add x t env) e2 in
 117:       Let((x, t), e1', e2'), t2
 118:   | Syntax.Var(x) when M.mem x env -> Var(x), M.find x env
 119:   | Syntax.Var(x) -> (* 外部配列の参照 *)
 120:       (match M.find x !Typing.extenv with
 121:       | Type.Array(_) as t -> ExtArray x, t
 122:       | _ -> failwith (Printf.sprintf "external variable %s does not have an array type" x))
 123:   | Syntax.LetRec(fundefs, e2) ->
 124:       let env' =
 125:         M.add_list
 126:           (List.map (fun fundef -> fundef.Syntax.name) fundefs)
 127:           env in
 128:       let e2', t2 = g env' e2 in
 129:       LetRec(List.map
 130:                (fun { Syntax.name = xt; Syntax.args = yts; Syntax.body = e1 } ->
 131:                  let e1', t1 = g (M.add_list yts env') e1 in
 132:                  { name = xt; args = yts; body = e1' })
 133:                fundefs,
 134:              e2'),
 135:       t2
 136:   | Syntax.App(Syntax.Var(f), e2s) when not (M.mem f env) -> (* 外部関数の呼び出し *)
 137:       (match M.find f !Typing.extenv with
 138:       | Type.Fun(_, t) ->
 139:           let rec bind xs = function (* "xs" are identifiers for the arguments *)
 140:             | [] -> ExtFunApp(f, xs), t
 141:             | e2 :: e2s ->
 142:                 insert_let (g env e2)
 143:                   (fun x -> bind (xs @ [x]) e2s) in
 144:           bind [] e2s (* left-to-right evaluation *)
 145:       | _ -> assert false)
 146:   | Syntax.App(e1, e2s) ->
 147:       (match g env e1 with
 148:       | e1', Type.Fun(_, t) as et1 ->
 149:           insert_let et1
 150:             (fun f ->
 151:               let rec bind xs = function (* "xs" are identifiers for the arguments *)
 152:                 | [] -> App(f, xs), t
 153:                 | e2 :: e2s ->
 154:                     insert_let (g env e2)
 155:                       (fun x -> bind (xs @ [x]) e2s) in
 156:               bind [] e2s) (* left-to-right evaluation *)
 157:       | _ -> assert false)
 158:   | Syntax.Tuple(es) ->
 159:       let rec bind xs ts = function (* "xs" and "ts" are identifiers and types for the elements *)
 160:         | [] -> Tuple(xs), Type.Tuple(ts)
 161:         | e :: es ->
 162:             let _, t as et = g env e in
 163:             insert_let et
 164:               (fun x -> bind (xs @ [x]) (ts @ [t]) es) in
 165:       bind [] [] es
 166:   | Syntax.LetTuple(xts, e1, e2) ->
 167:       insert_let (g env e1)
 168:         (fun y ->
 169:           let e2', t2 = g (M.add_list xts env) e2 in
 170:           LetTuple(xts, y, e2'), t2)
 171:   | Syntax.Array(e1, e2) ->
 172:       insert_let (g env e1)
 173:         (fun x ->
 174:           let _, t2 as et2 = g env e2 in
 175:           insert_let et2
 176:             (fun y ->
 177:               let l =
 178:                 match t2 with
 179:                 | Type.Float -> "create_float_array"
 180:                 | _ -> "create_array" in
 181:               ExtFunApp(l, [x; y]), Type.Array(t2)))
 182:   | Syntax.Get(e1, e2) ->
 183:       (match g env e1 with
 184:       |        e1', Type.Array(t) as et1 ->
 185:           insert_let et1
 186:             (fun x -> insert_let (g env e2)
 187:                 (fun y -> Get(x, y), t))
 188:       | _ -> assert false)
 189:   | Syntax.Put(e1, e2, e3) ->
 190:       insert_let (g env e1)
 191:         (fun x -> insert_let (g env e2)
 192:             (fun y -> insert_let (g env e3)
 193:                 (fun z -> Put(x, y, z), Type.Unit)))
 194: 
 195: let f e = fst (g M.empty e)

alpha.mli

   1: val f : KNormal.t -> KNormal.t
   2: val g : Id.t M.t -> KNormal.t -> KNormal.t (* for Inline.g *)

alpha.ml

   1: (* rename identifiers to make them unique (alpha-conversion) *)
   2: 
   3: open KNormal
   4: 
   5: