├── src ├── closure.ml ├── setup.sh ├── Makefile ├── m.ml ├── s.ml ├── type.ml ├── id.ml ├── alias.ml ├── main.ml ├── alpha.ml ├── libmincaml.j ├── elim.ml ├── lexer.mll ├── inline.ml ├── asm.ml ├── constFold.ml ├── simulate.ml ├── syntax.ml ├── parser.mly ├── typing.ml ├── normal.ml ├── emit.ml ├── virtual.ml └── OCamlMakefile ├── example ├── cls-bug.ml ├── minrt_input.bin ├── fib.ml ├── cls-rec.ml ├── tuple.ml ├── cls-bug2.ml ├── gcd.ml ├── ack.ml ├── funcomp.ml ├── even-odd.ml ├── cls-bug2 │ ├── cls.j │ ├── main.j │ └── cls_f_3.j ├── funcomp │ ├── cls.j │ ├── cls_composed_13_22.j │ ├── cls_composed_13_17.j │ └── main.j ├── cls-reg-bug │ ├── cls.j │ ├── main.j │ └── cls_g_15.j ├── cls-reg-bug.ml ├── cls-bug │ └── main.j ├── cls-rec │ └── main.j ├── mandelbrot.ml ├── fib │ └── main.j ├── gcd │ └── main.j ├── ack │ └── main.j ├── even-odd │ └── main.j ├── tuple │ └── main.j └── mandelbrot │ └── main.j ├── .gitignore └── README.md /src/closure.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/momohatt/min-caml-jvm/HEAD/src/closure.ml -------------------------------------------------------------------------------- /example/cls-bug.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/momohatt/min-caml-jvm/HEAD/example/cls-bug.ml -------------------------------------------------------------------------------- /example/minrt_input.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/momohatt/min-caml-jvm/HEAD/example/minrt_input.bin -------------------------------------------------------------------------------- /example/fib.ml: -------------------------------------------------------------------------------- 1 | let rec fib n = 2 | if n <= 1 then n else 3 | fib (n - 1) + fib (n - 2) in 4 | print_int (fib 30); 5 | print_newline () 6 | -------------------------------------------------------------------------------- /example/cls-rec.ml: -------------------------------------------------------------------------------- 1 | let x = 10 in 2 | let rec f y = 3 | if y = 0 then 0 else 4 | x + f (y - 1) in 5 | print_int (f 123); 6 | print_newline () 7 | -------------------------------------------------------------------------------- /example/tuple.ml: -------------------------------------------------------------------------------- 1 | let a = Array.make 1 (2, 3) in 2 | let b = Array.make 1 a in 3 | let (c, d) = b.(0).(0) in 4 | print_int d; 5 | print_newline () 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.cmi 2 | *.cmo 3 | *.o 4 | *.top 5 | min-caml 6 | ._bcdi/ 7 | ._d/ 8 | lexer.ml 9 | parser.ml 10 | parser.mli 11 | *.class 12 | *.ppm 13 | src/test/ 14 | -------------------------------------------------------------------------------- /example/cls-bug2.ml: -------------------------------------------------------------------------------- 1 | let rec f n = 2 | if n < 0 then () else 3 | (print_int n; 4 | let a = Array.make 1 f in 5 | a.(0) (n - 1)) in 6 | f 9; 7 | print_newline () 8 | -------------------------------------------------------------------------------- /example/gcd.ml: -------------------------------------------------------------------------------- 1 | let rec gcd m n = 2 | if m = 0 then n else 3 | if m <= n then gcd m (n - m) else 4 | gcd n (m - n) in 5 | print_int (gcd 21600 337500); 6 | print_newline () 7 | -------------------------------------------------------------------------------- /example/ack.ml: -------------------------------------------------------------------------------- 1 | let rec ack x y = 2 | if x <= 0 then y + 1 else 3 | if y <= 0 then ack (x - 1) 1 else 4 | ack (x - 1) (ack x (y - 1)) in 5 | print_int (ack 3 10); 6 | print_newline () 7 | -------------------------------------------------------------------------------- /src/setup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | if !(type "jasmin" > /dev/null 2>&1); then 4 | echo "[ERROR] jasmin is not installed." 5 | exit 1 6 | fi 7 | 8 | # generate libmincaml.class 9 | jasmin libmincaml.j 10 | -------------------------------------------------------------------------------- /example/funcomp.ml: -------------------------------------------------------------------------------- 1 | let rec compose f g = 2 | let rec composed x = g (f x) in 3 | composed in 4 | let rec dbl x = x + x in 5 | let rec inc x = x + 1 in 6 | let rec dec x = x - 1 in 7 | let h = compose inc (compose dbl dec) in 8 | print_int (h 123); 9 | print_newline () 10 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | RESULT = min-caml 2 | SOURCES = id.ml type.ml m.ml s.ml syntax.ml \ 3 | typing.ml lexer.mll parser.mly \ 4 | normal.ml \ 5 | alpha.ml alias.ml elim.ml inline.ml constFold.ml \ 6 | closure.ml asm.ml emit.ml virtual.ml simulate.ml \ 7 | main.ml 8 | 9 | include OCamlMakefile 10 | -------------------------------------------------------------------------------- /example/even-odd.ml: -------------------------------------------------------------------------------- 1 | let t = 123 in 2 | let f = 456 in 3 | let rec even x = 4 | let rec odd x = 5 | if x > 0 then even (x - 1) else 6 | if x < 0 then even (x + 1) else 7 | f in 8 | if x > 0 then odd (x - 1) else 9 | if x < 0 then odd (x + 1) else 10 | t in 11 | print_int (even 789); 12 | print_newline () 13 | -------------------------------------------------------------------------------- /example/cls-bug2/cls.j: -------------------------------------------------------------------------------- 1 | .class abstract cls 2 | .super java/lang/Object 3 | 4 | .method public ([Ljava/lang/Object;)V 5 | .limit stack 5 6 | .limit locals 5 7 | aload_0 8 | invokespecial java/lang/Object/()V 9 | return 10 | .end method 11 | 12 | .method public abstract app([Ljava/lang/Object;)Ljava/lang/Object; 13 | .end method 14 | -------------------------------------------------------------------------------- /example/funcomp/cls.j: -------------------------------------------------------------------------------- 1 | .class abstract cls 2 | .super java/lang/Object 3 | 4 | .method public ([Ljava/lang/Object;)V 5 | .limit stack 5 6 | .limit locals 5 7 | aload_0 8 | invokespecial java/lang/Object/()V 9 | return 10 | .end method 11 | 12 | .method public abstract app([Ljava/lang/Object;)Ljava/lang/Object; 13 | .end method 14 | -------------------------------------------------------------------------------- /src/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 13 | -------------------------------------------------------------------------------- /example/cls-reg-bug/cls.j: -------------------------------------------------------------------------------- 1 | .class abstract cls 2 | .super java/lang/Object 3 | 4 | .method public ([Ljava/lang/Object;)V 5 | .limit stack 5 6 | .limit locals 5 7 | aload_0 8 | invokespecial java/lang/Object/()V 9 | return 10 | .end method 11 | 12 | .method public abstract app([Ljava/lang/Object;)Ljava/lang/Object; 13 | .end method 14 | -------------------------------------------------------------------------------- /src/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 12 | 13 | let print_set (s : S.t) = 14 | print_endline ("Set: " ^ (String.concat ", " (S.elements s))) 15 | -------------------------------------------------------------------------------- /example/cls-reg-bug.ml: -------------------------------------------------------------------------------- 1 | (* thanks to autotaker: https://github.com/esumii/min-caml/pull/2 *) 2 | let rec h p = 3 | let (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10) = p in 4 | let rec g z = 5 | let r = v1 + v2 + v3 + v4 + v5 + v6 + v7 + v8 + v9 + v10 in 6 | if z > 0 then r else g (-z) in 7 | g 1 in 8 | print_int (h (1,2,3,4,5,6,7,8,9,10)); 9 | print_newline () 10 | -------------------------------------------------------------------------------- /example/cls-bug/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static main([Ljava/lang/String;)V 12 | .limit stack 100 13 | .limit locals 100 14 | ldc 912 15 | invokestatic libmincaml.min_caml_print_int(I)V 16 | invokestatic libmincaml.min_caml_print_newline()V 17 | return 18 | .end method ; main 19 | 20 | -------------------------------------------------------------------------------- /example/funcomp/cls_composed_13_22.j: -------------------------------------------------------------------------------- 1 | .class public cls_composed_13_22 2 | .super cls 3 | .method public ([Ljava/lang/Object;)V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | aload 1 8 | invokespecial cls/([Ljava/lang/Object;)V 9 | return 10 | .end method ; 11 | 12 | .method public app([Ljava/lang/Object;)Ljava/lang/Object; 13 | .limit stack 100 14 | .limit locals 100 15 | aload 1 16 | dup 17 | ldc 0 18 | aaload 19 | checkcast java/lang/Integer 20 | invokevirtual java/lang/Integer/intValue()I 21 | istore 2 22 | iload 2 23 | iload 2 24 | iadd 25 | istore 3 ; Ti24 26 | iload 3 27 | ldc 1 28 | isub 29 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 30 | areturn 31 | .end method ; app 32 | 33 | -------------------------------------------------------------------------------- /src/type.ml: -------------------------------------------------------------------------------- 1 | type t = 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) 12 | 13 | (* [WEEK1 Q2] pretty print for Type.t *) 14 | let rec string_of_t t = 15 | match t with 16 | | Unit -> "unit" 17 | | Bool -> "bool" 18 | | Int -> "int" 19 | | Float -> "float" 20 | | Fun (l, t) -> (String.concat " -> " (List.map string_of_t l)) ^ " -> " ^ string_of_t t 21 | | Tuple l -> "(" ^ (String.concat " * " (List.map string_of_t l)) ^ ")" 22 | | Array t -> string_of_t t ^ " array" 23 | | Var t -> (match !t with 24 | | Some t' -> string_of_t t' 25 | | None -> "'a") 26 | 27 | let print_t t = 28 | print_endline (string_of_t t) 29 | -------------------------------------------------------------------------------- /example/cls-bug2/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static main([Ljava/lang/String;)V 12 | .limit stack 100 13 | .limit locals 100 14 | new cls_f_3 15 | dup 16 | ldc 0 17 | anewarray java/lang/Object 18 | invokespecial cls_f_3/([Ljava/lang/Object;)V 19 | astore 0 20 | aload 0 21 | ldc 1 22 | anewarray java/lang/Object 23 | dup 24 | ldc 0 25 | ldc 9 26 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 27 | aastore 28 | invokevirtual cls_f_3/app([Ljava/lang/Object;)Ljava/lang/Object; 29 | pop 30 | invokestatic libmincaml.min_caml_print_newline()V 31 | return 32 | .end method ; main 33 | 34 | -------------------------------------------------------------------------------- /example/cls-rec/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static f_3(I)I 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ifne ifeq_else_1 16 | ldc 0 17 | goto ifeq_cont_1 18 | ifeq_else_1: 19 | ldc 10 20 | iload 0 21 | ldc 1 22 | isub 23 | invokestatic main.f_3(I)I 24 | iadd 25 | ifeq_cont_1: 26 | ireturn 27 | .end method ; f_3 28 | 29 | .method public static main([Ljava/lang/String;)V 30 | .limit stack 100 31 | .limit locals 100 32 | ldc 123 33 | invokestatic main.f_3(I)I 34 | invokestatic libmincaml.min_caml_print_int(I)V 35 | invokestatic libmincaml.min_caml_print_newline()V 36 | return 37 | .end method ; main 38 | 39 | -------------------------------------------------------------------------------- /example/mandelbrot.ml: -------------------------------------------------------------------------------- 1 | let rec yloop y = 2 | if y >= 400 then () else 3 | let rec xloop x y = 4 | if x >= 400 then () else 5 | let cr = (float_of_int x) *. 2.0 /. 400.0 -. 1.5 in 6 | let ci = (float_of_int y) *. 2.0 /. 400.0 -. 1.0 in 7 | let rec iloop i zr zi zr2 zi2 cr ci = 8 | if i = 0 then print_int 1 else 9 | let tr = zr2 -. zi2 +. cr in 10 | let ti = 2.0 *. zr *. zi +. ci in 11 | let zr = tr in 12 | let zi = ti in 13 | let zr2 = zr *. zr in 14 | let zi2 = zi *. zi in 15 | if zr2 +. zi2 > 2.0 *. 2.0 then print_int 0 else 16 | iloop (i - 1) zr zi zr2 zi2 cr ci in 17 | iloop 100 0.0 0.0 0.0 0.0 cr ci; 18 | xloop (x + 1) y in 19 | print_newline (); 20 | xloop 0 y; 21 | yloop (y + 1) in 22 | yloop 0 23 | -------------------------------------------------------------------------------- /example/fib/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static fib_2(I)I 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ldc 1 16 | if_icmpgt ifle_else_10 17 | iload 0 18 | goto ifle_cont_10 19 | ifle_else_10: 20 | iload 0 21 | ldc 1 22 | isub 23 | invokestatic main.fib_2(I)I 24 | iload 0 25 | ldc 2 26 | isub 27 | invokestatic main.fib_2(I)I 28 | iadd 29 | ifle_cont_10: 30 | ireturn 31 | .end method ; fib_2 32 | 33 | .method public static main([Ljava/lang/String;)V 34 | .limit stack 100 35 | .limit locals 100 36 | ldc 30 37 | invokestatic main.fib_2(I)I 38 | invokestatic libmincaml.min_caml_print_int(I)V 39 | invokestatic libmincaml.min_caml_print_newline()V 40 | return 41 | .end method ; main 42 | 43 | -------------------------------------------------------------------------------- /example/gcd/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static gcd_2(II)I 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ifne ifeq_else_11 16 | iload 1 17 | goto ifeq_cont_11 18 | ifeq_else_11: 19 | iload 0 20 | iload 1 21 | if_icmpgt ifle_else_12 22 | iload 0 23 | iload 1 24 | iload 0 25 | isub 26 | invokestatic main.gcd_2(II)I 27 | goto ifle_cont_12 28 | ifle_else_12: 29 | iload 1 30 | iload 0 31 | iload 1 32 | isub 33 | invokestatic main.gcd_2(II)I 34 | ifle_cont_12: 35 | ifeq_cont_11: 36 | ireturn 37 | .end method ; gcd_2 38 | 39 | .method public static main([Ljava/lang/String;)V 40 | .limit stack 100 41 | .limit locals 100 42 | ldc 21600 43 | ldc 337500 44 | invokestatic main.gcd_2(II)I 45 | invokestatic libmincaml.min_caml_print_int(I)V 46 | invokestatic libmincaml.min_caml_print_newline()V 47 | return 48 | .end method ; main 49 | 50 | -------------------------------------------------------------------------------- /example/ack/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static ack_2(II)I 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ifgt ifle_else_1 16 | iload 1 17 | ldc 1 18 | iadd 19 | goto ifle_cont_1 20 | ifle_else_1: 21 | iload 1 22 | ifgt ifle_else_2 23 | iload 0 24 | ldc 1 25 | isub 26 | ldc 1 27 | invokestatic main.ack_2(II)I 28 | goto ifle_cont_2 29 | ifle_else_2: 30 | iload 0 31 | ldc 1 32 | isub 33 | iload 0 34 | iload 1 35 | ldc 1 36 | isub 37 | invokestatic main.ack_2(II)I 38 | invokestatic main.ack_2(II)I 39 | ifle_cont_2: 40 | ifle_cont_1: 41 | ireturn 42 | .end method ; ack_2 43 | 44 | .method public static main([Ljava/lang/String;)V 45 | .limit stack 100 46 | .limit locals 100 47 | ldc 3 48 | ldc 10 49 | invokestatic main.ack_2(II)I 50 | invokestatic libmincaml.min_caml_print_int(I)V 51 | invokestatic libmincaml.min_caml_print_newline()V 52 | return 53 | .end method ; main 54 | 55 | -------------------------------------------------------------------------------- /example/funcomp/cls_composed_13_17.j: -------------------------------------------------------------------------------- 1 | .class public cls_composed_13_17 2 | .super cls 3 | .field public Tf16 Lcls; 4 | .method public ([Ljava/lang/Object;)V 5 | .limit stack 10 6 | .limit locals 10 7 | aload 0 8 | aload 1 9 | invokespecial cls/([Ljava/lang/Object;)V 10 | aload 0 11 | aload 1 12 | ldc 0 13 | aaload 14 | checkcast cls 15 | putfield cls_composed_13_17/Tf16 Lcls; 16 | return 17 | .end method ; 18 | 19 | .method public app([Ljava/lang/Object;)Ljava/lang/Object; 20 | .limit stack 100 21 | .limit locals 100 22 | aload 1 23 | dup 24 | ldc 0 25 | aaload 26 | checkcast java/lang/Integer 27 | invokevirtual java/lang/Integer/intValue()I 28 | istore 2 29 | aload 0 30 | getfield cls_composed_13_17/Tf16 Lcls; 31 | ldc 1 32 | anewarray java/lang/Object 33 | dup 34 | ldc 0 35 | iload 2 36 | ldc 1 37 | iadd 38 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 39 | aastore 40 | invokevirtual cls/app([Ljava/lang/Object;)Ljava/lang/Object; 41 | checkcast java/lang/Integer 42 | invokevirtual java/lang/Integer/intValue()I 43 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 44 | areturn 45 | .end method ; app 46 | 47 | -------------------------------------------------------------------------------- /src/id.ml: -------------------------------------------------------------------------------- 1 | type t = string 2 | 3 | type l = L of string 4 | 5 | let rec pp_list = function 6 | | [] -> "" 7 | | [x] -> x 8 | | x :: xs -> x ^ " " ^ pp_list xs 9 | 10 | let count = ref 0 11 | let pair_count = ref 0 12 | 13 | let genid s = 14 | incr count; 15 | Printf.sprintf "%s_%d" s !count 16 | 17 | let genPairLabel s1 s2 = 18 | incr pair_count; 19 | (Printf.sprintf "%s_%d" s1 !pair_count, Printf.sprintf "%s_%d" s2 !pair_count) 20 | 21 | let genLabel s = 22 | incr pair_count; 23 | Printf.sprintf "%s_%d" s !pair_count 24 | 25 | let rec id_of_typ = function 26 | | Type.Unit -> "u" 27 | | Type.Bool -> "b" 28 | | Type.Int -> "i" 29 | | Type.Float -> "d" 30 | | Type.Fun _ -> "f" 31 | | Type.Tuple _ -> "t" 32 | | Type.Array _ -> "a" 33 | | Type.Var _ -> assert false 34 | 35 | let gentmp typ = 36 | incr count; 37 | Printf.sprintf "T%s%d" (id_of_typ typ) !count 38 | 39 | let mem x (env : (t * 'a) list) = 40 | List.exists (fun (y, _) -> x = y) env 41 | 42 | let mem3 x (env : (t * 'a * 'b) list) = 43 | List.exists (fun (y, _, _) -> x = y) env 44 | 45 | let print_env (env : (t * 'a) list) = 46 | Printf.printf "env:[%s]\n" (String.concat ", " (List.map fst env)) 47 | -------------------------------------------------------------------------------- /example/funcomp/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static main([Ljava/lang/String;)V 12 | .limit stack 100 13 | .limit locals 100 14 | new cls_composed_13_22 15 | dup 16 | ldc 0 17 | anewarray java/lang/Object 18 | invokespecial cls_composed_13_22/([Ljava/lang/Object;)V 19 | astore 0 20 | aload 0 21 | astore 0 ; Tf16 22 | new cls_composed_13_17 23 | dup 24 | ldc 1 25 | anewarray java/lang/Object 26 | dup 27 | ldc 0 28 | aload 0 29 | aastore 30 | invokespecial cls_composed_13_17/([Ljava/lang/Object;)V 31 | astore 1 32 | aload 1 33 | astore 0 ; h_11 34 | aload 0 35 | ldc 1 36 | anewarray java/lang/Object 37 | dup 38 | ldc 0 39 | ldc 123 40 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 41 | aastore 42 | invokevirtual cls/app([Ljava/lang/Object;)Ljava/lang/Object; 43 | checkcast java/lang/Integer 44 | invokevirtual java/lang/Integer/intValue()I 45 | invokestatic libmincaml.min_caml_print_int(I)V 46 | invokestatic libmincaml.min_caml_print_newline()V 47 | return 48 | .end method ; main 49 | 50 | -------------------------------------------------------------------------------- /example/cls-bug2/cls_f_3.j: -------------------------------------------------------------------------------- 1 | .class public cls_f_3 2 | .super cls 3 | .method public ([Ljava/lang/Object;)V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | aload 1 8 | invokespecial cls/([Ljava/lang/Object;)V 9 | return 10 | .end method ; 11 | 12 | .method public app([Ljava/lang/Object;)Ljava/lang/Object; 13 | .limit stack 100 14 | .limit locals 100 15 | aload 1 16 | dup 17 | ldc 0 18 | aaload 19 | checkcast java/lang/Integer 20 | invokevirtual java/lang/Integer/intValue()I 21 | istore 2 22 | iload 2 23 | iflt ifge_cont_1 24 | iload 2 25 | invokestatic libmincaml.min_caml_print_int(I)V 26 | new cls_f_3 27 | dup 28 | ldc 0 29 | anewarray java/lang/Object 30 | invokespecial cls_f_3/([Ljava/lang/Object;)V 31 | astore 3 32 | aload 3 33 | astore 3 34 | ldc 1 35 | anewarray cls 36 | dup 37 | ldc 0 38 | aload 3 39 | aastore 40 | astore 3 ; a_7 41 | aload 3 42 | ldc 0 43 | aaload 44 | checkcast cls 45 | ldc 1 46 | anewarray java/lang/Object 47 | dup 48 | ldc 0 49 | iload 2 50 | ldc 1 51 | isub 52 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 53 | aastore 54 | invokevirtual cls/app([Ljava/lang/Object;)Ljava/lang/Object; 55 | pop 56 | ifge_cont_1: 57 | areturn 58 | .end method ; app 59 | 60 | -------------------------------------------------------------------------------- /example/even-odd/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static odd_7(I)I 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ifgt ifle_else_1 16 | iload 0 17 | iflt ifge_else_2 18 | ldc 456 19 | goto ifge_cont_2 20 | ifge_else_2: 21 | iload 0 22 | ldc 1 23 | iadd 24 | invokestatic main.even_4(I)I 25 | ifge_cont_2: 26 | goto ifle_cont_1 27 | ifle_else_1: 28 | iload 0 29 | ldc 1 30 | isub 31 | invokestatic main.even_4(I)I 32 | ifle_cont_1: 33 | ireturn 34 | .end method ; odd_7 35 | 36 | .method public static even_4(I)I 37 | .limit stack 100 38 | .limit locals 100 39 | iload 0 40 | ifgt ifle_else_3 41 | iload 0 42 | iflt ifge_else_4 43 | ldc 123 44 | goto ifge_cont_4 45 | ifge_else_4: 46 | iload 0 47 | ldc 1 48 | iadd 49 | invokestatic main.odd_7(I)I 50 | ifge_cont_4: 51 | goto ifle_cont_3 52 | ifle_else_3: 53 | iload 0 54 | ldc 1 55 | isub 56 | invokestatic main.odd_7(I)I 57 | ifle_cont_3: 58 | ireturn 59 | .end method ; even_4 60 | 61 | .method public static main([Ljava/lang/String;)V 62 | .limit stack 100 63 | .limit locals 100 64 | ldc 789 65 | invokestatic main.even_4(I)I 66 | invokestatic libmincaml.min_caml_print_int(I)V 67 | invokestatic libmincaml.min_caml_print_newline()V 68 | return 69 | .end method ; main 70 | 71 | -------------------------------------------------------------------------------- /example/tuple/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .field public static a_2 [[Ljava/lang/Object; 4 | .field public static b_3 [[[Ljava/lang/Object; 5 | .method public static ()V 6 | .limit stack 100 7 | .limit locals 100 8 | ldc 2 9 | anewarray java/lang/Object 10 | dup 11 | ldc 0 12 | ldc 2 13 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 14 | aastore 15 | dup 16 | ldc 1 17 | ldc 3 18 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 19 | aastore 20 | astore 0 21 | ldc 1 22 | anewarray [Ljava/lang/Object; 23 | dup 24 | ldc 0 25 | aload 0 26 | aastore 27 | putstatic main/a_2 [[Ljava/lang/Object; 28 | getstatic main/a_2 [[Ljava/lang/Object; 29 | astore 0 30 | ldc 1 31 | anewarray [[Ljava/lang/Object; 32 | dup 33 | ldc 0 34 | aload 0 35 | aastore 36 | putstatic main/b_3 [[[Ljava/lang/Object; 37 | return 38 | .end method ; 39 | 40 | .method public ()V 41 | .limit stack 10 42 | .limit locals 10 43 | aload 0 44 | invokespecial java/lang/Object/()V 45 | return 46 | .end method ; 47 | 48 | .method public static main([Ljava/lang/String;)V 49 | .limit stack 100 50 | .limit locals 100 51 | getstatic main/b_3 [[[Ljava/lang/Object; 52 | ldc 0 53 | aaload 54 | checkcast [[Ljava/lang/Object; 55 | ldc 0 56 | aaload 57 | checkcast [Ljava/lang/Object; 58 | dup 59 | ldc 1 60 | aaload 61 | checkcast java/lang/Integer 62 | invokevirtual java/lang/Integer/intValue()I 63 | istore 0 64 | pop 65 | iload 0 66 | invokestatic libmincaml.min_caml_print_int(I)V 67 | invokestatic libmincaml.min_caml_print_newline()V 68 | return 69 | .end method ; main 70 | 71 | -------------------------------------------------------------------------------- /src/alias.ml: -------------------------------------------------------------------------------- 1 | open Normal 2 | 3 | let find x env = try M.find x env with Not_found -> x 4 | let rec g env e = match e with 5 | | Unit -> Unit 6 | | Bool(b) -> Bool(b) 7 | | Int(i) -> Int(i) 8 | | Float(d) -> Float(d) 9 | | Neg(e) -> Neg(g env e) 10 | | Not(e) -> Not(g env e) 11 | | Xor(e1, e2) -> Xor(g env e1, g env e2) 12 | | Add(e1, e2) -> Add(g env e1, g env e2) 13 | | Sub(e1, e2) -> Sub(g env e1, g env e2) 14 | | Mul(e1, e2) -> Mul(g env e1, g env e2) 15 | | Div(e1, e2) -> Div(g env e1, g env e2) 16 | | FNeg(e) -> FNeg(g env e) 17 | | FAdd(e1, e2) -> FAdd(g env e1, g env e2) 18 | | FSub(e1, e2) -> FSub(g env e1, g env e2) 19 | | FMul(e1, e2) -> FMul(g env e1, g env e2) 20 | | FDiv(e1, e2) -> FDiv(g env e1, g env e2) 21 | | Eq(e1, e2, t) -> Eq(g env e1, g env e2, t) 22 | | LE(e1, e2, t) -> LE(g env e1, g env e2, t) 23 | | If(e1, e2, e3) -> If(g env e1, g env e2, g env e3) 24 | | Let((x, t), Var(y), e2) -> 25 | let env' = M.add x y env in 26 | g env' e2 27 | | Let((x, t), e1, e2) -> 28 | Let((x, t), g env e1, g env e2) 29 | | Var(x) -> Var(find x env) 30 | | LetRec(e1, e2) -> 31 | LetRec({ e1 with body = g env e1.body }, g env e2) 32 | | App((e1, t), e2s) -> App((g env e1, t), List.map (fun e -> g env e) e2s) 33 | | Tuple(ets) -> Tuple(List.map (fun (e, t) -> g env e, t) ets) 34 | | LetTuple(xts, e1, e2) -> 35 | LetTuple(List.map (fun (x, t) -> (find x env, t)) xts, 36 | g env e1, 37 | g env e2) 38 | | Array(e1, e2, t) -> Array(g env e1, g env e2, t) 39 | | Get(e1, e2, t) -> Get(g env e1, g env e2, t) 40 | | Put(e1, e2, e3, t) -> Put(g env e1, g env e2, g env e3, t) 41 | 42 | let f = g M.empty 43 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | let limit = ref 1000 2 | 3 | let rec iter n e = 4 | Format.eprintf "iteration%d.\n" n; 5 | if n = 0 then e else ( 6 | let e' = Inline.f e in 7 | let e' = Alias.f e' in 8 | let e' = ConstFold.f e' in 9 | let e' = Elim.f e' in 10 | if e = e' then e else 11 | iter (n - 1) e' 12 | ) 13 | 14 | let compile oc dirname e = 15 | Id.count := 0; 16 | let e = Parser.exp Lexer.token e in 17 | let e = Typing.f e in 18 | let e = Normal.f e in 19 | let e = Alpha.f e in 20 | print_endline "-------Passed Normal.f-------"; 21 | Normal.print_t e; 22 | let e = iter !limit e in 23 | print_endline "-------Passed iter-------"; 24 | Normal.print_t e; 25 | let e = Closure.f e in 26 | print_endline "-------Passed Closure.f-------"; 27 | Closure.print_prog e; 28 | print_newline (); 29 | let e = Virtual.f e in 30 | print_endline "-------Passed Virtual.f-------"; 31 | (* let e = Simulate.f e in *) 32 | Emit.f oc dirname e 33 | 34 | let file f = 35 | let id = String.sub f 0 ((String.length f) - 3) in 36 | let inchan = open_in f in 37 | Sys.command ("rm -rf " ^ id) |> ignore; (* [XXX] reset *) 38 | Sys.command ("mkdir -p " ^ id) |> ignore; 39 | let ofilename = id ^ "/main.j" in 40 | let outchan = open_out ofilename in 41 | try 42 | compile outchan id (Lexing.from_channel inchan); 43 | close_in inchan; 44 | close_out outchan; 45 | with e -> (close_in inchan; close_out outchan; raise e) 46 | 47 | let _ = 48 | let files = ref [] in 49 | Arg.parse 50 | [("-inline", Arg.Int(fun i -> Inline.threshold := i), "maximum size of functions inlined"); 51 | ("-iter", Arg.Int(fun i -> limit := i), "maximum number of optimizations iterated")] 52 | (fun s -> files := !files @ [s]) 53 | (Printf.sprintf "usage: %s ...filenames..." Sys.argv.(0)); 54 | List.iter 55 | (fun f -> ignore (file f)) 56 | !files 57 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # min-caml-jvm 2 | 3 | This compiler converts min-caml, a subset of OCaml language, into Jasmin (JVM assembler). 4 | 5 | ## Features 6 | * Closures are supported. 7 | * Output jasmin class files consists of one main class file and (possibly) several closure class files. 8 | * Global variables are treated as static fields of main class. 9 | * Every closure class inherits from an abstract class named `cls` (closure), which would look like as follows in Java: 10 | ```java 11 | public abstract class cls { 12 | public cls(Object... arg) {} 13 | public abstract Object app(Object... arg); 14 | } 15 | ``` 16 | 17 | ## Requirement 18 | * `jasmin` (JVM assembler) 19 | * can be installed with Homebrew (mac) etc. 20 | 21 | * `java` 22 | 23 | ## Setup & Build 24 | ``` 25 | $ ./setup.sh # generate libmincaml.class 26 | $ make 27 | ``` 28 | 29 | ## Usage 30 | ``` 31 | $ ./min-caml filename.ml # filename/main.j will be created 32 | $ jasmin filename/*.j # Make sure to pass *every file in filename/* to jasmin. 33 | # main.class (and maybe other class files) will be generated. 34 | $ java main 35 | ``` 36 | 37 | Make sure to place `libmincaml.class` in your working directory. 38 | 39 | ## Examples 40 | See [example/](https://github.com/momohatt/min-caml-jvm/tree/master/example) 41 | 42 | ### Try running minrt! 43 | `minrt/main.j` requires some input (`minrt_input.bin`), so you need to do the following at `example/`. 44 | ``` 45 | $ jasmin minrt/main.j 46 | $ java main < minrt_input.bin > output.ppm 47 | $ open output.ppm # show the result image 48 | ``` 49 | 50 | ### Running other examples 51 | Other examples do not require inputs. 52 | 53 | ### Experimenting with JVM optimization 54 | By passing `-Xint` option to `java` like the following, you can run JVM without JIT optimization. 55 | ``` 56 | $ java -Xint main < minrt_input.bin > output.ppm 57 | ``` 58 | 59 | You'll notice how the program execution is dramatically slowed without JIT! 60 | 61 | ## References 62 | * [min-caml](https://github.com/esumii/min-caml) 63 | -------------------------------------------------------------------------------- /src/alpha.ml: -------------------------------------------------------------------------------- 1 | open Normal 2 | 3 | let find x env = try M.find x env with Not_found -> x 4 | 5 | let rec g env = function (* where alpha-conversion happens (caml2html: alpha_g) *) 6 | | Unit -> Unit 7 | | Bool(b) -> Bool(b) 8 | | Int(i) -> Int(i) 9 | | Float(d) -> Float(d) 10 | | Neg(e) -> Neg(g env e) 11 | | Not(e) -> Not(g env e) 12 | | Xor(e1, e2) -> Xor(g env e1, g env e2) 13 | | Add(e1, e2) -> Add(g env e1, g env e2) 14 | | Sub(e1, e2) -> Sub(g env e1, g env e2) 15 | | Mul(e1, e2) -> Mul(g env e1, g env e2) 16 | | Div(e1, e2) -> Div(g env e1, g env e2) 17 | | FNeg(e) -> FNeg(g env e) 18 | | FAdd(e1, e2) -> FAdd(g env e1, g env e2) 19 | | FSub(e1, e2) -> FSub(g env e1, g env e2) 20 | | FMul(e1, e2) -> FMul(g env e1, g env e2) 21 | | FDiv(e1, e2) -> FDiv(g env e1, g env e2) 22 | | Eq(e1, e2, t) -> Eq(g env e1, g env e2, t) 23 | | LE(e1, e2, t) -> LE(g env e1, g env e2, t) 24 | | If(e1, e2, e3) -> If(g env e1, g env e2, g env e3) 25 | | Let((x, t), e1, e2) -> 26 | let x' = Id.genid x in 27 | Let((x', t), g env e1, g (M.add x x' env) e2) 28 | | Var(x) -> Var(find x env) 29 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> 30 | let env = M.add x (Id.genid x) env in 31 | let ys = List.map fst yts in 32 | let env' = M.add_list2 ys (List.map Id.genid ys) env in 33 | LetRec({ name = (find x env, t); 34 | args = List.map (fun (y, t) -> (find y env', t)) yts; 35 | body = g env' e1 }, 36 | g env e2) 37 | | App((e1, t), e2s) -> App((g env e1, t), List.map (fun e -> g env e) e2s) 38 | | Tuple(ets) -> Tuple(List.map (fun (e, t) -> g env e, t) ets) 39 | | LetTuple(xts, e1, e2) -> 40 | let xs = List.map fst xts in 41 | let env' = M.add_list2 xs (List.map Id.genid xs) env in 42 | LetTuple(List.map (fun (x, t) -> (find x env', t)) xts, 43 | g env e1, 44 | g env' e2) 45 | | Array(e1, e2, t) -> Array(g env e1, g env e2, t) 46 | | Get(e1, e2, t) -> Get(g env e1, g env e2, t) 47 | | Put(e1, e2, e3, t) -> Put(g env e1, g env e2, g env e3, t) 48 | 49 | let f = g M.empty 50 | -------------------------------------------------------------------------------- /src/libmincaml.j: -------------------------------------------------------------------------------- 1 | .class public libmincaml 2 | .super java/lang/Object 3 | .method public ()V 4 | aload_0 5 | invokespecial java/lang/Object/()V 6 | return 7 | .end method 8 | 9 | .method public static min_caml_print_int(I)V 10 | .limit stack 5 11 | .limit locals 5 12 | iload 0 13 | getstatic java/lang/System/out Ljava/io/PrintStream; 14 | swap 15 | invokevirtual java/io/PrintStream/print(I)V 16 | return 17 | .end method 18 | 19 | .method public static min_caml_print_float(F)V 20 | .limit stack 5 21 | .limit locals 5 22 | fload 0 23 | getstatic java/lang/System/out Ljava/io/PrintStream; 24 | swap 25 | invokevirtual java/io/PrintStream/print(F)V 26 | return 27 | .end method 28 | 29 | .method public static min_caml_print_char(I)V 30 | .limit stack 5 31 | .limit locals 5 32 | iload 0 33 | i2c 34 | getstatic java/lang/System/out Ljava/io/PrintStream; 35 | swap 36 | invokevirtual java/io/PrintStream/print(C)V 37 | return 38 | .end method 39 | 40 | .method public static min_caml_print_newline()V 41 | .limit stack 5 42 | .limit locals 5 43 | ldc "\n" 44 | getstatic java/lang/System/out Ljava/io/PrintStream; 45 | swap 46 | invokevirtual java/io/PrintStream/print(Ljava/lang/String;)V 47 | return 48 | .end method 49 | 50 | ; 入力はバイナリを想定 51 | .method public static min_caml_read_float()F 52 | .limit stack 5 53 | .limit locals 5 54 | new java/io/DataInputStream 55 | dup 56 | getstatic java/lang/System/in Ljava/io/InputStream; 57 | invokespecial java/io/DataInputStream/(Ljava/io/InputStream;)V 58 | invokevirtual java/io/DataInputStream/readFloat()F 59 | freturn 60 | .end method 61 | 62 | ; 入力はバイナリを想定 63 | .method public static min_caml_read_int()I 64 | .limit stack 5 65 | .limit locals 5 66 | new java/io/DataInputStream 67 | dup 68 | getstatic java/lang/System/in Ljava/io/InputStream; 69 | invokespecial java/io/DataInputStream/(Ljava/io/InputStream;)V 70 | invokevirtual java/io/DataInputStream/readInt()I 71 | ireturn 72 | .end method 73 | -------------------------------------------------------------------------------- /src/elim.ml: -------------------------------------------------------------------------------- 1 | open Normal 2 | 3 | let rec effect = function (* whether there's a side effect (caml2html: elim_effect) *) 4 | | Neg(e) | Not(e) | FNeg(e) -> effect e 5 | | Xor(e1, e2) | Add(e1, e2) | Sub(e1, e2) | Mul(e1, e2) | Div(e1, e2) 6 | | FAdd(e1, e2) | FSub(e1, e2) | FMul(e1, e2) | FDiv(e1, e2) 7 | | Eq(e1, e2, _) | LE(e1, e2, _) 8 | | Let(_, e1, e2) | LetRec({ body = e1 }, e2) | LetTuple(_, e1, e2) 9 | | Array(e1, e2, _) | Get(e1, e2, _) -> effect e1 || effect e2 10 | | If(e1, e2, e3) -> effect e1 || effect e2 || effect e3 11 | | Put _ | App _ -> true 12 | | _ -> false 13 | 14 | let rec g = function 15 | | Neg(e) -> Neg(g e) 16 | | Not(e) -> Not(g e) 17 | | Add(e1, e2) -> Add(g e1, g e2) 18 | | Sub(e1, e2) -> Sub(g e1, g e2) 19 | | Mul(e1, e2) -> Mul(g e1, g e2) 20 | | Div(e1, e2) -> Div(g e1, g e2) 21 | | FNeg(e) -> FNeg(g e) 22 | | FAdd(e1, e2) -> FAdd(g e1, g e2) 23 | | FSub(e1, e2) -> FSub(g e1, g e2) 24 | | FMul(e1, e2) -> FMul(g e1, g e2) 25 | | FDiv(e1, e2) -> FDiv(g e1, g e2) 26 | | Eq(e1, e2, t) -> Eq(g e1, g e2, t) 27 | | LE(e1, e2, t) -> LE(g e1, g e2, t) 28 | | If(e1, e2, e3) -> If(g e1, g e2, g e3) 29 | | Let((x, t), e1, e2) -> 30 | let e1' = g e1 in 31 | let e2' = g e2 in 32 | if effect e1' || S.mem x (fv e2') then Let((x, t), e1', e2') else 33 | (Format.eprintf "eliminating variable %s@." x; 34 | e2') 35 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> 36 | let e2' = g e2 in 37 | if S.mem x (fv e2') then 38 | LetRec({ name = (x, t); args = yts; body = g e1 }, e2') 39 | else 40 | (Format.eprintf "eliminating function %s@." x; 41 | e2') 42 | | App((e1, t), e2s) -> App((g e1, t), List.map g e2s) 43 | | Tuple(es) -> Tuple(List.map (fun (e, t) -> (g e, t)) es) 44 | | LetTuple(xts, y, e) -> 45 | let xs = List.map fst xts in 46 | let e' = g e in 47 | let live = fv e' in 48 | if List.exists (fun x -> S.mem x live) xs then LetTuple(xts, y, e') else 49 | (Format.eprintf "eliminating variables %s@." (Id.pp_list xs); 50 | e') 51 | | Array(e1, e2, t) -> Array(g e1, g e2, t) 52 | | Get(e1, e2, t) -> Get(g e1, g e2, t) 53 | | Put(e1, e2, e3, t) -> Put(g e1, g e2, g e3, t) 54 | | e -> e 55 | 56 | let f e = g e 57 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | open Type 4 | } 5 | 6 | let space = [' ' '\t' '\r'] 7 | let digit = ['0'-'9'] 8 | let lower = ['a'-'z'] 9 | let upper = ['A'-'Z'] 10 | 11 | rule token = parse 12 | | space+ 13 | { token lexbuf } 14 | | "(*" 15 | { comment lexbuf; (* trick for nested comment *) 16 | token lexbuf } 17 | | '(' 18 | { LPAREN } 19 | | ')' 20 | { RPAREN } 21 | | "true" 22 | { BOOL(true) } 23 | | "false" 24 | { BOOL(false) } 25 | | "not" 26 | { NOT } 27 | | digit+ 28 | { INT(int_of_string (Lexing.lexeme lexbuf)) } 29 | | digit+ ('.' digit*)? (['e' 'E'] ['+' '-']? digit+)? 30 | { FLOAT(float_of_string (Lexing.lexeme lexbuf)) } 31 | | '-' (* -.より後回しにしなくても良い? 最長一致? *) 32 | { MINUS } 33 | | '+' (* +.より後回しにしなくても良い? 最長一致? *) 34 | { PLUS } 35 | | '*' 36 | { AST } 37 | | '/' 38 | { SLASH } 39 | | "-." 40 | { MINUS_DOT } 41 | | "+." 42 | { PLUS_DOT } 43 | | "*." 44 | { AST_DOT } 45 | | "/." 46 | { SLASH_DOT } 47 | | '=' 48 | { EQUAL } 49 | | "<>" 50 | { LESS_GREATER } 51 | | "<=" 52 | { LESS_EQUAL } 53 | | ">=" 54 | { GREATER_EQUAL } 55 | | '<' 56 | { LESS } 57 | | '>' 58 | { GREATER } 59 | | "if" 60 | { IF } 61 | | "then" 62 | { THEN } 63 | | "else" 64 | { ELSE } 65 | | "let" 66 | { LET } 67 | | "in" 68 | { IN } 69 | | "rec" 70 | { REC } 71 | | ',' 72 | { COMMA } 73 | | '_' 74 | { IDENT(Id.gentmp Type.Unit) } 75 | | "Array.create" | "Array.make" | "create_array" (* [XX] ad hoc *) 76 | { ARRAY_CREATE } 77 | | '.' 78 | { DOT } 79 | | "<-" 80 | { LESS_MINUS } 81 | | ';' 82 | { SEMICOLON } 83 | | '\n' (* [WEEK1 Q2] improve parse/typing error messages *) 84 | { Lexing.new_line lexbuf; token lexbuf } 85 | | eof 86 | { EOF } 87 | | lower (digit|lower|upper|'_'|'\'')* (* must come later than other reserved word *) 88 | { IDENT(Lexing.lexeme lexbuf) } 89 | | _ 90 | { failwith 91 | (Printf.sprintf "unknown token %s near line %d, characters %d-%d" 92 | (Lexing.lexeme lexbuf) 93 | (lexbuf.lex_curr_p.pos_lnum) 94 | (Lexing.lexeme_start lexbuf) 95 | (Lexing.lexeme_end lexbuf)) } 96 | and comment = parse 97 | | "*)" 98 | { () } 99 | | "(*" 100 | { comment lexbuf; 101 | comment lexbuf } 102 | | "\n" 103 | { Lexing.new_line lexbuf; comment lexbuf } 104 | | eof 105 | { Format.eprintf "warning: unterminated comment@." } 106 | | _ 107 | { comment lexbuf } 108 | -------------------------------------------------------------------------------- /example/mandelbrot/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static iloop_13(IFFFFFF)V 12 | .limit stack 100 13 | .limit locals 100 14 | iload 0 15 | ifne ifeq_else_13 16 | ldc 1 17 | invokestatic libmincaml.min_caml_print_int(I)V 18 | goto ifeq_cont_13 19 | ifeq_else_13: 20 | fload 3 21 | fload 4 22 | fsub 23 | fload 5 24 | fadd 25 | fstore 7 ; tr_22 26 | ldc 2.000000 27 | fload 1 28 | fmul 29 | fload 2 30 | fmul 31 | fload 6 32 | fadd 33 | fstore 8 ; ti_23 34 | fload 7 35 | fload 7 36 | fmul 37 | fstore 9 ; zr2_26 38 | fload 8 39 | fload 8 40 | fmul 41 | fstore 10 ; zi2_27 42 | fload 9 43 | fload 10 44 | fadd 45 | ldc 4.000000 46 | fcmpl 47 | ifgt ifle_else_14 48 | iload 0 49 | ldc 1 50 | isub 51 | fload 7 52 | fload 8 53 | fload 9 54 | fload 10 55 | fload 5 56 | fload 6 57 | invokestatic main.iloop_13(IFFFFFF)V 58 | goto ifle_cont_14 59 | ifle_else_14: 60 | ldc 0 61 | invokestatic libmincaml.min_caml_print_int(I)V 62 | ifle_cont_14: 63 | ifeq_cont_13: 64 | return 65 | .end method ; iloop_13 66 | 67 | .method public static xloop_6(II)V 68 | .limit stack 100 69 | .limit locals 100 70 | ldc 400 71 | iload 0 72 | if_icmple ifle_cont_15 73 | iload 0 74 | i2f 75 | ldc 2.000000 76 | fmul 77 | ldc 400.000000 78 | fdiv 79 | ldc 1.500000 80 | fsub 81 | fstore 2 ; cr_11 82 | iload 1 83 | i2f 84 | ldc 2.000000 85 | fmul 86 | ldc 400.000000 87 | fdiv 88 | ldc 1.000000 89 | fsub 90 | fstore 3 ; ci_12 91 | ldc 100 92 | ldc 0.000000 93 | ldc 0.000000 94 | ldc 0.000000 95 | ldc 0.000000 96 | fload 2 97 | fload 3 98 | invokestatic main.iloop_13(IFFFFFF)V 99 | iload 0 100 | ldc 1 101 | iadd 102 | iload 1 103 | invokestatic main.xloop_6(II)V 104 | ifle_cont_15: 105 | return 106 | .end method ; xloop_6 107 | 108 | .method public static yloop_4(I)V 109 | .limit stack 100 110 | .limit locals 100 111 | ldc 400 112 | iload 0 113 | if_icmple ifle_cont_16 114 | invokestatic libmincaml.min_caml_print_newline()V 115 | ldc 0 116 | iload 0 117 | invokestatic main.xloop_6(II)V 118 | iload 0 119 | ldc 1 120 | iadd 121 | invokestatic main.yloop_4(I)V 122 | ifle_cont_16: 123 | return 124 | .end method ; yloop_4 125 | 126 | .method public static main([Ljava/lang/String;)V 127 | .limit stack 100 128 | .limit locals 100 129 | ldc 0 130 | invokestatic main.yloop_4(I)V 131 | return 132 | .end method ; main 133 | 134 | -------------------------------------------------------------------------------- /src/inline.ml: -------------------------------------------------------------------------------- 1 | open Normal 2 | 3 | let threshold = ref 10 4 | 5 | let rec size e = match e with 6 | | Neg(e) | Not(e) | FNeg(e) -> size e + 1 7 | | Xor(e1, e2) | Add(e1, e2) | Sub(e1, e2) | Mul(e1, e2) | Div(e1, e2) 8 | | FAdd(e1, e2) | FSub(e1, e2) | FMul(e1, e2) | FDiv(e1, e2) 9 | | Eq(e1, e2, _) | LE(e1, e2, _) 10 | | Let(_, e1, e2) | LetRec({ body = e1 }, e2) | LetTuple(_, e1, e2) 11 | | Array(e1, e2, _) | Get(e1, e2, _) -> size e1 + size e2 + 1 12 | | If(e1, e2, e3) | Put(e1, e2, e3, _) -> size e1 + size e2 + size e3 + 1 13 | | App((e1, t), e2s) -> size e1 + (List.fold_left (fun n e -> n + size e) 0 e2s) 14 | | _ -> 1 15 | 16 | let rec g env e = match e with 17 | | Unit | Bool _ | Int _ | Float _ | Var _ -> e 18 | | Neg(e) -> Neg(g env e) 19 | | Not(e) -> Not(g env e) 20 | | Xor(e1, e2) -> Xor(g env e1, g env e2) 21 | | Add(e1, e2) -> Add(g env e1, g env e2) 22 | | Sub(e1, e2) -> Sub(g env e1, g env e2) 23 | | Mul(e1, e2) -> Mul(g env e1, g env e2) 24 | | Div(e1, e2) -> Div(g env e1, g env e2) 25 | | FNeg(e) -> FNeg(g env e) 26 | | FAdd(e1, e2) -> FAdd(g env e1, g env e2) 27 | | FSub(e1, e2) -> FSub(g env e1, g env e2) 28 | | FMul(e1, e2) -> FMul(g env e1, g env e2) 29 | | FDiv(e1, e2) -> FDiv(g env e1, g env e2) 30 | | Eq(e1, e2, t) -> Eq(g env e1, g env e2, t) 31 | | LE(e1, e2, t) -> LE(g env e1, g env e2, t) 32 | | If(e1, e2, e3) -> If(g env e1, g env e2, g env e3) 33 | | Let(xt, e1, e2) -> Let(xt, g env e1, g env e2) 34 | | LetRec({ name = (x, t); args = yts; body = e1 } as f, e2) -> 35 | let env = if size e1 > !threshold then 36 | env 37 | else 38 | (Format.eprintf "inlining %s@." x; 39 | M.add x (yts, e1) env) 40 | in 41 | LetRec({ f with body = g env f.body }, g env e2) 42 | | App((Var(x), t), ys) when M.mem x env -> 43 | let (args, body) = M.find x env in 44 | let new_args = List.map (fun (_, t) -> Id.gentmp t, t) args in 45 | let env' = 46 | List.fold_left2 47 | (fun env' (z, t) (y, _) -> M.add z y env') 48 | M.empty 49 | args 50 | new_args in 51 | List.fold_right2 52 | (fun (z, t) y e -> Let((z, t), y, e)) 53 | new_args 54 | ys 55 | (Alpha.g env' body) 56 | | App((e1, t), e2) -> App((g env e1, t), List.map (g env) e2) 57 | | Tuple(ets) -> Tuple(List.map (fun (x, t) -> g env x, t) ets) 58 | | LetTuple(xts, y, e) -> LetTuple(xts, y, g env e) 59 | | Array(e1, e2, t) -> Array(g env e1, g env e2, t) 60 | | Get(e1, e2, t) -> Get(g env e1, g env e2, t) 61 | | Put(e1, e2, e3, t) -> Put(g env e1, g env e2, g env e3, t) 62 | 63 | let f e = g M.empty e 64 | -------------------------------------------------------------------------------- /src/asm.ml: -------------------------------------------------------------------------------- 1 | type imm = 2 | | I of int 3 | | F of float 4 | 5 | type ty = [`I | `F | `A | `V] 6 | type ty_prim = [`I | `F] 7 | 8 | type ty_obj = 9 | | Obj 10 | | Integer 11 | | Float 12 | | C of string 13 | | Ary of ty_obj (* array *) 14 | 15 | type ty_sig = 16 | | PInt 17 | | PFloat 18 | | Void 19 | | Array of ty_obj (* no primitive arrays! *) 20 | | Fun of ty_sig list * ty_sig 21 | | O of ty_obj 22 | 23 | type inst = 24 | | Comment of string 25 | | Load of ty * int 26 | | Store of ty * int 27 | | Store_c of ty * int * string (* comment *) 28 | | ALoad of ty (* load from array *) 29 | | AStore of ty (* store to array *) 30 | | NewArray of ty_prim 31 | | ANewArray of ty_obj 32 | | Ldc of imm 33 | | Neg of ty_prim 34 | | IXor 35 | | Add of ty_prim 36 | | Sub of ty_prim 37 | | Mul of ty_prim 38 | | Div of ty_prim 39 | | ItoF 40 | | FtoI 41 | | Dup 42 | | Pop 43 | | New of Id.t 44 | | Boxing of ty_sig 45 | | Unboxing of ty_sig 46 | | Checkcast of ty_obj 47 | (* NOTE: mainクラスはstatic fieldのみを持ち、closureクラスはnon-static fieldのみを持つ *) 48 | | PutField of Id.t * string (* classname *) * ty_obj 49 | | GetField of Id.t * string (* classname *) * ty_obj 50 | | PutStatic of Id.t * string (* classname *) * ty_obj 51 | | GetStatic of Id.t * string (* classname *) * ty_obj 52 | (* If0: comparison with zero *) 53 | | If0 of string (* branch cond. *) * string (* negative branch cond. *) * inst list * inst list * inst list 54 | | If of string (* branch cond. *) * string (* negative branch cond. *) * inst list * inst list * inst list * inst list 55 | | FCmp 56 | | Return of [`I | `F | `A | `V] 57 | (* call to java/lang/Math library (sin, cos, ...) *) 58 | | CallMath of Id.t * string (* type signature (which often includes double) *) 59 | | InvokeStatic of Id.t * ty_sig (* mainly for calling function declared in main.j (AppDir) *) 60 | | InvokeVirtual of Id.t * ty_sig (* mainly for closure application *) 61 | | InvokeSpecial of Id.t * ty_sig (* mainly for calling *) 62 | 63 | type modifiers = 64 | | Static 65 | 66 | type fundef = { 67 | name : (Id.t * ty_sig); 68 | modifiers : modifiers list; 69 | args : (Id.t * ty_sig) list; 70 | fv : (Id.t * ty_sig) list; 71 | stack : int; (* stack limits *) 72 | locals : int; (* locals limits *) 73 | body : inst list 74 | } 75 | 76 | type file = { 77 | classname : string; (* this also becomes the filename (without .j) *) 78 | clinit : fundef option; (* class initializer, mainのみ必要(static fieldの初期化のため) *) 79 | init : ty_sig * inst list; 80 | funs : fundef list; 81 | super : string; 82 | fields : (Id.t * ty_obj) list 83 | } 84 | 85 | type prog = file list 86 | -------------------------------------------------------------------------------- /src/constFold.ml: -------------------------------------------------------------------------------- 1 | open Normal 2 | 3 | let rec g env e = 4 | match e with 5 | | Unit | Bool _ | Int _ | Float _ -> e 6 | | Not(e') -> (match g env e' with 7 | | Bool(b) -> Bool(not b) 8 | | e' -> Not(e')) 9 | | Neg(e') -> (match g env e' with 10 | | Int(n) -> Int(-n) 11 | | e' -> Neg(e')) 12 | | Xor(e1, e2) -> (match g env e1, g env e2 with 13 | | Bool(b1), Bool(b2) -> Bool(b1 <> b2) 14 | | e1', e2' -> Xor(e1', e2')) 15 | | Add(e1, e2) -> (match g env e1, g env e2 with 16 | | Int(n1), Int(n2) -> Int(n1 + n2) 17 | | e1', e2' -> Add(e1', e2')) 18 | | Sub(e1, e2) -> (match g env e1, g env e2 with 19 | | Int(n1), Int(n2) -> Int(n1 - n2) 20 | | e1', e2' -> Sub(e1', e2')) 21 | | Mul(e1, e2) -> (match g env e1, g env e2 with 22 | | Int(n1), Int(n2) -> Int(n1 * n2) 23 | | e1', e2' -> Mul(e1', e2')) 24 | | Div(e1, e2) -> (match g env e1, g env e2 with 25 | | Int(n1), Int(n2) -> Int(n1 / n2) 26 | | e1', e2' -> Div(e1', e2')) 27 | | FNeg(e') -> (match g env e' with 28 | | Float(f) -> Float(-1. *. f) | e' -> FNeg(e')) 29 | | FAdd(e1, e2) -> (match g env e1, g env e2 with 30 | | Float(f1), Float(f2) -> Float(f1 +. f2) 31 | | e1', e2' -> FAdd(e1', e2')) 32 | | FSub(e1, e2) -> (match g env e1, g env e2 with 33 | | Float(f1), Float(f2) -> Float(f1 -. f2) 34 | | e1', e2' -> FSub(e1', e2')) 35 | | FMul(e1, e2) -> (match g env e1, g env e2 with 36 | | Float(f1), Float(f2) -> Float(f1 *. f2) 37 | | e1', e2' -> FMul(e1', e2')) 38 | | FDiv(e1, e2) -> (match g env e1, g env e2 with 39 | | Float(f1), Float(f2) -> Float(f1 /. f2) 40 | | e1', e2' -> FDiv(e1', e2')) 41 | | Eq(e1, e2, t) -> 42 | (match g env e1, g env e2 with 43 | | Bool(b1), Bool(b2) -> Bool(b1 = b2) 44 | | Int(n1), Int(n2) -> Bool(n1 = n2) 45 | | Float(n1), Float(n2) -> Bool(n1 = n2) 46 | | e1', e2' -> Eq(e1', e2', t)) 47 | | LE(e1, e2, t) -> 48 | (match g env e1, g env e2 with 49 | | Bool(b1), Bool(b2) -> Bool(b1 <= b2) 50 | | Int(n1), Int(n2) -> Bool(n1 <= n2) 51 | | Float(n1), Float(n2) -> Bool(n1 <= n2) 52 | | e1', e2' -> LE(e1', e2', t)) 53 | | If(e1, e2, e3) -> (match g env e1 with 54 | | Bool(b) -> if b then g env e2 else g env e3 55 | | e1' -> If(e1', g env e2, g env e3)) 56 | | Let((x, t), e1, e2) -> 57 | let e1' = g env e1 in 58 | (match e1' with 59 | | Bool _ | Int _ | Float _ -> 60 | (Format.eprintf "eliminating variable %s@." x; 61 | g ((x, e1') :: env) e2) 62 | | _ -> Let((x, t), e1', g env e2)) 63 | | Var(x) when Id.mem x env -> List.assoc x env 64 | | Var(x) -> Var(x) 65 | | LetRec(f, e) -> LetRec({ f with body = g env f.body }, g env e) 66 | | App((Var"int_of_float", t) as e1, [e2]) -> (match g env e2 with 67 | | Float(f) -> Int(int_of_float f) 68 | | e2' -> App(e1, [e2'])) 69 | | App((Var"float_of_int", t) as e1, [e2]) -> (match g env e2 with 70 | | Int(n) -> Float(float_of_int n) 71 | | e2' -> App(e1, [e2'])) 72 | | App(et1, e2) -> App(et1, List.map (g env) e2) 73 | | Tuple(e) -> Tuple(List.map (fun e -> g env (fst e), snd e) e) 74 | | LetTuple(e1, e2, e3) -> LetTuple(e1, e2, g env e3) 75 | | Array(e1, e2, t) -> Array(g env e1, g env e2, t) 76 | | Get(e1, e2, t) -> Get(g env e1, g env e2, t) 77 | | Put(e1, e2, e3, t) -> Put(g env e1, g env e2, g env e3, t) 78 | 79 | let f e = g [] e 80 | -------------------------------------------------------------------------------- /src/simulate.ml: -------------------------------------------------------------------------------- 1 | open Asm 2 | 3 | let stack_max = ref 0 4 | let local_max = ref 0 5 | 6 | let rec g prog stack local = 7 | (* Printf.printf "%d %d\n" stack local; *) 8 | if stack > !stack_max then stack_max := stack; 9 | if local > !local_max then local_max := local; 10 | match prog with 11 | | [] -> ([], !stack_max, !local_max) 12 | | i :: xi -> 13 | let prog = match i with 14 | | Return t -> ([], !stack_max, !local_max) 15 | | Comment _ -> g xi stack local 16 | | Load(t, n) -> g xi (stack + 1) local 17 | | Store(t, n) | Store_c(t, n, _) -> 18 | assert (n <= local); 19 | if n = local then g xi (stack - 1) (local + 1) else g xi (stack - 1) local 20 | | ALoad(t) -> (* arrayref, index -> value *) 21 | g xi (stack - 1) local 22 | | AStore(t) -> (* arrayref, index, value -> [] *) 23 | g xi (stack - 3) local 24 | | NewArray(t) -> (* count -> arrayref *) 25 | g xi stack local 26 | | ANewArray(t) -> (* count -> arrayref *) 27 | g xi stack local 28 | | Ldc(_) -> g xi (stack + 1) local 29 | | Neg t -> g xi stack local 30 | | IXor -> g xi (stack - 1) local 31 | | Add t -> g xi (stack - 1) local 32 | | Sub t -> g xi (stack - 1) local 33 | | Mul t -> g xi (stack - 1) local 34 | | Div t -> g xi (stack - 1) local 35 | | FtoI -> g xi stack local 36 | | ItoF -> g xi stack local 37 | | FCmp -> g xi (stack - 1) local 38 | | Dup -> g xi (stack + 1) local 39 | | Pop -> g xi (stack - 1) local 40 | | New x -> g xi (stack + 1) local 41 | | Boxing t -> g xi stack local 42 | | Unboxing t -> g xi stack local 43 | | Checkcast t -> g xi stack local (* failしなければ変化はない *) 44 | | PutField (x, c, t) -> g xi (stack - 2) local 45 | | GetField (x, c, t) -> g xi stack local 46 | | PutStatic(x, c, t) -> g xi (stack - 1) local 47 | | GetStatic(x, c, t) -> g xi (stack + 1) local 48 | | If0(b, bn, e1, e2, e3) -> 49 | let (_, stack', local') = g e1 stack local in 50 | (* assert (g e2 (stack' - 1) local' = g e3 (stack' - 1) local'); *) 51 | g (e2 @ xi) (stack' - 1) local' 52 | | If(b, bn, e1, e2, e3, e4) -> 53 | let (_, stack', local') = g (e1 @ e2) stack local in 54 | (* assert (g e3 (stack' - 2) local' = g e4 (stack' - 2) local'); *) 55 | g (e3 @ xi) (stack' - 2) local' 56 | | CallMath(f, signature) -> g xi stack local (* [XXX] sin, cos, atan, sqrt, floorのとき *) 57 | | InvokeStatic(f, t) -> (match t with 58 | | Fun(ta, _) -> g xi (stack - (List.length ta)) local 59 | | _ -> assert false) 60 | | InvokeVirtual(f, t) | InvokeSpecial(f, t) -> (match t with 61 | | Fun(ta, _) -> g xi (stack - 1 - (List.length ta)) local 62 | | _ -> assert false) 63 | in 64 | let (inst, s, l) = prog in 65 | (i :: (Comment (Printf.sprintf "%d, %d" stack local)) :: inst, s, l) 66 | 67 | let round_10 n = if n mod 10 = 0 then n + 10 else ((n / 10) + 1) * 10 68 | 69 | let h fundef = 70 | (* print_endline @@ fst fundef.name; *) 71 | stack_max := 0; 72 | local_max := 0; 73 | let inst, stack, local = 74 | if fundef.modifiers = [Static] then 75 | g fundef.body 0 (List.length fundef.args) 76 | else 77 | g fundef.body 0 (1 + List.length fundef.args) 78 | in 79 | { fundef with stack = round_10 stack; locals = round_10 local } 80 | 81 | let f files = 82 | List.map (fun file -> 83 | { file with clinit = 84 | (match file.clinit with 85 | | Some f -> Some (h f) 86 | | None -> None); 87 | funs = List.map h file.funs }) files 88 | -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | type pos = Lexing.position 2 | 3 | type t = 4 | | Unit 5 | | Bool of bool 6 | | Int of int 7 | | Float of float 8 | | Not of t * pos 9 | | Neg of t * pos 10 | | Add of t * t * pos 11 | | Sub of t * t * pos 12 | | Mul of t * t * pos 13 | | Div of t * t * pos 14 | | FNeg of t * pos 15 | | FAdd of t * t * pos 16 | | FSub of t * t * pos 17 | | FMul of t * t * pos 18 | | FDiv of t * t * pos 19 | | Eq of t * t * Type.t * pos 20 | | LE of t * t * Type.t * pos 21 | | If of t * t * t * pos 22 | | Let of (Id.t * Type.t) * t * t * pos 23 | | Var of Id.t 24 | | LetRec of fundef * t * pos 25 | | App of (t * Type.t) * t list * pos 26 | | Tuple of (t * Type.t) list 27 | | LetTuple of (Id.t * Type.t) list * t * t * pos 28 | | Array of t * t * Type.t * pos 29 | | Get of t * t * Type.t * pos 30 | | Put of t * t * t * Type.t * pos 31 | and fundef = { name : Id.t * Type.t; args : (Id.t * Type.t) list; body : t } 32 | 33 | (* [WEEK1 Q1] output pretty string for Syntax.t *) 34 | let rec string_of_t ?(do_indent = true) ?(endline = "\n") (exp : t) (depth : int) : string = 35 | let indent = (String.make (depth * 2) ' ') in 36 | let prefix = (match do_indent with 37 | | true -> indent 38 | | false -> "") in 39 | match exp with 40 | | Unit -> prefix ^ "()" ^ endline 41 | | Bool b -> (match b with 42 | | true -> prefix ^ "BOOL TRUE" ^ endline 43 | | false -> prefix ^ "BOOL FALSE" ^ endline) 44 | | Int n -> prefix ^ "INT " ^ (string_of_int n) ^ endline 45 | | Float f -> prefix ^ "FLOAT " ^ (string_of_float f) ^ endline 46 | | Not (e, _) -> prefix ^ "NOT\n" ^ (string_of_t e (depth + 1)) 47 | | Neg (e, _) -> prefix ^ "NEG\n" ^ (string_of_t e (depth + 1)) 48 | | Add (e1, e2, _) -> prefix ^ "ADD\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 49 | | Sub (e1, e2, _) -> prefix ^ "SUB\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 50 | | Mul (e1, e2, _) -> prefix ^ "MUL\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 51 | | Div (e1, e2, _) -> prefix ^ "DIV\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 52 | | FNeg (e, _) -> prefix ^ "FNEG\n" ^ (string_of_t e (depth + 1)) 53 | | FAdd (e1, e2, _) -> prefix ^ "FADD\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 54 | | FSub (e1, e2, _) -> prefix ^ "FSUB\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 55 | | FMul (e1, e2, _) -> prefix ^ "FMUL\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 56 | | FDiv (e1, e2, _) -> prefix ^ "FDIV\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 57 | | Eq (e1, e2, _, _) -> prefix ^ "EQ\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 58 | | LE (e1, e2, _, _) -> prefix ^ "LE\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 59 | | If (b, e1, e2, _) -> prefix ^ "IF\n" ^ (string_of_t b (depth + 1)) ^ 60 | prefix ^ "THEN\n" ^ (string_of_t e1 (depth + 1)) ^ 61 | prefix ^ "ELSE\n" ^ (string_of_t e2 (depth + 1)) 62 | | Let ((x, _), e1, e2, _) -> prefix ^ "LET " ^ x ^ " =\n" ^ (string_of_t e1 (depth + 1)) ^ (indent ^ "IN\n") 63 | ^ (string_of_t e2 depth) 64 | | Var x -> prefix ^ "VAR " ^ x ^ endline 65 | | LetRec (f, e, _) -> prefix ^ "LET REC " ^ (string_of_fundef f (depth + 1)) ^ (indent ^ "IN\n") ^ (string_of_t e depth) 66 | | App ((e1, _), e2, _) -> prefix ^ (string_of_t e1 0) ^ String.concat "" (List.map (fun e -> string_of_t e (depth + 1)) e2) 67 | | Tuple e -> prefix ^ "( " ^ 68 | String.concat ", " (List.map (fun ex -> string_of_t (fst ex) (depth + 1) ~do_indent:false ~endline:"") e) ^ " )" ^ endline 69 | | LetTuple (l, e1, e2, _) -> prefix ^ "LET (" ^ (String.concat ", " (List.map fst l)) ^ ") =\n" 70 | ^ (string_of_t e1 (depth + 1)) ^ (indent ^ "IN\n") ^ (string_of_t e2 depth) 71 | | Array (e1, e2, _, _) -> prefix ^ "[ " ^ (string_of_t e1 depth ~do_indent:false) ^ (string_of_t e2 (depth + 1) ~endline:" ]\n") 72 | | Get (e1, e2, _, _) -> (string_of_t e1 depth ~endline:"[ ") ^ (string_of_t e2 (depth + 1) ~do_indent:false ~endline:" ]") ^ endline 73 | | Put (e1, e2, e3, _, _) -> (string_of_t e1 depth ~endline:"[ ") ^ (string_of_t e2 (depth + 1) ~do_indent:false ~endline:" ] <-\n") 74 | ^ (string_of_t e3 (depth + 1)) ^ endline 75 | and 76 | string_of_fundef (f : fundef) (depth : int) = 77 | Printf.sprintf "%s (%s) : %s =\n%s" (fst f.name) (String.concat ", " (List.map fst f.args)) (Type.string_of_t (snd f.name)) (string_of_t f.body depth) 78 | 79 | (* [WEEK1 Q1] pretty print for Syntax.t *) 80 | let print_t (exp : t) = 81 | print_string (string_of_t exp 0) 82 | -------------------------------------------------------------------------------- /example/cls-reg-bug/main.j: -------------------------------------------------------------------------------- 1 | .class public main 2 | .super java/lang/Object 3 | .method public ()V 4 | .limit stack 10 5 | .limit locals 10 6 | aload 0 7 | invokespecial java/lang/Object/()V 8 | return 9 | .end method ; 10 | 11 | .method public static h_2([Ljava/lang/Object;)I 12 | .limit stack 100 13 | .limit locals 100 14 | aload 0 15 | dup 16 | ldc 0 17 | aaload 18 | checkcast java/lang/Integer 19 | invokevirtual java/lang/Integer/intValue()I 20 | istore 1 21 | dup 22 | ldc 1 23 | aaload 24 | checkcast java/lang/Integer 25 | invokevirtual java/lang/Integer/intValue()I 26 | istore 2 27 | dup 28 | ldc 2 29 | aaload 30 | checkcast java/lang/Integer 31 | invokevirtual java/lang/Integer/intValue()I 32 | istore 3 33 | dup 34 | ldc 3 35 | aaload 36 | checkcast java/lang/Integer 37 | invokevirtual java/lang/Integer/intValue()I 38 | istore 4 39 | dup 40 | ldc 4 41 | aaload 42 | checkcast java/lang/Integer 43 | invokevirtual java/lang/Integer/intValue()I 44 | istore 5 45 | dup 46 | ldc 5 47 | aaload 48 | checkcast java/lang/Integer 49 | invokevirtual java/lang/Integer/intValue()I 50 | istore 6 51 | dup 52 | ldc 6 53 | aaload 54 | checkcast java/lang/Integer 55 | invokevirtual java/lang/Integer/intValue()I 56 | istore 7 57 | dup 58 | ldc 7 59 | aaload 60 | checkcast java/lang/Integer 61 | invokevirtual java/lang/Integer/intValue()I 62 | istore 8 63 | dup 64 | ldc 8 65 | aaload 66 | checkcast java/lang/Integer 67 | invokevirtual java/lang/Integer/intValue()I 68 | istore 9 69 | dup 70 | ldc 9 71 | aaload 72 | checkcast java/lang/Integer 73 | invokevirtual java/lang/Integer/intValue()I 74 | istore 10 75 | pop 76 | new cls_g_15 77 | dup 78 | ldc 10 79 | anewarray java/lang/Object 80 | dup 81 | ldc 0 82 | iload 10 83 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 84 | aastore 85 | dup 86 | ldc 1 87 | iload 1 88 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 89 | aastore 90 | dup 91 | ldc 2 92 | iload 2 93 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 94 | aastore 95 | dup 96 | ldc 3 97 | iload 3 98 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 99 | aastore 100 | dup 101 | ldc 4 102 | iload 4 103 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 104 | aastore 105 | dup 106 | ldc 5 107 | iload 5 108 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 109 | aastore 110 | dup 111 | ldc 6 112 | iload 6 113 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 114 | aastore 115 | dup 116 | ldc 7 117 | iload 7 118 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 119 | aastore 120 | dup 121 | ldc 8 122 | iload 8 123 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 124 | aastore 125 | dup 126 | ldc 9 127 | iload 9 128 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 129 | aastore 130 | invokespecial cls_g_15/([Ljava/lang/Object;)V 131 | astore 11 132 | aload 11 133 | ldc 1 134 | anewarray java/lang/Object 135 | dup 136 | ldc 0 137 | ldc 1 138 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 139 | aastore 140 | invokevirtual cls_g_15/app([Ljava/lang/Object;)Ljava/lang/Object; 141 | checkcast java/lang/Integer 142 | invokevirtual java/lang/Integer/intValue()I 143 | ireturn 144 | .end method ; h_2 145 | 146 | .method public static main([Ljava/lang/String;)V 147 | .limit stack 100 148 | .limit locals 100 149 | ldc 10 150 | anewarray java/lang/Object 151 | dup 152 | ldc 0 153 | ldc 1 154 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 155 | aastore 156 | dup 157 | ldc 1 158 | ldc 2 159 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 160 | aastore 161 | dup 162 | ldc 2 163 | ldc 3 164 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 165 | aastore 166 | dup 167 | ldc 3 168 | ldc 4 169 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 170 | aastore 171 | dup 172 | ldc 4 173 | ldc 5 174 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 175 | aastore 176 | dup 177 | ldc 5 178 | ldc 6 179 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 180 | aastore 181 | dup 182 | ldc 6 183 | ldc 7 184 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 185 | aastore 186 | dup 187 | ldc 7 188 | ldc 8 189 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 190 | aastore 191 | dup 192 | ldc 8 193 | ldc 9 194 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 195 | aastore 196 | dup 197 | ldc 9 198 | ldc 10 199 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 200 | aastore 201 | invokestatic main.h_2([Ljava/lang/Object;)I 202 | invokestatic libmincaml.min_caml_print_int(I)V 203 | invokestatic libmincaml.min_caml_print_newline()V 204 | return 205 | .end method ; main 206 | 207 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | let addtyp x = (x, Type.gentyp ()) 4 | 5 | (* [WEEK1 Q2] improve error message with reporting the position in the input program *) 6 | let get_pos () = Parsing.symbol_start_pos () 7 | %} 8 | 9 | %token BOOL 10 | %token INT 11 | %token FLOAT 12 | %token NOT 13 | %token MINUS 14 | %token PLUS 15 | %token AST 16 | %token SLASH 17 | %token MINUS_DOT 18 | %token PLUS_DOT 19 | %token AST_DOT 20 | %token SLASH_DOT 21 | %token EQUAL 22 | %token LESS_GREATER 23 | %token LESS_EQUAL 24 | %token GREATER_EQUAL 25 | %token LESS 26 | %token GREATER 27 | %token IF 28 | %token THEN 29 | %token ELSE 30 | %token IDENT 31 | %token LET 32 | %token IN 33 | %token REC 34 | %token COMMA 35 | %token ARRAY_CREATE 36 | %token DOT 37 | %token LESS_MINUS 38 | %token SEMICOLON 39 | %token LPAREN 40 | %token RPAREN 41 | %token EOF 42 | 43 | %nonassoc IN 44 | %right prec_let 45 | %right SEMICOLON 46 | %right prec_if 47 | %right LESS_MINUS 48 | %nonassoc prec_tuple 49 | %left COMMA 50 | %left EQUAL LESS_GREATER LESS GREATER LESS_EQUAL GREATER_EQUAL 51 | %left PLUS MINUS PLUS_DOT MINUS_DOT 52 | %left AST SLASH AST_DOT SLASH_DOT 53 | %right prec_unary_minus 54 | %left prec_app 55 | %left DOT 56 | 57 | %type exp 58 | %start exp 59 | 60 | %% 61 | 62 | simple_exp: 63 | | LPAREN exp RPAREN 64 | { $2 } 65 | | LPAREN RPAREN 66 | { Unit } 67 | | BOOL 68 | { Bool($1) } 69 | | INT 70 | { Int($1) } 71 | | FLOAT 72 | { Float($1) } 73 | | IDENT 74 | { Var($1) } 75 | | simple_exp DOT LPAREN exp RPAREN 76 | { Get($1, $4, Type.gentyp (), get_pos ()) } 77 | 78 | exp: 79 | | simple_exp 80 | { $1 } 81 | | NOT exp 82 | %prec prec_app 83 | { Not($2, get_pos ()) } 84 | | MINUS exp 85 | %prec prec_unary_minus 86 | { match $2 with 87 | | Float(f) -> Float(-.f) (* -1.23 won't raise type error *) 88 | | e -> Neg(e, get_pos ()) } 89 | | exp PLUS exp 90 | { Add($1, $3, get_pos ()) } 91 | | exp MINUS exp 92 | { Sub($1, $3, get_pos ()) } 93 | | exp AST exp 94 | { Mul($1, $3, get_pos ()) } 95 | | exp SLASH exp 96 | { Div($1, $3, get_pos ()) } 97 | | exp EQUAL exp 98 | { Eq($1, $3, Type.gentyp(), get_pos ()) } 99 | | exp LESS_GREATER exp 100 | { Not(Eq($1, $3, Type.gentyp(), get_pos ()), get_pos ()) } 101 | | exp LESS exp 102 | { Not(LE($3, $1, Type.gentyp(), get_pos ()), get_pos ()) } 103 | | exp GREATER exp 104 | { Not(LE($1, $3, Type.gentyp(), get_pos ()), get_pos ()) } 105 | | exp LESS_EQUAL exp 106 | { LE($1, $3, Type.gentyp(), get_pos ()) } 107 | | exp GREATER_EQUAL exp 108 | { LE($3, $1, Type.gentyp(), get_pos ()) } 109 | | IF exp THEN exp ELSE exp 110 | %prec prec_if 111 | { If($2, $4, $6, get_pos ()) } 112 | | MINUS_DOT exp 113 | %prec prec_unary_minus 114 | { FNeg($2, get_pos ()) } 115 | | exp PLUS_DOT exp 116 | { FAdd($1, $3, get_pos ()) } 117 | | exp MINUS_DOT exp 118 | { FSub($1, $3, get_pos ()) } 119 | | exp AST_DOT exp 120 | { FMul($1, $3, get_pos ()) } 121 | | exp SLASH_DOT exp 122 | { FDiv($1, $3, get_pos ()) } 123 | | LET IDENT EQUAL exp IN exp 124 | %prec prec_let 125 | { Let(addtyp $2, $4, $6, get_pos ()) } 126 | | LET REC fundef IN exp 127 | %prec prec_let 128 | { LetRec($3, $5, get_pos ()) } 129 | | simple_exp actual_args 130 | %prec prec_app 131 | { App(($1, Type.gentyp()), $2, get_pos ()) } 132 | | elems 133 | %prec prec_tuple 134 | { Tuple($1) } 135 | | LET LPAREN pat RPAREN EQUAL exp IN exp 136 | { LetTuple($3, $6, $8, get_pos ()) } 137 | | simple_exp DOT LPAREN exp RPAREN LESS_MINUS exp 138 | { Put($1, $4, $7, Type.gentyp (), get_pos ()) } 139 | | exp SEMICOLON exp 140 | { Let((Id.gentmp Type.Unit, Type.Unit), $1, $3, get_pos ()) } 141 | | exp SEMICOLON 142 | { Let((Id.gentmp Type.Unit, Type.Unit), $1, Unit, get_pos ()) } 143 | | ARRAY_CREATE simple_exp simple_exp 144 | %prec prec_app 145 | { Array($2, $3, Type.gentyp (), get_pos ()) } 146 | | error 147 | { let start_pos = Parsing.symbol_start_pos () in 148 | let end_pos = Parsing.symbol_end_pos () in 149 | failwith 150 | (* [WEEK1 Q2] improve parse-error message *) 151 | (Printf.sprintf "parse error near line %d, characters %d-%d" 152 | start_pos.pos_lnum 153 | (start_pos.pos_cnum - start_pos.pos_bol) 154 | (end_pos.pos_cnum - end_pos.pos_bol)) } 155 | 156 | fundef: 157 | | IDENT formal_args EQUAL exp 158 | { { name = addtyp $1; args = $2; body = $4 } } 159 | 160 | formal_args: 161 | | IDENT formal_args 162 | { addtyp $1 :: $2 } 163 | | IDENT 164 | { [addtyp $1] } 165 | 166 | actual_args: 167 | | actual_args simple_exp 168 | %prec prec_app 169 | { $1 @ [$2] } 170 | | simple_exp 171 | %prec prec_app 172 | { [$1] } 173 | 174 | elems: 175 | | elems COMMA exp 176 | { $1 @ [($3, Type.gentyp ())] } 177 | | exp COMMA exp 178 | { [($1, Type.gentyp ()); ($3, Type.gentyp ())] } 179 | 180 | pat: 181 | | pat COMMA IDENT 182 | { $1 @ [addtyp $3] } 183 | | IDENT COMMA IDENT 184 | { [addtyp $1; addtyp $3] } 185 | -------------------------------------------------------------------------------- /example/cls-reg-bug/cls_g_15.j: -------------------------------------------------------------------------------- 1 | .class public cls_g_15 2 | .super cls 3 | .field public v10_14 Ljava/lang/Integer; 4 | .field public v1_5 Ljava/lang/Integer; 5 | .field public v2_6 Ljava/lang/Integer; 6 | .field public v3_7 Ljava/lang/Integer; 7 | .field public v4_8 Ljava/lang/Integer; 8 | .field public v5_9 Ljava/lang/Integer; 9 | .field public v6_10 Ljava/lang/Integer; 10 | .field public v7_11 Ljava/lang/Integer; 11 | .field public v8_12 Ljava/lang/Integer; 12 | .field public v9_13 Ljava/lang/Integer; 13 | .method public ([Ljava/lang/Object;)V 14 | .limit stack 10 15 | .limit locals 10 16 | aload 0 17 | aload 1 18 | invokespecial cls/([Ljava/lang/Object;)V 19 | aload 0 20 | aload 1 21 | ldc 0 22 | aaload 23 | checkcast java/lang/Integer 24 | putfield cls_g_15/v10_14 Ljava/lang/Integer; 25 | aload 0 26 | aload 1 27 | ldc 1 28 | aaload 29 | checkcast java/lang/Integer 30 | putfield cls_g_15/v1_5 Ljava/lang/Integer; 31 | aload 0 32 | aload 1 33 | ldc 2 34 | aaload 35 | checkcast java/lang/Integer 36 | putfield cls_g_15/v2_6 Ljava/lang/Integer; 37 | aload 0 38 | aload 1 39 | ldc 3 40 | aaload 41 | checkcast java/lang/Integer 42 | putfield cls_g_15/v3_7 Ljava/lang/Integer; 43 | aload 0 44 | aload 1 45 | ldc 4 46 | aaload 47 | checkcast java/lang/Integer 48 | putfield cls_g_15/v4_8 Ljava/lang/Integer; 49 | aload 0 50 | aload 1 51 | ldc 5 52 | aaload 53 | checkcast java/lang/Integer 54 | putfield cls_g_15/v5_9 Ljava/lang/Integer; 55 | aload 0 56 | aload 1 57 | ldc 6 58 | aaload 59 | checkcast java/lang/Integer 60 | putfield cls_g_15/v6_10 Ljava/lang/Integer; 61 | aload 0 62 | aload 1 63 | ldc 7 64 | aaload 65 | checkcast java/lang/Integer 66 | putfield cls_g_15/v7_11 Ljava/lang/Integer; 67 | aload 0 68 | aload 1 69 | ldc 8 70 | aaload 71 | checkcast java/lang/Integer 72 | putfield cls_g_15/v8_12 Ljava/lang/Integer; 73 | aload 0 74 | aload 1 75 | ldc 9 76 | aaload 77 | checkcast java/lang/Integer 78 | putfield cls_g_15/v9_13 Ljava/lang/Integer; 79 | return 80 | .end method ; 81 | 82 | .method public app([Ljava/lang/Object;)Ljava/lang/Object; 83 | .limit stack 100 84 | .limit locals 100 85 | aload 1 86 | dup 87 | ldc 0 88 | aaload 89 | checkcast java/lang/Integer 90 | invokevirtual java/lang/Integer/intValue()I 91 | istore 2 92 | aload 0 93 | getfield cls_g_15/v1_5 Ljava/lang/Integer; 94 | invokevirtual java/lang/Integer/intValue()I 95 | aload 0 96 | getfield cls_g_15/v2_6 Ljava/lang/Integer; 97 | invokevirtual java/lang/Integer/intValue()I 98 | iadd 99 | aload 0 100 | getfield cls_g_15/v3_7 Ljava/lang/Integer; 101 | invokevirtual java/lang/Integer/intValue()I 102 | iadd 103 | aload 0 104 | getfield cls_g_15/v4_8 Ljava/lang/Integer; 105 | invokevirtual java/lang/Integer/intValue()I 106 | iadd 107 | aload 0 108 | getfield cls_g_15/v5_9 Ljava/lang/Integer; 109 | invokevirtual java/lang/Integer/intValue()I 110 | iadd 111 | aload 0 112 | getfield cls_g_15/v6_10 Ljava/lang/Integer; 113 | invokevirtual java/lang/Integer/intValue()I 114 | iadd 115 | aload 0 116 | getfield cls_g_15/v7_11 Ljava/lang/Integer; 117 | invokevirtual java/lang/Integer/intValue()I 118 | iadd 119 | aload 0 120 | getfield cls_g_15/v8_12 Ljava/lang/Integer; 121 | invokevirtual java/lang/Integer/intValue()I 122 | iadd 123 | aload 0 124 | getfield cls_g_15/v9_13 Ljava/lang/Integer; 125 | invokevirtual java/lang/Integer/intValue()I 126 | iadd 127 | aload 0 128 | getfield cls_g_15/v10_14 Ljava/lang/Integer; 129 | invokevirtual java/lang/Integer/intValue()I 130 | iadd 131 | istore 3 ; r_17 132 | iload 2 133 | ifgt ifle_else_2 134 | new cls_g_15 135 | dup 136 | ldc 10 137 | anewarray java/lang/Object 138 | dup 139 | ldc 0 140 | aload 0 141 | getfield cls_g_15/v10_14 Ljava/lang/Integer; 142 | invokevirtual java/lang/Integer/intValue()I 143 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 144 | aastore 145 | dup 146 | ldc 1 147 | aload 0 148 | getfield cls_g_15/v1_5 Ljava/lang/Integer; 149 | invokevirtual java/lang/Integer/intValue()I 150 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 151 | aastore 152 | dup 153 | ldc 2 154 | aload 0 155 | getfield cls_g_15/v2_6 Ljava/lang/Integer; 156 | invokevirtual java/lang/Integer/intValue()I 157 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 158 | aastore 159 | dup 160 | ldc 3 161 | aload 0 162 | getfield cls_g_15/v3_7 Ljava/lang/Integer; 163 | invokevirtual java/lang/Integer/intValue()I 164 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 165 | aastore 166 | dup 167 | ldc 4 168 | aload 0 169 | getfield cls_g_15/v4_8 Ljava/lang/Integer; 170 | invokevirtual java/lang/Integer/intValue()I 171 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 172 | aastore 173 | dup 174 | ldc 5 175 | aload 0 176 | getfield cls_g_15/v5_9 Ljava/lang/Integer; 177 | invokevirtual java/lang/Integer/intValue()I 178 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 179 | aastore 180 | dup 181 | ldc 6 182 | aload 0 183 | getfield cls_g_15/v6_10 Ljava/lang/Integer; 184 | invokevirtual java/lang/Integer/intValue()I 185 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 186 | aastore 187 | dup 188 | ldc 7 189 | aload 0 190 | getfield cls_g_15/v7_11 Ljava/lang/Integer; 191 | invokevirtual java/lang/Integer/intValue()I 192 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 193 | aastore 194 | dup 195 | ldc 8 196 | aload 0 197 | getfield cls_g_15/v8_12 Ljava/lang/Integer; 198 | invokevirtual java/lang/Integer/intValue()I 199 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 200 | aastore 201 | dup 202 | ldc 9 203 | aload 0 204 | getfield cls_g_15/v9_13 Ljava/lang/Integer; 205 | invokevirtual java/lang/Integer/intValue()I 206 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 207 | aastore 208 | invokespecial cls_g_15/([Ljava/lang/Object;)V 209 | astore 4 210 | aload 4 211 | ldc 1 212 | anewarray java/lang/Object 213 | dup 214 | ldc 0 215 | iload 2 216 | ineg 217 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 218 | aastore 219 | invokevirtual cls_g_15/app([Ljava/lang/Object;)Ljava/lang/Object; 220 | checkcast java/lang/Integer 221 | invokevirtual java/lang/Integer/intValue()I 222 | goto ifle_cont_2 223 | ifle_else_2: 224 | iload 3 225 | ifle_cont_2: 226 | invokestatic java/lang/Integer/valueOf(I)Ljava/lang/Integer; 227 | areturn 228 | .end method ; app 229 | 230 | -------------------------------------------------------------------------------- /src/typing.ml: -------------------------------------------------------------------------------- 1 | (* type inference/reconstruction *) 2 | 3 | open Syntax 4 | 5 | exception Unify of Type.t * Type.t * Syntax.pos 6 | exception Error of string 7 | 8 | let extenv = ref M.empty 9 | 10 | (* for pretty printing (and type normalization) *) 11 | let rec deref_typ = function (* replace type variable with its decoded ones (caml2html: typing_deref) *) 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, p) -> Not(deref_term e, p) 27 | | Neg(e, p) -> Neg(deref_term e, p) 28 | | Add(e1, e2, p) -> Add(deref_term e1, deref_term e2, p) 29 | | Sub(e1, e2, p) -> Sub(deref_term e1, deref_term e2, p) 30 | | Eq(e1, e2, t, p) -> Eq(deref_term e1, deref_term e2, deref_typ t, p) 31 | | LE(e1, e2, t, p) -> LE(deref_term e1, deref_term e2, deref_typ t, p) 32 | | FNeg(e, p) -> FNeg(deref_term e, p) 33 | | FAdd(e1, e2, p) -> FAdd(deref_term e1, deref_term e2, p) 34 | | FSub(e1, e2, p) -> FSub(deref_term e1, deref_term e2, p) 35 | | FMul(e1, e2, p) -> FMul(deref_term e1, deref_term e2, p) 36 | | FDiv(e1, e2, p) -> FDiv(deref_term e1, deref_term e2, p) 37 | | If(e1, e2, e3, p) -> If(deref_term e1, deref_term e2, deref_term e3, p) 38 | | Let(xt, e1, e2, p) -> Let(deref_id_typ xt, deref_term e1, deref_term e2, p) 39 | | LetRec({ name = xt; args = yts; body = e1 }, e2, p) -> 40 | LetRec({ name = deref_id_typ xt; 41 | args = List.map deref_id_typ yts; 42 | body = deref_term e1 }, 43 | deref_term e2, p) 44 | | App((x, t), es, p) -> App((deref_term x, deref_typ t), List.map deref_term es, p) 45 | | Tuple(es) -> Tuple(List.map (fun (e, t) -> deref_term e, deref_typ t) es) 46 | | LetTuple(xts, e1, e2, p) -> LetTuple(List.map deref_id_typ xts, deref_term e1, deref_term e2, p) 47 | | Array(e1, e2, t, p) -> Array(deref_term e1, deref_term e2, deref_typ t, p) 48 | | Get(e1, e2, t, p) -> Get(deref_term e1, deref_term e2, deref_typ t, p) 49 | | Put(e1, e2, e3, t, p) -> Put(deref_term e1, deref_term e2, deref_term e3, deref_typ t, p) 50 | | e -> e 51 | 52 | let rec occur r1 = function (* occur check (caml2html: typing_occur) *) 53 | | Type.Fun(t2s, t2) -> List.exists (occur r1) t2s || occur r1 t2 54 | | Type.Tuple(t2s) -> List.exists (occur r1) t2s 55 | | Type.Array(t2) -> occur r1 t2 56 | | Type.Var(r2) when r1 == r2 -> true 57 | | Type.Var({ contents = None }) -> false 58 | | Type.Var({ contents = Some(t2) }) -> occur r1 t2 59 | | _ -> false 60 | 61 | (* [WEEK1 Q2] improve unification error message with reporting the position in the input program *) 62 | let unify t1 t2 pos = 63 | let rec _unify t1 t2 = (* original `unify` *) 64 | match t1, t2 with 65 | | Type.Unit, Type.Unit | Type.Bool, Type.Bool | Type.Int, Type.Int | Type.Float, Type.Float -> () 66 | | Type.Fun(t1s, t1'), Type.Fun(t2s, t2') -> 67 | (try List.iter2 _unify t1s t2s 68 | with Invalid_argument(_) -> raise (Unify(t1, t2, pos))); 69 | _unify t1' t2' 70 | | Type.Tuple(t1s), Type.Tuple(t2s) -> 71 | (try List.iter2 _unify t1s t2s 72 | with Invalid_argument(_) -> raise (Unify(t1, t2, pos))) 73 | | Type.Array(t1), Type.Array(t2) -> _unify t1 t2 74 | | Type.Var(r1), Type.Var(r2) when r1 == r2 -> () 75 | | Type.Var({ contents = Some(t1') }), _ -> _unify t1' t2 76 | | _, Type.Var({ contents = Some(t2') }) -> _unify t1 t2' 77 | | Type.Var({ contents = None } as r1), _ -> (* one of the tyvars is undefined (caml2html: typing_undef) *) 78 | if occur r1 t2 then raise (Unify(t1, t2, pos)); 79 | r1 := Some(t2) 80 | | _, Type.Var({ contents = None } as r2) -> 81 | if occur r2 t1 then raise (Unify(t1, t2, pos)); 82 | r2 := Some(t1) 83 | | _, _ -> raise (Unify(t1, t2, pos)) 84 | in _unify t1 t2 85 | 86 | let rec g env e = 87 | try 88 | match e with 89 | | Unit -> Type.Unit 90 | | Bool(_) -> Type.Bool 91 | | Int(_) -> Type.Int 92 | | Float(_) -> Type.Float 93 | | Not(e, p) -> 94 | unify Type.Bool (g env e) p; 95 | Type.Bool 96 | | Neg(e, p) -> 97 | unify Type.Int (g env e) p; 98 | Type.Int 99 | | Add(e1, e2, p) | Sub(e1, e2, p) | Mul(e1, e2, p) | Div(e1, e2, p) -> 100 | unify Type.Int (g env e1) p; 101 | unify Type.Int (g env e2) p; 102 | Type.Int 103 | | FNeg(e, p) -> 104 | unify Type.Float (g env e) p; 105 | Type.Float 106 | | FAdd(e1, e2, p) | FSub(e1, e2, p) | FMul(e1, e2, p) | FDiv(e1, e2, p) -> 107 | unify Type.Float (g env e1) p; 108 | unify Type.Float (g env e2) p; 109 | Type.Float 110 | | Eq(e1, e2, t, p) | LE(e1, e2, t, p) -> 111 | unify t (g env e1) p; 112 | unify t (g env e2) p; 113 | Type.Bool 114 | | If(e1, e2, e3, p) -> 115 | unify (g env e1) Type.Bool p; 116 | let t2 = g env e2 in 117 | let t3 = g env e3 in 118 | unify t2 t3 p; 119 | t2 120 | | Let((x, t), e1, e2, p) -> 121 | unify t (g env e1) p; 122 | g (M.add x t env) e2 123 | | Var(x) when M.mem x env -> M.find x env 124 | | Var(x) when M.mem x !extenv -> M.find x !extenv 125 | | Var(x) -> (* type reference for external variables (caml2html: typing_extvar) *) 126 | Format.eprintf "free variable %s assumed as external@." x; 127 | let t = Type.gentyp () in 128 | extenv := M.add x t !extenv; 129 | t 130 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2, p) -> 131 | let env = M.add x t env in 132 | unify t (Type.Fun(List.map snd yts, g (M.add_list yts env) e1)) p; 133 | g env e2 134 | | App((Var("create_array"), t), [e1; e2], p) -> 135 | unify Type.Int (g env e1) p; 136 | let t' = Type.gentyp () in 137 | unify (g env e2) t' p; 138 | unify t (Type.Fun([Type.Int; t'], Type.Array(t'))) p; 139 | Type.Array(t') 140 | | App((x, t), es, p) -> 141 | let t' = Type.gentyp () in 142 | unify (g env x) (Type.Fun(List.map (g env) es, t')) p; 143 | unify t (Type.Fun(List.map (g env) es, t')) p; 144 | t' 145 | | Tuple(ets) -> 146 | List.iter (fun (e, t) -> 147 | unify t (g env e) Lexing.dummy_pos) ets; 148 | Type.Tuple(List.map snd ets) 149 | | LetTuple(xts, e1, e2, p) -> 150 | unify (Type.Tuple(List.map snd xts)) (g env e1) p; 151 | g (M.add_list xts env) e2 152 | | Array(e1, e2, t, p) -> (* must be a primitive for "polymorphic" typing *) 153 | unify (g env e1) Type.Int p; 154 | unify t (g env e2) p; 155 | Type.Array(t) 156 | | Get(e1, e2, t, p) -> 157 | unify (Type.Array(t)) (g env e1) p; 158 | unify Type.Int (g env e2) p; 159 | t 160 | | Put(e1, e2, e3, t, p) -> 161 | unify (Type.Array(t)) (g env e1) p; 162 | unify Type.Int (g env e2) p; 163 | unify t (g env e3) p; 164 | Type.Unit 165 | with Unify(t1, t2, p) -> 166 | let errmsg = Printf.sprintf "Type error in line %d, from character %d: unable to unify " (p.pos_lnum) (p.pos_cnum - p.pos_bol) in 167 | let errmsg = errmsg ^ (Type.string_of_t (deref_typ t1)) ^ " and " ^ (Type.string_of_t (deref_typ t2)) in 168 | raise (Error errmsg) 169 | 170 | let f e = 171 | extenv := M.empty; 172 | extenv := M.add "xor" (Type.Fun([Bool; Bool], Bool)) !extenv; 173 | extenv := M.add "sin" (Type.Fun([Float], Float)) !extenv; 174 | extenv := M.add "cos" (Type.Fun([Float], Float)) !extenv; 175 | extenv := M.add "atan" (Type.Fun([Float], Float)) !extenv; 176 | extenv := M.add "sqrt" (Type.Fun([Float], Float)) !extenv; 177 | extenv := M.add "fsqr" (Type.Fun([Float], Float)) !extenv; 178 | extenv := M.add "fhalf" (Type.Fun([Float], Float)) !extenv; 179 | extenv := M.add "fneg" (Type.Fun([Float], Float)) !extenv; 180 | extenv := M.add "fabs" (Type.Fun([Float], Float)) !extenv; 181 | extenv := M.add "floor" (Type.Fun([Float], Float)) !extenv; 182 | extenv := M.add "fiszero" (Type.Fun([Float], Bool)) !extenv; 183 | extenv := M.add "fispos" (Type.Fun([Float], Bool)) !extenv; 184 | extenv := M.add "fisneg" (Type.Fun([Float], Bool)) !extenv; 185 | extenv := M.add "fless" (Type.Fun([Float; Float], Bool)) !extenv; 186 | extenv := M.add "abs_float" (Type.Fun([Float], Float)) !extenv; 187 | extenv := M.add "create_array" (Type.Fun([Int; Int], Array(Int))) !extenv; 188 | extenv := M.add "float_of_int" (Type.Fun([Int], Float)) !extenv; 189 | extenv := M.add "int_of_float" (Type.Fun([Float], Int)) !extenv; 190 | extenv := M.add "print_newline" (Type.Fun([Unit], Unit)) !extenv; 191 | extenv := M.add "print_int" (Type.Fun([Int], Unit)) !extenv; 192 | extenv := M.add "print_char" (Type.Fun([Int], Unit)) !extenv; 193 | extenv := M.add "print_float" (Type.Fun([Float], Unit)) !extenv; 194 | extenv := M.add "read_int" (Type.Fun([Unit], Int)) !extenv; 195 | extenv := M.add "read_float" (Type.Fun([Unit], Float)) !extenv; 196 | (* 197 | (match deref_typ (g M.empty e) with 198 | | Type.Unit -> () 199 | | _ -> Format.eprintf "warning: final result does not have type unit@."); 200 | *) 201 | (try unify Type.Unit (g M.empty e) Lexing.dummy_pos 202 | with Unify _ -> failwith "top level does not have type unit"); 203 | extenv := M.map deref_typ !extenv; 204 | deref_term e 205 | -------------------------------------------------------------------------------- /src/normal.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Unit 3 | | Bool of bool 4 | | Int of int 5 | | Float of float 6 | | Neg of t 7 | | Not of t 8 | | Xor of t * t 9 | | Add of t * t 10 | | Sub of t * t 11 | | Mul of t * t 12 | | Div of t * t 13 | | FNeg of t 14 | | FAdd of t * t 15 | | FSub of t * t 16 | | FMul of t * t 17 | | FDiv of t * t 18 | | Eq of t * t * Type.t 19 | | LE of t * t * Type.t 20 | | If of t * t * t 21 | | Let of (Id.t * Type.t) * t * t 22 | | Var of Id.t 23 | | LetRec of fundef * t 24 | | App of (t * Type.t) * t list 25 | | Tuple of (t * Type.t) list 26 | | LetTuple of (Id.t * Type.t) list * t * t 27 | | Array of t * t * Type.t 28 | | Get of t * t * Type.t 29 | | Put of t * t * t * Type.t 30 | and fundef = { name : Id.t * Type.t; args : (Id.t * Type.t) list; body : t } 31 | 32 | let rec string_of_t ?(do_indent = true) ?(endline = "\n") (exp : t) (depth : int) : string = 33 | let indent = (String.make (depth * 2) ' ') in 34 | let prefix = (match do_indent with 35 | | true -> indent 36 | | false -> "") in 37 | match exp with 38 | | Unit -> prefix ^ "()" ^ endline 39 | | Bool b -> (match b with 40 | | true -> prefix ^ "BOOL TRUE" ^ endline 41 | | false -> prefix ^ "BOOL FALSE" ^ endline) 42 | | Int n -> prefix ^ "INT " ^ (string_of_int n) ^ endline 43 | | Float f -> prefix ^ "FLOAT " ^ (string_of_float f) ^ endline 44 | | Not (e) -> prefix ^ "NOT\n" ^ (string_of_t e (depth + 1)) 45 | | Neg (e) -> prefix ^ "NEG\n" ^ (string_of_t e (depth + 1)) 46 | | Xor (e1, e2) -> prefix ^ "XOR\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 47 | | Add (e1, e2) -> prefix ^ "ADD\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 48 | | Sub (e1, e2) -> prefix ^ "SUB\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 49 | | Mul (e1, e2) -> prefix ^ "MUL\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 50 | | Div (e1, e2) -> prefix ^ "DIV\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 51 | | FNeg (e) -> prefix ^ "FNEG\n" ^ (string_of_t e (depth + 1)) 52 | | FAdd (e1, e2) -> prefix ^ "FADD\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 53 | | FSub (e1, e2) -> prefix ^ "FSUB\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 54 | | FMul (e1, e2) -> prefix ^ "FMUL\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 55 | | FDiv (e1, e2) -> prefix ^ "FDIV\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 56 | | Eq (e1, e2, _) -> prefix ^ "EQ\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 57 | | LE (e1, e2, _) -> prefix ^ "LE\n" ^ (string_of_t e1 (depth + 1)) ^ (string_of_t e2 (depth + 1)) 58 | | If (b, e1, e2) -> prefix ^ "IF\n" ^ (string_of_t b (depth + 1)) ^ 59 | prefix ^ "THEN\n" ^ (string_of_t e1 (depth + 1)) ^ 60 | prefix ^ "ELSE\n" ^ (string_of_t e2 (depth + 1)) 61 | | Let ((x, _), e1, e2) -> prefix ^ "LET " ^ x ^ " =\n" ^ (string_of_t e1 (depth + 1)) ^ (indent ^ "IN\n") 62 | ^ (string_of_t e2 depth) 63 | | Var x -> prefix ^ "VAR " ^ x ^ endline 64 | | LetRec (f, e) -> prefix ^ "LET REC " ^ (string_of_fundef f (depth + 1)) ^ (indent ^ "IN\n") ^ (string_of_t e depth) 65 | | App ((e1, _), e2) -> prefix ^ (string_of_t e1 0) ^ String.concat "" (List.map (fun e -> string_of_t e (depth + 1)) e2) 66 | | Tuple e -> prefix ^ "( " ^ 67 | String.concat ", " (List.map (fun ex -> string_of_t (fst ex) (depth + 1) ~do_indent:false ~endline:"") e) ^ " )" ^ endline 68 | | LetTuple (l, e1, e2) -> prefix ^ "LET (" ^ (String.concat ", " (List.map fst l)) ^ ") =\n" 69 | ^ (string_of_t e1 (depth + 1)) ^ (indent ^ "IN\n") ^ (string_of_t e2 depth) 70 | | Array (e1, e2, _) -> prefix ^ "[ " ^ (string_of_t e1 depth ~do_indent:false) ^ (string_of_t e2 (depth + 1) ~endline:" ]\n") 71 | | Get (e1, e2, _) -> (string_of_t e1 depth ~endline:"[ ") ^ (string_of_t e2 (depth + 1) ~do_indent:false ~endline:" ]") ^ endline 72 | | Put (e1, e2, e3, _) -> (string_of_t e1 depth ~endline:"[ ") ^ (string_of_t e2 (depth + 1) ~do_indent:false ~endline:" ] <-\n") 73 | ^ (string_of_t e3 (depth + 1)) ^ endline 74 | and 75 | string_of_fundef (f : fundef) (depth : int) = 76 | Printf.sprintf "%s (%s) : %s =\n%s" (fst f.name) (String.concat ", " (List.map fst f.args)) (Type.string_of_t (snd f.name)) (string_of_t f.body depth) 77 | 78 | let print_t (exp : t) = 79 | print_string (string_of_t exp 0) 80 | 81 | let rec fv = function 82 | | Unit | Bool(_) | Int(_) | Float(_) -> S.empty 83 | | Not(x) | Neg(x) | FNeg(x) -> fv x 84 | | Xor(x, y) | Add(x, y) | Sub(x, y) | Mul(x, y) | Div(x, y) 85 | | FAdd(x, y) | FSub(x, y) | FMul(x, y) | FDiv(x, y) 86 | | Eq(x, y, _) | LE(x, y, _) 87 | | Array(x, y, _) | Get(x, y, _) -> 88 | S.union (fv x) (fv y) 89 | | Let((x, t), e1, e2) -> S.union (fv e1) (S.remove x (fv e2)) 90 | | Var(x) -> S.singleton x 91 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> 92 | let zs = S.diff (fv e1) (S.of_list (List.map fst yts)) in 93 | S.diff (S.union zs (fv e2)) (S.singleton x) 94 | | App((x, _), ys) -> S.union (fv x) (List.fold_left (fun s e -> S.union s (fv e)) S.empty ys) 95 | | Tuple(xs) -> List.fold_left (fun s e -> S.union s (fv (fst e))) S.empty xs 96 | | If(x, y, z) | Put(x, y, z, _) -> S.union (fv x) (S.union (fv y) (fv z)) 97 | | LetTuple(xs, y, e) -> S.union (fv y) (S.diff (fv e) (S.of_list (List.map fst xs))) 98 | 99 | (* fsqr, fhalf, fnev, fiszero, fispos, fisneg, flessを除く *) 100 | let rec unfold_extfun (exp : Syntax.t) : Syntax.t = 101 | match exp with 102 | | Not(e, p) -> Not(unfold_extfun e, p) 103 | | Neg(e, p) -> Neg(unfold_extfun e, p) 104 | | Add(e1, e2, p) -> Add(unfold_extfun e1, unfold_extfun e2, p) 105 | | Sub(e1, e2, p) -> Sub(unfold_extfun e1, unfold_extfun e2, p) 106 | | Mul(e1, e2, p) -> Mul(unfold_extfun e1, unfold_extfun e2, p) 107 | | Div(e1, e2, p) -> Div(unfold_extfun e1, unfold_extfun e2, p) 108 | | FNeg(e, p) -> FNeg(unfold_extfun e, p) 109 | | FAdd(e1, e2, p) -> FAdd(unfold_extfun e1, unfold_extfun e2, p) 110 | | FSub(e1, e2, p) -> FSub(unfold_extfun e1, unfold_extfun e2, p) 111 | | FMul(e1, e2, p) -> FMul(unfold_extfun e1, unfold_extfun e2, p) 112 | | FDiv(e1, e2, p) -> FDiv(unfold_extfun e1, unfold_extfun e2, p) 113 | | Eq(e1, e2, t, p) -> Eq(unfold_extfun e1, unfold_extfun e2, t, p) 114 | | LE(e1, e2, t, p) -> LE(unfold_extfun e1, unfold_extfun e2, t, p) 115 | | If(e1, e2, e3, p) -> If(unfold_extfun e1, unfold_extfun e2, unfold_extfun e3, p) 116 | | Let(xt, e1, e2, p) -> Let(xt, unfold_extfun e1, unfold_extfun e2, p) 117 | | LetRec(f, e, p) -> LetRec({ name = f.name; args = f.args; body = unfold_extfun f.body }, unfold_extfun e, p) 118 | | App((Var("fsqr"), t), [e], p) -> let e' = unfold_extfun e in FMul(e', e', p) 119 | | App((Var("fhalf"), t), [e], p) -> FDiv(unfold_extfun e, Float 2.0, p) 120 | | App((Var("fneg"), t), [e], p) -> FNeg(unfold_extfun e, p) 121 | | App((Var("fiszero"), t), [e], p) -> Eq(unfold_extfun e, Float(0.0), Type.Float, p) 122 | | App((Var("fispos"), t), [e], p) -> Not(LE(unfold_extfun e, Float(0.0), Type.Float, p), p) 123 | | App((Var("fisneg"), t), [e], p) -> Not(LE(Float(0.0), unfold_extfun e, Type.Float, p), p) 124 | | App((Var("fless"), t), [e1; e2], p) -> Not(LE(unfold_extfun e2, unfold_extfun e1, Type.Float, p), p) 125 | | App((e1, t), e2, p) -> App((unfold_extfun e1, t), List.map unfold_extfun e2, p) 126 | | Tuple(es) -> Tuple(List.map (fun (x, t) -> unfold_extfun x, t) es) 127 | | LetTuple(xts, e1, e2, p) -> LetTuple(xts, unfold_extfun e1, unfold_extfun e2, p) 128 | | Array(e1, e2, t, p) -> Array(unfold_extfun e1, unfold_extfun e2, t, p) 129 | | Get(e1, e2, t, p) -> Get(unfold_extfun e1, unfold_extfun e2, t, p) 130 | | Put(e1, e2, e3, t, p) -> Put(unfold_extfun e1, unfold_extfun e2, unfold_extfun e3, t, p) 131 | | _ -> exp 132 | 133 | (* pos(入力プログラム中での行番号の情報)を除いて扱いやすくする *) 134 | let rec g (exp : Syntax.t) : t = 135 | match exp with 136 | | Syntax.Unit -> Unit 137 | | Syntax.Bool(b) -> Bool(b) 138 | | Syntax.Int(i) -> Int(i) 139 | | Syntax.Float(d) -> Float(d) 140 | | Syntax.Not(e, p) -> Not(g e) 141 | | Syntax.Neg(e, _) -> Neg(g e) 142 | | Syntax.Add(e1, e2, _) -> Add(g e1, g e2) 143 | | Syntax.Sub(e1, e2, _) -> Sub(g e1, g e2) 144 | | Syntax.Mul(e1, e2, _) -> Mul(g e1, g e2) 145 | | Syntax.Div(e1, e2, _) -> Div(g e1, g e2) 146 | | Syntax.FNeg(e, _) -> FNeg(g e) 147 | | Syntax.FAdd(e1, e2, _) -> FAdd(g e1, g e2) 148 | | Syntax.FSub(e1, e2, _) -> FSub(g e1, g e2) 149 | | Syntax.FMul(e1, e2, _) -> FMul(g e1, g e2) 150 | | Syntax.FDiv(e1, e2, _) -> FDiv(g e1, g e2) 151 | | Syntax.Eq(e1, e2, t, _) -> Eq(g e1, g e2, t) 152 | | Syntax.LE(e1, e2, t, _) -> LE(g e1, g e2, t) 153 | | Syntax.If(Syntax.Not(e1, _), e2, e3, _) -> If(g e1, g e3, g e2) 154 | | Syntax.If(e1, e2, e3, _) -> If(g e1, g e2, g e3) 155 | | Syntax.Let((x, t), e1, e2, _) -> Let((x, t), g e1, g e2) 156 | | Syntax.Var(x) -> Var(x) 157 | | Syntax.LetRec({ Syntax.name = (x, t); Syntax.args = yts; Syntax.body = e1 }, e2, _) -> 158 | LetRec({ name = (x, t); args = yts; body = g e1 }, g e2) 159 | | Syntax.App((Syntax.Var("xor"), _), [e1; e2], _) -> Xor(g e1, g e2) 160 | | Syntax.App((e1, t), e2, _) -> App((g e1, t), List.map g e2) 161 | | Syntax.Tuple(es) -> Tuple(List.map (fun (x, t) -> g x, t) es) 162 | | Syntax.LetTuple(xts, e1, e2, _) -> LetTuple(xts, g e1, g e2) 163 | | Syntax.Array(e1, e2, t, _) -> Array(g e1, g e2, t) 164 | | Syntax.Get(e1, e2, t, _) -> Get(g e1, g e2, t) 165 | | Syntax.Put(e1, e2, e3, t, _) -> Put(g e1, g e2, g e3, t) 166 | 167 | let f e = g (unfold_extfun e) 168 | -------------------------------------------------------------------------------- /src/emit.ml: -------------------------------------------------------------------------------- 1 | open Asm 2 | 3 | let str_of_ty t = match t with 4 | | `I -> "i" 5 | | `F -> "f" 6 | | `A -> "a" 7 | | `V -> "" 8 | 9 | let rec str_of_ty_obj t = match t with 10 | | Obj -> "Ljava/lang/Object;" 11 | | Integer -> "Ljava/lang/Integer;" 12 | | Float -> "Ljava/lang/Float;" 13 | | C(s) -> Printf.sprintf "L%s;" s 14 | | Ary(t') -> "[" ^ (str_of_ty_obj t') 15 | 16 | let rec str_of_ty_obj_array t = match t with 17 | | Obj -> "java/lang/Object" 18 | | Integer -> "java/lang/Integer" 19 | | Float -> "java/lang/Float" 20 | | C(s) -> s 21 | | Ary(t') -> "[" ^ str_of_ty_obj t' 22 | 23 | let rec str_of_ty_sig (t : ty_sig) = match t with 24 | | PInt -> "I" 25 | | PFloat -> "F" 26 | | Void -> "" 27 | | Array(t) -> "[" ^ (str_of_ty_obj t) 28 | | O(t) -> str_of_ty_obj t 29 | | Fun(t, Void) -> Printf.sprintf "(%s)V" (String.concat "" (List.map str_of_ty_sig t)) 30 | | Fun(t1, t2) -> Printf.sprintf "(%s)%s" (String.concat "" (List.map str_of_ty_sig t1)) (str_of_ty_sig t2) 31 | 32 | let rec str_of_modifiers m = match m with 33 | | [] -> "" 34 | | Static :: xm -> "static " ^ (str_of_modifiers xm) 35 | 36 | let rec g oc e = 37 | match e with 38 | | Comment(s) -> Printf.fprintf oc "\t; %s\n" s 39 | | Load(t, n) -> Printf.fprintf oc "\t%sload %d\n" (str_of_ty t) n 40 | | Store(t, n) -> Printf.fprintf oc "\t%sstore %d\n" (str_of_ty t) n 41 | | Store_c(t, n, c) -> Printf.fprintf oc "\t%sstore %d\t; %s\n" (str_of_ty t) n c 42 | | ALoad(t) -> Printf.fprintf oc "\t%saload\n" (str_of_ty t) 43 | | AStore(t) -> Printf.fprintf oc "\t%sastore\n" (str_of_ty t) 44 | | NewArray(t) -> Printf.fprintf oc "\tnewarray %s\n" (match t with `I -> "int" | `F -> "float") 45 | | ANewArray(t) -> Printf.fprintf oc "\tanewarray %s\n" (str_of_ty_obj_array t) 46 | | Ldc(I(n)) -> Printf.fprintf oc "\tldc %d\n" n 47 | | Ldc(F(n)) -> Printf.fprintf oc "\tldc %f\n" n 48 | | Neg t -> Printf.fprintf oc "\t%sneg\n" (str_of_ty t) 49 | | IXor -> Printf.fprintf oc "\tixor\n" 50 | | Add t -> Printf.fprintf oc "\t%sadd\n" (str_of_ty t) 51 | | Sub t -> Printf.fprintf oc "\t%ssub\n" (str_of_ty t) 52 | | Mul t -> Printf.fprintf oc "\t%smul\n" (str_of_ty t) 53 | | Div t -> Printf.fprintf oc "\t%sdiv\n" (str_of_ty t) 54 | | FtoI -> Printf.fprintf oc "\tf2i\n" 55 | | ItoF -> Printf.fprintf oc "\ti2f\n" 56 | | FCmp -> Printf.fprintf oc "\tfcmpl\n" 57 | | Dup -> Printf.fprintf oc "\tdup\n" 58 | | Pop -> Printf.fprintf oc "\tpop\n" 59 | | New x -> Printf.fprintf oc "\tnew %s\n" x 60 | | Boxing t -> (match t with 61 | | PInt -> g oc (InvokeStatic("java/lang/Integer/valueOf", Fun([PInt], O(C "java/lang/Integer")))) 62 | | PFloat -> g oc (InvokeStatic("java/lang/Float/valueOf", Fun([PFloat], O(C "java/lang/Float")))) 63 | | _ -> ()) 64 | | Unboxing t -> (match t with 65 | | PInt -> g oc (InvokeVirtual("java/lang/Integer/intValue", Fun([Void], PInt))) 66 | | PFloat -> g oc (InvokeVirtual("java/lang/Float/floatValue", Fun([Void], PFloat))) 67 | | _ -> ()) 68 | | Checkcast t -> 69 | (match t with 70 | | Integer -> Printf.fprintf oc "\tcheckcast java/lang/Integer\n" 71 | | Float -> Printf.fprintf oc "\tcheckcast java/lang/Float\n" 72 | | Ary _ -> Printf.fprintf oc "\tcheckcast %s\n" (str_of_ty_obj t) 73 | | C s -> Printf.fprintf oc "\tcheckcast %s\n" s 74 | | Obj -> ()) 75 | | PutField (x, c, t) -> Printf.fprintf oc "\tputfield %s/%s %s\n" c x (str_of_ty_obj t) 76 | | GetField (x, c, t) -> Printf.fprintf oc "\tgetfield %s/%s %s\n" c x (str_of_ty_obj t) 77 | | PutStatic(x, c, t) -> Printf.fprintf oc "\tputstatic %s/%s %s\n" c x (str_of_ty_obj t) 78 | | GetStatic(x, c, t) -> Printf.fprintf oc "\tgetstatic %s/%s %s\n" c x (str_of_ty_obj t) 79 | | If0(b, bn, e1, [], e3) -> (* optimization for less branch *) 80 | let l_cont = Id.genLabel (Printf.sprintf "if%s_cont" b) in 81 | List.iter (g oc) e1; 82 | Printf.fprintf oc "\tif%s %s\n" b l_cont; 83 | List.iter (g oc) e3; 84 | Printf.fprintf oc "%s:\n" l_cont 85 | | If0(b, bn, e1, e2, []) -> (* optimization for less branch *) 86 | let l_cont = Id.genLabel (Printf.sprintf "if%s_cont" b) in 87 | List.iter (g oc) e1; 88 | Printf.fprintf oc "\tif%s %s\n" bn l_cont; 89 | List.iter (g oc) e2; 90 | Printf.fprintf oc "%s:\n" l_cont 91 | | If0(b, bn, e1, e2, e3) -> 92 | let (l_else, l_cont) = Id.genPairLabel (Printf.sprintf "if%s_else" b) (Printf.sprintf "if%s_cont" b) in 93 | List.iter (g oc) e1; 94 | Printf.fprintf oc "\tif%s %s\n" bn l_else; 95 | List.iter (g oc) e2; 96 | Printf.fprintf oc "\tgoto %s\n" l_cont; 97 | Printf.fprintf oc "%s:\n" l_else; 98 | List.iter (g oc) e3; 99 | Printf.fprintf oc "%s:\n" l_cont 100 | | If(b, bn, e1, e2, [], e4) -> (* optimization for less branch *) 101 | let l_cont = Id.genLabel (Printf.sprintf "if%s_cont" b) in 102 | List.iter (g oc) e1; 103 | List.iter (g oc) e2; 104 | Printf.fprintf oc "\tif_icmp%s %s\n" b l_cont; 105 | List.iter (g oc) e4; 106 | Printf.fprintf oc "%s:\n" l_cont 107 | | If(b, bn, e1, e2, e3, []) -> (* optimization for less branch *) 108 | let l_cont = Id.genLabel (Printf.sprintf "if%s_cont" b) in 109 | List.iter (g oc) e1; 110 | List.iter (g oc) e2; 111 | Printf.fprintf oc "\tif_icmp%s %s\n" bn l_cont; 112 | List.iter (g oc) e3; 113 | Printf.fprintf oc "%s:\n" l_cont 114 | | If(b, bn, e1, e2, e3, e4) -> 115 | let l_else, l_cont = Id.genPairLabel (Printf.sprintf "if%s_else" b) (Printf.sprintf "if%s_cont" b) in 116 | List.iter (g oc) e1; 117 | List.iter (g oc) e2; 118 | Printf.fprintf oc "\tif_icmp%s %s\n" bn l_else; 119 | List.iter (g oc) e3; 120 | Printf.fprintf oc "\tgoto %s\n" l_cont; 121 | Printf.fprintf oc "%s:\n" l_else; 122 | List.iter (g oc) e4; 123 | Printf.fprintf oc "%s:\n" l_cont 124 | | Return t -> Printf.fprintf oc "\t%sreturn\n" (str_of_ty t) 125 | | CallMath(f, signature) -> 126 | Printf.fprintf oc "\tf2d\n"; 127 | Printf.fprintf oc "\tinvokestatic java/lang/Math.%s%s\n" f signature; 128 | Printf.fprintf oc "\td2f\n"; 129 | | InvokeStatic(f, t) -> 130 | Printf.fprintf oc "\tinvokestatic %s%s\n" f (str_of_ty_sig t) 131 | | InvokeVirtual(f, t) -> 132 | Printf.fprintf oc "\tinvokevirtual %s%s\n" f (str_of_ty_sig t) 133 | | InvokeSpecial(f, t) -> 134 | Printf.fprintf oc "\tinvokespecial %s%s\n" f (str_of_ty_sig t) 135 | 136 | let h oc f = 137 | Printf.fprintf oc ".method public %s%s%s\n" (str_of_modifiers f.modifiers) (fst f.name) (str_of_ty_sig (snd f.name)); 138 | Printf.fprintf oc "\t.limit stack %d\n" f.stack; 139 | Printf.fprintf oc "\t.limit locals %d\n" f.locals; 140 | List.iter (fun e -> g oc e) f.body; 141 | Printf.fprintf oc ".end method\t; %s\n\n" (fst f.name) 142 | 143 | let f oc dirname (files : Asm.prog) = 144 | let has_closure = ref false in 145 | List.iter (fun file -> 146 | if file.classname <> "main" then 147 | (* closure classes *) 148 | (has_closure := true; 149 | let oc = open_out (Printf.sprintf "%s/%s.j" dirname file.classname) in 150 | Printf.fprintf oc ".class public %s\n" (file.classname); 151 | Printf.fprintf oc ".super %s\n" (file.super); 152 | List.iter (fun field -> 153 | Printf.fprintf oc ".field public %s %s\n" (fst field) (str_of_ty_obj (snd field))) 154 | file.fields; 155 | Printf.fprintf oc ".method public %s\n" (str_of_ty_sig (fst file.init)); 156 | Printf.fprintf oc "\t.limit stack 10\n"; (*TODO*) 157 | Printf.fprintf oc "\t.limit locals 10\n"; 158 | List.iter (g oc) (snd file.init); 159 | Printf.fprintf oc ".end method\t; \n\n"; 160 | List.iter (fun f -> h oc f) file.funs; 161 | close_out oc) 162 | else 163 | (* main class *) 164 | (Printf.fprintf oc ".class public main\n"; 165 | Printf.fprintf oc ".super %s\n" (file.super); 166 | List.iter (fun field -> 167 | (* only main class can have static field *) 168 | Printf.fprintf oc ".field public static %s %s\n" (fst field) (str_of_ty_obj (snd field))) 169 | file.fields; 170 | (* *) 171 | (match file.clinit with 172 | | None -> () 173 | | Some(clinit) -> 174 | Printf.fprintf oc ".method public static %s\n" (str_of_ty_sig (snd clinit.name)); 175 | Printf.fprintf oc "\t.limit stack %d\n" clinit.stack; 176 | Printf.fprintf oc "\t.limit locals %d\n" clinit.locals; 177 | List.iter (g oc) clinit.body; 178 | Printf.fprintf oc ".end method\t; \n\n"); 179 | (* *) 180 | Printf.fprintf oc ".method public %s\n" (str_of_ty_sig (fst file.init)); 181 | Printf.fprintf oc "\t.limit stack 10\n"; (* TODO *) 182 | Printf.fprintf oc "\t.limit locals 10\n"; 183 | List.iter (g oc) (snd file.init); 184 | Printf.fprintf oc ".end method\t; \n\n"; 185 | List.iter (fun f -> h oc f) file.funs)) 186 | files; 187 | (* if there are any closures, output cls.j *) 188 | if !has_closure then 189 | let oc = open_out (dirname ^ "/cls.j") in 190 | (Printf.fprintf oc ".class abstract cls\n"; 191 | Printf.fprintf oc ".super java/lang/Object\n\n"; 192 | Printf.fprintf oc ".method public ([Ljava/lang/Object;)V\n"; 193 | Printf.fprintf oc "\t.limit stack 5\n"; 194 | Printf.fprintf oc "\t.limit locals 5\n"; 195 | Printf.fprintf oc "\taload_0\n"; 196 | Printf.fprintf oc "\tinvokespecial java/lang/Object/()V\n"; 197 | Printf.fprintf oc "\treturn\n"; 198 | Printf.fprintf oc ".end method\n\n"; 199 | Printf.fprintf oc ".method public abstract app([Ljava/lang/Object;)Ljava/lang/Object;\n"; 200 | Printf.fprintf oc ".end method\n"; 201 | close_out oc) 202 | -------------------------------------------------------------------------------- /src/virtual.ml: -------------------------------------------------------------------------------- 1 | open Asm 2 | 3 | let toplevel = ref [] 4 | let classname = ref "" 5 | let main_globals = ref [] 6 | let is_main = ref false 7 | 8 | let getindex x env = 9 | let rec inner_ x env i = 10 | match env with 11 | | [] -> print_endline (x ^ " was not found"); assert false 12 | | (y, _) :: ys when x = y -> i 13 | | y :: ys -> inner_ x ys (i - 1) 14 | in inner_ x env ((List.length env) - 1) 15 | 16 | let typet2ty (t : Type.t) : ty = match Typing.deref_typ t with 17 | | Type.Int | Type.Bool -> `I 18 | | Type.Float -> `F 19 | | Type.Array _ | Type.Tuple _ | Type.Fun _ -> `A 20 | | Type.Unit -> `V 21 | | Type.Var _ -> assert false 22 | 23 | let rec typet2tyobj (t : Type.t) : ty_obj = match Typing.deref_typ t with 24 | | Type.Unit -> Ary(Obj) (* ?? *) 25 | | Type.Int | Type.Bool -> Integer 26 | | Type.Float -> Float 27 | | Type.Array(t) -> Ary(typet2tyobj t) 28 | | Type.Tuple _ -> Ary(Obj) 29 | | Type.Fun(ts, t) -> C "cls" 30 | | Type.Var _ -> assert false 31 | 32 | let rec typet2tysig (t : Type.t) : ty_sig = match Typing.deref_typ t with 33 | | Type.Unit -> Void 34 | | Type.Int | Type.Bool -> PInt 35 | | Type.Float -> PFloat 36 | | Type.Array(t) -> Array(typet2tyobj t) 37 | | Type.Tuple _ -> Array(Obj) 38 | | Type.Fun(ts, t) -> Fun(List.map typet2tysig ts, typet2tysig t) 39 | | Type.Var _ -> assert false 40 | 41 | let rec box_tysig t = match t with 42 | | Fun _ -> O(C "cls") 43 | | _ -> O(Obj) 44 | 45 | let rec tysig2tyobj t = match t with 46 | | Void -> Ary(Obj) (* ?? *) 47 | | PInt -> Integer 48 | | PFloat -> Float 49 | | Array(t) -> Ary(t) 50 | | Fun _ -> C "cls" 51 | | O(t) -> t 52 | 53 | let rec tysig2ty t = match t with 54 | | PInt -> `I 55 | | PFloat -> `F 56 | | Void -> `V 57 | | Array _ -> `A 58 | | _ -> assert false 59 | 60 | (* fv: fvs of *current* function *) 61 | let rec g fv env e = 62 | match e with 63 | | Closure.Unit -> [] 64 | | Closure.Int(n) -> [Ldc(I(n))] 65 | | Closure.Float(f) -> [Ldc(F(f))] 66 | | Closure.Not(e) -> g fv env e @ [Ldc(I(1)); IXor] 67 | | Closure.Neg(e) -> g fv env e @ [Neg `I] 68 | | Closure.Xor(e1, e2) -> g fv env e1 @ g fv env e2 @ [IXor] 69 | | Closure.Add(e1, e2) -> g fv env e1 @ g fv env e2 @ [Add `I] 70 | | Closure.Sub(e1, e2) -> g fv env e1 @ g fv env e2 @ [Sub `I] 71 | | Closure.Mul(e1, e2) -> g fv env e1 @ g fv env e2 @ [Mul `I] 72 | | Closure.Div(e1, e2) -> g fv env e1 @ g fv env e2 @ [Div `I] 73 | | Closure.FNeg(e) -> g fv env e @ [Neg `F] 74 | | Closure.FAdd(e1, e2) -> g fv env e1 @ g fv env e2 @ [Add `F] 75 | | Closure.FSub(e1, e2) -> g fv env e1 @ g fv env e2 @ [Sub `F] 76 | | Closure.FMul(e1, e2) -> g fv env e1 @ g fv env e2 @ [Mul `F] 77 | | Closure.FDiv(e1, e2) -> g fv env e1 @ g fv env e2 @ [Div `F] 78 | | Closure.FCmp(e1, e2) -> g fv env e1 @ g fv env e2 @ [FCmp] 79 | | Closure.IfEq(Int(0), e1, e3, e4) 80 | | Closure.IfEq(e1, Int(0), e3, e4) -> [If0("eq", "ne", g fv env e1, g fv env e3, g fv env e4)] 81 | | Closure.IfLE(Int(0), e1, e3, e4) -> [If0("ge", "lt", g fv env e1, g fv env e3, g fv env e4)] 82 | | Closure.IfLE(e1, Int(0), e3, e4) -> [If0("le", "gt", g fv env e1, g fv env e3, g fv env e4)] 83 | | Closure.IfEq(e1, e2, e3, e4) -> [If("eq", "ne", g fv env e1, g fv env e2, g fv env e3, g fv env e4)] 84 | | Closure.IfLE(e1, e2, e3, e4) -> [If("le", "gt", g fv env e1, g fv env e2, g fv env e3, g fv env e4)] 85 | | Closure.Let((x, Type.Unit), e1, e2) -> 86 | g fv env e1 @ g fv env e2 87 | | Closure.Let((x, t), e1, e2) -> 88 | g fv env e1 @ [Store_c(typet2ty t, List.length env, x)] @ g fv ((x, t) :: env) e2 89 | | Closure.Var(x) when Id.mem x fv -> (* when x is free variable *) 90 | let t = List.assoc x fv in 91 | [Load(`A, 0); GetField(x, !classname, tysig2tyobj t); Unboxing(t)] 92 | | Closure.Var(x) when !is_main && Id.mem3 x !main_globals -> 93 | (* Printf.printf "case of Closure.Var(x) when x is global (x = %s)\n" x; *) 94 | let (_, t, _) = List.find (fun (y, _, _) -> x = y) !main_globals in 95 | [GetStatic(x, !classname, typet2tyobj t)] 96 | | Closure.Var(x) -> 97 | (* Printf.printf "case of Closure.Var(x) (x = %s)\n" x; *) 98 | assert (Id.mem x env); 99 | [Load(typet2ty (List.assoc x env), getindex x env)] 100 | | Closure.ExtFunApp("sin", [e2]) -> g fv env e2 @ [CallMath("sin", "(D)D")] 101 | | Closure.ExtFunApp("cos", [e2]) -> g fv env e2 @ [CallMath("cos", "(D)D")] 102 | | Closure.ExtFunApp("atan", [e2]) -> g fv env e2 @ [CallMath("atan", "(D)D")] 103 | | Closure.ExtFunApp("sqrt", [e2]) -> g fv env e2 @ [CallMath("sqrt", "(D)D")] 104 | | Closure.ExtFunApp("abs_float", [e2]) -> g fv env e2 @ [InvokeStatic("java/lang/Math.abs", Fun([PFloat], PFloat))] 105 | | Closure.ExtFunApp("fabs", [e2]) -> g fv env e2 @ [InvokeStatic("java/lang/Math.abs", Fun([PFloat], PFloat))] 106 | | Closure.ExtFunApp("floor", [e2]) -> g fv env e2 @ [CallMath("floor", "(D)D")] 107 | | Closure.ExtFunApp("float_of_int", [e2]) -> g fv env e2 @ [ItoF] 108 | | Closure.ExtFunApp("int_of_float", [e2]) -> g fv env e2 @ [FtoI] 109 | | Closure.ExtFunApp("truncate", [e2]) -> g fv env e2 @ [FtoI] 110 | | Closure.ExtFunApp(f, e2) -> 111 | List.concat (List.map (g fv env) e2) @ [InvokeStatic("libmincaml.min_caml_" ^ f, typet2tysig (M.find f !Typing.extenv))] 112 | | Closure.AppDir(f, e2) -> 113 | List.concat (List.map (g fv env) e2) @ [InvokeStatic("main." ^ f, List.assoc f !toplevel)] 114 | | Closure.AppCls(Var(f) as e1, e2, Fun(ts, t)) when Id.mem f !toplevel -> (* when the closure name is known *) 115 | let body = 116 | g fv env e1 @ 117 | g fv env (Tuple(List.combine e2 ts)) @ 118 | (if Id.mem f !toplevel then 119 | (match List.assoc f !toplevel with 120 | | Fun(_, t) -> [InvokeVirtual("cls_" ^ f ^ "/app", Fun([Array(Obj)], box_tysig t))] 121 | | _ -> assert false) 122 | else 123 | [InvokeVirtual("cls_" ^ f ^ "/app", Fun([Array(Obj)], O(Obj)))]) in 124 | let cast = 125 | match t with 126 | | Type.Unit -> [Pop] (* [XXX] in order to balance the stack height *) 127 | | _ -> [Checkcast(typet2tyobj t); Unboxing(typet2tysig t)] in 128 | body @ cast 129 | | Closure.AppCls(e1, e2, Fun(ts, t)) -> 130 | let body = 131 | g fv env e1 @ 132 | g fv env (Tuple(List.combine e2 ts)) @ 133 | [InvokeVirtual("cls/app", Fun([Array(Obj)], O(Obj)))] in 134 | let cast = 135 | match t with 136 | | Type.Unit -> [Pop] (* [XXX] in order to balance the stack height *) 137 | | _ -> [Checkcast(typet2tyobj t); Unboxing(typet2tysig t)] in 138 | body @ cast 139 | | Closure.AppCls _ -> assert false (* closure's type should be Fun *) 140 | | Closure.Tuple(e) -> 141 | Ldc(I(List.length e)) :: 142 | ANewArray(Obj) :: 143 | List.concat (List.mapi 144 | (fun n (y, t) -> [Dup; Ldc(I(n))] @ 145 | (g fv env y) @ 146 | [Boxing(typet2tysig t); 147 | AStore(`A)]) 148 | e) 149 | | Closure.LetTuple(xts, e1, e2) -> 150 | g fv env e1 @ 151 | let xts' = List.filter (fun (y, _, _) -> S.mem y (Closure.fv e2)) (List.mapi (fun n (x, t) -> (x, t, n)) xts) in 152 | List.concat 153 | (List.mapi 154 | (fun n (y, t, i) -> 155 | [Dup; Ldc(I(i)); 156 | ALoad(`A); 157 | Checkcast(typet2tyobj t); 158 | Unboxing(typet2tysig t); 159 | Store(typet2ty t, List.length env + n)]) 160 | xts') @ 161 | [Pop] @ g fv ((List.rev (List.map (fun (y, t, _) -> (y, t)) xts')) @ env) e2 162 | | Closure.Array(Int(n) as e1, e2, t) when n <= 2 -> 163 | (* 初期値をlocal variableに(一時的に)store *) 164 | let inst = ref (g fv env e2 @ [Boxing(typet2tysig t); Store(`A, List.length env)] @ g fv env e1) in 165 | inst := !inst @ [ANewArray(typet2tyobj t)]; 166 | for i = 0 to n - 1 do 167 | inst := !inst @ [Dup; Ldc(I(i)); Load(`A, List.length env); AStore(`A)]; 168 | done; 169 | !inst 170 | | Closure.Array(e1, e2, t) -> 171 | g fv env e1 @ [ANewArray(typet2tyobj t); Dup; Checkcast(Ary(Obj))] @ 172 | g fv env e2 @ [Boxing(typet2tysig t)] @ 173 | [InvokeStatic("java/util/Arrays.fill", Fun([Array(Obj); O(Obj)], Void))] 174 | | Closure.Get(e1, e2, t) -> 175 | g fv env e1 @ g fv env e2 @ [ALoad(`A); Checkcast(typet2tyobj t); Unboxing(typet2tysig t)] 176 | | Closure.Put(e1, e2, e3, t) -> 177 | g fv env e1 @ g fv env e2 @ g fv env e3 @ [Boxing(typet2tysig t); AStore(`A)] 178 | | Closure.MakeCls(_, { name = f; typ = t; fv = yts }, e) -> 179 | let args = List.map (fun (x, t) -> (Closure.Var(x), t)) yts in 180 | [New("cls_" ^ f); Dup] @ (g fv env (Closure.Tuple(args))) @ 181 | [InvokeSpecial("cls_" ^ f ^ "/", Fun([Array(Obj)], Void)); Store(`A, List.length env)] @ 182 | (g fv ((f, t) :: env) e) 183 | | Closure.ExtArray _ -> assert false 184 | 185 | let h { Closure.name = (x, t); Closure.args = yts; Closure.fv = zts; Closure.body = e } = 186 | (* Printf.printf "Closure.name = %s\n" x; *) 187 | match t with 188 | | Type.Fun(_, rt) -> 189 | let t' = typet2tysig t in 190 | let args = List.map (fun (y, t) -> y, typet2tysig t) yts in 191 | let fv = List.map (fun (y, t) -> y, typet2tysig t) zts in 192 | if !is_main then 193 | let env' = List.rev yts in 194 | { name = (x, t'); modifiers = [Static]; args; fv; stack = 100; locals = 100; 195 | body = g fv env' e @ [Return (typet2ty rt)] } 196 | else 197 | ((* closure *) 198 | (* non-static methodの場合はlocalsの0番目がthisポインタになる *) 199 | let env' = List.rev (("", Type.Unit) (* dummy ('this' ptr) *) :: yts) in 200 | let prologue = 201 | (* TODO: 引数が使われない場合はUnboxしない *) 202 | Load(`A, 1) :: 203 | List.concat (List.mapi 204 | (fun n (y, t) -> 205 | [Dup; Ldc(I(n)); 206 | ALoad(`A); 207 | Checkcast(typet2tyobj t); 208 | Unboxing(typet2tysig t); 209 | Store(typet2ty t, List.length env' + n)]) yts) in 210 | let epilogue = [Boxing(typet2tysig rt); Return(`A)] in 211 | let env' = (List.rev yts) @ env' in 212 | { name = (x, t'); modifiers = [Static]; args; fv; stack = 100; locals = 100; 213 | body = prologue @ g fv env' e @ epilogue }) 214 | | _ -> assert false 215 | 216 | (* gをfundefsに適用して変換しながらファイルに分ける (files, main_funs)を返す *) 217 | let rec to_files closures acc (main_funs : Asm.fundef list) (fundefs : Closure.fundef list) = 218 | match fundefs with 219 | | [] -> 220 | (acc, main_funs) 221 | | f :: xf when not (Id.mem (fst f.name) closures) -> 222 | classname := "main"; 223 | is_main := true; 224 | to_files closures acc (main_funs @ [h f]) xf 225 | | f :: xf -> 226 | classname := "cls_" ^ fst f.name; 227 | is_main := false; 228 | let f = h f in 229 | let closure : Closure.closure = List.assoc (fst f.name) closures in 230 | let fields = List.map (fun (x, t) -> x, typet2tyobj t) closure.fv in 231 | let init = 232 | [Load(`A, 0); Load(`A, 1); InvokeSpecial("cls/", Fun([Array(Obj)], Void))] @ 233 | (List.concat @@ List.mapi 234 | (fun n (x, t) -> [Load(`A, 0); 235 | Load(`A, 1); 236 | Ldc(I(n)); 237 | ALoad(`A); 238 | Checkcast(t); 239 | PutField(x, !classname, t)]) fields) @ 240 | [Return `V] 241 | in 242 | let app_tysig = match snd f.name with 243 | | Fun(_, t) -> Fun([Array(Obj)], box_tysig t) 244 | | _ -> assert false in 245 | let acc' = 246 | { classname = !classname; 247 | init = (Fun([Array(Obj)], Void), init); clinit = None; 248 | funs = [{ name = ("app", app_tysig); modifiers = []; 249 | args = f.args; fv = f.fv; 250 | stack = 100; locals = 100; 251 | body = f.body }]; 252 | super = "cls"; fields = fields } :: acc in 253 | to_files closures acc' main_funs xf 254 | 255 | let f { Closure.closures = closures; Closure.globals = glb; Closure.funs = fundef; Closure.main = e } : Asm.prog = 256 | (* List.iter (fun f -> let { Closure.name = (x, _); _} = f in print_endline x) fundef; *) 257 | (* Printf.printf "globals = %s\n" (String.concat " " (List.map (fun (x, _, _) -> x) glb)); *) 258 | (* この時点でfundefは遅く定義された方から並んでいる *) 259 | main_globals := List.rev glb; 260 | (* toplevelはここで設定(cf. even-odd.ml) *) 261 | toplevel := List.map (fun (f : Closure.fundef) -> let (x, t) = f.name in (x, typet2tysig t)) fundef; 262 | (* main以外の関数を変換 *) 263 | (* files: main.j以外のファイル(クロージャ), main_funs: main.jに宣言されるmain以外の(非クロージャ)関数 *) 264 | let files, main_funs = to_files closures [] [] (List.rev fundef) in 265 | (* main関数を変換 *) 266 | classname := "main"; 267 | is_main := true; 268 | let main_body = (g [] [] e) @ [Return `V] in 269 | let main_field = 270 | List.map 271 | (fun (x, t, e) -> (x, typet2tyobj t)) 272 | !main_globals in 273 | let main = { name = ("main", Fun([Array(C "java/lang/String")], Void)); 274 | modifiers = [Static]; 275 | args = []; fv = []; 276 | stack = 100; locals = 100; 277 | body = main_body } in 278 | let main_clinit_body = 279 | (List.concat @@ List.mapi 280 | (fun n (x, t, e) -> 281 | g [] [] e @ 282 | [PutStatic(x, !classname, typet2tyobj t)]) !main_globals) @ 283 | [Return `V] in 284 | let main_clinit = 285 | { name = "", Fun([Void], Void); 286 | modifiers = []; args = []; fv = []; 287 | stack = 100; locals = 100; 288 | body = main_clinit_body } in 289 | let main_init = 290 | [Load(`A, 0); InvokeSpecial("java/lang/Object/", Fun([Void], Void)); Return `V] in 291 | { classname = "main"; 292 | init = Fun([Void], Void), main_init; 293 | clinit = if !main_globals = [] then None else Some main_clinit; 294 | funs = main_funs @ [main]; 295 | super = "java/lang/Object"; 296 | fields = main_field } :: 297 | files 298 | -------------------------------------------------------------------------------- /src/OCamlMakefile: -------------------------------------------------------------------------------- 1 | ########################################################################### 2 | # OCamlMakefile 3 | # Copyright (C) 1999- Markus Mottl 4 | # 5 | # For updates see: 6 | # http://www.ocaml.info/home/ocaml_sources.html 7 | # 8 | ########################################################################### 9 | 10 | # Modified by damien for .glade.ml compilation 11 | 12 | # Set these variables to the names of the sources to be processed and 13 | # the result variable. Order matters during linkage! 14 | 15 | ifndef SOURCES 16 | SOURCES := foo.ml 17 | endif 18 | export SOURCES 19 | 20 | ifndef RES_CLIB_SUF 21 | RES_CLIB_SUF := _stubs 22 | endif 23 | export RES_CLIB_SUF 24 | 25 | ifndef RESULT 26 | RESULT := foo 27 | endif 28 | export RESULT := $(strip $(RESULT)) 29 | 30 | export LIB_PACK_NAME 31 | 32 | ifndef DOC_FILES 33 | DOC_FILES := $(filter %.mli, $(SOURCES)) 34 | endif 35 | export DOC_FILES 36 | FIRST_DOC_FILE := $(firstword $(DOC_FILES)) 37 | 38 | export BCSUFFIX 39 | export NCSUFFIX 40 | 41 | ifndef TOPSUFFIX 42 | TOPSUFFIX := .top 43 | endif 44 | export TOPSUFFIX 45 | 46 | # Eventually set include- and library-paths, libraries to link, 47 | # additional compilation-, link- and ocamlyacc-flags 48 | # Path- and library information needs not be written with "-I" and such... 49 | # Define THREADS if you need it, otherwise leave it unset (same for 50 | # USE_CAMLP4)! 51 | 52 | export THREADS 53 | export VMTHREADS 54 | export ANNOTATE 55 | export USE_CAMLP4 56 | 57 | export INCDIRS 58 | export LIBDIRS 59 | export EXTLIBDIRS 60 | export RESULTDEPS 61 | export OCAML_DEFAULT_DIRS 62 | 63 | export LIBS 64 | export CLIBS 65 | export CFRAMEWORKS 66 | 67 | export OCAMLFLAGS 68 | export OCAMLNCFLAGS 69 | export OCAMLBCFLAGS 70 | 71 | export OCAMLLDFLAGS 72 | export OCAMLNLDFLAGS 73 | export OCAMLBLDFLAGS 74 | 75 | export OCAMLMKLIB_FLAGS 76 | 77 | ifndef OCAMLCPFLAGS 78 | OCAMLCPFLAGS := a 79 | endif 80 | export OCAMLCPFLAGS 81 | 82 | ifndef DOC_DIR 83 | DOC_DIR := doc 84 | endif 85 | export DOC_DIR 86 | 87 | export PPFLAGS 88 | 89 | export LFLAGS 90 | export YFLAGS 91 | export IDLFLAGS 92 | 93 | export OCAMLDOCFLAGS 94 | 95 | export OCAMLFIND_INSTFLAGS 96 | 97 | export DVIPSFLAGS 98 | 99 | export STATIC 100 | 101 | # Add a list of optional trash files that should be deleted by "make clean" 102 | export TRASH 103 | 104 | ECHO := echo 105 | 106 | ifdef REALLY_QUIET 107 | export REALLY_QUIET 108 | ECHO := true 109 | LFLAGS := $(LFLAGS) -q 110 | YFLAGS := $(YFLAGS) -q 111 | endif 112 | 113 | #################### variables depending on your OCaml-installation 114 | 115 | SYSTEM := $(shell ocamlc -config 2>/dev/null | grep system | sed 's/system: //') 116 | # This may be 117 | # - mingw 118 | # - mingw64 119 | # - win32 120 | # - cygwin 121 | # - some other string means Unix 122 | # - empty means ocamlc does not support -config 123 | 124 | ifeq ($(SYSTEM),$(filter $(SYSTEM),mingw mingw64)) 125 | MINGW=1 126 | endif 127 | ifeq ($(SYSTEM),win32) 128 | MSVC=1 129 | endif 130 | 131 | ifdef MINGW 132 | export MINGW 133 | WIN32 := 1 134 | # The default value 'cc' makes 'ocamlc -cc "cc"' raises the error 'The 135 | # NTVDM CPU has encountered an illegal instruction'. 136 | ifndef CC 137 | MNO_CYGWIN := $(shell gcc -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 138 | CC := gcc 139 | else 140 | MNO_CYGWIN := $(shell $$CC -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 141 | endif 142 | # We are compiling with cygwin tools: 143 | ifeq ($(MNO_CYGWIN),0) 144 | CFLAGS_WIN32 := -mno-cygwin 145 | endif 146 | # The OCaml C header files use this flag: 147 | CFLAGS += -D__MINGW32__ 148 | endif 149 | ifdef MSVC 150 | export MSVC 151 | WIN32 := 1 152 | ifndef STATIC 153 | CPPFLAGS_WIN32 := -DCAML_DLL 154 | endif 155 | CFLAGS_WIN32 += -nologo 156 | EXT_OBJ := obj 157 | EXT_LIB := lib 158 | ifeq ($(CC),gcc) 159 | # work around GNU Make default value 160 | ifdef THREADS 161 | CC := cl -MT 162 | else 163 | CC := cl 164 | endif 165 | endif 166 | ifeq ($(CXX),g++) 167 | # work around GNU Make default value 168 | CXX := $(CC) 169 | endif 170 | CFLAG_O := -Fo 171 | endif 172 | ifdef WIN32 173 | EXT_CXX := cpp 174 | EXE := .exe 175 | endif 176 | 177 | ifndef EXT_OBJ 178 | EXT_OBJ := o 179 | endif 180 | ifndef EXT_LIB 181 | EXT_LIB := a 182 | endif 183 | ifndef EXT_CXX 184 | EXT_CXX := cc 185 | endif 186 | ifndef EXE 187 | EXE := # empty 188 | endif 189 | ifndef CFLAG_O 190 | CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! 191 | endif 192 | 193 | export CC 194 | export CXX 195 | export CFLAGS 196 | export CXXFLAGS 197 | export LDFLAGS 198 | export CPPFLAGS 199 | 200 | ifndef RPATH_FLAG 201 | ifdef ELF_RPATH_FLAG 202 | RPATH_FLAG := $(ELF_RPATH_FLAG) 203 | else 204 | RPATH_FLAG := -R 205 | endif 206 | endif 207 | export RPATH_FLAG 208 | 209 | ifndef MSVC 210 | ifndef PIC_CFLAGS 211 | PIC_CFLAGS := -fPIC 212 | endif 213 | ifndef PIC_CPPFLAGS 214 | PIC_CPPFLAGS := -DPIC 215 | endif 216 | endif 217 | 218 | export PIC_CFLAGS 219 | export PIC_CPPFLAGS 220 | 221 | BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) 222 | NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) 223 | TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) 224 | 225 | ifndef OCAMLFIND 226 | OCAMLFIND := ocamlfind 227 | endif 228 | export OCAMLFIND 229 | 230 | ifndef OCAML 231 | OCAML := ocaml 232 | endif 233 | export OCAML 234 | 235 | ifndef OCAMLC 236 | OCAMLC := ocamlc 237 | endif 238 | export OCAMLC 239 | 240 | ifndef OCAMLOPT 241 | OCAMLOPT := ocamlopt 242 | endif 243 | export OCAMLOPT 244 | 245 | ifndef OCAMLMKTOP 246 | OCAMLMKTOP := ocamlmktop 247 | endif 248 | export OCAMLMKTOP 249 | 250 | ifndef OCAMLCP 251 | OCAMLCP := ocamlcp 252 | endif 253 | export OCAMLCP 254 | 255 | ifndef OCAMLDEP 256 | OCAMLDEP := ocamldep 257 | endif 258 | export OCAMLDEP 259 | 260 | ifndef OCAMLLEX 261 | OCAMLLEX := ocamllex 262 | endif 263 | export OCAMLLEX 264 | 265 | ifndef OCAMLYACC 266 | OCAMLYACC := ocamlyacc 267 | endif 268 | export OCAMLYACC 269 | 270 | ifndef OCAMLMKLIB 271 | OCAMLMKLIB := ocamlmklib 272 | endif 273 | export OCAMLMKLIB 274 | 275 | ifndef OCAML_GLADECC 276 | OCAML_GLADECC := lablgladecc2 277 | endif 278 | export OCAML_GLADECC 279 | 280 | ifndef OCAML_GLADECC_FLAGS 281 | OCAML_GLADECC_FLAGS := 282 | endif 283 | export OCAML_GLADECC_FLAGS 284 | 285 | ifndef CAMELEON_REPORT 286 | CAMELEON_REPORT := report 287 | endif 288 | export CAMELEON_REPORT 289 | 290 | ifndef CAMELEON_REPORT_FLAGS 291 | CAMELEON_REPORT_FLAGS := 292 | endif 293 | export CAMELEON_REPORT_FLAGS 294 | 295 | ifndef CAMELEON_ZOGGY 296 | CAMELEON_ZOGGY := camlp4o pa_zog.cma pr_o.cmo 297 | endif 298 | export CAMELEON_ZOGGY 299 | 300 | ifndef CAMELEON_ZOGGY_FLAGS 301 | CAMELEON_ZOGGY_FLAGS := 302 | endif 303 | export CAMELEON_ZOGGY_FLAGS 304 | 305 | ifndef OXRIDL 306 | OXRIDL := oxridl 307 | endif 308 | export OXRIDL 309 | 310 | ifndef CAMLIDL 311 | CAMLIDL := camlidl 312 | endif 313 | export CAMLIDL 314 | 315 | ifndef CAMLIDLDLL 316 | CAMLIDLDLL := camlidldll 317 | endif 318 | export CAMLIDLDLL 319 | 320 | ifndef NOIDLHEADER 321 | MAYBE_IDL_HEADER := -header 322 | endif 323 | export NOIDLHEADER 324 | 325 | export NO_CUSTOM 326 | 327 | ifndef CAMLP4 328 | CAMLP4 := camlp4 329 | endif 330 | export CAMLP4 331 | 332 | ifndef REAL_OCAMLFIND 333 | ifdef PACKS 334 | ifndef CREATE_LIB 335 | ifdef THREADS 336 | PACKS += threads 337 | endif 338 | endif 339 | empty := 340 | space := $(empty) $(empty) 341 | comma := , 342 | ifdef PREDS 343 | PRE_OCAML_FIND_PREDICATES := $(subst $(space),$(comma),$(PREDS)) 344 | PRE_OCAML_FIND_PACKAGES := $(subst $(space),$(comma),$(PACKS)) 345 | OCAML_FIND_PREDICATES := -predicates $(PRE_OCAML_FIND_PREDICATES) 346 | # OCAML_DEP_PREDICATES := -syntax $(PRE_OCAML_FIND_PREDICATES) 347 | OCAML_FIND_PACKAGES := $(OCAML_FIND_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 348 | OCAML_DEP_PACKAGES := $(OCAML_DEP_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 349 | else 350 | OCAML_FIND_PACKAGES := -package $(subst $(space),$(comma),$(PACKS)) 351 | OCAML_DEP_PACKAGES := 352 | endif 353 | OCAML_FIND_LINKPKG := -linkpkg 354 | REAL_OCAMLFIND := $(OCAMLFIND) 355 | endif 356 | endif 357 | 358 | export OCAML_FIND_PACKAGES 359 | export OCAML_DEP_PACKAGES 360 | export OCAML_FIND_LINKPKG 361 | export REAL_OCAMLFIND 362 | 363 | ifndef OCAMLDOC 364 | OCAMLDOC := ocamldoc 365 | endif 366 | export OCAMLDOC 367 | 368 | ifndef LATEX 369 | LATEX := latex 370 | endif 371 | export LATEX 372 | 373 | ifndef DVIPS 374 | DVIPS := dvips 375 | endif 376 | export DVIPS 377 | 378 | ifndef PS2PDF 379 | PS2PDF := ps2pdf 380 | endif 381 | export PS2PDF 382 | 383 | ifndef OCAMLMAKEFILE 384 | OCAMLMAKEFILE := OCamlMakefile 385 | endif 386 | export OCAMLMAKEFILE 387 | 388 | ifndef OCAMLLIBPATH 389 | OCAMLLIBPATH := \ 390 | $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/local/lib/ocaml) 391 | endif 392 | export OCAMLLIBPATH 393 | 394 | ifndef OCAML_LIB_INSTALL 395 | OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib 396 | endif 397 | export OCAML_LIB_INSTALL 398 | 399 | ########################################################################### 400 | 401 | #################### change following sections only if 402 | #################### you know what you are doing! 403 | 404 | # delete target files when a build command fails 405 | .PHONY: .DELETE_ON_ERROR 406 | .DELETE_ON_ERROR: 407 | 408 | # for pedants using "--warn-undefined-variables" 409 | export MAYBE_IDL 410 | export REAL_RESULT 411 | export CAMLIDLFLAGS 412 | export THREAD_FLAG 413 | export RES_CLIB 414 | export MAKEDLL 415 | export ANNOT_FLAG 416 | export C_OXRIDL 417 | export SUBPROJS 418 | export CFLAGS_WIN32 419 | export CPPFLAGS_WIN32 420 | 421 | INCFLAGS := 422 | 423 | SHELL := /bin/sh 424 | 425 | MLDEPDIR := ._d 426 | BCDIDIR := ._bcdi 427 | NCDIDIR := ._ncdi 428 | 429 | FILTER_EXTNS := %.mli %.ml %.mll %.mly %.idl %.oxridl %.c %.m %.$(EXT_CXX) %.rep %.zog %.glade 430 | 431 | FILTERED := $(filter $(FILTER_EXTNS), $(SOURCES)) 432 | SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) 433 | 434 | FILTERED_REP := $(filter %.rep, $(FILTERED)) 435 | DEP_REP := $(FILTERED_REP:%.rep=$(MLDEPDIR)/%.d) 436 | AUTO_REP := $(FILTERED_REP:.rep=.ml) 437 | 438 | FILTERED_ZOG := $(filter %.zog, $(FILTERED)) 439 | DEP_ZOG := $(FILTERED_ZOG:%.zog=$(MLDEPDIR)/%.d) 440 | AUTO_ZOG := $(FILTERED_ZOG:.zog=.ml) 441 | 442 | FILTERED_GLADE := $(filter %.glade, $(FILTERED)) 443 | DEP_GLADE := $(FILTERED_GLADE:%.glade=$(MLDEPDIR)/%.d) 444 | AUTO_GLADE := $(FILTERED_GLADE:.glade=.ml) 445 | 446 | FILTERED_ML := $(filter %.ml, $(FILTERED)) 447 | DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) 448 | 449 | FILTERED_MLI := $(filter %.mli, $(FILTERED)) 450 | DEP_MLI := $(FILTERED_MLI:.mli=.di) 451 | 452 | FILTERED_MLL := $(filter %.mll, $(FILTERED)) 453 | DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) 454 | AUTO_MLL := $(FILTERED_MLL:.mll=.ml) 455 | 456 | FILTERED_MLY := $(filter %.mly, $(FILTERED)) 457 | DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) 458 | AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) 459 | 460 | FILTERED_IDL := $(filter %.idl, $(FILTERED)) 461 | DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) 462 | C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) 463 | ifndef NOIDLHEADER 464 | C_IDL += $(FILTERED_IDL:.idl=.h) 465 | endif 466 | OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) 467 | AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) 468 | 469 | FILTERED_OXRIDL := $(filter %.oxridl, $(FILTERED)) 470 | DEP_OXRIDL := $(FILTERED_OXRIDL:%.oxridl=$(MLDEPDIR)/%.d) $(FILTERED_OXRIDL:.oxridl=.di) 471 | AUTO_OXRIDL := $(FILTERED_OXRIDL:.oxridl=.mli) $(FILTERED_OXRIDL:.oxridl=.ml) $(C_OXRIDL) 472 | 473 | FILTERED_C_CXX := $(filter %.c %.m %.$(EXT_CXX), $(FILTERED)) 474 | OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) 475 | OBJ_C_CXX := $(OBJ_C_CXX:.m=.$(EXT_OBJ)) 476 | OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) 477 | 478 | PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) $(AUTO_OXRIDL) $(AUTO_ZOG) $(AUTO_REP) $(AUTO_GLADE) 479 | 480 | ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) $(DEP_OXRIDL) $(DEP_ZOG) $(DEP_REP) $(DEP_GLADE) 481 | 482 | MLDEPS := $(filter %.d, $(ALL_DEPS)) 483 | MLIDEPS := $(filter %.di, $(ALL_DEPS)) 484 | BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) 485 | NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) 486 | 487 | ALLML := $(filter %.mli %.ml %.mll %.mly %.idl %.oxridl %.rep %.zog %.glade, $(FILTERED)) 488 | 489 | IMPLO_INTF := $(ALLML:%.mli=%.mli.__) 490 | IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ 491 | $(basename $(file)).cmi $(basename $(file)).cmo) 492 | IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) 493 | IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) 494 | 495 | IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) 496 | 497 | INTF := $(filter %.cmi, $(IMPLO_INTF)) 498 | IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) 499 | IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) 500 | IMPL_ASM := $(IMPL_CMO:.cmo=.asm) 501 | IMPL_S := $(IMPL_CMO:.cmo=.s) 502 | 503 | OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) 504 | OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) 505 | 506 | EXECS := $(addsuffix $(EXE), \ 507 | $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) 508 | ifdef WIN32 509 | EXECS += $(BCRESULT).dll $(NCRESULT).dll 510 | endif 511 | 512 | CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) 513 | ifneq ($(strip $(OBJ_LINK)),) 514 | RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) 515 | endif 516 | 517 | ifdef WIN32 518 | DLLSONAME := dll$(CLIB_BASE).dll 519 | else 520 | DLLSONAME := dll$(CLIB_BASE).so 521 | endif 522 | 523 | NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(IMPL_ASM) $(IMPL_S) \ 524 | $(OBJ_FILES) $(PRE_TARGETS) $(BCRESULT).cma $(NCRESULT).cmxa \ 525 | $(NCRESULT).$(EXT_LIB) $(BCRESULT).cmi $(BCRESULT).cmo \ 526 | $(NCRESULT).cmi $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 527 | $(RES_CLIB) $(IMPL_CMO:.cmo=.annot) \ 528 | $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(LIB_PACK_NAME).cmx \ 529 | $(LIB_PACK_NAME).$(EXT_OBJ) 530 | 531 | ifndef STATIC 532 | NONEXECS += $(DLLSONAME) 533 | endif 534 | 535 | ifndef LIBINSTALL_FILES 536 | LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ 537 | $(RESULT).cmxa $(RESULT).$(EXT_LIB) $(RES_CLIB) 538 | ifndef STATIC 539 | ifneq ($(strip $(OBJ_LINK)),) 540 | LIBINSTALL_FILES += $(DLLSONAME) 541 | endif 542 | endif 543 | endif 544 | 545 | export LIBINSTALL_FILES 546 | 547 | ifdef WIN32 548 | # some extra stuff is created while linking DLLs 549 | NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp $(CLIB_BASE).exp $(CLIB_BASE).lib 550 | endif 551 | 552 | TARGETS := $(EXECS) $(NONEXECS) 553 | 554 | # If there are IDL-files 555 | ifneq ($(strip $(FILTERED_IDL)),) 556 | MAYBE_IDL := -cclib -lcamlidl 557 | endif 558 | 559 | ifdef USE_CAMLP4 560 | CAMLP4PATH := \ 561 | $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/local/lib/camlp4) 562 | INCFLAGS := -I $(CAMLP4PATH) 563 | CINCFLAGS := -I$(CAMLP4PATH) 564 | endif 565 | 566 | INCFLAGS := $(INCFLAGS) $(INCDIRS:%=-I %) $(SOURCE_DIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) 567 | CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) 568 | 569 | ifndef MSVC 570 | CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) \ 571 | $(EXTLIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) 572 | 573 | ifeq ($(ELF_RPATH), yes) 574 | CLIBFLAGS += $(EXTLIBDIRS:%=-Wl,$(RPATH_FLAG)%) 575 | endif 576 | endif 577 | 578 | ifndef PROFILING 579 | INTF_OCAMLC := $(OCAMLC) 580 | else 581 | ifndef THREADS 582 | INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) 583 | else 584 | # OCaml does not support profiling byte code 585 | # with threads (yet), therefore we force an error. 586 | ifndef REAL_OCAMLC 587 | $(error Profiling of multithreaded byte code not yet supported by OCaml) 588 | endif 589 | INTF_OCAMLC := $(OCAMLC) 590 | endif 591 | endif 592 | 593 | ifndef MSVC 594 | COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ 595 | $(LIBDIRS:%=-ccopt -L%) $(EXTLIBDIRS:%=-ccopt -L%) \ 596 | $(EXTLIBDIRS:%=-ccopt -Wl $(OCAML_DEFAULT_DIRS:%=-ccopt -L%)) 597 | 598 | ifeq ($(ELF_RPATH),yes) 599 | COMMON_LDFLAGS += $(EXTLIBDIRS:%=-ccopt -Wl,$(RPATH_FLAG)%) 600 | endif 601 | else 602 | COMMON_LDFLAGS := -ccopt "/link -NODEFAULTLIB:LIBC $(LDFLAGS:%=%) $(SOURCE_DIRS:%=-LIBPATH:%) \ 603 | $(LIBDIRS:%=-LIBPATH:%) $(EXTLIBDIRS:%=-LIBPATH:%) \ 604 | $(OCAML_DEFAULT_DIRS:%=-LIBPATH:%) " 605 | endif 606 | 607 | CLIBS_OPTS := $(CLIBS:%=-cclib -l%) $(CFRAMEWORKS:%=-cclib '-framework %') 608 | ifdef MSVC 609 | ifndef STATIC 610 | # MSVC libraries do not have 'lib' prefix 611 | CLIBS_OPTS := $(CLIBS:%=-cclib %.lib) 612 | endif 613 | endif 614 | 615 | ifneq ($(strip $(OBJ_LINK)),) 616 | ifdef CREATE_LIB 617 | OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) 618 | else 619 | OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) 620 | endif 621 | else 622 | OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) 623 | endif 624 | 625 | ifdef LIB_PACK_NAME 626 | FOR_PACK_NAME := $(shell echo $(LIB_PACK_NAME) | awk '{print toupper(substr($$0,1,1))substr($$0,2)}') 627 | endif 628 | 629 | # If we have to make byte-code 630 | ifndef REAL_OCAMLC 631 | BYTE_OCAML := y 632 | 633 | # EXTRADEPS is added dependencies we have to insert for all 634 | # executable files we generate. Ideally it should be all of the 635 | # libraries we use, but it's hard to find the ones that get searched on 636 | # the path since I don't know the paths built into the compiler, so 637 | # just include the ones with slashes in their names. 638 | EXTRADEPS := $(addsuffix .cma,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 639 | 640 | 641 | ifndef LIB_PACK_NAME 642 | SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) 643 | else 644 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLBCFLAGS) 645 | endif 646 | 647 | REAL_OCAMLC := $(INTF_OCAMLC) 648 | 649 | REAL_IMPL := $(IMPL_CMO) 650 | REAL_IMPL_INTF := $(IMPLO_INTF) 651 | IMPL_SUF := .cmo 652 | 653 | DEPFLAGS := 654 | MAKE_DEPS := $(MLDEPS) $(BCDEPIS) 655 | 656 | ifdef CREATE_LIB 657 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 658 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 659 | ifndef STATIC 660 | ifneq ($(strip $(OBJ_LINK)),) 661 | MAKEDLL := $(DLLSONAME) 662 | ALL_LDFLAGS := -dllib $(DLLSONAME) 663 | endif 664 | endif 665 | endif 666 | 667 | ifndef NO_CUSTOM 668 | ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS) $(CFRAMEWORKS))" "" 669 | ALL_LDFLAGS += -custom 670 | endif 671 | endif 672 | 673 | ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ 674 | $(COMMON_LDFLAGS) $(LIBS:%=%.cma) 675 | CAMLIDLDLLFLAGS := 676 | 677 | ifdef THREADS 678 | ifdef VMTHREADS 679 | THREAD_FLAG := -vmthread 680 | else 681 | THREAD_FLAG := -thread 682 | endif 683 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 684 | ifndef CREATE_LIB 685 | ifndef REAL_OCAMLFIND 686 | ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) 687 | endif 688 | endif 689 | endif 690 | 691 | # we have to make native-code 692 | else 693 | EXTRADEPS := $(addsuffix .cmxa,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 694 | ifndef PROFILING 695 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 696 | PLDFLAGS := 697 | else 698 | SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) 699 | PLDFLAGS := -p 700 | endif 701 | 702 | ifndef LIB_PACK_NAME 703 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 704 | else 705 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLNCFLAGS) 706 | endif 707 | REAL_IMPL := $(IMPL_CMX) 708 | REAL_IMPL_INTF := $(IMPLX_INTF) 709 | IMPL_SUF := .cmx 710 | 711 | override CPPFLAGS := -DNATIVE_CODE $(CPPFLAGS) 712 | 713 | DEPFLAGS := -native 714 | MAKE_DEPS := $(MLDEPS) $(NCDEPIS) 715 | 716 | ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ 717 | $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) 718 | CAMLIDLDLLFLAGS := -opt 719 | 720 | ifndef CREATE_LIB 721 | ALL_LDFLAGS += $(LIBS:%=%.cmxa) 722 | else 723 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 724 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 725 | endif 726 | 727 | ifdef THREADS 728 | THREAD_FLAG := -thread 729 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 730 | ifndef CREATE_LIB 731 | ifndef REAL_OCAMLFIND 732 | ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) 733 | endif 734 | endif 735 | endif 736 | endif 737 | 738 | export MAKE_DEPS 739 | 740 | ifdef ANNOTATE 741 | ANNOT_FLAG := -annot 742 | else 743 | endif 744 | 745 | ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(ANNOT_FLAG) $(OCAMLFLAGS) \ 746 | $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) 747 | 748 | ifdef make_deps 749 | -include $(MAKE_DEPS) 750 | PRE_TARGETS := 751 | endif 752 | 753 | ########################################################################### 754 | # USER RULES 755 | 756 | # Call "OCamlMakefile QUIET=" to get rid of all of the @'s. 757 | QUIET=@ 758 | 759 | # generates byte-code (default) 760 | byte-code: $(PRE_TARGETS) 761 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 762 | REAL_RESULT="$(BCRESULT)" make_deps=yes 763 | bc: byte-code 764 | 765 | byte-code-nolink: $(PRE_TARGETS) 766 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 767 | REAL_RESULT="$(BCRESULT)" make_deps=yes 768 | bcnl: byte-code-nolink 769 | 770 | top: $(PRE_TARGETS) 771 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ 772 | REAL_RESULT="$(BCRESULT)" make_deps=yes 773 | 774 | # generates native-code 775 | 776 | native-code: $(PRE_TARGETS) 777 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 778 | REAL_RESULT="$(NCRESULT)" \ 779 | REAL_OCAMLC="$(OCAMLOPT)" \ 780 | make_deps=yes 781 | nc: native-code 782 | 783 | native-code-nolink: $(PRE_TARGETS) 784 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 785 | REAL_RESULT="$(NCRESULT)" \ 786 | REAL_OCAMLC="$(OCAMLOPT)" \ 787 | make_deps=yes 788 | ncnl: native-code-nolink 789 | 790 | # generates byte-code libraries 791 | byte-code-library: $(PRE_TARGETS) 792 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 793 | $(RES_CLIB) $(BCRESULT).cma \ 794 | REAL_RESULT="$(BCRESULT)" \ 795 | CREATE_LIB=yes \ 796 | make_deps=yes 797 | bcl: byte-code-library 798 | 799 | # generates native-code libraries 800 | native-code-library: $(PRE_TARGETS) 801 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 802 | $(RES_CLIB) $(NCRESULT).cmxa \ 803 | REAL_RESULT="$(NCRESULT)" \ 804 | REAL_OCAMLC="$(OCAMLOPT)" \ 805 | CREATE_LIB=yes \ 806 | make_deps=yes 807 | ncl: native-code-library 808 | 809 | ifdef WIN32 810 | # generates byte-code dll 811 | byte-code-dll: $(PRE_TARGETS) 812 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 813 | $(RES_CLIB) $(BCRESULT).dll \ 814 | REAL_RESULT="$(BCRESULT)" \ 815 | make_deps=yes 816 | bcd: byte-code-dll 817 | 818 | # generates native-code dll 819 | native-code-dll: $(PRE_TARGETS) 820 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 821 | $(RES_CLIB) $(NCRESULT).dll \ 822 | REAL_RESULT="$(NCRESULT)" \ 823 | REAL_OCAMLC="$(OCAMLOPT)" \ 824 | make_deps=yes 825 | ncd: native-code-dll 826 | endif 827 | 828 | # generates byte-code with debugging information 829 | debug-code: $(PRE_TARGETS) 830 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 831 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 832 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 833 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 834 | dc: debug-code 835 | 836 | debug-code-nolink: $(PRE_TARGETS) 837 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 838 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 839 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 840 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 841 | dcnl: debug-code-nolink 842 | 843 | # generates byte-code with debugging information (native code) 844 | debug-native-code: $(PRE_TARGETS) 845 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 846 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 847 | REAL_OCAMLC="$(OCAMLOPT)" \ 848 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 849 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 850 | dnc: debug-native-code 851 | 852 | debug-native-code-nolink: $(PRE_TARGETS) 853 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 854 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 855 | REAL_OCAMLC="$(OCAMLOPT)" \ 856 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 857 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 858 | dncnl: debug-native-code-nolink 859 | 860 | # generates byte-code libraries with debugging information 861 | debug-code-library: $(PRE_TARGETS) 862 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 863 | $(RES_CLIB) $(BCRESULT).cma \ 864 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 865 | CREATE_LIB=yes \ 866 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 867 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 868 | dcl: debug-code-library 869 | 870 | # generates byte-code libraries with debugging information (native code) 871 | debug-native-code-library: $(PRE_TARGETS) 872 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 873 | $(RES_CLIB) $(NCRESULT).cmxa \ 874 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 875 | REAL_OCAMLC="$(OCAMLOPT)" \ 876 | CREATE_LIB=yes \ 877 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 878 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 879 | dncl: debug-native-code-library 880 | 881 | # generates byte-code for profiling 882 | profiling-byte-code: $(PRE_TARGETS) 883 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 884 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 885 | make_deps=yes 886 | pbc: profiling-byte-code 887 | 888 | # generates native-code 889 | 890 | profiling-native-code: $(PRE_TARGETS) 891 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 892 | REAL_RESULT="$(NCRESULT)" \ 893 | REAL_OCAMLC="$(OCAMLOPT)" \ 894 | PROFILING="y" \ 895 | make_deps=yes 896 | pnc: profiling-native-code 897 | 898 | # generates byte-code libraries 899 | profiling-byte-code-library: $(PRE_TARGETS) 900 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 901 | $(RES_CLIB) $(BCRESULT).cma \ 902 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 903 | CREATE_LIB=yes \ 904 | make_deps=yes 905 | pbcl: profiling-byte-code-library 906 | 907 | # generates native-code libraries 908 | profiling-native-code-library: $(PRE_TARGETS) 909 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 910 | $(RES_CLIB) $(NCRESULT).cmxa \ 911 | REAL_RESULT="$(NCRESULT)" PROFILING="y" \ 912 | REAL_OCAMLC="$(OCAMLOPT)" \ 913 | CREATE_LIB=yes \ 914 | make_deps=yes 915 | pncl: profiling-native-code-library 916 | 917 | # packs byte-code objects 918 | pack-byte-code: $(PRE_TARGETS) 919 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT).cmo \ 920 | REAL_RESULT="$(BCRESULT)" \ 921 | PACK_LIB=yes make_deps=yes 922 | pabc: pack-byte-code 923 | 924 | # packs native-code objects 925 | pack-native-code: $(PRE_TARGETS) 926 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 927 | $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 928 | REAL_RESULT="$(NCRESULT)" \ 929 | REAL_OCAMLC="$(OCAMLOPT)" \ 930 | PACK_LIB=yes make_deps=yes 931 | panc: pack-native-code 932 | 933 | # generates HTML-documentation 934 | htdoc: $(DOC_DIR)/$(RESULT)/html/index.html 935 | 936 | # generates Latex-documentation 937 | ladoc: $(DOC_DIR)/$(RESULT)/latex/doc.tex 938 | 939 | # generates PostScript-documentation 940 | psdoc: $(DOC_DIR)/$(RESULT)/latex/doc.ps 941 | 942 | # generates PDF-documentation 943 | pdfdoc: $(DOC_DIR)/$(RESULT)/latex/doc.pdf 944 | 945 | # generates all supported forms of documentation 946 | doc: htdoc ladoc psdoc pdfdoc 947 | 948 | ########################################################################### 949 | # LOW LEVEL RULES 950 | 951 | $(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(RESULTDEPS) 952 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) \ 953 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 954 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 955 | $(REAL_IMPL) 956 | 957 | nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) 958 | 959 | ifdef WIN32 960 | $(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) 961 | $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ 962 | -o $@ $(REAL_IMPL) 963 | endif 964 | 965 | %$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) 966 | $(REAL_OCAMLFIND) $(OCAMLMKTOP) \ 967 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 968 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 969 | $(REAL_IMPL) 970 | 971 | .SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ 972 | .mly .di .d .$(EXT_LIB) .idl %.oxridl .c .m .$(EXT_CXX) .h .so \ 973 | .rep .zog .glade 974 | 975 | ifndef STATIC 976 | ifdef MINGW 977 | # From OCaml 3.11.0, ocamlmklib is available on windows 978 | OCAMLMLIB_EXISTS = $(shell which $(OCAMLMKLIB)) 979 | ifeq ($(strip $(OCAMLMLIB_EXISTS)),) 980 | $(DLLSONAME): $(OBJ_LINK) 981 | $(CC) $(CFLAGS) $(CFLAGS_WIN32) $(OBJ_LINK) -shared -o $@ \ 982 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/lib%.a))) \ 983 | '$(OCAMLLIBPATH)/ocamlrun.a' \ 984 | -Wl,--whole-archive \ 985 | -Wl,--export-all-symbols \ 986 | -Wl,--allow-multiple-definition \ 987 | -Wl,--enable-auto-import 988 | else 989 | $(DLLSONAME): $(OBJ_LINK) 990 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 991 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) \ 992 | $(CFRAMEWORKS:%=-framework %) \ 993 | $(OCAMLMKLIB_FLAGS) 994 | endif 995 | else 996 | ifdef MSVC 997 | $(DLLSONAME): $(OBJ_LINK) 998 | link /NOLOGO /DLL /OUT:$@ $(OBJ_LINK) \ 999 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/%.lib))) \ 1000 | '$(OCAMLLIBPATH)/ocamlrun.lib' 1001 | 1002 | else 1003 | $(DLLSONAME): $(OBJ_LINK) 1004 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 1005 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) $(CFRAMEWORKS:%=-framework %) \ 1006 | $(OCAMLMKLIB_FLAGS) 1007 | endif 1008 | endif 1009 | endif 1010 | 1011 | ifndef LIB_PACK_NAME 1012 | $(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1013 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1014 | 1015 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) $(EXTRADEPS) $(RESULTDEPS) 1016 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1017 | else 1018 | # Packing a bytecode library 1019 | LIB_PACK_NAME_MLI = $(wildcard $(LIB_PACK_NAME).mli) 1020 | ifeq ($(LIB_PACK_NAME_MLI),) 1021 | LIB_PACK_NAME_CMI = $(LIB_PACK_NAME).cmi 1022 | else 1023 | # $(LIB_PACK_NAME).mli exists, it likely depends on other compiled interfaces 1024 | LIB_PACK_NAME_CMI = 1025 | $(LIB_PACK_NAME).cmi: $(REAL_IMPL_INTF) 1026 | endif 1027 | ifdef BYTE_OCAML 1028 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmo: $(REAL_IMPL_INTF) 1029 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmo $(OCAMLLDFLAGS) $(REAL_IMPL) 1030 | # Packing into a unit which can be transformed into a library 1031 | # Remember the .ml's must have been compiled with -for-pack $(LIB_PACK_NAME) 1032 | else 1033 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmx: $(REAL_IMPL_INTF) 1034 | $(REAL_OCAMLFIND) $(OCAMLOPT) -pack -o $(LIB_PACK_NAME).cmx $(OCAMLLDFLAGS) $(REAL_IMPL) 1035 | endif 1036 | 1037 | $(RESULT).cma: $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1038 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(LIB_PACK_NAME).cmo 1039 | 1040 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx $(EXTRADEPS) $(RESULTDEPS) 1041 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(filter-out -custom, $(ALL_LDFLAGS)) -o $@ $(LIB_PACK_NAME).cmx 1042 | endif 1043 | 1044 | $(RES_CLIB): $(OBJ_LINK) 1045 | ifndef MSVC 1046 | ifneq ($(strip $(OBJ_LINK)),) 1047 | $(AR) rcs $@ $(OBJ_LINK) 1048 | endif 1049 | else 1050 | ifneq ($(strip $(OBJ_LINK)),) 1051 | lib -nologo -debugtype:cv -out:$(RES_CLIB) $(OBJ_LINK) 1052 | endif 1053 | endif 1054 | 1055 | %.cmi: %.mli $(EXTRADEPS) 1056 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1057 | if [ -z "$$pp" ]; then \ 1058 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1059 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1060 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1061 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1062 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1063 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1064 | else \ 1065 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1066 | -c -pp \"$$pp $(PPFLAGS)\" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1067 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1068 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1069 | -c -pp "$$pp $(PPFLAGS)" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1070 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1071 | fi 1072 | 1073 | %.cmi: %$(IMPL_SUF); 1074 | 1075 | %$(IMPL_SUF) %.$(EXT_OBJ): %.ml $(EXTRADEPS) 1076 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1077 | if [ -z "$$pp" ]; then \ 1078 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1079 | -c $(ALL_OCAMLCFLAGS) $<; \ 1080 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1081 | -c $(ALL_OCAMLCFLAGS) $<; \ 1082 | else \ 1083 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1084 | -c -pp \"$$pp $(PPFLAGS)\" $(ALL_OCAMLCFLAGS) $<; \ 1085 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1086 | -c -pp "$$pp $(PPFLAGS)" $(ALL_OCAMLCFLAGS) $<; \ 1087 | fi 1088 | 1089 | .PRECIOUS: %.ml 1090 | %.ml: %.mll 1091 | $(OCAMLLEX) $(LFLAGS) $< 1092 | 1093 | .PRECIOUS: %.ml %.mli 1094 | %.ml %.mli: %.mly 1095 | $(OCAMLYACC) $(YFLAGS) $< 1096 | $(QUIET)pp=`sed -n -e 's/.*(\*pp \([^*]*\) \*).*/\1/p;q' $<`; \ 1097 | if [ ! -z "$$pp" ]; then \ 1098 | mv $*.ml $*.ml.temporary; \ 1099 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.ml; \ 1100 | cat $*.ml.temporary >> $*.ml; \ 1101 | rm $*.ml.temporary; \ 1102 | mv $*.mli $*.mli.temporary; \ 1103 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.mli; \ 1104 | cat $*.mli.temporary >> $*.mli; \ 1105 | rm $*.mli.temporary; \ 1106 | fi 1107 | 1108 | 1109 | .PRECIOUS: %.ml 1110 | %.ml: %.rep 1111 | $(CAMELEON_REPORT) $(CAMELEON_REPORT_FLAGS) -gen $< 1112 | 1113 | .PRECIOUS: %.ml 1114 | %.ml: %.zog 1115 | $(CAMELEON_ZOGGY) $(CAMELEON_ZOGGY_FLAGS) -impl $< > $@ 1116 | 1117 | .PRECIOUS: %.ml 1118 | %.ml: %.glade 1119 | $(OCAML_GLADECC) $(OCAML_GLADECC_FLAGS) $< > $@ 1120 | 1121 | .PRECIOUS: %.ml %.mli 1122 | %.ml %.mli: %.oxridl 1123 | $(OXRIDL) $< 1124 | 1125 | .PRECIOUS: %.ml %.mli %_stubs.c %.h 1126 | %.ml %.mli %_stubs.c %.h: %.idl 1127 | $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ 1128 | $(CAMLIDLFLAGS) $< 1129 | $(QUIET)if [ $(NOIDLHEADER) ]; then touch $*.h; fi 1130 | 1131 | %.$(EXT_OBJ): %.c 1132 | $(OCAMLC) -c -cc "$(CC)" -ccopt "$(CFLAGS) \ 1133 | $(CPPFLAGS) $(CPPFLAGS_WIN32) \ 1134 | $(CFLAGS_WIN32) $(CINCFLAGS) $(CFLAG_O)$@ " $< 1135 | 1136 | %.$(EXT_OBJ): %.m 1137 | $(CC) -c $(CFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1138 | -I'$(OCAMLLIBPATH)' \ 1139 | $< $(CFLAG_O)$@ 1140 | 1141 | %.$(EXT_OBJ): %.$(EXT_CXX) 1142 | $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1143 | -I'$(OCAMLLIBPATH)' \ 1144 | $< $(CFLAG_O)$@ 1145 | 1146 | $(MLDEPDIR)/%.d: %.ml 1147 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1148 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1149 | if [ -z "$$pp" ]; then \ 1150 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1151 | $(INCFLAGS) $< \> $@; \ 1152 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1153 | $(INCFLAGS) $< > $@; \ 1154 | else \ 1155 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1156 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1157 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1158 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1159 | fi 1160 | 1161 | $(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli 1162 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1163 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1164 | if [ -z "$$pp" ]; then \ 1165 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< \> $@; \ 1166 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< > $@; \ 1167 | else \ 1168 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1169 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1170 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1171 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1172 | fi 1173 | 1174 | $(DOC_DIR)/$(RESULT)/html: 1175 | mkdir -p $@ 1176 | 1177 | $(DOC_DIR)/$(RESULT)/html/index.html: $(DOC_DIR)/$(RESULT)/html $(DOC_FILES) 1178 | rm -rf $