summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGuillaume Seguin <guillaume@segu.in>2009-01-14 09:39:18 +0100
committerGuillaume Seguin <guillaume@segu.in>2009-01-14 09:39:18 +0100
commiteae584152cd35e0ee489a7f2938878fb294faa9e (patch)
treefd5472f1d24f7e385d0cbdfe1a2a7c325272cce9
parent44b8335645e10cc1065eea8c904a3b8bd11da378 (diff)
downloadpetitcaml-eae584152cd35e0ee489a7f2938878fb294faa9e.tar.gz
petitcaml-eae584152cd35e0ee489a7f2938878fb294faa9e.tar.bz2
[petitcaml] Make it actually work
-rw-r--r--Makefile3
-rw-r--r--ast.mli8
-rw-r--r--closure.ml80
-rw-r--r--compile.ml450
-rw-r--r--main.ml29
-rw-r--r--mips.ml25
-rw-r--r--mipshelpers.ml22
-rw-r--r--optimize.ml104
-rw-r--r--primitives.ml80
-rw-r--r--runtests.py38
-rw-r--r--tests/assembly/lists-ops.ml36
-rw-r--r--tests/assembly/lists.ml27
-rw-r--r--tests/assembly/ops.ml42
-rw-r--r--tests/assembly/primitives.ml9
-rw-r--r--tests/assembly/recursive.ml24
-rw-r--r--tests/assembly/redefine-primitive.ml9
-rw-r--r--tests/assembly/tuples.ml15
-rw-r--r--tests/assembly/vicious.ml14
-rw-r--r--tests/typing/base-fail.ml2
-rw-r--r--tests/typing/match-fail3.ml9
-rw-r--r--typing.ml74
-rw-r--r--utils.ml21
22 files changed, 913 insertions, 208 deletions
diff --git a/Makefile b/Makefile
index 593b289..4329146 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,6 @@
CMO=typing.cmo utils.cmo lexer.cmo parser.cmo \
- primitives.cmo mips.cmo closure.cmo optimize.cmo compile.cmo \
+ mips.cmo mipshelpers.cmo primitives.cmo \
+ closure.cmo optimize.cmo compile.cmo \
main.cmo
CMI=ast.cmi
CMO_DEP=typing.cmo utils.cmo
diff --git a/ast.mli b/ast.mli
index f335fde..fcbd2b0 100644
--- a/ast.mli
+++ b/ast.mli
@@ -1,3 +1,7 @@
+(****************************************
+ ast.mli - types, motifs, expressions
+ ****************************************)
+
open Lexing
(* Types *)
@@ -62,7 +66,7 @@ type expr_raw =
| Elistcons of expr * expr
| Ecall of expr * expr
| Ematch of expr * expr * motif * motif * expr
- | Eclos of ident * ident list
+ | Eclos of bool * ident * ident list
and expr = { e : expr_raw ;
loc : expr_loc ;
mutable t : expr_typ }
@@ -70,3 +74,5 @@ and func = { name : func_name ;
recursive : bool ;
arg : motif ;
body : expr }
+
+type letfun = ident * ident list * motif * expr
diff --git a/closure.ml b/closure.ml
index 7549c86..07a6662 100644
--- a/closure.ml
+++ b/closure.ml
@@ -1,19 +1,31 @@
+(****************************************
+ closure.ml - gestion des clotures
+ ****************************************)
+
open Ast
open Utils
-let next_fun_id = ref 0
+module Sset = Set.Make(String)
+
+let next_fun_id = ref 1
+
+(* Gestion des conflits de labels sur les fonctions *)
+let rec new_function_label idents =
+ let label = Printf.sprintf "fun___%d" !next_fun_id
+ in
+ incr next_fun_id;
+ if Sset.mem label idents then
+ new_function_label idents
+ else
+ label
-let get_function_name f =
+(* Petit helper, générant un identifiant à la volée si nécessaire *)
+let get_function_name idents f =
match f.name with
- | None ->
- let name = Printf.sprintf "fun____%d" !next_fun_id
- in
- incr next_fun_id;
- name
+ | None -> new_function_label idents
| Some s -> s
-module Sset = Set.Make(String)
-
+(* Calcul des identifiants d'un motif *)
let rec motif_vars m =
match m.m with
| Munderscore -> Sset.empty
@@ -22,6 +34,8 @@ let rec motif_vars m =
Sset.union base (motif_vars motif))
Sset.empty l
+(* Détermination des variables libres d'une expression,
+ utilisée lors de la construction des clotures et letfuns *)
let rec free_vars expr =
match expr.e with
| Econst _ -> Sset.empty
@@ -36,7 +50,7 @@ let rec free_vars expr =
| Eif (e1, e2, e3) ->
Sset.union (Sset.union (free_vars e1) (free_vars e2))
(free_vars e3)
- | Eletin ({m = Mident id}, {e = Efunc f}, e2) when f.recursive ->
+ | Eletin ({ m = Mident id }, { e = (Efunc f) }, e2) when f.recursive ->
Sset.diff (Sset.union (free_vars (raw_expr (Efunc f)))
(free_vars e2))
(Sset.singleton id)
@@ -53,70 +67,72 @@ let rec free_vars expr =
(Sset.diff (free_vars result_expr) motifs_idents)
| Eclos _ -> failwith "free_vars : Unreachable matching"
-let rec replace_funcs expr =
+(* Parcours récursif de l'arbre pour remplacer les fonctions par des
+ clotures et des letfuns, retourne un (expr * (letfun list)) *)
+let rec replace_funcs idents expr =
match expr.e with
| Econst _ -> expr, []
| Eident _ -> expr, []
| Etuple l ->
let l, letfuns =
List.fold_right (fun e (l, letfuns) ->
- let e2, letfuns2 = replace_funcs e
+ let e2, letfuns2 = replace_funcs idents e
in
(e2::l, letfuns2 @ letfuns))
l ([], [])
in
(raw_expr (Etuple l)), letfuns
| Ebinop (e1, o, e2) ->
- let e1, letfuns1 = replace_funcs e1
- and e2, letfuns2 = replace_funcs e2
+ let e1, letfuns1 = replace_funcs idents e1
+ and e2, letfuns2 = replace_funcs idents e2
in
(raw_expr (Ebinop (e1, o, e2))), letfuns1 @ letfuns2
| Eunop (o, e) ->
- let e, letfuns = replace_funcs e
+ let e, letfuns = replace_funcs idents e
in
(raw_expr (Eunop (o, e))), letfuns
| Eletin (m, val_expr, body_expr) ->
- let val_expr, letfuns1 = replace_funcs val_expr
- and body_expr, letfuns2 = replace_funcs body_expr
+ let val_expr, letfuns1 = replace_funcs idents val_expr
+ and body_expr, letfuns2 = replace_funcs idents body_expr
in
(raw_expr (Eletin (m, val_expr, body_expr))),
letfuns1 @ letfuns2
| Efunc f ->
- let fname = get_function_name f
+ let fname = get_function_name idents f
in
let fvars = Sset.elements (free_vars expr)
in
- (raw_expr (Eclos (fname, fvars))),
- (build_letfun fname f fvars)
+ (raw_expr (Eclos (f.recursive, fname, fvars))),
+ (build_letfun idents fname f fvars)
| Eif (cond_expr, then_expr, else_expr) ->
- let cond_expr, letfuns1 = replace_funcs cond_expr
- and then_expr, letfuns2 = replace_funcs then_expr
- and else_expr, letfuns3 = replace_funcs else_expr
+ let cond_expr, letfuns1 = replace_funcs idents cond_expr
+ and then_expr, letfuns2 = replace_funcs idents then_expr
+ and else_expr, letfuns3 = replace_funcs idents else_expr
in
(raw_expr (Eif (cond_expr, then_expr, else_expr))),
letfuns1 @ letfuns2 @ letfuns3
| Elistcons (head_expr, tail_expr) ->
- let head_expr, letfuns1 = replace_funcs head_expr
- and tail_expr, letfuns2 = replace_funcs tail_expr
+ let head_expr, letfuns1 = replace_funcs idents head_expr
+ and tail_expr, letfuns2 = replace_funcs idents tail_expr
in
(raw_expr (Elistcons (head_expr, tail_expr))),
letfuns1 @ letfuns2
| Ecall (func_expr, arg_expr) ->
- let func_expr, letfuns1 = replace_funcs func_expr
- and arg_expr, letfuns2 = replace_funcs arg_expr
+ let func_expr, letfuns1 = replace_funcs idents func_expr
+ and arg_expr, letfuns2 = replace_funcs idents arg_expr
in
(raw_expr (Ecall (func_expr, arg_expr))),
letfuns1 @ letfuns2
| Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
- let match_expr, letfuns1 = replace_funcs match_expr
- and empty_expr, letfuns2 = replace_funcs empty_expr
- and result_expr, letfuns3 = replace_funcs result_expr
+ let match_expr, letfuns1 = replace_funcs idents match_expr
+ and empty_expr, letfuns2 = replace_funcs idents empty_expr
+ and result_expr, letfuns3 = replace_funcs idents result_expr
in
(raw_expr (Ematch (match_expr, empty_expr,
head_m, tail_m, result_expr))),
letfuns1 @ letfuns2 @ letfuns3
| Eclos _ -> failwith "replace_funcs : Unreachable matching"
-and build_letfun fname f fvars =
- let fbody, letfuns = replace_funcs f.body
+and build_letfun idents fname f fvars =
+ let fbody, letfuns = replace_funcs idents f.body
in
letfuns @ [(fname, fvars, f.arg, fbody)]
diff --git a/compile.ml b/compile.ml
index 0393838..2ef5da0 100644
--- a/compile.ml
+++ b/compile.ml
@@ -1,3 +1,7 @@
+(****************************************
+ compile.ml - production de code
+ ****************************************)
+
open Format
open Mips
open Ast
@@ -5,59 +9,104 @@ open Utils
open Closure
open Optimize
open Primitives
+open Mipshelpers
module Smap = Map.Make(String)
-type env = { mutable addrs : ident_address Smap.t ;
- mutable fp : int }
-let empty_env = { addrs = Smap.empty ; fp = 0 }
+type env = { addrs : ident_address Smap.t ;
+ fp : int ;
+ idents : Sset.t }
+let empty_env = { idents = Sset.empty ; addrs = Smap.empty ; fp = 0 }
let frame_size = ref 0
let next_string_id = ref 1
let next_jump_id = ref 1
-let heap_push n =
- Addi (SP, SP, - n)
-let heap_pop n =
- Addi (SP, SP, n)
-
-let push reg =
- [Addi (SP, SP, -4) ;
- Sw (reg, (0, SP))]
-
-let pop reg =
- [Lw (reg, (0, SP)) ;
- Addi (SP, SP, 4)]
-
-let malloc n =
- [Li (V0, 9) ;
- Li (A0, n) ;
- Syscall]
+let new_primitive_label idents ident =
+ let rec aux i =
+ let label = Printf.sprintf "%s__%d" ident i
+ in
+ if Sset.mem label idents then
+ aux (i + 1)
+ else
+ label
+ in
+ if Sset.mem ident idents then
+ aux 0
+ else
+ ident
-(* Compilation des listes :
- allocation d'un bloc de 4 + 4 = 8 octets contenant, en supposant que
- l'adresse soit dans le registre V0, la valeur ou le pointeur de la valeur
- de tête dans 0(V0), et le pointeur vers la queue dans 4(V0) *)
+let rec new_string_label env =
+ let label = Printf.sprintf "jump___%d" !next_jump_id
+ in
+ incr next_jump_id;
+ if Sset.mem label env.idents then
+ new_string_label env
+ else
+ label
-let new_string_label () =
+let rec new_jump_label env =
let label = Printf.sprintf "string___%d" !next_string_id
in
incr next_string_id;
- label
+ if Sset.mem label env.idents then
+ new_jump_label env
+ else
+ label
-let new_jump_label () =
- let label = Printf.sprintf "jump___%d" !next_jump_id
+let assign_ident_to_addr env ident addr =
+ { env with addrs = Smap.add ident addr env.addrs }
+
+let push_closure env =
+ if !frame_size = env.fp then frame_size := 4 + !frame_size;
+ let curr_fp = env.fp
in
- incr next_jump_id;
- label
+ (-curr_fp, FP),
+ [Comment "Push closure address to stack" ;
+ Sw (A0, (- curr_fp, FP))],
+ { env with fp = env.fp + 4 }
let assign_ident env ident =
if !frame_size = env.fp then frame_size := 4 + !frame_size;
- let new_addrs = Smap.add ident (Areg (env.fp, FP)) env.addrs
+ let new_addrs = Smap.add ident (Amem (- env.fp, FP)) env.addrs
and curr_fp = env.fp
in
- [Lw (V0, (curr_fp, FP))], { addrs = new_addrs ; fp = env.fp + 4 }
+ [Comment (Printf.sprintf "Assign %s" ident); Sw (V0, (- curr_fp, FP))],
+ { env with addrs = new_addrs ; fp = env.fp + 4 }
+
+let make_base_env idents =
+ List.fold_left (fun (base_code, base_register_code, env) ident ->
+ let assign_code, env = assign_ident env ident
+ and label = new_primitive_label idents ident
+ in
+ base_code
+ @
+ [Label label]
+ @
+ (Smap.find ident primitives_map),
+ base_register_code
+ @
+ [Comment (Printf.sprintf "Register %s" ident)]
+ @
+ (primitive_register_code label)
+ @ assign_code,
+ env)
+ ([], [], { empty_env with idents = idents })
+
+let function_header frame_size =
+ [Addi (SP, SP, - 12) ;
+ Sw (RA, (8, SP)) ;
+ Sw (FP, (4, SP)) ;
+ Move (FP, SP) ;
+ Addi (SP, SP, - frame_size)]
+
+let function_footer frame_size =
+ [Addi (SP, SP, frame_size) ;
+ Lw (RA, (8, SP)) ;
+ Lw (FP, (4, SP)) ;
+ Addi (SP, SP, 12) ;
+ Jr RA]
let rec assign_motif env m =
match m.m with
@@ -77,42 +126,74 @@ let rec assign_motif env m =
Lw (V0, (4 * !i, V0))]
@
instrs, env2))
- ([heap_push 4 ;
- Sw (V0, (0, SP))], env)
+ ([Comment "Assign tuple"]
+ @
+ (heap_push 4)
+ @
+ [Sw (V0, (0, SP))], env)
l
in
- instrs @ [heap_pop 4], env
+ instrs @ (heap_pop 4), env
let ident_to_reg env ident reg =
- match Smap.find ident env.addrs with
- | Alab label -> [Lw_label (reg, label)]
- | Areg radd -> [Lw (reg, radd)]
+ try
+ match Smap.find ident env.addrs with
+ | Alab label -> [Lw_label (reg, label)]
+ | Areg rsrc -> [Move (reg, rsrc)]
+ | Amem radd -> [Lw (reg, radd)]
+ | Aclosure (id, clos_add) ->
+ [Lw (reg, clos_add) ;
+ Lw (reg, (id, reg))]
+ with Not_found ->
+ failwith (Printf.sprintf "ident_to_reg : Unknown ident %s" ident)
+
+(* Compilation des listes :
+ allocation d'un bloc de 4 + 4 = 8 octets contenant, en supposant que
+ l'adresse soit dans le registre V0, la valeur ou le pointeur de la valeur
+ de tête dans 0(V0), et le pointeur vers la queue dans 4(V0) *)
+(* Compilation des tuples :
+ bloc de 4 * n octets pour un tuple à n éléments *)
+(* Cloture :
+ bloc de 4 * (n + 1) octets pour n variables à stocker
+ Si la cloture correspond à une fonction récursive, elle stocke l'adresse du
+ bloc de données dans la cloture elle même *)
(* Compile une expression, et assure que le résultat sera dans V0 *)
let rec compile_expr env expr =
match expr.e with
| Econst (Cint c) ->
- [Li (V0, c)]
+ [Comment (Printf.sprintf "Load int const %d" c) ;
+ Li (V0, c)]
| Econst (Cstring s) ->
- let label = new_string_label ()
+ let label = new_string_label env
in
- [Asciiz (label, s);
+ [Comment (Printf.sprintf "Load string %S" s) ;
+ Asciiz (label, s);
La (V0, label)]
| Econst (Cbool true) ->
- [Li (V0, 1)]
+ [Comment "Load true" ;
+ Li (V0, 1)]
+ | Econst Cunit ->
+ [Comment "Ignoring unit"]
| Econst (Cbool false)
- | Econst Cunit
| Econst Cemptylist ->
- [Li (V0, 0)]
+ [Comment "Load false/emptylist" ;
+ Li (V0, 0)]
| Eident ident ->
- ident_to_reg env ident V0
+ let instrs = (ident_to_reg env ident V0)
+ in
+ (Comment (Printf.sprintf "Load ident %s" ident))::instrs
| Etuple l ->
let len = List.length l
and i = ref (-1)
in
+ [Comment (Printf.sprintf "Compute tuple of length %d" len)]
+ @
malloc (4 * len)
@
- [heap_push 4 ;
+ (heap_push 4)
+ @
+ [Comment "Store tuple address on the stack";
Sw (V0, (0, SP))]
@
(List.fold_left (fun base e ->
@@ -125,36 +206,52 @@ let rec compile_expr env expr =
Sw (V0, (4 * !i, T0))])
[] l)
@
- [heap_pop 4]
+ [Comment "Restore tuple address to V0" ;
+ Lw (V0, (0, SP))]
+ @
+ (heap_pop 4)
| Ebinop (e1, o, e2) ->
+ [Comment "Binop" ;
+ Comment "Compute left member"]
+ @
(compile_expr env e1)
@
- [heap_push 4 ;
- Sw (V0, (0, SP))]
+ [Comment "Backup left value"]
+ @
+ (heap_push 4)
+ @
+ [Sw (V0, (0, SP)) ;
+ Comment "Compute right member"]
@
(compile_expr env e2)
@
- [Lw (A0, (0, SP)) ;
+ [Comment "Reload left value & compute op" ;
+ Lw (A0, (0, SP)) ;
begin
match o with
- | OAdd -> Add (V0, V0, A0)
- | OSub -> Sub (V0, V0, A0)
- | OMul -> Mul (V0, V0, A0)
- | ODiv -> Div (V0, V0, A0)
- | OAnd -> And (V0, V0, A0)
- | OOr -> Or (V0, V0, A0)
- | OEq -> Seq (V0, V0, A0)
- | ONeq -> Sne (V0, V0, A0)
- | OLt -> Slt (V0, V0, A0)
- | OLe -> Sle (V0, V0, A0)
- | OGt -> Sgt (V0, V0, A0)
- | OGe -> Sge (V0, V0, A0)
- end ;
- heap_pop 4]
+ | OAdd -> Add (V0, A0, V0)
+ | OSub -> Sub (V0, A0, V0)
+ | OMul -> Mul (V0, A0, V0)
+ | ODiv -> Div (V0, A0, V0)
+ | OAnd -> And (V0, A0, V0)
+ | OOr -> Or (V0, A0, V0)
+ | OEq -> Seq (V0, A0, V0)
+ | ONeq -> Sne (V0, A0, V0)
+ | OLt -> Slt (V0, A0, V0)
+ | OLe -> Sle (V0, A0, V0)
+ | OGt -> Sgt (V0, A0, V0)
+ | OGe -> Sge (V0, A0, V0)
+ end]
+ @
+ (heap_pop 4)
| Eunop (o, e) ->
+ [Comment "Compute unop" ;
+ Comment "Compule right member" ;]
+ @
(compile_expr env e)
@
- [begin
+ [Comment "Apply op" ;
+ begin
match o with
| ONot -> Not (V0, V0)
| ONeg -> Neg (V0, V0)
@@ -163,147 +260,240 @@ let rec compile_expr env expr =
let val_instrs = compile_expr env val_expr
and set_instrs, env2 = assign_motif env m
in
+ [Comment "Letin" ;
+ Comment "Compute value"]
+ @
val_instrs
@
+ [Comment "Assign value"]
+ @
set_instrs
@
+ [Comment "Compute body"]
+ @
(compile_expr env2 body_expr)
| Eif (cond_expr, then_expr, else_expr) ->
- let else_label = new_jump_label ()
- and end_label = new_jump_label ()
+ let else_label = new_jump_label env
+ and end_label = new_jump_label env
in
+ [Comment "If" ;
+ Comment "Compute condition"]
+ @
(compile_expr env cond_expr)
@
- [Blez (V0, else_label)]
+ [Comment "If branching" ;
+ Blez (V0, else_label) ;
+ Comment "Compute result (when true)"]
@
(compile_expr env then_expr)
@
- [J end_label ;
+ [Comment "Jump towards end-of-if label" ;
+ J end_label ;
+ Comment "Compute result (when false)" ;
Label else_label]
@
(compile_expr env else_expr)
@
- [Label end_label]
+ [Comment "End-of-if label" ;
+ Label end_label]
| Elistcons (head_expr, tail_expr) ->
+ [Comment "Listcons" ;
+ Comment "Compute head"]
+ @
(compile_expr env head_expr)
@
- [heap_push 8 ; (* On réserve direct les deux blocs pour backup
- de la valeur de tête de de queue *)
- Sw (V0, (4, SP))]
+ (heap_push 8) (* On réserve direct les deux blocs pour backup
+ de la valeur de tête de de queue *)
+ @
+ [Comment "Store head" ;
+ Sw (V0, (4, SP)) ;
+ Comment "Compute tail"]
@
(compile_expr env tail_expr)
@
- [Sw (V0, (0, SP))]
+ [Comment "Store tail" ;
+ Sw (V0, (0, SP)) ;
+ Comment "Allocate list item & set it"]
@
(malloc 8)
@
[Lw (A1, (0, SP)) ;
Lw (A0, (4, SP)) ;
Sw (A0, (0, V0)) ;
- Sw (A1, (4, V0)) ;
- heap_pop 8]
+ Sw (A1, (4, V0))]
+ @
+ (heap_pop 8)
| Ecall (func_expr, arg_expr) ->
+ [Comment "Call" ;
+ Comment "Compute called expression"]
+ @
(compile_expr env func_expr)
@
- [heap_push 4 ;
- Sw (V0, (0, SP))]
+ (push V0)
+ @
+ [Comment "Compute argument"]
@
(compile_expr env arg_expr)
@
- [Move (A1, V0) ; (* Cloture dans A0, argument dans A1,
- adresse du bloc de code dans T0 *)
- Lw (A0, (0, SP)) ;
- Lw (T0, (0, A0)) ;
- Jalr (T0, RA)]
+ [Comment "Do the call" ;
+ Move (A1, V0)] (* Cloture dans A0, argument dans A1,
+ adresse du bloc de code dans T0 *)
+ @
+ (pop A0)
+ @
+ [Lw (T0, (0, A0)) ;
+ Jalr T0]
| Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
(* Petit trick : a::b est représenté comme (a, b) dans la
mémoire, abusons donc le processus pour faciliter l'assignation
Note : on pourrait (en plus) remplacer le match par un if
bien placé, mais ça serait vraiment coquin *)
- let empty_label = new_jump_label ()
- and end_label = new_jump_label ()
+ let empty_label = new_jump_label env
+ and end_label = new_jump_label env
and set_instrs, env2 = assign_motif env
(raw_motif (Mtuple [head_m ;
tail_m]))
in
+ [Comment "Match" ;
+ Comment "Compute matched expr"]
+ @
(compile_expr env match_expr)
@
- [Blez (V0, empty_label)]
+ [Comment "Match branching" ;
+ Blez (V0, empty_label) ;
+ Comment "Set when non-empty list"]
@
set_instrs
@
+ [Comment "Compute result (when non-empty list)"]
+ @
(compile_expr env2 result_expr)
@
- [J end_label ;
+ [Comment "Jump towards end of match" ;
+ J end_label ;
+ Comment "Compute result (when empty list)" ;
Label empty_label]
@
(compile_expr env empty_expr)
@
- [Label end_label]
+ [Comment "End-of-match label" ;
+ Label end_label]
| Efunc _ -> failwith "compile_expr : Unreachable matching"
- | Eclos (fname, vars) ->
+ | Eclos (recursive, fname, vars) ->
+ (* i -> référence utilisée par le folder pour la position dans le
+ bloc de la cloture *)
+ (* env : si la fonction est récursive, on ajoute le nom de la
+ fonction à l'environnement avec pour adresse le champ V0,
+ qui contient l'adresse du bloc mémoire de la cloture *)
let i = ref 0
+ and env = if not recursive then env
+ else assign_ident_to_addr env fname (Areg V0)
in
- (malloc ((List.length vars) + 1))
+ [Comment (Printf.sprintf "Closure %s" fname)]
+ @
+ (malloc (4 * ((List.length vars) + 1)))
@
(List.fold_left (fun base ident ->
incr i;
base
@
- (ident_to_reg env ident A0)
+ (ident_to_reg env ident T1)
@
- [Lw (A0, (4 * !i, V0))])
- [La (A0, fname) ;
- Lw (A0, (0, V0))]
+ [Sw (T1, (4 * !i, V0))])
+ [La (T1, fname) ;
+ Sw (T1, (0, V0))]
vars)
and compile_letfuns env = function
- | [] -> [], env
+ | [] -> []
| (fname, fvars, farg, fbody)::l ->
- let letfuns, env = (compile_letfuns env l)
+ let i = ref 0
in
- [Label fname ;
- Addi (SP, SP, -8) ;
- Sw (RA, (4, SP)) ;
- Sw (FP, (0, SP))]
- @
- (compile_expr env fbody)
- @
- [Lw (RA, (4, SP)) ;
- Lw (FP, (0, SP)) ;
- Jr RA]
- @
- letfuns, env
+ let closure_addr, assign_closure_instrs, env2 =
+ push_closure empty_env
+ in
+ let env_folder env ident =
+ incr i;
+ assign_ident_to_addr env
+ ident
+ (Aclosure (4 * !i, closure_addr))
+ in
+ let env2 =
+ List.fold_left env_folder env2 fvars
+ in
+ let assign_instrs, env2 = assign_motif env2 farg
+ in
+ let compiled_body = compile_expr env2 fbody
+ in
+ [Label fname]
+ @
+ (function_header !frame_size)
+ @
+ assign_closure_instrs
+ @
+ [Move (V0, A1)]
+ @
+ assign_instrs
+ @
+ compiled_body
+ @
+ (function_footer !frame_size)
+ @
+ (compile_letfuns env l)
-let header_code =
- print_int_code
- @
+(* Ces deux helpers sont fonctions pour que frame_size ait été calculé
+ au moment de l'écriture de ces blocs de code *)
+let header_code () =
[Label "main" ;
+ Move (FP, SP) ;
Addi (SP, SP, -(!frame_size)) ;
- Addi (FP, SP, !frame_size - 4) ;
Move (T9, RA)]
-and footer_code =
+and footer_code () =
[Move (RA, T9) ;
Addi (SP, SP, !frame_size) ;
Jr (RA)]
-let base_env =
- { empty_env with addrs = Smap.add "print_int"
- (Alab "print_int")
- Smap.empty }
-
-let compile a ofile =
- let a, letfuns = replace_funcs (optimize_ast a)
+(* La fonction-main-hyper-indentée :
+ Prend un argument un ast a, un fichier de sortie ofile et le paramètre
+ verbose assembly
+ Opérations réalisées, dans l'ordre :
+ * détermination des identifiants de l'arbre
+ * détermination des primitives potentiellement utilisées
+ * optimisation de l'ast (effectue les calculs constants, etc)
+ * remplacements des fonctions par des clotures et des letfuns
+ * génération des codes des primitives et création de l'environnement de base
+ * compilation de l'ast et des letfuns
+ * génération du header et du footer du programme, concaténation des diverses
+ listes d'instructions dans le bon ordre
+ * filtrage du programme (sépare les data des instructions)
+ * optimisations éventuelles (factorise les addi consécutifs, par exemple)
+ * suppression éventuelle des commentaires, si "not verbose_assembly"
+ * écriture de l'assembleur dans le fichier ofile
+ Ouf, fini ! *)
+let compile a ofile verbose_assembly =
+ let idents = identifiers a
in
- let compiled_letfuns, env = compile_letfuns base_env letfuns
+ let primitives = in_use_primitives idents
in
- let instructions = header_code
- @ (compile_expr env a)
- @ footer_code
- and f = open_out ofile
+ let a, letfuns = replace_funcs idents (optimize_ast a)
+ and primitives_code, primitives_register_code, env =
+ make_base_env idents primitives
in
- let program = optimize_program (filter_program instructions)
- and fmt = formatter_of_out_channel f
+ let compiled_letfuns, compiled_exprs =
+ (compile_letfuns env letfuns), (compile_expr env a)
+ and f = open_out ofile
in
- format_program fmt program;
- fprintf fmt "@?";
- close_out f
+ let program = (compiled_letfuns @ primitives_code
+ @ (header_code ()) @ primitives_register_code
+ @ compiled_exprs @ (footer_code ()))
+ and fmt = formatter_of_out_channel f
+ in
+ let program = optimize_program (filter_program program)
+ in
+ let program =
+ { program with
+ text = if verbose_assembly then program.text
+ else filter_comments program.text }
+ in
+ format_program fmt program;
+ fprintf fmt "@?";
+ close_out f
diff --git a/main.ml b/main.ml
index e75a2d5..19d636e 100644
--- a/main.ml
+++ b/main.ml
@@ -1,10 +1,16 @@
+(****************************************
+ main.ml - là où tout converge
+ ****************************************)
+
open Format
open Lexing
open Ast
+(* Les options ... *)
let parse_only = ref false
let type_only = ref false
let verbose = ref false
+let verbose_assembly = ref false
let ifile = ref ""
let ifile_length = ref 0
@@ -19,17 +25,21 @@ let options =
" Arrête la compilation après la phase d'analyse sémantique";
"-v", Arg.Set verbose,
" Affiche des informations supplémentaires sur la compilation";
+ "-verbose-assembly", Arg.Set verbose_assembly,
+ " Active les commentaires du code assembleur produit";
"-o", Arg.String (set_file ofile),
"<file> Définit le nom du fichier de sortie)"]
let usage = "Usage: petit-caml [option] file.ml"
+(* Localisation des erreurs venant du parser/lexer *)
let localisation pos =
let l = pos.pos_lnum in
let c = pos.pos_cnum - pos.pos_bol + 1 in
eprintf "File \"%s\", line %d, characters %d-%d:\n" !ifile l (c-1) c
+(* Localisation des erreurs du typeur (informations issues de l'ast) *)
let localisation_expr = function
- | None ->
+ | None -> (* Ce cas ne devrait pas être atteignable, mais bon *)
eprintf "File \"%s\", line 0, characters 0-%d:\n"
!ifile
!ifile_length
@@ -46,7 +56,17 @@ let localisation_expr = function
loc.spos.c
(loc.spos.c + loc.epos.raw_c - loc.epos.raw_c)
-let () =
+(* Le main du compilateur :
+ * Vérification des arguments, du nom du fichier source
+ * Génération éventuelle du nom de fichier de sortie
+ * Ouverture du fichier source
+ * Création d'un tampon d'analyse lexicale (lexbuf)
+ * Lancement de l'analyse syntaxique avec ce lexbuf
+ => arrêt éventuel à cet endroit (si parse-only)
+ * Analyse sémantique
+ => arrêt éventuel à cet endroit (si type-only)
+ * Génération du code et écriture du fichier de sortie *)
+let _ =
Arg.parse options (set_file ifile) usage;
if !ifile = "" then begin
@@ -84,7 +104,7 @@ let () =
if !type_only then exit 0;
- Compile.compile a !ofile
+ Compile.compile a !ofile !verbose_assembly
with
| Lexer.Lexing_error err ->
localisation (Lexing.lexeme_start_p buf);
@@ -98,3 +118,6 @@ let () =
localisation_expr loc;
eprintf "Erreur dans l'analyse sémantique : %s@." err;
exit 1
+ | _ ->
+ eprintf "Erreur du compilateur.";
+ exit 2
diff --git a/mips.ml b/mips.ml
index ee0d046..2b4cee8 100644
--- a/mips.ml
+++ b/mips.ml
@@ -11,7 +11,11 @@ type register =
type label = string
type regaddress = int * register
-type ident_address = Alab of label | Areg of regaddress
+type ident_address =
+ | Alab of label
+ | Areg of register
+ | Amem of regaddress
+ | Aclosure of int * regaddress
type instruction =
| Move of register * register
@@ -40,9 +44,10 @@ type instruction =
| Blez of register * label
| J of label
| Jal of label
- | Jalr of register * register
+ | Jalr of register
| Jr of register
| Syscall
+ | Comment of string
| Label of label
| Asciiz of label * string
| Word of label * int
@@ -164,20 +169,22 @@ let print_instruction fmt = function
fprintf fmt "\tj %s\n" s
| Jal s ->
fprintf fmt "\tjal %s\n" s
- | Jalr (radd, rsave) ->
- fprintf fmt "\tjalr %a, %a\n" print_register radd print_register rsave
+ | Jalr radd ->
+ fprintf fmt "\tjalr %a\n" print_register radd
| Jr r ->
fprintf fmt "\tjr %a\n" print_register r
| Syscall ->
fprintf fmt "\tsyscall\n"
| Label s ->
- fprintf fmt "%s:" s
+ fprintf fmt "%s:\n" s
+ | Comment s ->
+ fprintf fmt "\t# %s\n" s
| Asciiz _
| Word _ -> failwith "Unreachable matching"
let print_data fmt = function
| Asciiz (l, s) ->
- fprintf fmt "%s:\t.asciiz %s\n" l s
+ fprintf fmt "%s:\t.asciiz %S\n" l s
| Word (l, n) ->
fprintf fmt "%s:\t.word %d\n" l n
| _ -> failwith "Unreachable matching"
@@ -186,6 +193,11 @@ type program =
{ text : instruction list ;
data : instruction list }
+let rec filter_comments = function
+ | [] -> []
+ | (Comment c)::l -> filter_comments l
+ | x::l -> x::(filter_comments l)
+
let rec filter_program = function
| [] -> { text = [] ; data = [] }
| (Asciiz (label, s))::l ->
@@ -206,4 +218,3 @@ let format_program fmt p =
List.iter (print_instruction fmt) p.text;
fprintf fmt "\t.data\n";
List.iter (print_data fmt) p.data
-
diff --git a/mipshelpers.ml b/mipshelpers.ml
new file mode 100644
index 0000000..241b6a7
--- /dev/null
+++ b/mipshelpers.ml
@@ -0,0 +1,22 @@
+open Mips
+
+let heap_push n =
+ [Comment (Printf.sprintf "heap_push %d" n) ;
+ Addi (SP, SP, - n)]
+let heap_pop n =
+ [Comment (Printf.sprintf "heap_pop %d" n) ;
+ Addi (SP, SP, n)]
+
+let push reg =
+ [Addi (SP, SP, -4) ;
+ Sw (reg, (0, SP))]
+
+let pop reg =
+ [Lw (reg, (0, SP)) ;
+ Addi (SP, SP, 4)]
+
+let malloc n =
+ [Comment (Printf.sprintf "Malloc %d" n) ;
+ Li (V0, 9) ;
+ Li (A0, n) ;
+ Syscall]
diff --git a/optimize.ml b/optimize.ml
new file mode 100644
index 0000000..5f88ec2
--- /dev/null
+++ b/optimize.ml
@@ -0,0 +1,104 @@
+open Ast
+open Utils
+open Mips
+
+let optimize_binop e1 o e2 =
+ match e1.e, o, e2.e with
+ | (Econst (Cint c1), OAdd, Econst (Cint c2)) ->
+ Econst (Cint (c1 + c2))
+ | (Econst (Cint c1), OSub, Econst (Cint c2)) ->
+ Econst (Cint (c1 - c2))
+ | (Econst (Cint c1), OMul, Econst (Cint c2)) ->
+ Econst (Cint (c1 * c2))
+ | (Econst (Cint c1), ODiv, Econst (Cint c2)) ->
+ Econst (Cint (c1 / c2))
+ | (Econst (Cint c1), OEq, Econst (Cint c2)) ->
+ Econst (Cbool (c1 = c2))
+ | (Econst (Cint c1), ONeq, Econst (Cint c2)) ->
+ Econst (Cbool (c1 <> c2))
+ | (Econst (Cint c1), OLt, Econst (Cint c2)) ->
+ Econst (Cbool (c1 < c2))
+ | (Econst (Cint c1), OLe, Econst (Cint c2)) ->
+ Econst (Cbool (c1 <= c2))
+ | (Econst (Cint c1), OGt, Econst (Cint c2)) ->
+ Econst (Cbool (c1 > c2))
+ | (Econst (Cint c1), OGe, Econst (Cint c2)) ->
+ Econst (Cbool (c1 >= c2))
+ | (Econst (Cbool c1), OAnd, Econst (Cbool c2)) ->
+ Econst (Cbool (c1 && c2))
+ | (Econst (Cbool true), OAnd, e)
+ | (e, OAnd, Econst (Cbool true)) ->
+ e
+ | (Econst (Cbool false), OAnd, e)
+ | (e, OAnd, Econst (Cbool false)) ->
+ Econst (Cbool false)
+ | (Econst (Cbool c1), OOr, Econst (Cbool c2)) ->
+ Econst (Cbool (c1 || c2))
+ | (Econst (Cbool true), OOr, e)
+ | (e, OOr, Econst (Cbool true)) ->
+ Econst (Cbool true)
+ | (Econst (Cbool false), OOr, e)
+ | (e, OOr, Econst (Cbool false)) ->
+ e
+ | _ ->
+ Ebinop (e1, o, e2)
+
+let optimize_unop o e =
+ match o, e.e with
+ | (ONeg, Econst (Cint c)) ->
+ Econst (Cint (-c))
+ | (ONot, Econst (Cbool b)) ->
+ Econst (Cbool (not b))
+ | _ ->
+ Eunop (o, e)
+
+let optimize_if cond_expr then_expr else_expr =
+ match cond_expr.e with
+ | Econst (Cbool true) -> then_expr.e
+ | Econst (Cbool false) -> else_expr.e
+ | _ -> Eif (cond_expr, then_expr, else_expr)
+
+let optimize_match match_expr empty_expr head_m tail_m result_expr =
+ match match_expr.e with
+ | Econst (Cemptylist) -> empty_expr.e
+ | _ -> Ematch (match_expr, empty_expr, head_m, tail_m, result_expr)
+
+let rec optimize_ast expr =
+ let new_e =
+ match expr.e with
+ | Econst _ -> expr.e
+ | Eident _ -> expr.e
+ | Etuple l ->
+ Etuple (List.map optimize_ast l)
+ | Ebinop (e1, o, e2) ->
+ optimize_binop (optimize_ast e1) o (optimize_ast e2)
+ | Eunop (o, e) ->
+ optimize_unop o (optimize_ast e)
+ | Eletin (m, val_expr, in_expr) ->
+ Eletin (m, optimize_ast val_expr, optimize_ast in_expr)
+ | Efunc f ->
+ Efunc {f with body = optimize_ast f.body}
+ | Eif (cond_expr, then_expr, else_expr) ->
+ optimize_if (optimize_ast cond_expr)
+ (optimize_ast then_expr)
+ (optimize_ast else_expr)
+ | Elistcons (e1, e2) ->
+ Elistcons (optimize_ast e1, optimize_ast e2)
+ | Ecall (e1, e2) ->
+ Ecall (optimize_ast e1, optimize_ast e2)
+ | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
+ Ematch (optimize_ast match_expr,
+ optimize_ast empty_expr,
+ head_m,
+ tail_m,
+ optimize_ast result_expr)
+ | Eclos _ -> failwith "optimize_ast : Unreachable matching"
+ in
+ raw_expr new_e
+
+let optimize_program p =
+ let rec optimize_instrs = function
+ | [] -> []
+ | i::l -> i::(optimize_instrs l) (* TODO *)
+ in
+ {p with text = optimize_instrs p.text}
diff --git a/primitives.ml b/primitives.ml
new file mode 100644
index 0000000..2b50c0b
--- /dev/null
+++ b/primitives.ml
@@ -0,0 +1,80 @@
+(****************************************
+ primitives.mli - ... les primitives
+ [o'rly ?]
+ ****************************************)
+
+open Mips
+open Mipshelpers
+open Ast
+
+module Sset = Set.Make(String)
+module Smap = Map.Make(String)
+
+(* Les codes des primitives *)
+let print_int_code =
+ [Move (A0, A1) ;
+ Li (V0, 1) ; (* print_int *)
+ Syscall ;
+ Jr RA]
+
+let print_string_code =
+ [Move (A0, A1) ;
+ Li (V0, 4) ; (* print_string *)
+ Syscall ;
+ Jr RA]
+
+let print_newline_code =
+ [Li (A0, 10) ;
+ Li (V0, 11) ; (* print_char *)
+ Syscall ;
+ Jr RA]
+
+let read_int_code =
+ [Li (V0, 5) ; (* read_int *)
+ Syscall ;
+ Jr RA]
+
+let read_line_code =
+ (malloc 1024)
+ @
+ [Move (A0, V0) ;
+ Li (A1, 1024) ; (* on alloue ici un (gros) buffer
+ une version plus propre aurait été de faire
+ une boucle, accumulant les chars sur la pile
+ jusqu'à trouver un \n, allouant la bonne quantité
+ de mémoire et dépilant les chars ; mais TODO pour
+ l'instant *)
+ Li (V0, 8) ; (* read_string *)
+ Syscall ;
+ Move (V0, A0) ;
+ Jr RA]
+
+(* Le petit helper qui génère le code "d'enregistrement" d'une primitive,
+ code qui sera exécuté au début du main *)
+let primitive_register_code fname =
+ [La (T1, fname)]
+ @
+ (malloc 4)
+ @
+ [Sw (T1, (0, V0))]
+
+(* Petits helpers utiles pour la détermination des primitives utilisées
+ et la génération du code (pour l'assignation de labels non utilisés) *)
+let primitives = [("print_int", print_int_code) ;
+ ("print_string", print_string_code) ;
+ ("print_newline", print_newline_code) ;
+ ("read_int", read_int_code) ;
+ ("read_line", read_line_code)]
+
+let primitives_map, primitives_set =
+ let rec aux = function
+ | [] -> Smap.empty, Sset.empty
+ | (id, code)::l ->
+ let map, set = aux l
+ in
+ Smap.add id code map, Sset.add id set
+ in
+ aux primitives
+
+let in_use_primitives idents =
+ Sset.elements (Sset.inter idents primitives_set)
diff --git a/runtests.py b/runtests.py
index eae5ea4..ae688b7 100644
--- a/runtests.py
+++ b/runtests.py
@@ -2,6 +2,13 @@ import glob
import os
import subprocess
+SPIM_COPYRIGHT_HEADER = '''SPIM Version 7.3. of August 28, 2006
+Copyright 1990-2004 by James R. Larus (larus@cs.wisc.edu).
+All Rights Reserved.
+See the file README for a full copyright notice.
+Loaded: /usr/lib/spim/exceptions.s
+'''
+
def bold(s):
return "\033[1;37m%s\033[0m" % s
@@ -10,7 +17,7 @@ NOTOK = "\033[1;31m!!\033[0m"
def list_tests():
tests = []
- for path in ("lexing", "parsing", "typing"):
+ for path in ("lexing", "parsing", "typing", "assembly"):
tests += glob.glob("tests/%s/*.ml" % path)
return tests
@@ -21,6 +28,15 @@ def run_test(test_file):
expected_return_code = int(lines[1][13])
if expected_return_code != 0:
expected_error = lines[3] + lines[4]
+ base_command = "./petit-caml %s" % test_file
+ test_assembly = False
+ if "lexing" in test_file or "parsing" in test_file:
+ command = base_command + " -parse-only"
+ elif "typing" in test_file:
+ command = base_command + " -type-only"
+ else:
+ test_assembly = True
+ command = base_command
process = subprocess.Popen("./petit-caml %s" % test_file,
stderr = subprocess.PIPE,
shell = True)
@@ -38,6 +54,26 @@ def run_test(test_file):
expected_error.strip())
else:
status = "%s\n%s" % (NOTOK, error.strip())
+ if status == OK and test_assembly:
+ process = subprocess.Popen("spim %s" % test_file.replace(".ml", ".s"),
+ stderr = subprocess.PIPE,
+ stdout = subprocess.PIPE,
+ shell = True)
+ return_code = process.wait()
+ if return_code != 0:
+ error = process.stderr.read()
+ status = "%s\n%s" % (NOTOK, error.strip())
+ i = 3
+ expected_output = ""
+ while not lines[i].startswith("*)"):
+ expected_output += lines[i]
+ i += 1
+ output = process.stdout.read()
+ output = output.replace(SPIM_COPYRIGHT_HEADER, "")
+ if output != expected_output:
+ status = "%s\n%s\n%s\n%s" % (NOTOK, output.strip(),
+ bold("Expected :"),
+ expected_output.strip())
print "%s : %s" % (bold(test_file), status)
def run_tests():
diff --git a/tests/assembly/lists-ops.ml b/tests/assembly/lists-ops.ml
new file mode 100644
index 0000000..0fc5e89
--- /dev/null
+++ b/tests/assembly/lists-ops.ml
@@ -0,0 +1,36 @@
+(*
+ return : 0
+ output :
+123
+4284126
+321
+123
+*)
+let rec iter f l =
+ match l with
+ [] -> ()
+ | x::l ->
+ let _ = f x
+ in
+ iter f l
+let _ = iter print_int [1 ; 2 ; 3]
+let _ = print_newline ()
+let rec map f l =
+ match l with
+ [] -> []
+ | x::l ->
+ (f x)::(map f l)
+let _ = iter print_int (map (function x -> x * 42) [1 ; 2 ; 3])
+let _ = print_newline ()
+let rev_map f l =
+ let rec rev_map_aux acc l =
+ match l with
+ [] -> acc
+ | x::l -> rev_map_aux (f x::acc) l
+ in
+ rev_map_aux [] l
+let rev = rev_map (function x -> x)
+let _ = iter print_int (rev [1 ; 2 ; 3])
+let _ = print_newline ()
+let _ = rev_map print_int [1 ; 2 ; 3] (* Ha-ha :( *)
+let _ = print_newline ()
diff --git a/tests/assembly/lists.ml b/tests/assembly/lists.ml
new file mode 100644
index 0000000..79ab169
--- /dev/null
+++ b/tests/assembly/lists.ml
@@ -0,0 +1,27 @@
+(*
+ return : 0
+ output :
+1
+2
+1 2 3 4
+*)
+let test a =
+ let _ = print_int a
+ in
+ print_newline ()
+let hd l = match l with
+ [] -> 0 | x::l -> x
+let tl l = match l with
+ [] -> [] | x::l -> l
+let _ = test (hd [1 ; 2 ; 3])
+let _ = test (hd (tl [1 ; 2 ; 3]))
+let rec print_list l =
+ match l with
+ [] -> print_newline ()
+ | x::l ->
+ let _ = print_int x
+ in
+ let _ = print_string " "
+ in
+ print_list l
+let _ = print_list [1;2;3;4]
diff --git a/tests/assembly/ops.ml b/tests/assembly/ops.ml
new file mode 100644
index 0000000..a610718
--- /dev/null
+++ b/tests/assembly/ops.ml
@@ -0,0 +1,42 @@
+(*
+ return : 0
+ output :
+-42
+59
+25
+714
+2
+false
+true
+false
+false
+true
+true
+true
+false
+true
+*)
+let test a =
+ let _ = print_int a
+ in
+ print_newline ()
+let test_if b =
+ let _ = print_string (if b then "true" else "false")
+ in
+ print_newline ()
+let x = 42
+let y = 17
+let _ = test (- x)
+let _ = test (x + y)
+let _ = test (x - y)
+let _ = test (x * y)
+let _ = test (x / y)
+let _ = test_if (x <= y)
+let _ = test_if (17 <= 17)
+let _ = test_if (x < y)
+let _ = test_if (17 < 17)
+let _ = test_if (x >= y)
+let _ = test_if (17 >= 17)
+let _ = test_if (x > y)
+let _ = test_if (17 > 17)
+let _ = test_if (not (17 > 17))
diff --git a/tests/assembly/primitives.ml b/tests/assembly/primitives.ml
new file mode 100644
index 0000000..a182479
--- /dev/null
+++ b/tests/assembly/primitives.ml
@@ -0,0 +1,9 @@
+(*
+ return : 0
+ output :
+4242 blah blah \\ \\
+ " prout prout\"
+*)
+let _ = print_int 42
+let _ = print_string "42 blah blah \\ \\ \n \" prout prout\\"
+let _ = print_newline ()
diff --git a/tests/assembly/recursive.ml b/tests/assembly/recursive.ml
new file mode 100644
index 0000000..23e8e49
--- /dev/null
+++ b/tests/assembly/recursive.ml
@@ -0,0 +1,24 @@
+(*
+ return : 0
+ output :
+24
+89
+61
+*)
+let test a =
+ let _ = print_int a
+ in
+ print_newline ()
+let rec fact n =
+ if n = 1 then 1
+ else n * (fact (n - 1))
+let _ = test (fact 4)
+let rec fib n =
+ if n <= 1 then 1
+ else (fib (n - 1)) + (fib (n - 2))
+let _ = test (fib 10)
+let rec ack m n =
+ if m = 0 then n + 1
+ else if n = 0 then ack (m - 1) 1
+ else ack (m - 1) (ack m (n - 1))
+let _ = test (ack 3 3)
diff --git a/tests/assembly/redefine-primitive.ml b/tests/assembly/redefine-primitive.ml
new file mode 100644
index 0000000..5c6686d
--- /dev/null
+++ b/tests/assembly/redefine-primitive.ml
@@ -0,0 +1,9 @@
+(*
+ return : 0
+ output :
+84
+*)
+let print_int a =
+ print_int (a + 42)
+let _ = print_int 42
+let _ = print_newline ()
diff --git a/tests/assembly/tuples.ml b/tests/assembly/tuples.ml
new file mode 100644
index 0000000..1ae17e1
--- /dev/null
+++ b/tests/assembly/tuples.ml
@@ -0,0 +1,15 @@
+(*
+ return : 0
+ output :
+42
+17
+*)
+let test a =
+ let _ = print_int a
+ in
+ print_newline ()
+let fst (a, _) = a
+let snd (_, b) = b
+let t = (42, 17)
+let _ = test (fst t)
+let _ = test (snd t)
diff --git a/tests/assembly/vicious.ml b/tests/assembly/vicious.ml
new file mode 100644
index 0000000..ccb3edd
--- /dev/null
+++ b/tests/assembly/vicious.ml
@@ -0,0 +1,14 @@
+(*
+ return : 0
+ output :
+42
+42!
+*)
+let test a =
+ let _ = print_int a
+ in
+ print_newline ()
+let test_string = print_string
+let rec x x = x
+let _ = test (x 42)
+let _ = test_string (x "42!\n")
diff --git a/tests/typing/base-fail.ml b/tests/typing/base-fail.ml
index a0427bc..d10d25b 100644
--- a/tests/typing/base-fail.ml
+++ b/tests/typing/base-fail.ml
@@ -2,6 +2,6 @@
return : 1
output :
File "tests/typing/base-fail.ml", line 7, characters 8-14:
-Erreur dans l'analyse sémantique : Cette expression a le type int * int mais est ici utilisée avec le type int
+Erreur dans l'analyse sémantique : Cette expression a le type (int * int) mais est ici utilisée avec le type int
*)
let _ = (1, 2) + 3
diff --git a/tests/typing/match-fail3.ml b/tests/typing/match-fail3.ml
new file mode 100644
index 0000000..f2a7070
--- /dev/null
+++ b/tests/typing/match-fail3.ml
@@ -0,0 +1,9 @@
+(*
+ return : 1
+ output :
+File "tests/typing/match-fail3.ml", line 8, characters 4-27:
+Erreur dans l'analyse sémantique : Variable a non unique dans ce motif
+*)
+let rec h l =
+ match l with
+ [] -> 0 | a::a -> a
diff --git a/typing.ml b/typing.ml
index 23fece0..13598d4 100644
--- a/typing.ml
+++ b/typing.ml
@@ -35,12 +35,14 @@ let canon_string t tvar_names =
| Tunit -> "unit"
| Tbool -> "bool"
| Tarrow (t1, t2) ->
- Printf.sprintf "%s -> %s" (canon_aux t1) (canon_aux t2)
+ Printf.sprintf "(%s -> %s)" (canon_aux t1) (canon_aux t2)
| Tproduct (t::l) ->
- List.fold_left (fun base t ->
- Printf.sprintf "%s * %s" base (canon_aux t))
- (canon_aux t)
- l
+ Printf.sprintf "(%s)"
+ (List.fold_left (fun base t ->
+ Printf.sprintf "%s * %s"
+ base (canon_aux t))
+ (canon_aux t)
+ l)
| Tproduct _ -> failwith "canon_aux : Unreachable matching"
| Tlist t ->
Printf.sprintf "%s list" (canon_aux t)
@@ -163,12 +165,21 @@ let add ident t env =
{ bindings = Smap.add ident { vars = Vset.empty ; typ = t } env.bindings;
fvars = Vset.union env.fvars (fvars t) }
+let verify_fvars_folder tv current =
+ match head (Tvar tv) with
+ | Tvar tv -> Vset.add tv current
+ | _ -> current
+
let add_gen ident t env =
- let binding_vars = Vset.diff (fvars t) env.fvars
+ let envfvars =
+ Vset.fold verify_fvars_folder env.fvars Vset.empty
in
- { env with bindings = Smap.add ident
- { vars = binding_vars ; typ = t }
- env.bindings }
+ let binding_vars = Vset.diff (fvars t) envfvars
+ in
+ { bindings = Smap.add ident
+ { vars = binding_vars ; typ = t }
+ env.bindings ;
+ fvars = envfvars }
let rec replace_var orig new_tv = function
| Tarrow (t1, t2) ->
@@ -184,7 +195,9 @@ let rec replace_var orig new_tv = function
| t -> t
let use_freshvar tv t =
- replace_var tv.id (Tvar (V.create())) t
+ match head (Tvar tv) with
+ | Tvar tv -> replace_var tv.id (Tvar (V.create())) t
+ | _ -> t
let find ident env =
let binding = Smap.find ident env.bindings
@@ -304,16 +317,16 @@ let rec w env e =
let arg_t = w_motif f.arg
and return_t = Tvar (V.create ())
in
- let env2 = add_motif env f.arg arg_t
+ let env2 =
+ let fname = match f.name with
+ | Some name -> name
+ | None -> failwith "w : Unreachable matching"
+ in
+ add fname (Tarrow (arg_t, return_t)) env
in
- let env3 =
- let fname = match f.name with
- | Some name -> name
- | None -> failwith "w : Unreachable matching"
- in
- add fname (Tarrow (arg_t, return_t)) env2
+ let env2 = add_motif env2 f.arg arg_t
in
- unify f.body.loc (w env3 f.body) return_t;
+ unify f.body.loc (w env2 f.body) return_t;
Tarrow (arg_t, return_t)
| Eif (cond, then_expr, else_expr) ->
let cond_t = w env cond
@@ -339,9 +352,10 @@ let rec w env e =
| Ematch (match_expr, empty_expr, head_m, tail_m, expr) ->
let match_t = w env match_expr
and empty_t = w env empty_expr
- and alpha_t = Tvar (V.create ())
+ and head_t = w_motif head_m
+ and tail_t = w_motif tail_m
in
- unify match_expr.loc match_t (Tlist alpha_t);
+ unify match_expr.loc match_t (Tlist head_t);
let vars_base =
match tail_m.m with
| Mtuple _ ->
@@ -350,21 +364,17 @@ let rec w env e =
liste"
| Mident ident -> Sset.singleton ident
| Munderscore -> Sset.empty
- and head_t = w_motif head_m
in
- let tail_t = w_motif tail_m
+ unify match_expr.loc tail_t (Tlist head_t);
+ let env2 = add_motif (add_motif env head_m head_t)
+ tail_m
+ tail_t
+ and _ = motif_vars e.loc vars_base head_m
in
- let env2 = add_motif_gen (add_motif_gen env
- head_m
- head_t)
- tail_m
- tail_t
- and _ = motif_vars e.loc vars_base head_m
+ let result_t = w env2 expr
in
- let result_t = w env2 expr
- in
- unify expr.loc result_t empty_t;
- result_t
+ unify expr.loc result_t empty_t;
+ result_t
| Eclos _ -> failwith "w : Unreachable matching"
in
let t = w_aux e
diff --git a/utils.ml b/utils.ml
index ccdbd63..8b727a2 100644
--- a/utils.ml
+++ b/utils.ml
@@ -178,3 +178,24 @@ let make_func id recur fbody = function
recursive = recur <> None ;
arg = arg ;
body = body }
+
+let rec identifiers expr =
+ match expr.e with
+ | Econst _ -> Sset.empty
+ | Eident id -> Sset.singleton id
+ | Etuple l -> List.fold_left (fun base e ->
+ Sset.union base (identifiers e))
+ Sset.empty l
+ | Ebinop (e1, _, e2)
+ | Elistcons (e1, e2)
+ | Ecall (e1, e2)
+ | Eletin (_, e1, e2) ->
+ Sset.union (identifiers e1) (identifiers e2)
+ | Eunop (_, e) -> identifiers e
+ | Eif (e1, e2, e3)
+ | Ematch (e1, e2, _, _, e3) ->
+ Sset.union (Sset.union (identifiers e1) (identifiers e2))
+ (identifiers e3)
+ | Efunc f -> identifiers f.body
+ | Eclos _ -> failwith "Unreachable matching"
+