Remove virtual object fields from IR and compiler

src/as_frontend/typing.ml

@@ -395,6 +395,28 @@ let check_lit env t lit at =
         "literal of type\n  %s\ndoes not have expected type\n  %s"
         (T.string_of_typ t') (T.string_of_typ_expand t)
 
+(* Coercions *)
+
+let array_obj t =
+  let open T in
+  let immut t =
+    [ {lab = "get";  typ = Func (Local, Returns, [], [Prim Nat], [t])};
+      {lab = "len";  typ = Func (Local, Returns, [], [], [Prim Nat])};
+      {lab = "keys"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Nat)])};
+      {lab = "vals"; typ = Func (Local, Returns, [], [], [iter_obj t])};
+    ] in
+  let mut t = immut t @
+    [ {lab = "set"; typ = Func (Local, Returns, [], [Prim Nat; t], [])} ] in
+  Object Local,
+  List.sort compare_field (match t with Mut t' -> mut t' | t -> immut t)
+
+let text_obj () =
+  let open T in
+  Object Local,
+  [ {lab = "chars"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Char)])};
+    {lab = "len";  typ = Func (Local, Returns, [], [], [Prim Nat])};
+  ]
+
 
 (* Expressions *)
 
@@ -527,8 +549,8 @@ and infer_exp'' env exp : T.typ =
     let t1 = infer_exp_promote env exp1 in
     let _s, tfs =
       try T.as_obj_sub id.it t1 with Invalid_argument _ ->
-      try T.array_obj (T.as_array_sub t1) with Invalid_argument _ ->
-      try T.text_obj (T.as_prim_sub T.Text t1) with Invalid_argument _ ->
+      try array_obj (T.as_array_sub t1) with Invalid_argument _ ->
+      try text_obj (T.as_prim_sub T.Text t1) with Invalid_argument _ ->
         error env exp1.at
           "expected object type, but expression produces type\n  %s"
           (T.string_of_typ_expand t1)

src/as_ir/check_ir.ml

@@ -355,10 +355,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
       check_exp env exp1;
       let t1 = typ exp1 in
       let sort, tfs =
-        (* TODO: separate array and text accessors *)
         try T.as_obj_sub n t1 with Invalid_argument _ ->
-        try T.array_obj (T.as_array_sub t1) with Invalid_argument _ ->
-        try T.text_obj (T.as_prim_sub T.Text t1) with Invalid_argument _ ->
           error env exp1.at "expected object type, but expression produces type\n  %s"
             (T.string_of_typ_expand t1)
       in

src/as_types/type.ml

@@ -75,6 +75,8 @@ let unit = Tup []
 let bool = Prim Bool
 let nat = Prim Nat
 let int = Prim Int
+let text = Prim Text
+let char = Prim Char
 
 let prim = function
   | "Null" -> Null
@@ -108,34 +110,12 @@ let compare_field f1 f2 =
   | {lab = l1; typ = _}, {lab = l2; typ = Typ _ } -> 1
   | {lab = l1; typ = _}, {lab = l2; typ = _ } -> compare l1 l2
 
-
 (* Coercions *)
 
-(* TODO: Move to typing once we have separated accessors in IR. *)
-
 let iter_obj t =
   Obj (Object Local,
     [{lab = "next"; typ = Func (Local, Returns, [], [], [Opt t])}])
 
-let array_obj t =
-  let immut t =
-    [ {lab = "get";  typ = Func (Local, Returns, [], [Prim Nat], [t])};
-      {lab = "len";  typ = Func (Local, Returns, [], [], [Prim Nat])};
-      {lab = "keys"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Nat)])};
-      {lab = "vals"; typ = Func (Local, Returns, [], [], [iter_obj t])};
-    ] in
-  let mut t = immut t @
-    [ {lab = "set"; typ = Func (Local, Returns, [], [Prim Nat; t], [])} ] in
-  Object Local,
-  List.sort compare_field (match t with Mut t' -> mut t' | t -> immut t)
-
-let text_obj () =
-  Object Local,
-  [ {lab = "chars"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Char)])};
-    {lab = "len";  typ = Func (Local, Returns, [], [], [Prim Nat])};
-  ]
-
-
 (* Shifting *)
 
 let rec shift i n t =

src/as_types/type.mli

@@ -64,6 +64,9 @@ val unit : typ
 val bool : typ
 val nat : typ
 val int : typ
+val text : typ
+val char : typ
+val iter_obj : typ -> typ
 
 val prim : string -> prim
 
@@ -126,12 +129,6 @@ val lookup_typ_field : string -> field list -> con option
 val compare_field : field -> field -> int
 
 
-(* Corercions *)
-
-val array_obj : typ -> obj_sort * field list
-val text_obj : unit -> obj_sort * field list
-
-
 (* Constructors *)
 
 val set_kind : con -> kind -> unit

src/as_values/prim.ml

@@ -255,6 +255,19 @@ let prim = function
                     k (Tup [Word32 (of_int (length nobbles)); Char (to_int code)])
   | "@serialize" -> fun v k -> k (Serialized v)
   | "@deserialize" -> fun v k -> k (as_serialized v)
+
+  | "array_len" -> fun v k ->
+    k (Int (Int.of_int (Array.length (Value.as_array v))))
+  | "text_len" -> fun v k ->
+    k (Int (Nat.of_int (List.length (Wasm.Utf8.decode (Value.as_text v)))))
+  | "text_chars" -> fun v k ->
+    let i = ref 0 in
+    let s = Wasm.Utf8.decode (Value.as_text v) in
+    let next = local_func 0 1 @@ fun v k' ->
+        if !i = List.length s then k' Null else
+          let v = Opt (Char (List.nth s !i)) in incr i; k' v
+    in k (Obj (Env.singleton "next" next))
+
   | "Array.init" -> fun v k ->
     (match Value.as_tup v with
     | [len; x] ->

src/codegen/compile.ml

@@ -1024,7 +1024,7 @@ module Tagged = struct
     | _ -> true
 
   (* like branch_with but with type information to statically skip some branches *)
-  let branch_typed_with env ty retty branches =
+  let _branch_typed_with env ty retty branches =
     branch_with env retty (List.filter (fun (tag,c) -> can_have_tag ty tag) branches)
 
   let obj env tag element_instructions : G.t =
@@ -1900,7 +1900,7 @@ module Iterators = struct
     get_x: The thing to put in the closure, and pass to mk_next
 
   Return code that takes the object (array or text) on the stack and puts a
-  closure onto the stack.
+  the iterator onto the stack.
   *)
   let create outer_env name mk_stop mk_next =
     Func.share_code1 outer_env name ("x", I32Type) [I32Type] (fun env get_x ->
@@ -1942,23 +1942,14 @@ module Iterators = struct
         )
       ) in
 
-      let iter_funid = E.add_fun env (name ^ "_iter") (
-        Func.of_body env ["clos", I32Type] [I32Type] (fun env ->
-          (* closure for the function *)
-          let (set_ni, get_ni) = new_local env "next" in
-          Closure.fixed_closure env next_funid
-            [ Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ]
-            ;  Closure.get ^^ Closure.load_data 0l
-            ] ^^
-          set_ni ^^
-
-          Object.lit_raw env
-            [ "next", fun _ -> get_ni ]
-        )
-      ) in
+      let (set_ni, get_ni) = new_local env "next" in
+      Closure.fixed_closure env next_funid
+        [ Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ]
+        ; get_x
+        ] ^^
+      set_ni ^^
 
-      (* Now build the closure *)
-      Closure.fixed_closure env iter_funid [ get_x ]
+      Object.lit_raw env [ "next", fun _ -> get_ni ]
     )
 
 end (* Iterators *)
@@ -2079,8 +2070,8 @@ module Text = struct
         get_res ^^ UnboxedSmallWord.box_codepoint
       )
 
-  let text_chars env =
-    Iterators.create env "text_chars"
+  let text_chars_direct env =
+    Iterators.create env "text_chars_direct"
       (fun env get_x -> get_x ^^ Heap.load_field len_field)
       (fun env get_i get_x ->
           let (set_char, get_char) = new_local env "char" in
@@ -2090,29 +2081,25 @@ module Text = struct
           get_char ^^ UnboxedSmallWord.box_codepoint
       )
 
-  let partial_len env =
-    Func.share_code1 env "text_len_partial" ("x", I32Type) [I32Type] (fun env get_x ->
-      let funid = E.add_fun env "text_len" (Func.of_body env ["clos", I32Type] [I32Type] (fun env ->
-        let get_text_object = Closure.get ^^ Closure.load_data 0l in
-        let (set_max, get_max) = new_local env "max" in
-        let (set_n, get_n) = new_local env "n" in
-        let (set_len, get_len) = new_local env "len" in
-        compile_unboxed_zero ^^ set_n ^^
-        compile_unboxed_zero ^^ set_len ^^
-        get_text_object ^^ Heap.load_field len_field ^^ set_max ^^
-        compile_while
-          (get_n ^^ get_max ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)))
-          begin
-            get_text_object ^^ payload_ptr_unskewed ^^ get_n ^^
-              G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^
-            UnboxedSmallWord.len_UTF8_head env (G.i Drop) ^^
-            get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_n ^^
-            get_len ^^ compile_add_const 1l ^^ set_len
-          end ^^
-        get_len ^^
-        BigNum.from_word32 env
-      )) in
-      Closure.fixed_closure env funid [ get_x ]
+  let len env =
+    Func.share_code1 env "text_len" ("x", I32Type) [I32Type] (fun env get_x ->
+      let (set_max, get_max) = new_local env "max" in
+      let (set_n, get_n) = new_local env "n" in
+      let (set_len, get_len) = new_local env "len" in
+      compile_unboxed_zero ^^ set_n ^^
+      compile_unboxed_zero ^^ set_len ^^
+      get_x ^^ Heap.load_field len_field ^^ set_max ^^
+      compile_while
+        (get_n ^^ get_max ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)))
+        begin
+          get_x ^^ payload_ptr_unskewed ^^ get_n ^^
+            G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^
+          UnboxedSmallWord.len_UTF8_head env (G.i Drop) ^^
+          get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_n ^^
+          get_len ^^ compile_add_const 1l ^^ set_len
+        end ^^
+      get_len ^^
+      BigNum.from_word32 env
     )
 
   let prim_showChar env =
@@ -2207,64 +2194,12 @@ module Arr = struct
       G.i (Binary (Wasm.Values.I32 I32Op.Add))
     )
 
-  let partial_get env =
-    Func.share_code1 env "array_get_partial" ("x", I32Type) [I32Type] (fun env get_x ->
-      let funid = E.add_fun env "array_get" (Func.of_body env ["clos", I32Type; "idx", I32Type] [I32Type] (fun env1 ->
-        let get_idx = G.i (LocalGet (nr 1l)) in
-        Closure.get ^^ Closure.load_data 0l ^^
-        get_idx ^^ BigNum.to_word32 env1 ^^
-        idx env1 ^^
-        load_ptr
-      )) in
-      Closure.fixed_closure env funid [ get_x ]
-    )
-
-  let partial_set env =
-    Func.share_code1 env "array_set_partial" ("x", I32Type) [I32Type] (fun env get_x ->
-      let funid = E.add_fun env "array_set" (Func.of_body env ["clos", I32Type; "idx", I32Type; "val", I32Type] [] (fun env1 ->
-        let get_idx = G.i (LocalGet (nr 1l)) in
-        let get_val = G.i (LocalGet (nr 2l)) in
-        Closure.get ^^ Closure.load_data 0l ^^
-        get_idx ^^ BigNum.to_word32 env1 ^^
-        idx env1 ^^
-        get_val ^^
-        store_ptr
-      )) in
-      Closure.fixed_closure env funid [ get_x ]
-    )
-
-  let partial_len env =
-    Func.share_code1 env "array_len_partial" ("x", I32Type) [I32Type] (fun env get_x ->
-      let funid = E.add_fun env "array_len" (Func.of_body env ["clos", I32Type] [I32Type] (fun env1 ->
-        Closure.get ^^ Closure.load_data 0l ^^
-        Heap.load_field len_field ^^
-        BigNum.from_word32 env1
-      )) in
-      Closure.fixed_closure env funid [ get_x ]
-    )
-
   (* Compile an array literal. *)
   let lit env element_instructions =
     Tagged.obj env Tagged.Array
      ([ compile_unboxed_const (Wasm.I32.of_int_u (List.length element_instructions))
       ] @ element_instructions)
 
-  let keys_iter env =
-    Iterators.create env "array_keys"
-      (fun env get_x -> get_x ^^ Heap.load_field len_field)
-      (fun env get_i get_x ->
-        compile_unboxed_const 1l ^^ (* advance by one *)
-        get_i ^^ BigNum.from_word32 env (* return the boxed index *)
-      )
-
-  let vals_iter env =
-    Iterators.create env "array_vals"
-      (fun env get_x -> get_x ^^ Heap.load_field len_field)
-      (fun env get_i get_x ->
-        compile_unboxed_const 1l ^^ (* advance by one *)
-        get_x ^^ get_i ^^ idx env ^^ load_ptr (* return the element *)
-      )
-
   (* Does not initialize the fields! *)
   let alloc env =
     let (set_len, get_len) = new_local env "len" in
@@ -4766,30 +4701,8 @@ let compile_relop env t op =
     compile_comparison env t1 op1
   | _ -> todo_trap env "compile_relop" (Arrange_ops.relop op)
 
-(* compile_load_field implements the various “virtual fields”, which
-   we currently have for arrays and text.
-   It goes through branch_typed_with, which does a dynamic check of the
-   heap object type *)
 let compile_load_field env typ name =
-  let branches =
-    ( Tagged.Object, Object.load_idx env typ name ) ::
-    match name with
-    | "len" ->
-      [ Tagged.Array, Arr.partial_len env
-      ; Tagged.Text, Text.partial_len env ]
-    | "get" ->
-      [ Tagged.Array, Arr.partial_get env ]
-    | "set" ->
-      [ Tagged.Array, Arr.partial_set env ]
-    | "keys" ->
-      [ Tagged.Array, Arr.keys_iter env ]
-    | "vals" ->
-      [ Tagged.Array, Arr.vals_iter env ]
-    | "chars" ->
-      [ Tagged.Text, Text.text_chars env ]
-    | _ -> []
-    in
-  Tagged.branch_typed_with env typ (ValBlockType (Some I32Type)) branches
+  Object.load_idx env typ name
 
 (* compile_lexp is used for expressions on the left of an
 assignment operator, produces some code (with side effect), and some pure code *)
@@ -4825,7 +4738,7 @@ and compile_exp (env : E.t) ae exp =
   | DotE (e, name) ->
     SR.Vanilla,
     compile_exp_vanilla env ae e ^^
-    compile_load_field env e.note.note_typ name
+    Object.load_idx env e.note.note_typ name
   | ActorDotE (e, name) ->
     SR.UnboxedReference,
     compile_exp_as env ae SR.UnboxedReference e ^^
@@ -4835,6 +4748,22 @@ and compile_exp (env : E.t) ae exp =
     begin
       (* First check for all unary prims. *)
       match p with
+        | "array_len" ->
+          SR.Vanilla,
+          compile_exp_vanilla env ae e ^^
+          Heap.load_field Arr.len_field ^^
+          BigNum.from_word32 env
+
+        | "text_len" ->
+          SR.Vanilla,
+          compile_exp_vanilla env ae e ^^
+          Text.len env
+
+        | "text_chars" ->
+          SR.Vanilla,
+          compile_exp_vanilla env ae e ^^
+          Text.text_chars_direct env
+
        | "@serialize" ->
          SR.UnboxedReference,
          let t = match typ_args with [t] -> t | _ -> assert false in