Implement Lazy.force as a primitive, and optimize its calls.

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

15 files changed, 219 insertions, 65 deletions

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 77ac32e4a..1422401d6 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -29,6 +29,8 @@ type primitive =
   | Pfloatfield of int
   | Psetfloatfield of int
   | Pduprecord of Types.record_representation * int
+  (* Force lazy values *)
+  | Plazyforce
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 2f6896678..46a2cf012 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -29,6 +29,8 @@ type primitive =
   | Pfloatfield of int
   | Psetfloatfield of int
   | Pduprecord of Types.record_representation * int
+  (* Force lazy values *)
+  | Plazyforce
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 261318d3d..0addf7e37 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1309,30 +1309,100 @@ let matcher_lazy p rem = match p.pat_desc with
 | Tpat_var _          -> get_arg_lazy omega rem
 | _                   -> get_arg_lazy p rem
 
+(* Inlining the tag tests before calling the primitive that works on
+   lazy blocks. This is alse used in translcore.ml.
+   No call other than Obj.tag when the value has been forced before.
+*)
 
-(* Compute lazily the lambda-code of Lazy.force *)
+let prim_obj_tag =
+  {prim_name = "caml_obj_tag";
+   prim_arity = 1; prim_alloc = false;
+   prim_native_name = "";
+   prim_native_float = false}
 
-let lambda_of_force =
+let get_mod_field modname field =
   lazy (
-    let lazy_mod_ident = Ident.create_persistent "Lazy" in
-    let lazy_env = Env.open_pers_signature "Lazy" Env.initial in
-    let p = try
-      match Env.lookup_value (Longident.Lident "force") lazy_env with
-      | (Path.Pdot(_,_,i), _) -> i
-      | _ -> assert false
-    with Not_found -> assert false
-    in
-    Lprim(Pfield p, [Lprim(Pgetglobal lazy_mod_ident, [])])
+    try
+      let mod_ident = Ident.create_persistent modname in
+      let env = Env.open_pers_signature modname Env.initial in
+      let p = try
+        match Env.lookup_value (Longident.Lident field) env with
+        | (Path.Pdot(_,_,i), _) -> i
+        | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
+      with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.")
+      in
+      Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
+    with Not_found -> fatal_error ("Module "^modname^" unavailable.")
   )
 
+let code_force_lazy_block =
+  get_mod_field "CamlinternalLazy" "force_lazy_block"
+;;
+
+(* inline_lazy_force inlines the beginning of the code of Lazy.force. When
+   the value argument is tagged as:
+   - forward, take field 0
+   - lazy, call the primitive that forces (without testing again the tag)
+   - anything else, return it
+
+   Using Lswitch below relies on the fact that the GC does not shortcut
+   Forward(val_out_of_heap).
+*)
+
+let inline_lazy_force_cond arg loc =
+  let idarg = Ident.create "lzarg" in
+  let varg = Lvar idarg in
+  let tag = Ident.create "tag" in
+  let force_fun = Lazy.force code_force_lazy_block in
+  Llet(Strict, idarg, arg,
+       Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]),
+            Lifthenelse(
+              (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
+              Lprim(Pintcomp Ceq,
+                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
+              Lprim(Pfield 0, [varg]),
+              Lifthenelse(
+                (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
+                Lprim(Pintcomp Ceq,
+                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
+                Lapply(force_fun, [varg], loc),
+                (* ... arg *)
+                  varg))))
+
+let inline_lazy_force_switch arg loc =
+  let idarg = Ident.create "lzarg" in
+  let varg = Lvar idarg in
+  let force_fun = Lazy.force code_force_lazy_block in
+  Llet(Strict, idarg, arg,
+       Lifthenelse(
+         Lprim(Pisint, [varg]), varg,
+         (Lswitch
+            (varg,
+             { sw_numconsts = 0; sw_consts = [];   
+               sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
+               sw_blocks =
+                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
+                   (Obj.lazy_tag,
+                    Lapply(force_fun, [varg], loc)) ];
+               sw_failaction = Some varg } ))))
+
+let inline_lazy_force =
+  if !Clflags.native_code then
+    (* Lswitch generates compact and efficient native code *)
+    inline_lazy_force_switch
+  else
+    (* generating bytecode: Lswitch would generate too many rather big
+       tables (~ 250 elts); conditionals are better *)
+    inline_lazy_force_cond
+
 let make_lazy_matching def = function
     [] -> fatal_error "Matching.make_lazy_matching"
   | (arg,mut) :: argl ->
       { cases = [];
-        args = (Lapply(Lazy.force lambda_of_force, [arg], Location.none),
-                Strict) :: argl;
+        args =
+          (inline_lazy_force arg Location.none, Strict) :: argl;
         default = make_default matcher_lazy def }
-    
+
 let divide_lazy p ctx pm =
   divide_line
     (filter_ctx p)
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index acbcd6ff8..ebfed8410 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -39,3 +39,5 @@ val flatten_pattern: int -> pattern -> pattern list
 val make_test_sequence:
         lambda option -> primitive -> primitive -> lambda ->
         (Asttypes.constant * lambda) list -> lambda
+
+val inline_lazy_force : lambda -> Location.t -> lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 80cc7d3f6..0d6e19148 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -103,6 +103,7 @@ let primitive ppf = function
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
   | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
+  | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Praise -> fprintf ppf "raise"
   | Psequand -> fprintf ppf "&&"
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 2fa3af40f..a3edc117e 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -202,6 +202,7 @@ let primitives_table = create_hashtable 57 [
   "%obj_field", Parrayrefu Pgenarray;
   "%obj_set_field", Parraysetu Pgenarray;
   "%obj_is_int", Pisint;
+  "%lazy_force", Plazyforce;
   "%nativeint_of_int", Pbintofint Pnativeint;
   "%nativeint_to_int", Pintofbint Pnativeint;
   "%nativeint_neg", Pnegbint Pnativeint;
@@ -351,10 +352,15 @@ let transl_primitive p =
       Hashtbl.find primitives_table p.prim_name
     with Not_found ->
       Pccall p in
-  let rec make_params n =
-    if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
-  let params = make_params p.prim_arity in
-  Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
+  match prim with
+    Plazyforce ->
+      let parm = Ident.create "prim" in
+      Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none)
+  | _ ->
+      let rec make_params n =
+        if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
+      let params = make_params p.prim_arity in
+      Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
 
 (* To check the well-formedness of r.h.s. of "let rec" definitions *)
 
@@ -584,10 +590,10 @@ and transl_exp0 e =
             transl_function e.exp_loc !Clflags.native_code repr partial pl)
       in
       Lfunction(kind, params, body)
-  | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
-    when List.length args >= p.prim_arity
-    && List.for_all (fun (arg,_) -> arg <> None) args ->
-      let args, args' = cut p.prim_arity args in
+  | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs)
+    when List.length oargs >= p.prim_arity
+    && List.for_all (fun (arg,_) -> arg <> None) oargs ->
+      let args, args' = cut p.prim_arity oargs in
       let wrap f =
         if args' = []
         then event_after e f
@@ -613,8 +619,13 @@ and transl_exp0 e =
           (Praise, [arg1]) ->
             wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
         | (_, _) ->
-            let p = Lprim(prim, argl) in
-            if primitive_is_ccall prim then wrap p else wrap0 p
+            begin match (prim, argl) with
+            | (Plazyforce, [a]) ->
+                wrap (Matching.inline_lazy_force a e.exp_loc)
+            | (Plazyforce, _) -> assert false
+            |_ -> let p = Lprim(prim, argl) in
+               if primitive_is_ccall prim then wrap p else wrap0 p
+            end
       end
   | Texp_apply(funct, oargs) ->
       event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index b0ad09945..6a060ba18 100644
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -34,13 +34,14 @@ LIB_OBJS=pervasives.cmo \
   $(LIB)/nativeint.cmo \
   $(LIB)/lexing.cmo $(LIB)/parsing.cmo \
   $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \
+  $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo \
   $(LIB)/stream.cmo $(LIB)/buffer.cmo \
   $(LIB)/printf.cmo $(LIB)/format.cmo \
   $(LIB)/scanf.cmo $(LIB)/arg.cmo \
   $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \
   $(LIB)/camlinternalOO.cmo $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo \
   $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \
-  $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \
+  $(LIB)/filename.cmo $(LIB)/complex.cmo \
   $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \
   $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo
 
diff --git a/stdlib/.depend b/stdlib/.depend
index fc51ab117..a45db17de 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,3 +1,4 @@
+camlinternalLazy.cmi: obj.cmi 
 camlinternalMod.cmi: obj.cmi 
 camlinternalOO.cmi: obj.cmi 
 format.cmi: buffer.cmi 
@@ -18,6 +19,7 @@ buffer.cmo: sys.cmi string.cmi buffer.cmi
 buffer.cmx: sys.cmx string.cmx buffer.cmi 
 callback.cmo: obj.cmi callback.cmi 
 callback.cmx: obj.cmx callback.cmi 
+camlinternalLazy.cmo: camlinternalLazy.cmi
 camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi 
 camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi 
 camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
@@ -46,8 +48,8 @@ int32.cmo: pervasives.cmi int32.cmi
 int32.cmx: pervasives.cmx int32.cmi 
 int64.cmo: pervasives.cmi int64.cmi 
 int64.cmx: pervasives.cmx int64.cmi 
-lazy.cmo: obj.cmi lazy.cmi 
-lazy.cmx: obj.cmx lazy.cmi 
+lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi 
+lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi 
 lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi 
 lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi 
 list.cmo: list.cmi 
diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 02a986238..2440f1b9a 100755
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -28,8 +28,9 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
   hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
   int32.cmo int64.cmo nativeint.cmo \
   lexing.cmo parsing.cmo \
-  set.cmo map.cmo stack.cmo queue.cmo lazy.cmo stream.cmo buffer.cmo \
-  printf.cmo format.cmo scanf.cmo \
+  set.cmo map.cmo stack.cmo queue.cmo \
+  camlinternalLazy.cmo lazy.cmo stream.cmo \
+  buffer.cmo printf.cmo format.cmo scanf.cmo \
   arg.cmo printexc.cmo gc.cmo \
   digest.cmo random.cmo callback.cmo \
   camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index f9fec2d96..4f689f8c4 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -8,6 +8,7 @@ STDLIB_MODULES=\
   arrayLabels \
   buffer \
   callback \
+  camlinternalLazy \
   camlinternalMod \
   camlinternalOO \
   char \
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
new file mode 100644
index 000000000..46cf42788
--- /dev/null
+++ b/stdlib/camlinternalLazy.ml
@@ -0,0 +1,64 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Internals of forcing lazy values. *)
+
+exception Undefined;;
+
+let raise_undefined = Obj.repr (fun () -> raise Undefined);;
+
+(* Assume [blk] is a block with tag lazy *)
+let force_lazy_block (blk : 'arg lazy_t) =
+  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
+  Obj.set_field (Obj.repr blk) 0 raise_undefined;
+  try
+    let result = closure () in
+    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+    Obj.set_tag (Obj.repr blk) Obj.forward_tag;
+    result
+  with e ->
+    Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
+    raise e
+;;
+
+(* Assume [blk] is a block with tag lazy *)
+let force_val_lazy_block (blk : 'arg lazy_t) =
+  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
+  Obj.set_field (Obj.repr blk) 0 raise_undefined;
+  let result = closure () in
+  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+  Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
+  result
+;;
+
+(* [force] is not used, since [Lazy.force] is declared as a primitive
+   whose code inlines the tag tests of its argument.  This function is
+   here for the sake of completeness, and for debugging purpose. *)
+
+let force (lzv : 'arg lazy_t) =
+  let x = Obj.repr lzv in
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
+  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else force_lazy_block lzv
+;;
+
+let force_val (lzv : 'arg lazy_t) =
+  let x = Obj.repr lzv in
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
+  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else force_val_lazy_block lzv
+;;
diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
new file mode 100644
index 000000000..37b707d4f
--- /dev/null
+++ b/stdlib/camlinternalLazy.mli
@@ -0,0 +1,25 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Internals of forcing lazy values *)
+
+exception Undefined;;
+
+val force_lazy_block : 'a lazy_t -> 'a ;;
+
+val force_val_lazy_block : 'a lazy_t -> 'a ;;
+
+val force : 'a lazy_t -> 'a ;;
+val force_val : 'a lazy_t -> 'a ;;
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index 70acccd10..b1a9cbbda 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -46,46 +46,16 @@
 *)
 
 type 'a t = 'a lazy_t;;
-exception Undefined;;
 
-let raise_undefined = Obj.repr (fun () -> raise Undefined);;
+exception Undefined = CamlinternalLazy.Undefined;;
 
-external follow_forward : Obj.t -> 'a = "caml_lazy_follow_forward";;
 external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";;
 
-let force (l : 'arg t) =
-  let x = Obj.repr l in
-  let t = Obj.tag x in
-  if t = Obj.forward_tag then (follow_forward x : 'arg)
-  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
-  else begin
-    let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
-    Obj.set_field x 0 raise_undefined;
-    try
-      let result = closure () in
-      Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
-      Obj.set_tag x Obj.forward_tag;
-      result
-    with e ->
-      Obj.set_field x 0 (Obj.repr (fun () -> raise e));
-      raise e
-  end
-;;
+external force : 'a t -> 'a = "%lazy_force";;
 
-let force_val (l : 'arg t) =
-  let x = Obj.repr l in
-  let t = Obj.tag x in
-  if t = Obj.forward_tag then (follow_forward x : 'arg)
-  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
-  else begin
-    let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
-    Obj.set_field x 0 raise_undefined;
-    let result = closure () in
-    Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
-    Obj.set_tag x (Obj.forward_tag);
-    result
-  end
-;;
+(* let force = force;; *)
+
+let force_val = CamlinternalLazy.force_val;;
 
 let lazy_from_fun (f : unit -> 'arg) =
   let x = Obj.new_block Obj.lazy_tag 1 in
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
index afdb1e6d1..f0255c224 100644
--- a/stdlib/lazy.mli
+++ b/stdlib/lazy.mli
@@ -39,7 +39,8 @@ type 'a t = 'a lazy_t;;
 
 exception Undefined;;
 
-val force : 'a t -> 'a;;
+external force : 'a t -> 'a = "%lazy_force";;
+(* val force : 'a t -> 'a ;; *)
 (** [force x] forces the suspension [x] and returns its result.
    If [x] has already been forced, [Lazy.force x] returns the
    same value again without recomputing it.  If it raised an exception,
diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib
index b3c6924f5..9f835c6fa 100644
--- a/stdlib/stdlib.mllib
+++ b/stdlib/stdlib.mllib
@@ -8,6 +8,7 @@ Array
 ArrayLabels
 Buffer
 Callback
+CamlinternalLazy
 CamlinternalMod
 CamlinternalOO
 Char