diff options
| -rw-r--r-- | Changes | 5 | ||||
| -rw-r--r-- | asmcomp/cmmgen.ml | 39 | ||||
| -rw-r--r-- | bytecomp/bytegen.ml | 32 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 13 | ||||
| -rw-r--r-- | stdlib/sys.ml | 2 | ||||
| -rw-r--r-- | test/Moretest/recvalues.ml | 16 |
6 files changed, 70 insertions, 37 deletions
@@ -1,3 +1,8 @@ +- Enhanced the compilation of recursive values: "let rec" is now + less restrictive. + +- Additions to the Arg module: Set_*, Symbol + - Match_failure and Assert_failure now report (file, line, column), instead of (file, starting char, ending char). diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index e49463632..788016a2d 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -317,21 +317,24 @@ let fundecls_size fundecls = fundecls; !sz +type rhs_kind = + | RHS_block of int + | RHS_nonrec +;; let rec expr_size = function - Uclosure(fundecls, clos_vars) -> - fundecls_size fundecls + List.length clos_vars - | Uprim(Pmakeblock(tag, mut), args) -> - List.length args - | Uprim(Pmakearray(Paddrarray | Pintarray), args) -> - List.length args + | Uclosure(fundecls, clos_vars) -> + RHS_block (fundecls_size fundecls + List.length clos_vars) | Ulet(id, exp, body) -> expr_size body | Uletrec(bindings, body) -> expr_size body + | Uprim(Pmakeblock(tag, mut), args) -> + RHS_block (List.length args) + | Uprim(Pmakearray(Paddrarray | Pintarray), args) -> + RHS_block (List.length args) | Usequence(exp, exp') -> expr_size exp' - | _ -> - fatal_error "Cmmgen.expr_size" + | _ -> RHS_nonrec (* Record application and currying functions *) @@ -1411,21 +1414,25 @@ and transl_switch arg index cases = match Array.length cases with (fun i -> Cconst_int i) a (Array.of_list !inters) actions) - + and transl_letrec bindings cont = + let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in let rec init_blocks = function - [] -> fill_blocks bindings - | (id, exp) :: rem -> - Clet(id, Cop(Cextcall("alloc_dummy", typ_addr, true), - [int_const(expr_size exp)]), + | [] -> fill_blocks bsz + | (id, exp, RHS_block sz) :: rem -> + Clet(id, Cop(Cextcall("alloc_dummy", typ_addr, true), [int_const sz]), init_blocks rem) + | (id, exp, RHS_nonrec) :: rem -> + Clet (id, transl exp, init_blocks rem) and fill_blocks = function - [] -> cont - | (id, exp) :: rem -> + | [] -> cont + | (id, exp, RHS_block _) :: rem -> Csequence(Cop(Cextcall("update_dummy", typ_void, false), [Cvar id; transl exp]), fill_blocks rem) - in init_blocks bindings + | (id, exp, RHS_nonrec) :: rem -> + fill_blocks rem + in init_blocks bsz (* Translate a function definition *) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index c42ccf9a5..674b5293b 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -126,16 +126,20 @@ let rec push_dummies n k = match n with (**** Auxiliary for compiling "let rec" ****) +type rhs_kind = + | RHS_block of int + | RHS_nonrec +;; let rec size_of_lambda = function | Lfunction(kind, params, body) as funct -> - 1 + IdentSet.cardinal(free_variables funct) - | Lprim(Pmakeblock(tag, mut), args) -> List.length args - | Lprim(Pmakearray kind, args) -> List.length args + RHS_block (1 + IdentSet.cardinal(free_variables funct)) | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body + | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) + | Lprim(Pmakearray kind, args) -> RHS_block (List.length args) | Levent (lam, _) -> size_of_lambda lam | Lsequence (lam, lam') -> size_of_lambda lam' - | _ -> fatal_error "Bytegen.size_of_lambda" + | _ -> RHS_nonrec (**** Merging consecutive events ****) @@ -460,19 +464,27 @@ let rec comp_expr env exp sz cont = let decl_size = List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in let rec comp_decl new_env sz i = function - [] -> + | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, blocksize) :: rem -> + | (id, exp, RHS_block blocksize) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("update_dummy", 2) :: - comp_decl new_env sz (i-1) rem) in + comp_decl new_env sz (i-1) rem) + | (id, exp, RHS_nonrec) :: rem -> + comp_decl new_env sz (i-1) rem + in let rec comp_init new_env sz = function - [] -> + | [] -> comp_decl new_env sz ndecl decl_size - | (id, exp, blocksize) :: rem -> + | (id, exp, RHS_block blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("alloc_dummy", 1) :: Kpush :: - comp_init (add_var id (sz+1) new_env) (sz+1) rem in + comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, exp, RHS_nonrec) :: rem -> + comp_expr new_env exp sz + (Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem) + in comp_init env sz decl_size end | Lprim(Pidentity, [arg]) -> diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index cfecdabfe..cc2c0038f 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -299,23 +299,19 @@ let transl_primitive p = let check_recursive_lambda idlist lam = let rec check_top idlist = function - Lfunction(kind, params, body) as funct -> true - | Lprim(Pmakeblock(tag, mut), args) -> - List.for_all (check idlist) args - | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> - List.for_all (check idlist) args + | Lvar v -> not (List.mem v idlist) | Llet(str, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in List.for_all (fun (id, arg) -> check idlist' arg) bindings && check_top idlist' body + | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 | Levent (lam, _) -> check_top idlist lam - | _ -> false + | lam -> check idlist lam and check idlist = function - Lvar _ -> true - | Lconst cst -> true + | Lvar _ -> true | Lfunction(kind, params, body) -> true | Llet(str, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body @@ -327,6 +323,7 @@ let check_recursive_lambda idlist lam = List.for_all (check idlist) args | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all (check idlist) args + | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 | Levent (lam, _) -> check idlist lam | lam -> let fv = free_variables lam in diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 14e0e82c1..72332c228 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -77,4 +77,4 @@ let catch_break on = (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.06+17 (2002-11-07)";; +let ocaml_version = "3.06+18 (2002-11-07)";; diff --git a/test/Moretest/recvalues.ml b/test/Moretest/recvalues.ml index f2b88923c..c00ced827 100644 --- a/test/Moretest/recvalues.ml +++ b/test/Moretest/recvalues.ml @@ -16,11 +16,23 @@ let _ = else print_string "Test 2: FAILED\n"; let rec z = (Gc.minor(); (one, one+1)) :: z in (* Trash the minor generation *) - for i = 0 to 50000 do ref 0 done; + for i = 0 to 50000 do ignore (ref 0) done; if match z with (1,2) :: z' -> z == z' | _ -> false then print_string "Test 3: passed\n" else print_string "Test 3: FAILED\n"; - exit 0 +;; +let rec s = "bar" +and idx = 1 +and x1 = let f x = Printf.printf "%s\n" x in f "foo"; s, x4 +and x2 = [| x1; x1 |] +and x3 = (fun () -> fst (x2.(idx))) :: x3 +and x4 = {contents = x3} +;; + +Gc.minor ();; +if (List.hd (!(snd (x2.(0))))) () == s +then print_string "Test 4: passed\n" +else print_string "Test 4: FAILED\n" |