more shapes

Author: hhugo

compiler/lib/flow.ml

@@ -407,6 +407,8 @@ let rec the_shape_of info x =
           match info.info_defs.(Var.idx x) with
           | Expr (Block (_, a, _, Immutable)) ->
               Shape.Block (List.map ~f:(the_shape_of info) (Array.to_list a))
+          | Expr (Block (_, a, _, _)) when not (Var.ISet.mem info.info_possibly_mutable x)
+            -> Shape.Block (List.map ~f:(the_shape_of info) (Array.to_list a))
           | Expr (Closure (l, _)) ->
               Shape.Function { arity = List.length l; pure = false; res = Top "unk" }
           | Expr (Special (Alias_prim name)) -> (

compiler/lib/specialize.ml

@@ -28,31 +28,37 @@ let function_arity info x =
         match shape with
         | Function { arity; _ } -> Some arity
         | Block _ | Top _ -> None)
-    | None ->
-        get_approx
-          info
-          (fun x ->
-            match Info.def info x with
-            | Some (Closure (l, _)) -> Some (List.length l)
-            | Some (Special (Alias_prim prim)) -> (
-                try Some (Primitive.arity prim) with Not_found -> None)
-            | Some (Apply { f; args; _ }) -> (
-                if List.mem f ~set:acc
-                then None
-                else
-                  match arity info f (f :: acc) with
-                  | Some n ->
-                      let diff = n - List.length args in
-                      if diff > 0 then Some diff else None
-                  | None -> None)
-            | Some _ -> None
-            | None -> None)
-          None
-          (fun u v ->
-            match u, v with
-            | Some n, Some m when n = m -> u
-            | _ -> None)
-          x
+    | None -> (
+        match Shape.get x with
+        | Some shape -> (
+            match shape with
+            | Function { arity; _ } -> Some arity
+            | Block _ | Top _ -> None)
+        | None ->
+            get_approx
+              info
+              (fun x ->
+                match Info.def info x with
+                | Some (Closure (l, _)) -> Some (List.length l)
+                | Some (Special (Alias_prim prim)) -> (
+                    try Some (Primitive.arity prim) with Not_found -> None)
+                | Some (Apply { f; args; _ }) -> (
+                    if List.mem f ~set:acc
+                    then None
+                    else
+                      match arity info f (f :: acc) with
+                      | Some n ->
+                          let diff = n - List.length args in
+                          if diff > 0 then Some diff else None
+                      | None -> None)
+                | Some _ -> None
+                | None -> None)
+              None
+              (fun u v ->
+                match u, v with
+                | Some n, Some m when n = m -> u
+                | _ -> None)
+              x)
   in
   arity info x []
 

compiler/tests-compiler/gh747.ml

@@ -227,7 +227,7 @@ end
       1:
       2: //# unitInfo: Provides: Test
       3: //# unitInfo: Requires: Stdlib__Printf
-      4: //# shape: Test:[N,N,[N],N,N,N,N,N,N,N,N,N,N,F(2),F(2),[F(4)]]
+      4: //# shape: Test:[N,N,[N],N,N,N,N,N,N,N,N,N,[N,N],F(2),F(2),[F(4)]]
       5: (function
       6:   (globalThis){
       7:    "use strict";