Compiler: load shapes for cma.js and cmo.js

Author: hhugo

compiler/lib/driver.ml

@@ -23,8 +23,6 @@ let debug = Debug.find "main"
 
 let times = Debug.find "times"
 
-let debug_shapes = Debug.find "shapes"
-
 type optimized_result =
   { program : Code.program
   ; variable_uses : Deadcode.variable_uses
@@ -103,7 +101,7 @@ let ( +> ) f g x = g (f x)
 let map_fst4 f (x, y, z, t) = f x, y, z, t
 
 let collects_shapes ~shapes (p : Code.program) =
-  if debug_shapes () || shapes
+  if shapes
   then (
     let t = Timer.make () in
     let shapes = ref StringMap.empty in
@@ -709,17 +707,17 @@ let full ~shapes ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatte
     +> name_variables
     +> output formatter ~source_map ()
   in
-  let shapes = optimized_code.shapes in
+  let shapes_v = optimized_code.shapes in
   StringMap.iter
     (fun name shape ->
       Shape.Store.set ~name shape;
-      if debug_shapes ()
+      if shapes
       then
         Pretty_print.string
           formatter
           (Printf.sprintf "//# shape: %s:%s\n" name (Shape.to_string shape)))
-    shapes;
-  emit formatter optimized_code, shapes
+    shapes_v;
+  emit formatter optimized_code, shapes_v
 
 let full_no_source_map ~formatter ~shapes ~standalone ~wrap_with_fun ~profile ~link p =
   let (_ : Source_map.info * _) =

compiler/lib/shape.ml

@@ -64,6 +64,68 @@ let rec to_string (shape : t) =
         | Top -> ""
         | _ -> "->" ^ to_string res)
 
+let of_string (s : string) =
+  let pos = ref 0 in
+  let current () = s.[!pos] in
+  let next () = incr pos in
+  let parse_char c =
+    let c' = current () in
+    if Char.equal c c' then next () else assert false
+  in
+  let parse_char_opt c =
+    let c' = current () in
+    if Char.equal c c'
+    then (
+      next ();
+      true)
+    else false
+  in
+  let rec parse_int acc =
+    match current () with
+    | '0' .. '9' as c ->
+        let d = Char.code c - Char.code '0' in
+        let acc = (acc * 10) + d in
+        next ();
+        parse_int acc
+    | _ -> acc
+  in
+  let rec parse_shape () =
+    match current () with
+    | '[' ->
+        next ();
+        parse_block []
+    | 'N' ->
+        next ();
+        Top
+    | 'F' ->
+        next ();
+        parse_fun ()
+    | c -> failwith (String.make 1 c)
+  and parse_block acc =
+    let x = parse_shape () in
+    match current () with
+    | ',' ->
+        next ();
+        parse_block (x :: acc)
+    | ']' ->
+        next ();
+        Block (List.rev (x :: acc))
+    | _ -> assert false
+  and parse_fun () =
+    let () = parse_char '(' in
+    let arity = parse_int 0 in
+    let () = parse_char ')' in
+    let pure = parse_char_opt '*' in
+    match current () with
+    | '-' ->
+        next ();
+        parse_char '>';
+        let res = parse_shape () in
+        Function { arity; pure; res }
+    | _ -> Function { arity; pure; res = Top }
+  in
+  parse_shape ()
+
 module Store = struct
   let ext = ".jsoo-shape"
 
@@ -82,11 +144,21 @@ module Store = struct
   let load' fn =
     let ic = open_in_bin fn in
     let m = really_input_string ic (String.length magic) in
-    if not (String.equal m magic)
-    then failwith (Printf.sprintf "Invalid magic number for shape file %s" fn);
-    let shapes : (string * shape) list = Marshal.from_channel ic in
-    close_in ic;
-    List.iter shapes ~f:(fun (name, shape) -> set ~name shape)
+    if String.equal m magic
+    then (
+      let shapes : (string * shape) list = Marshal.from_channel ic in
+      close_in ic;
+      List.iter shapes ~f:(fun (name, shape) -> set ~name shape))
+    else (
+      close_in ic;
+      let l = file_lines_bin fn in
+      List.iter l ~f:(fun s ->
+          match String.drop_prefix ~prefix:"//#shape: " s with
+          | None -> ()
+          | Some name_n_shape -> (
+              match String.lsplit2 name_n_shape ~on:':' with
+              | None -> ()
+              | Some (name, shape) -> set ~name (of_string shape))))
 
   let load ~name ~paths =
     if String.Hashtbl.mem t name

compiler/lib/shape.mli

@@ -28,6 +28,8 @@ type t =
 
 val to_string : t -> string
 
+val of_string : string -> t
+
 val equal : t -> t -> bool
 
 val merge : t -> t -> t

compiler/tests-full/dune

@@ -11,8 +11,6 @@
    --debug
    var
    --debuginfo
-   --debug
-   shapes
    %{lib:stdlib:stdlib.cma}
    -o
    %{targets})))
@@ -50,8 +48,6 @@
    %{bin:js_of_ocaml}
    --pretty
    --debuginfo
-   --debug
-   shapes
    %{dep:shapes.cma}
    -o
    %{targets})))