amelioration de let rec

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5252 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -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).
 

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 *)
 

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]) ->

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

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)";;

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"