Compiler: optimize cond more

CHANGES.md

@@ -1,14 +1,15 @@
 # dev (2021-??-??) - ??
 ## Features/Changes
-* Compiler: static evaluation of backend_type
-* Compiler: speedup emitting js files.
-* Compiler: simplify (a | 0) >>> 0 into (a >>> 0)
-* Lib: add messageEvent to Dom_html
-* Lib: add PerformanceObserver API
-* Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty}
+* Compiler: static evaluation of backend_type (#1166)
+* Compiler: speedup emitting js files (#1174)
+* Compiler: simplify (a | 0) >>> 0 into (a >>> 0) (#1177)
+* Compiler: improve static evaluation of cond (#1178)
+* Lib: add messageEvent to Dom_html (#1164)
+* Lib: add PerformanceObserver API (#1164)
+* Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty} (#1170)
 
 ## Bug fixes
-* Compiler: fix sourcemap warning for empty cma
+* Compiler: fix sourcemap warning for empty cma (#1169)
 
 # 3.11.0 (2021-10-06) - Lille
 

compiler/lib/eval.ml

@@ -299,12 +299,39 @@ let the_case_of info x =
   | Pc (Tuple (j, _, _)) -> CTag j
   | _ -> Unknown
 
+type cond_of =
+  | Zero
+  | Non_zero
+  | Unknown
+
+let the_cond_of info x =
+  get_approx
+    info
+    (fun x ->
+      match info.info_defs.(Var.idx x) with
+      | Expr (Constant (Int 0l)) -> Zero
+      | Expr
+          (Constant
+            (Int _ | Float _ | Tuple _ | String _ | IString _ | Float_array _ | Int64 _))
+        ->
+          Non_zero
+      | Expr (Block (_, _, _)) -> Non_zero
+      | Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown
+      | Param | Phi _ -> Unknown)
+    Unknown
+    (fun u v ->
+      match u, v with
+      | Zero, Zero -> Zero
+      | Non_zero, Non_zero -> Non_zero
+      | _ -> Unknown)
+    x
+
 let eval_branch info = function
   | Cond (x, ftrue, ffalse) as b -> (
-      match the_int info (Pv x) with
-      | Some 0l -> Branch ffalse
-      | Some _ -> Branch ftrue
-      | _ -> b)
+      match the_cond_of info x with
+      | Zero -> Branch ffalse
+      | Non_zero -> Branch ftrue
+      | Unknown -> b)
   | Switch (x, const, tags) as b -> (
       (* [the_case_of info (Pv x)] might be meaningless when we're inside a dead code.
          The proper fix would be to remove the deadcode entirely.

compiler/tests-compiler/static_eval.ml

@@ -96,3 +96,57 @@ let%expect_test "static eval of Sys.backend_type" =
   print_fun_decl program (Some "myfun");
   [%expect {|
     function myfun(param){return 42} |}]
+
+let%expect_test "static eval of string get" =
+  let program =
+    compile_and_parse
+      {|
+
+      type ('a, 'b) bucketlist =
+        | Empty
+        | Cons of { mutable key: 'a;
+                    mutable data: 'b;
+                    mutable next: ('a, 'b) bucketlist }
+
+      let copy_bucketlist = function
+        | Empty -> Empty
+        | Cons {key; data; next} ->
+            let rec loop prec = function
+              | Empty -> ()
+              | Cons {key; data; next} ->
+                  let r = Cons {key; data; next} in
+                  begin match prec with
+                  | Empty -> assert false
+                  | Cons prec ->  prec.next <- r
+                  end;
+                  loop r next
+            in
+            let r = Cons {key; data; next} in
+            loop r next;
+            r
+  |}
+  in
+  print_fun_decl program (Some "copy_bucketlist");
+  [%expect
+    {|
+    function copy_bucketlist(param)
+     {if(param)
+       {var
+         key=param[1],
+         data=param[2],
+         next=param[3],
+         prec$0=[0,key,data,next],
+         prec=prec$0,
+         param$0=next;
+        for(;;)
+         {if(param$0)
+           {var
+             key$0=param$0[1],
+             data$0=param$0[2],
+             next$0=param$0[3],
+             r=[0,key$0,data$0,next$0];
+            prec[3] = r;
+            var prec=r,param$0=next$0;
+            continue}
+          return prec$0}}
+      return 0} |}]