change lazy representation not using blocking, fix rescript-lang#4325

Author: bobzhang

jscomp/core/lam_convert.ml

@@ -269,8 +269,10 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
         args loc App_infer_full
     | Blk_lazy_forward
       -> 
-      let info : Lam_tag_info.t = Blk_na "" in
-      prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc    
+      Lam.apply 
+        (prim ~primitive:(Pfield (1,Fld_module {name = "from_val"})) loc (*Invariant: hard code {from_fun} position*)
+         ~args: [Lam.global_module (Ident.create_persistent "CamlinternalLazy")] )
+        args loc App_infer_full
     | Blk_na s -> 
       let info : Lam_tag_info.t = Blk_na s in
       prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args loc

jscomp/stdlib-406/camlinternalLazy.ml

@@ -13,99 +13,82 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Internals of forcing lazy values. *)
-
-let lazy_tag = 246
-let forward_tag = 250
 
+(* Internals of forcing lazy values. *)
 type 'a t = {
-  mutable tag : int ; (* Invariant: name  *)
-  mutable _0 : 'a
+  mutable tag : int [@bs.as "tag"] ; 
+  (* Invariant: name  *)
+  mutable value : 'a (* [@bs.as "val"] *)
+  (* its type is ['a] or [unit -> 'a ] *)
 }
 
-external cast_from_lazy : 'a lazy_t -> 'b = "%identity"
-external cast_to_lazy : 'b -> 'a lazy_t = "%identity"
 
-(* external new_block : int -> int -> 'a lazy_t = "caml_obj_block" *)
-let set_tag : 'a lazy_t  -> int -> unit = fun x tag -> 
-  (x |. cast_from_lazy).tag<-tag
-let tag : 'a lazy_t -> int = fun x -> 
-  (x |. cast_from_lazy). tag 
+let%private lazy_tag = 246
+let%private forward_tag = 250
+external%private magic : 'a -> 'b = "%identity"
 
-let set_field (blk : 'arg lazy_t) (result : 'a) : unit = 
-  (* Obj.set_field (Obj.repr blk) 0 (Obj.repr result) *)
-  (blk |. cast_from_lazy)._0<-result
-let get_field (blk : 'arg lazy_t ) : 'a = 
-    (* Obj.obj (Obj.field (Obj.repr blk) 0) *)
-    (blk |. cast_from_lazy)._0
+let%private lazy_boxed (type a) (l : a ) : bool  = 
+  if Js.testAny l then false 
+  else   
+    let t = (magic l : _ t  ).tag in 
+    t = forward_tag || t = lazy_tag  
 
-let new_block_with_tag tag (value : 'a)  : 'arg lazy_t =
-  ({tag ; _0 = value}  |. cast_to_lazy)
-  (* let x = new_block tag 1 in 
-  set_field  x  value; 
-  x  *)
+let is_val (type a ) (l : a lazy_t) : bool = 
+  Js.testAny l || ((magic l : _ t ).tag  <> lazy_tag)
 
-let from_fun (f : unit -> 'arg ) = 
-  new_block_with_tag lazy_tag f 
+let from_fun (type arg ) (f : unit -> arg ) : arg lazy_t = 
+  (magic {tag = lazy_tag; value = f} : arg lazy_t) 
 
 
-let from_val (v : 'arg) =
-  let t = tag (cast_to_lazy v) in
-  if t = forward_tag || t = lazy_tag  then begin
-    new_block_with_tag forward_tag v
+let from_val (type arg ) (v : arg) : arg lazy_t=
+  if lazy_boxed v  then begin
+    (magic {tag = forward_tag ; value = v} : arg lazy_t )
   end else begin
-    (cast_to_lazy v : 'arg lazy_t)
+    (magic v : arg lazy_t)
   end    
 
+exception Undefined
 
-let forward_with_closure (blk : 'arg lazy_t) closure = 
+let%private forward_with_closure (type a ) (blk : a t) (closure : unit -> a) : a = 
   let result = closure () in
   (* do set_field BEFORE set_tag *)
-  set_field blk result;
-  set_tag blk forward_tag;
+  blk.value <- result;
+  blk.tag<- forward_tag;
   result
 
 
-exception Undefined
-
-let raise_undefined =  (fun () -> raise Undefined)
+let%private raise_undefined =  (fun () -> raise Undefined)
 
 (* Assume [blk] is a block with tag lazy *)
-let force_lazy_block (blk : 'arg lazy_t) =
-  let closure : unit -> 'arg = get_field blk in
-  set_field blk raise_undefined;
+let%private force_lazy_block (type a ) (blk : a t) : a  =
+  let closure : unit -> a = magic blk.value in
+  blk.value <- magic raise_undefined;
   try
     forward_with_closure blk closure
   with e ->
-    set_field blk (fun () -> raise e);
+    blk.value <- magic (fun () -> raise e);
     raise e
 
 
 (* Assume [blk] is a block with tag lazy *)
-let force_val_lazy_block (blk : 'arg lazy_t) =
-  let closure : unit -> 'arg = get_field blk  in
-  set_field blk  raise_undefined;
+let%private force_val_lazy_block (type a ) (blk : a t) : a  =
+  let closure : unit -> a = magic blk.value  in
+  blk.value <-  magic raise_undefined;
   forward_with_closure blk closure
 
-(* [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) : 'arg =
-  let t = tag lzv in
-  if t = forward_tag then get_field lzv  else
-  if t <> lazy_tag then cast_from_lazy lzv
-  else force_lazy_block lzv
 
 
-let force_val (lzv : 'arg lazy_t) : 'arg =
-  let t = tag lzv in
-  if t = forward_tag then get_field lzv  else
-  if t <> lazy_tag then cast_from_lazy lzv
-  else force_val_lazy_block lzv
-
+let force (type a ) (lzv : a lazy_t) : a =
+  if lazy_boxed  lzv then 
+    if is_val lzv then (magic lzv : _ t).value else
+      force_lazy_block (magic lzv : _ t)
+  else  magic lzv
 
 
 
+let force_val (lzv : 'arg lazy_t) : 'arg =
+  if lazy_boxed  lzv then 
+    if is_val lzv then (magic lzv : _ t).value  else
+      force_val_lazy_block (magic lzv : _ t)
+  else  magic lzv
 
-let is_val (l : 'arg lazy_t) = tag l <> lazy_tag

lib/js/camlinternalLazy.js

@@ -3,19 +3,38 @@
 var Curry = require("./curry.js");
 var Caml_exceptions = require("./caml_exceptions.js");
 
+function is_val(l) {
+  if (l == null) {
+    return true;
+  } else {
+    return l.tag !== 246;
+  }
+}
+
+function lazy_boxed(l) {
+  if (l == null) {
+    return false;
+  }
+  var t = l.tag;
+  if (t === 250) {
+    return true;
+  } else {
+    return t === 246;
+  }
+}
+
 function from_fun(f) {
   return {
           tag: 246,
-          _0: f
+          value: f
         };
 }
 
 function from_val(v) {
-  var t = v.tag;
-  if (t === 250 || t === 246) {
+  if (lazy_boxed(v)) {
     return {
             tag: 250,
-            _0: v
+            value: v
           };
   } else {
     return v;
@@ -24,7 +43,7 @@ function from_val(v) {
 
 function forward_with_closure(blk, closure) {
   var result = Curry._1(closure, undefined);
-  blk._0 = result;
+  blk.value = result;
   blk.tag = 250;
   return result;
 }
@@ -36,43 +55,41 @@ function raise_undefined(param) {
 }
 
 function force(lzv) {
-  var t = lzv.tag;
-  if (t === 250) {
-    return lzv._0;
-  } else if (t !== 246) {
-    return lzv;
-  } else {
-    var closure = lzv._0;
-    lzv._0 = raise_undefined;
-    try {
-      return forward_with_closure(lzv, closure);
-    }
-    catch (e){
-      lzv._0 = (function (param) {
-          throw e;
-        });
-      throw e;
+  if (lazy_boxed(lzv)) {
+    if (is_val(lzv)) {
+      return lzv.value;
+    } else {
+      var closure = lzv.value;
+      lzv.value = raise_undefined;
+      try {
+        return forward_with_closure(lzv, closure);
+      }
+      catch (e){
+        lzv.value = (function (param) {
+            throw e;
+          });
+        throw e;
+      }
     }
+  } else {
+    return lzv;
   }
 }
 
 function force_val(lzv) {
-  var t = lzv.tag;
-  if (t === 250) {
-    return lzv._0;
-  } else if (t !== 246) {
-    return lzv;
+  if (lazy_boxed(lzv)) {
+    if (is_val(lzv)) {
+      return lzv.value;
+    } else {
+      var closure = lzv.value;
+      lzv.value = raise_undefined;
+      return forward_with_closure(lzv, closure);
+    }
   } else {
-    var closure = lzv._0;
-    lzv._0 = raise_undefined;
-    return forward_with_closure(lzv, closure);
+    return lzv;
   }
 }
 
-function is_val(l) {
-  return l.tag !== 246;
-}
-
 exports.Undefined = Undefined;
 exports.force = force;
 exports.force_val = force_val;