lazy a la Tolmach

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

bytecomp/translcore.ml

@@ -452,6 +452,7 @@ let rec transl_exp e =
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
       transl_path path
+  | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
   | Texp_constant cst ->
       Lconst(Const_base cst)
   | Texp_let(rec_flag, pat_expr_list, body) ->
@@ -525,6 +526,7 @@ let rec transl_exp e =
       end
   | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
       transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
+  | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record"
   | Texp_field(arg, lbl) ->
       let access =
         match lbl.lbl_repres with
@@ -607,8 +609,9 @@ let rec transl_exp e =
       then lambda_unit
       else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
   | Texp_assertfalse -> assert_failed e.exp_loc
-  | _ ->
-      fatal_error "Translcore.transl"
+  | Texp_lazy e ->
+      let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
+      Lprim(Pmakeblock(Obj.lazy_tag, Immutable), [fn])
 
 and transl_list expr_list =
   List.map transl_exp expr_list

byterun/compare.c

@@ -84,6 +84,8 @@ static long compare_val(value v1, value v2)
 
   sp = compare_stack;
   while (1) {
+    while (Is_block (v1) && Tag_val (v1) == Forward_tag) v1 = Forward_val (v1);
+    while (Is_block (v2) && Tag_val (v2) == Forward_tag) v2 = Forward_val (v2);
     if (v1 == v2) goto next_item;
     if (Is_long(v1)) {
       if (Is_long(v2))

byterun/extern.c

@@ -317,6 +317,9 @@ static void extern_rec(value v)
       writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
       extern_rec(v - Infix_offset_hd(hd));
       break;
+    case Forward_tag:
+      v = Forward_val (v);
+      goto tailcall;
     case Object_tag:
       extern_invalid_argument("output_value: object value");
       break;

byterun/hash.c

@@ -49,6 +49,7 @@ static void hash_aux(value obj)
   hash_univ_limit--;
   if (hash_univ_count < 0 || hash_univ_limit < 0) return;
 
+ again:
   if (Is_long(obj)) {
     hash_univ_count--;
     Combine(Long_val(obj));
@@ -57,7 +58,8 @@ static void hash_aux(value obj)
 
   /* Pointers into the heap are well-structured blocks. So are atoms.
      We can inspect the block contents. */
-  
+
+  Assert (Is_block (obj));  
   if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
     tag = Tag_val(obj);
     switch (tag) {
@@ -104,6 +106,9 @@ static void hash_aux(value obj)
     case Infix_tag:
       hash_aux(obj - Infix_offset_val(obj));
       break;
+    case Forward_tag:
+      obj = Forward_val (obj);
+      goto again;
     case Object_tag:
       hash_univ_count--;
       Combine(Oid_val(obj));

byterun/major_gc.c

@@ -119,8 +119,14 @@ static void mark_slice (long work)
       if (Tag_hd (hd) < No_scan_tag){
         for (i = 0; i < size; i++){
           child = Field (v, i);
+        again:
           if (Is_block (child) && Is_in_heap (child)) {
             hd = Hd_val(child);
+            if (Tag_hd (hd) == Forward_tag){
+              child = Forward_val (child);
+              Field (v, i) = child;
+              goto again;
+            }
             if (Tag_hd(hd) == Infix_tag) {
               child -= Infix_offset_val(child);
               hd = Hd_val(child);

byterun/major_gc.h

@@ -58,7 +58,8 @@ extern char *gc_sweep_hp;
 #define Not_in_heap 0
 #define Page(p) ((unsigned long) (p) >> Page_log)
 #define Is_in_heap(p) \
-  ((addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
+  (Assert (Is_block (p)), \
+   (addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
    && page_table [Page (p)])
 
 void init_major_heap (asize_t);

byterun/minor_gc.c

@@ -69,6 +69,9 @@ void set_minor_heap_size (asize_t size)
 
 static value oldify_todo_list = NULL;
 
+/* Note that the tests on the tag depend on the fact that Infix_tag,
+   Forward_tag, and No_scan_tag are contiguous. */
+
 void oldify_one (value v, value *p)
 {
   value result, field0;
@@ -84,18 +87,7 @@ void oldify_one (value v, value *p)
       *p = Field (v, 0);  /*  then forward pointer is first field. */
     }else{
       tag = Tag_hd (hd);
-      if (tag >= No_scan_tag){
-        sz = Wosize_hd (hd);
-        result = alloc_shr (sz, tag);
-        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
-        Hd_val (v) = 0;            /* Set forward flag */
-        Field (v, 0) = result;     /*  and forward pointer. */
-        *p = result;
-      }else if (tag == Infix_tag){
-        mlsize_t offset = Infix_offset_hd (hd);
-        oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
-        *p += offset;
-      }else{
+      if (tag < Infix_tag){
         sz = Wosize_hd (hd);
         result = alloc_shr (sz, tag);
         *p = result;
@@ -112,6 +104,21 @@ void oldify_one (value v, value *p)
 	  v = field0;
           goto tail_call;
 	}
+      }else if (tag >= No_scan_tag){
+        sz = Wosize_hd (hd);
+        result = alloc_shr (sz, tag);
+        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
+        Hd_val (v) = 0;            /* Set forward flag */
+        Field (v, 0) = result;     /*  and forward pointer. */
+        *p = result;
+      }else if (tag == Infix_tag){
+        mlsize_t offset = Infix_offset_hd (hd);
+        oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
+        *p += offset;
+      }else{
+        Assert (tag == Forward_tag);
+        v = Forward_val (v);          /* Follow the forwarding */
+        goto tail_call;               /*  then oldify. */
       }
     }
   }else{

byterun/minor_gc.h

@@ -25,7 +25,8 @@ extern asize_t minor_heap_size;
 extern int in_minor_collection;
 
 #define Is_young(val) \
-  ((addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
+  (Assert (Is_block (val)), \
+   (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
 
 extern void set_minor_heap_size (asize_t);
 extern void empty_minor_heap (void);

byterun/misc.c

@@ -23,12 +23,13 @@
 
 #ifdef DEBUG
 
-void caml_failed_assert (char * expr, char * file, int line)
+int caml_failed_assert (char * expr, char * file, int line)
 {
   fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
            file, line, expr);
   fflush (stderr);
   exit (100);
+  return 1; /* not reached */
 }
 
 #endif

byterun/misc.h

@@ -62,10 +62,10 @@ typedef char * addr;
 /* Assertions */
 
 #ifdef DEBUG
-#define CAMLassert(x) if (!(x)) caml_failed_assert ( #x , __FILE__, __LINE__)
-void caml_failed_assert (char *, char *, int) Noreturn;
+#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
+int caml_failed_assert (char *, char *, int) Noreturn;
 #else
-#define CAMLassert(x)
+#define CAMLassert(x) 0
 #endif
 
 void fatal_error (char *msg) Noreturn;

byterun/mlvalues.h

@@ -158,10 +158,17 @@ bits  63    10 9     8 7   0
 typedef int32 opcode_t;
 typedef opcode_t * code_t;
 
-/* Special case of tuples of fields: closures */
+/* NOTE: [Forward_tag] and [Infix_tag] must be just under
+   [No_scan_tag], with [Infix_tag] the lower one.
+   See [oldify_one] in minor_gc.c for more details.
 
-#define Closure_tag 250
-#define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
+   NOTE: Update stdlib/obj.ml whenever you change the tags.
+ */
+
+/* Forward_tag: forwarding pointer that the GC may silently shortcut.
+   See stdlib/lazy.ml. */
+#define Forward_tag 250
+#define Forward_val(v) Field(v, 0)
 
 /* If tag == Infix_tag : an infix header inside a closure */
 /* Infix_tag must be odd so that the infix header is scanned as an integer */
@@ -177,6 +184,14 @@ typedef opcode_t * code_t;
 #define Class_val(val) Field((val), 0)
 #define Oid_val(val) Long_val(Field((val), 1))
 
+/* Special case of tuples of fields: closures */
+#define Closure_tag 247
+#define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
+
+/* This tag is not special for the runtime, but it must not be used
+   for any constructor.  See stdlib/lazy.ml. */
+#define Lazy_tag 246
+
 /* Another special case: variants */
 CAMLextern value hash_variant(char * tag);
 

byterun/obj.c

@@ -51,6 +51,12 @@ CAMLprim value obj_tag(value arg)
   return Val_int(Tag_val(arg));
 }
 
+CAMLprim value obj_set_tag (value arg, value new_tag)
+{
+  Tag_val (arg) = Int_val (new_tag);
+  return Val_unit;
+}
+
 CAMLprim value obj_block(value tag, value size)
 {
   value res;

camlp4/camlp4/ast2pt.ml

@@ -513,6 +513,7 @@ value rec expr =
       mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
   | ExInt loc s -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
   | ExLab loc _ _ -> error loc "labeled expression not allowed here"
+  | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
   | ExLet loc rf pel e ->
       mkexp loc (Pexp_let (mkrf rf) (List.map mkpe pel) (expr e))
   | ExLid loc s -> mkexp loc (Pexp_ident (lident s))

camlp4/camlp4/mLast.mli

@@ -84,6 +84,7 @@ and expr =
   | ExIfe of loc and expr and expr and expr
   | ExInt of loc and string
   | ExLab of loc and string and expr
+  | ExLaz of loc and expr
   | ExLet of loc and bool and list (patt * expr) and expr
   | ExLid of loc and string
   | ExLmd of loc and string and module_expr and expr

camlp4/camlp4/reloc.ml

@@ -113,6 +113,7 @@ and expr floc sh =
     | ExIfe loc x1 x2 x3 -> ExIfe (floc loc) (self x1) (self x2) (self x3)
     | ExInt loc x1 -> ExInt (floc loc) x1
     | ExLab loc x1 x2 -> ExLab (floc loc) x1 (self x2)
+    | ExLaz loc x1 -> ExLaz (floc loc) (self x1)
     | ExLet loc x1 x2 x3 ->
         ExLet (floc loc) x1
           (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3)

camlp4/etc/pa_o.ml

@@ -611,7 +611,7 @@ EXTEND
               if no_assert.val then <:expr< () >>
               else <:expr< if $e$ then () else $raiser$ >> ]
       | "lazy"; e = SELF ->
-          <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $e$)) >> ]
+          <:expr< lazy ($e$) >> ]
     | "." LEFTA
       [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
       | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>

camlp4/etc/pa_olabl.ml

@@ -1116,7 +1116,7 @@ EXTEND
               if no_assert.val then <:expr< () >>
               else <:expr< if $e$ then () else $raiser$ >> ]
       | "lazy"; e = SELF ->
-          <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $e$)) >> ]
+          <:expr< lazy ($e$) >> ]
     | "simple" LEFTA
       [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
       | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>

camlp4/etc/pr_o.ml

@@ -97,7 +97,7 @@ value is_keyword =
        "}"; "|"; "end"; "{"; "lxor"; "_"; "^"; "]"; "["; "let"; "!="; "||";
        "@"; ">"; "="; "<"; ";"; ":"; "mutable"; "/"; "[|"; "."; "-"; ","; "+";
        "begin"; "downto"; "*"; ")"; "|]"; "("; "'"; "&"; "functor"; ">="; "#";
-       "~-."; "!"; "~-"; "fun"; "mod"; "=="; "val"];
+       "~-."; "!"; "~-"; "fun"; "mod"; "=="; "val"; "lazy"; "assert"];
     fun s -> try Hashtbl.find keywords s with [ Not_found -> False ]
   }
 ;
@@ -1388,7 +1388,7 @@ pr_expr.pr_levels :=
       extfun Extfun.empty with
       [ <:expr< [$_$ :: $_$] >> as e ->
           fun curr next dg k -> [: `next e "" k :]
-      | <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $x$)) >> ->
+      | <:expr< lazy ($x$) >> ->
           fun curr next dg k -> [: `S LR "lazy"; `next x "" k :]
       | <:expr< if $e$ then () else raise (Assert_failure $_$) >> ->
           fun curr next dg k -> [: `S LR "assert"; `next e "" k :]

camlp4/etc/pr_r.ml

@@ -1272,7 +1272,7 @@ pr_expr.pr_levels :=
       extfun Extfun.empty with
       [ <:expr< [$_$ :: $_$] >> as e ->
           fun curr next _ k -> [: `next e "" k :]
-      | <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $x$)) >> ->
+      | <:expr< lazy ($x$) >> ->
           fun curr next _ k -> [: `S LR "lazy"; `next x "" k :]
       | <:expr< if $e$ then () else raise (Assert_failure $_$) >> ->
           fun curr next _ k -> [: `S LR "assert"; `next e "" k :]

camlp4/lib/fstream.ml

@@ -39,10 +39,10 @@ value empty s =
   | None -> Some ((), s) ]
 ;
 
-value nil () = {count = 0; data = ref (Lazy.Value Nil)};
+value nil () = {count = 0; data = Lazy.lazy_from_val Nil};
 value cons a s = Cons a s;
 value app s1 s2 = App s1 s2;
-value flazy f = {count = 0; data = ref (Lazy.Delayed f)};
+value flazy f = {count = 0; data = Lazy.lazy_from_fun f};
 
 value of_list l =
   List.fold_right (fun x s -> flazy (fun () -> cons x s)) l (nil ())
@@ -67,7 +67,9 @@ value count s = s.count;
 
 value count_unfrozen s =
   loop 0 s where rec loop cnt s =
-    match s.data.val with
-    [ Lazy.Value (Cons _ s) -> loop (cnt + 1) s
-    | _ -> cnt ]
+    if Lazy.lazy_is_val s.data then
+      match Lazy.force s.data with
+      [ (Cons _ s) -> loop (cnt + 1) s
+      | _ -> cnt ]
+    else cnt
 ;

camlp4/meta/pa_r.ml

@@ -150,10 +150,6 @@ value mkassert loc e =
       else <:expr< if $e$ then () else $raiser$ >> ]
 ;
 
-value mklazy loc e =
-  <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $e$)) >>
-;
-
 (* ...suppose to flush the input in case of syntax error to avoid multiple
    errors in case of cut-and-paste in the xterm, but work bad: for example
    the input "for x = 1;" waits for another line before displaying the
@@ -377,7 +373,7 @@ EXTEND
     | "apply" LEFTA
       [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >>
       | "assert"; e = SELF -> mkassert loc e
-      | "lazy"; e = SELF -> mklazy loc e ]
+      | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
     | "." LEFTA
       [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
       | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>

camlp4/meta/q_MLast.ml

@@ -147,21 +147,6 @@ value mkassert loc e =
       else Node "ExIfe" [Loc; e; Node "ExUid" [Loc; Str "()"]; raiser] ]
 ;
 
-value mklazy loc e =
-  Node "ExApp"
-    [Loc;
-     Node "ExAcc"
-       [Loc; Node "ExUid" [Loc; Str "Pervasives"];
-        Node "ExLid" [Loc; Str "ref"]];
-     Node "ExApp"
-       [Loc;
-        Node "ExAcc"
-          [Loc; Node "ExUid" [Loc; Str "Lazy"];
-           Node "ExUid" [Loc; Str "Delayed"]];
-        Node "ExFun"
-          [Loc; List [Tuple [Node "PaUid" [Loc; Str "()"]; Option None; e]]]]]
-;
-
 value not_yet_warned = ref True;
 value warning_seq () =
   if not_yet_warned.val then do {
@@ -408,7 +393,7 @@ EXTEND
     | "apply" LEFTA
       [ e1 = SELF; e2 = SELF -> Node "ExApp" [Loc; e1; e2]
       | "assert"; e = SELF -> mkassert loc e
-      | "lazy"; e = SELF -> mklazy loc e ]
+      | "lazy"; e = SELF -> Node "ExLaz" [Loc; e] ]
     | "." LEFTA
       [ e1 = SELF; "."; "("; e2 = SELF; ")" -> Node "ExAre" [Loc; e1; e2]
       | e1 = SELF; "."; "["; e2 = SELF; "]" -> Node "ExSte" [Loc; e1; e2]

camlp4/ocaml_src/camlp4/ast2pt.ml

@@ -521,6 +521,7 @@ let rec expr =
       mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3)))
   | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
   | ExLab (loc, _, _) -> error loc "labeled expression not allowed here"
+  | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
   | ExLet (loc, rf, pel, e) ->
       mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e))
   | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s))

camlp4/ocaml_src/camlp4/mLast.mli

@@ -82,6 +82,7 @@ and expr =
   | ExIfe of loc * expr * expr * expr
   | ExInt of loc * string
   | ExLab of loc * string * expr
+  | ExLaz of loc * expr
   | ExLet of loc * bool * (patt * expr) list * expr
   | ExLid of loc * string
   | ExLmd of loc * string * module_expr * expr

camlp4/ocaml_src/camlp4/reloc.ml

@@ -118,6 +118,7 @@ and expr floc sh =
     | ExIfe (loc, x1, x2, x3) -> ExIfe (floc loc, self x1, self x2, self x3)
     | ExInt (loc, x1) -> ExInt (floc loc, x1)
     | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, self x2)
+    | ExLaz (loc, x1) -> ExLaz (floc loc, self x1)
     | ExLet (loc, x1, x2, x3) ->
         ExLet
           (floc loc, x1,

camlp4/ocaml_src/lib/fstream.ml

@@ -38,10 +38,10 @@ let empty s =
   | None -> Some ((), s)
 ;;
 
-let nil () = {count = 0; data = ref (Lazy.Value Nil)};;
+let nil () = {count = 0; data = Lazy.lazy_from_val Nil};;
 let cons a s = Cons (a, s);;
 let app s1 s2 = App (s1, s2);;
-let flazy f = {count = 0; data = ref (Lazy.Delayed f)};;
+let flazy f = {count = 0; data = Lazy.lazy_from_fun f};;
 
 let of_list l =
   List.fold_right (fun x s -> flazy (fun () -> cons x s)) l (nil ())
@@ -71,9 +71,11 @@ let count s = s.count;;
 
 let count_unfrozen s =
   let rec loop cnt s =
-    match !(s.data) with
-      Lazy.Value (Cons (_, s)) -> loop (cnt + 1) s
-    | _ -> cnt
+    if Lazy.lazy_is_val s.data then
+      match Lazy.force s.data with
+        Cons (_, s) -> loop (cnt + 1) s
+      | _ -> cnt
+    else cnt
   in
   loop 0 s
 ;;

camlp4/ocaml_src/meta/pa_r.ml

@@ -148,18 +148,6 @@ let mkassert loc e =
       else MLast.ExIfe (loc, e, MLast.ExUid (loc, "()"), raiser)
 ;;
 
-let mklazy loc e =
-  MLast.ExApp
-    (loc,
-     MLast.ExAcc
-       (loc, MLast.ExUid (loc, "Pervasives"), MLast.ExLid (loc, "ref")),
-     MLast.ExApp
-       (loc,
-        MLast.ExAcc
-          (loc, MLast.ExUid (loc, "Lazy"), MLast.ExUid (loc, "Delayed")),
-        MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])))
-;;
-
 (* ...suppose to flush the input in case of syntax error to avoid multiple
    errors in case of cut-and-paste in the xterm, but work bad: for example
    the input "for x = 1;" waits for another line before displaying the
@@ -980,7 +968,8 @@ Grammar.extend
      Some "apply", Some Gramext.LeftA,
      [[Gramext.Stoken ("", "lazy"); Gramext.Sself],
       Gramext.action
-        (fun (e : 'expr) _ (loc : int * int) -> (mklazy loc e : 'expr));
+        (fun (e : 'expr) _ (loc : int * int) ->
+           (MLast.ExLaz (loc, e) : 'expr));
       [Gramext.Stoken ("", "assert"); Gramext.Sself],
       Gramext.action
         (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr));

camlp4/ocaml_src/meta/q_MLast.ml

@@ -153,29 +153,6 @@ let mkassert loc e =
       else Node ("ExIfe", [Loc; e; Node ("ExUid", [Loc; Str "()"]); raiser])
 ;;
 
-let mklazy loc e =
-  Node
-    ("ExApp",
-     [Loc;
-      Node
-        ("ExAcc",
-         [Loc; Node ("ExUid", [Loc; Str "Pervasives"]);
-          Node ("ExLid", [Loc; Str "ref"])]);
-      Node
-        ("ExApp",
-         [Loc;
-          Node
-            ("ExAcc",
-             [Loc; Node ("ExUid", [Loc; Str "Lazy"]);
-              Node ("ExUid", [Loc; Str "Delayed"])]);
-          Node
-            ("ExFun",
-             [Loc;
-              List
-                [Tuple
-                   [Node ("PaUid", [Loc; Str "()"]); Option None; e]]])])])
-;;
-
 let not_yet_warned = ref true;;
 let warning_seq () =
   if !not_yet_warned then
@@ -506,7 +483,7 @@ Grammar.extend
                 Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
               | _ ->
                   match () with
-                  _ -> raise (Match_failure ("q_MLast.ml", 6297, 6313))
+                  _ -> raise (Match_failure ("q_MLast.ml", 5892, 5908))
             in
             Node ("StExc", [Loc; c; tl; b]) :
             'str_item));
@@ -741,7 +718,7 @@ Grammar.extend
                 Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
               | _ ->
                   match () with
-                  _ -> raise (Match_failure ("q_MLast.ml", 8360, 8376))
+                  _ -> raise (Match_failure ("q_MLast.ml", 7955, 7971))
             in
             Node ("SgExc", [Loc; c; tl]) :
             'sig_item));
@@ -1272,7 +1249,8 @@ Grammar.extend
      Some "apply", Some Gramext.LeftA,
      [[Gramext.Stoken ("", "lazy"); Gramext.Sself],
       Gramext.action
-        (fun (e : 'expr) _ (loc : int * int) -> (mklazy loc e : 'expr));
+        (fun (e : 'expr) _ (loc : int * int) ->
+           (Node ("ExLaz", [Loc; e]) : 'expr));
       [Gramext.Stoken ("", "assert"); Gramext.Sself],
       Gramext.action
         (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr));

parsing/parser.mly

@@ -63,15 +63,6 @@ let mkassert e =
   | _ -> mkexp (Pexp_assert (e))
 ;;
 
-let mklazy e =
-  let void_pat = ghpat (Ppat_construct (Lident "()", None, false)) in
-  let f = ghexp (Pexp_function ("", None, [void_pat, e])) in
-  let delayed = Ldot (Lident "Lazy", "Delayed") in
-  let df = ghexp (Pexp_construct (delayed, Some f, false)) in
-  let r = ghexp (Pexp_ident (Ldot (Lident "Pervasives", "ref"))) in
-  ghexp (Pexp_apply (r, ["", df]))
-;;
-
 let mkinfix arg1 name arg2 =
   mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
 
@@ -833,7 +824,7 @@ expr:
   | ASSERT simple_expr %prec prec_appl
       { mkassert $2 }
   | LAZY simple_expr %prec prec_appl
-      { mklazy $2 }
+      { mkexp (Pexp_lazy ($2)) }
 ;
 simple_expr:
     val_longident

parsing/parsetree.mli

@@ -107,6 +107,7 @@ and expression_desc =
   | Pexp_letmodule of string * module_expr * expression
   | Pexp_assert of expression
   | Pexp_assertfalse
+  | Pexp_lazy of expression
 
 (* Value descriptions *)
 

parsing/printast.ml

@@ -271,6 +271,9 @@ and expression i ppf x =
       expression i ppf e;
   | Pexp_assertfalse ->
       line i ppf "Pexp_assertfalse";
+  | Pexp_lazy (e) ->
+      line i ppf "Pexp_lazy";
+      expression i ppf e;
 
 and value_description i ppf x =
   line i ppf "value_description\n";

stdlib/lazy.ml

@@ -15,22 +15,79 @@
 
 (* Module [Lazy]: deferred computations *)
 
-type 'a status =
-  | Delayed of (unit -> 'a)
-  | Value of 'a
-  | Exception of exn
-;;
 
-type 'a t = 'a status ref;;
+(*
+   WARNING: some purple magic is going on here.  Do not take this file
+   as an example of how to program in Objective Caml.
+*)
 
+
+(* We make use of two special tags provided by the runtime:
+   [lazy_tag] and [forward_tag].
+
+   A value of type ['a Lazy.t] can be one of three things:
+   1. A block of size 1 with tag [lazy_tag].  Its field is a closure of
+      type [unit -> 'a] that computes the value.
+   2. A block of size 1 with tag [forward_tag].  Its field is the value
+      of type ['a] that was computed.
+   3. Anything else.  This has type ['a] and is the value that was computed.
+   Exceptions are stored in format (1).
+   The GC will magically change things from (2) to (3) according to its
+   fancy.
+
+   We have to use the built-in type constructor [lazy_t] to
+   let the compiler implement the special typing and compilation
+   rules for the [lazy] keyword.
+*)
+
+type 'a t = 'a lazy_t;;
 exception Undefined;;
 
-let force l =
-  match !l with
-  | Value v -> v
-  | Exception e -> raise e
-  | Delayed f ->
-      l := Exception Undefined;
-      try let v = f () in l := Value v; v
-      with e -> l := Exception e; raise e
+let raise_undefined = Obj.repr (fun () -> raise Undefined);;
+
+let force (l : 'arg t) =
+  let x = Obj.repr l in
+  if Obj.is_int x then (Obj.obj x : 'arg)
+  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  else if Obj.tag x <> 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
+;;
+
+let force_val (l : 'arg t) =
+  let x = Obj.repr l in
+  if Obj.is_int x then (Obj.obj x : 'arg)
+  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  else if Obj.tag x <> 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 lazy_from_fun (f : unit -> 'arg) =
+  let x = Obj.new_block Obj.lazy_tag 1 in
+  Obj.set_field x 0 (Obj.repr f);
+  (Obj.obj x : 'arg t)
+;;
+
+let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
+
+let lazy_is_val (l : 'arg t) =
+  let x = Obj.repr l in
+  Obj.is_int x || Obj.tag x <> Obj.lazy_tag
 ;;

stdlib/lazy.mli

@@ -15,25 +15,50 @@
 
 (** Deferred computations. *)
 
-type 'a status = 
-    Delayed of (unit -> 'a) 
-  | Value of 'a 
-  | Exception of exn
+type 'a t = 'a lazy_t;;
+(** A value of type ['a Lazy.t] is a deferred computation, called
+   a suspension, that has a result of type ['a].  The special
+   expression syntax [lazy (expr)] makes a suspension of the
+   computation of [expr], without computing [expr] itself yet.
+   "Forcing" the suspension will then compute [expr] and return its
+   result.
 
-type 'a t = 'a status ref
-(** A value of type ['a Lazy.t] is a deferred computation (also called a
-   suspension) that computes a result of type ['a].  The expression
-   [lazy (expr)] returns a suspension that computes [expr]. **)
-
-
-exception Undefined
-
-val force : 'a t -> 'a
-(** [Lazy.force x] computes the suspension [x] and returns its result.
-   If the suspension was already computed, [Lazy.force x] returns the
-   same value again.  If it raised an exception, the same exception is
-   raised again.
-   Raise [Undefined] if the evaluation of the suspension requires its
-   own result.
+   Note: [lazy_t] is the built-in type constructor used by the compiler
+   for the [lazy] keyword.  You should not use it directly.  Always use
+   [Lazy.t] instead.
 *)
 
+
+exception Undefined;;
+
+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,
+   the same exception is raised again.
+   Raise [Undefined] if the forcing of [x] tries to force [x] itself
+   recursively.
+*)
+
+val force_val : 'a t -> 'a;;
+(** [force_val x] forces the suspension [x] and returns its
+    result.  If [x] has already been forced, [force_val x]
+    returns the same value again without recomputing it.
+    Raise [Undefined] if the forcing of [x] tries to force [x] itself
+    recursively.
+    If the computation of [x] raises an exception, it is unspecified
+    whether [force_val x] raises the same exception or [Undefined].
+*)
+
+val lazy_from_fun : (unit -> 'a) -> 'a t;;
+(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more
+    efficient. *)
+
+val lazy_from_val : 'a -> 'a t;;
+(** [lazy_from_val v] returns an already-forced suspension of [v]
+    This is for special purposes only and should not be confused with
+    [lazy (v)]. *)
+
+val lazy_is_val : 'a t -> bool;;
+(** [lazy_is_val x] returns [true] if [x] has already been forced and
+    did not raise an exception. *)

stdlib/obj.ml

@@ -23,6 +23,7 @@ external magic : 'a -> 'b = "%identity"
 external is_block : t -> bool = "obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
 external tag : t -> int = "obj_tag"
+external set_tag : t -> int -> unit = "obj_set_tag"
 external size : t -> int = "%obj_size"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
@@ -35,12 +36,14 @@ let marshal (obj : t) =
 let unmarshal str pos =
   (Marshal.from_string str pos, pos + Marshal.total_size str pos)
 
-let no_scan_tag = 251
-let closure_tag = 250
-let infix_tag = 249
+let lazy_tag = 246
+let closure_tag = 247
 let object_tag = 248
+let infix_tag = 249
+let forward_tag = 250
+let no_scan_tag = 251
 let abstract_tag = 251
 let string_tag = 252
 let double_tag = 253
 let double_array_tag = 254
-let final_tag = 255
+let custom_tag = 255

stdlib/obj.mli

@@ -26,24 +26,28 @@ external magic : 'a -> 'b = "%identity"
 external is_block : t -> bool = "obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
 external tag : t -> int = "obj_tag"
+external set_tag : t -> int -> unit = "obj_set_tag"
 external size : t -> int = "%obj_size"
+external truncate : t -> int -> unit = "obj_truncate"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external new_block : int -> int -> t = "obj_block"
 external dup : t -> t = "obj_dup"
-external truncate : t -> int -> unit = "obj_truncate"
 
-val no_scan_tag : int
+val lazy_tag : int
 val closure_tag : int
-val infix_tag : int
 val object_tag : int
+val infix_tag : int
+val forward_tag : int
+val no_scan_tag : int
 val abstract_tag : int
 val string_tag : int
 val double_tag : int
 val double_array_tag : int
-val final_tag : int
+val custom_tag : int
 
-(** The following two functions are deprecated.  Use module {!Marshal} instead. *)
+(** The following two functions are deprecated.  Use module {!Marshal}
+    instead. *)
 
 val marshal : t -> string
 val unmarshal : string -> int -> t * int

tools/addlabels.ml

@@ -252,7 +252,8 @@ let rec add_labels_expr ~text ~values ~classes expr =
   | Pexp_send (e, _)
   | Pexp_setinstvar (_, e)
   | Pexp_letmodule (_, _, e)
-  | Pexp_assert e ->
+  | Pexp_assert e
+  | Pexp_lazy e ->
       add_labels_rec e
   | Pexp_record (lst, opt) ->
       List.iter lst ~f:(fun (_,e) -> add_labels_rec e);

tools/ocamldep.ml

@@ -149,6 +149,7 @@ let rec add_expr bv exp =
       add_module bv m; add_expr (StringSet.add id bv) e
   | Pexp_assert (e) -> add_expr bv e
   | Pexp_assertfalse -> ()
+  | Pexp_lazy (e) -> add_expr bv e
 
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel

tools/ocamlprof.ml

@@ -285,6 +285,8 @@ and rw_exp iflag sexp =
   | Pexp_assert (cond) -> rewrite_exp iflag cond
   | Pexp_assertfalse -> ()
 
+  | Pexp_lazy (expr) -> rewrite_exp iflag expr
+
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
     insert_profile rw_exp sifbody

toplevel/genprintval.ml

@@ -225,6 +225,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                     Oval_array (List.rev (tree_of_items [] 0))
               else
                 Oval_array []
+          | Tconstr (path, [ty_arg], _)
+            when Path.same path Predef.path_lazy_t ->
+              if Lazy.lazy_is_val (O.obj obj)
+              then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
+                   Oval_constr (Oide_ident "lazy", [v])
+              else Oval_stuff "<lazy>"
           | Tconstr(path, ty_list, _) ->
               begin try
                 let decl = Env.find_type path env in

typing/predef.ml

@@ -32,6 +32,7 @@ and ident_option = Ident.create "option"
 and ident_nativeint = Ident.create "nativeint"
 and ident_int32 = Ident.create "int32"
 and ident_int64 = Ident.create "int64"
+and ident_lazy_t = Ident.create "lazy_t"
 
 let path_int = Pident ident_int
 and path_char = Pident ident_char
@@ -47,6 +48,7 @@ and path_option = Pident ident_option
 and path_nativeint = Pident ident_nativeint
 and path_int32 = Pident ident_int32
 and path_int64 = Pident ident_int64
+and path_lazy_t = Pident ident_lazy_t
 
 let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
 and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
@@ -61,6 +63,7 @@ and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
 and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
 and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
 and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
 
 let ident_match_failure = Ident.create "Match_failure"
 and ident_out_of_memory = Ident.create "Out_of_memory"
@@ -129,6 +132,13 @@ let build_initial_env add_type add_exception empty_env =
      type_kind = Type_variant["None", []; "Some", [tvar]];
      type_manifest = None;
      type_variance = [true, false]}
+  and decl_lazy_t =
+    let tvar = newgenvar() in
+    {type_params = [tvar];
+     type_arity = 1;
+     type_kind = Type_abstract;
+     type_manifest = None;
+     type_variance = [true, false]}
   in
 
   add_exception ident_match_failure
@@ -147,6 +157,7 @@ let build_initial_env add_type add_exception empty_env =
   add_type ident_int64 decl_abstr (
   add_type ident_int32 decl_abstr (
   add_type ident_nativeint decl_abstr (
+  add_type ident_lazy_t decl_lazy_t (
   add_type ident_option decl_option (
   add_type ident_format decl_format (
   add_type ident_list decl_list (
@@ -158,7 +169,7 @@ let build_initial_env add_type add_exception empty_env =
   add_type ident_string decl_abstr (
   add_type ident_char decl_abstr (
   add_type ident_int decl_abstr (
-    empty_env)))))))))))))))))))))))))
+    empty_env))))))))))))))))))))))))))
 
 let builtin_values =
   List.map (fun id -> Ident.make_global id; (Ident.name id, id))

typing/predef.mli

@@ -29,6 +29,7 @@ val type_option: type_expr -> type_expr
 val type_nativeint: type_expr
 val type_int32: type_expr
 val type_int64: type_expr
+val type_lazy_t: type_expr -> type_expr
 
 val path_int: Path.t
 val path_char: Path.t
@@ -44,6 +45,7 @@ val path_option: Path.t
 val path_nativeint: Path.t
 val path_int32: Path.t
 val path_int64: Path.t
+val path_lazy_t: Path.t
 
 val path_match_failure: Path.t
 val path_assert_failure : Path.t

typing/typecore.ml

@@ -506,9 +506,9 @@ let rec is_nonexpansive exp =
   | Texp_let(rec_flag, pat_exp_list, body) ->
       List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
       is_nonexpansive body
+  | Texp_function _ -> true
   | Texp_apply(e, (None,_)::el) ->
       is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el)
-  | Texp_function _ -> true
   | Texp_tuple el ->
       List.for_all is_nonexpansive el
   | Texp_construct(_, el) ->
@@ -525,6 +525,7 @@ let rec is_nonexpansive exp =
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
   | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
       true
+  | Texp_lazy e -> true
   | _ -> false
 
 and is_nonexpansive_opt = function
@@ -1129,6 +1130,14 @@ let rec type_exp env sexp =
          exp_type = newvar ();
          exp_env = env;
        }
+  | Pexp_lazy (e) ->
+       let arg = type_exp env e in
+       {
+         exp_desc = Texp_lazy arg;
+         exp_loc = sexp.pexp_loc;
+         exp_type = instance (Predef.type_lazy_t arg.exp_type);
+         exp_env = env;
+       }
 
 and type_argument env sarg ty_expected =
   let no_labels ty =

typing/typedtree.ml

@@ -76,6 +76,7 @@ and expression_desc =
   | Texp_letmodule of Ident.t * module_expr * expression
   | Texp_assert of expression
   | Texp_assertfalse
+  | Texp_lazy of expression
 
 and meth =
     Tmeth_name of string

typing/typedtree.mli

@@ -75,6 +75,7 @@ and expression_desc =
   | Texp_letmodule of Ident.t * module_expr * expression
   | Texp_assert of expression
   | Texp_assertfalse
+  | Texp_lazy of expression
 
 and meth =
     Tmeth_name of string

utils/config.mlp

@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "3.04+2 (2002-01-18)"
+let version = "3.04+3 (2002-01-20)"
 
 let standard_library =
   try
@@ -39,14 +39,14 @@ and cmo_magic_number = "Caml1999O004"
 and cma_magic_number = "Caml1999A006"
 and cmx_magic_number = "Caml1999Y006"
 and cmxa_magic_number = "Caml1999Z008"
-and ast_impl_magic_number = "Caml1999M008"
+and ast_impl_magic_number = "Caml1999M009"
 and ast_intf_magic_number = "Caml1999N007"
 
 let load_path = ref ([] : string list)
 
 let interface_suffix = ref ".mli"
 
-let max_tag = 246
+let max_tag = 245
 let max_young_wosize = 256
 let stack_threshold = 256 (* see byterun/config.h *)