Commits

Dmitry Grebeniuk  committed 4e68082

runtime type representation for arrays (as kind of tuples)

  • Participants
  • Parent commits b52ba4c

Comments (0)

Files changed (6)

File src/cd_Array.ml

     ?cmp ?eq ?hash ?show
     (ti_elem : #Cdt.ti 'b)
     () =
-      object (_self : #tifull (array 'a))
+      object (self : #tifull (array 'a))
 
         constraint 'z = array 'a;
 
           )
         ;
 
-        method type_desc = Simple "array"
+        method type_desc =
+          Tuple
+            (fun u ->
+               Array.map (ubox ti_elem) &
+               uget_exn self u
+            )
+            [| (ti_elem :> uti) |]
+            (fun uarr ->
+               ubox self &
+               Array.map (uget_exn ti_elem) uarr
+            )
+            Tk_Array
         ;
 
         inherit tifull_ops [_] ?cmp ?eq ?hash

File src/cd_Ds.ml

          let uarr = destr u in
          let () = sort_record_destr uarr in
          Lst (Array.map_to_list (snd @> ubox_to_lol) uarr)
-    | Tuple destr _utis _constr -> fun u ->
+    | Tuple destr _utis _constr _tk -> fun u ->
          let uarr = destr u in
          Lst (Array.map_to_list ubox_to_lol uarr)
      | Lambda _ _ _ ->
               utis
            )
 
-    | Tuple _destr utis constr ->
+    | Tuple _destr utis constr _tk ->
          ds_rmap
            (fun arr -> constr arr)
            (ds_array_map_seq ds_deser_struc utis)
+         (* it's wrong to ignore _tk, but this code is not used anymore *)
 
      | Lambda _ _ _ ->
          failwith "can't deserialize Lambda from dumbstreaming"

File src/cd_Json.ml

                 [ (fname, ubox_to_json fubox) :: acc ]
                 (i - 1)
 
-    | Tuple destr _utis _constr ->
+    | Tuple destr _utis _constr _tk ->
         fun u ->
           let uarr = destr u in
           let jcomps = Array.map_to_list ubox_to_json uarr in
                      find_constr (i + 1)
            ]
 
-       | Tuple _destr utis constr ->
+       | Tuple _destr utis constr tk ->
            fun j ->
            let jarr = Array.of_list (Br.array j) in
-           let ufields = Array.map2to1
-             (fun field_uti field_json ->
-                ubox_from_json field_uti field_json
-             )
-             utis
-             jarr
+           let ufields =
+             match tk with
+             [ Tk_Tuple ->
+                 Array.map2to1
+                   (fun field_uti field_json ->
+                      ubox_from_json field_uti field_json
+                   )
+                   utis
+                   jarr
+             | Tk_Array ->
+                 let uti = utis.(0) in
+                 Array.map
+                   (fun field_json ->
+                      ubox_from_json uti field_json
+                   )
+                   jarr
+             ]
            in
            constr ufields
 

File src/cd_Ser.ml

            let () = print_newline () in
            marshal_ser ti#type_name (variant_name, ustrs)
 
-     | Tuple destr _utis _constr ->
+     | Tuple destr _utis _constr _tk ->
          fun a ->
            let uvals = destr (ubox ti a) in
            let ustrs = ustrs_of_uvals uvals in
 
 
 
+value uval_of_ustr
+ : uti -> string -> ubox
+ = fun uti ustr ->
+     let deser = get_meth_untyped "deser.marshal" uti in
+     u_app deser (ubox ti_string ustr)
+;
+
 value uvals_of_ustrs
- : array string -> array uti -> array ubox
- = fun ustrs utis ->
-             Array.map2to1
-               (fun str uti ->
-                  let deser = get_meth_untyped "deser.marshal" uti in
-                  u_app deser (ubox ti_string str)
-               )
-               ustrs
-               utis
+ : array string -> array uti -> tuple_kind -> array ubox
+ = fun ustrs utis tk ->
+     match tk with
+     [ Tk_Tuple ->
+         Array.map2to1
+           uval_of_ustr
+           utis
+           ustrs
+     | Tk_Array ->
+         Array.map
+           (uval_of_ustr utis.(0))
+           ustrs
+     ]
 ;
 
 
              uvals_of_ustrs
                ustrs
                utis
+               Tk_Tuple
            in
            uget_exn ti & ctr_u uvals
 
          ->
            assert False
 
-     | Tuple _destr utis constr
+     | Tuple _destr utis constr tk
          ->
            fun s ->
              let ustrs : array string = marshal_deser ti#type_name s in
-             uget_exn ti & constr (uvals_of_ustrs ustrs utis)
+             uget_exn ti & constr (uvals_of_ustrs ustrs utis tk)
      ]
 ;
 

File src/cd_Tuples.ml

            [ [| ua ; ub |] -> ubox self (uget_exn ti1 ua, uget_exn ti2 ub)
            | _ -> assert False
            ])
+          Tk_Tuple
         ;
 
         inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
                (uget_exn ti1 ua, uget_exn ti2 ub, uget_exn ti3 uc)
            | _ -> assert False
            ])
+          Tk_Tuple
         ;
 
         inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
                )
            | _ -> assert False
            ])
+          Tk_Tuple
         ;
 
         inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
                )
            | _ -> assert False
            ])
+          Tk_Tuple
         ;
 
         inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
 ;
 
 
+(* tuples and arrays are almost the same for runtime type representation,
+   so arrays have [type_desc = Tuple _ [| uti_a |] _ Tk_Array] *)
+type tuple_kind = [ Tk_Tuple | Tk_Array ]
+;
+
+
 module rec R
  :
   sig
           of (R.ubox -> array R.ubox)
          and array uti
          and (array R.ubox -> R.ubox)
+         and tuple_kind
       ]
     ;
 
           of (R.ubox -> array R.ubox)
          and array uti
          and (array R.ubox -> R.ubox)
+         and tuple_kind
       ]
     ;
 
             " -> "
             (List.map uti_type_name arrow_components)
          )
-   | Tuple _destr utis _constr ->
-       Printf.sprintf "(%s)"
-         (String.concat
-            " * "
-            (Array.to_list
-               (Array.map
-                  (fun uti -> type_name_of_type_desc uti#type_desc)
-                  utis
-               )
-            )
-         )
+   | Tuple _destr utis _constr tk ->
+       let items =
+         Array.to_list
+           (Array.map
+              (fun uti -> type_name_of_type_desc uti#type_desc)
+              utis
+           )
+       in
+       match tk with
+       [ Tk_Tuple ->
+           Printf.sprintf "(%s)"
+             (String.concat
+                " * "
+                items
+             )
+       | Tk_Array ->
+           Printf.sprintf "[| %s |]"
+             (String.concat
+                " ; "
+                items
+             )
+       ]
    ]
 
 and get_lambda_spine uti type_desc =
    [ ( Simple _
      | Sum_type _
      | Record_type _
-     | Tuple _ _ _
+     | Tuple _ _ _ _
      ) ->
          [uti]
 
             binop_struc_tuple uti "sum type" xargs yargs
         ]
 
-    | Tuple destr _utis _constr ->
+    | Tuple destr _utis _constr tk ->
         let xargs = destr ux in
         let yargs = destr uy in
-        binop_struc_tuple uti "tuple" xargs yargs
+        binop_struc_tuple uti
+          (match tk with
+           [ Tk_Tuple -> "tuple"
+           | Tk_Array -> "array"
+           ]
+          )
+          xargs yargs
 
     | Record_type destr _utis _fields _constr ->
         let xfields = destr ux in
         let args = Array.map unop_struc_ubox (xgetargs unop_meth_name) in
         unop_reduce_sum_type xname args
 
-    | Tuple destr _utis _constr ->
+    | Tuple destr _utis _constr _tk ->
         let xargs = destr ux in
         let args = Array.map unop_struc_ubox xargs in
         unop_reduce_tuple args
   | Sum_type _ _
   | Dispatch_method _
   | Lambda _ _ _
-  | Tuple _ _ _ -> failwith "Cdt.ti_expect_record_exn: not a record type"
+  | Tuple _ _ _ _ -> failwith "Cdt.ti_expect_record_exn: not a record type"
   ]
 ;
 
   | Record_type _ _ _ _
   | Dispatch_method _
   | Lambda _ _ _
-  | Tuple _ _ _ -> failwith "Cdt.ti_expect_sum_exn: not a sum type"
+  | Tuple _ _ _ _ -> failwith "Cdt.ti_expect_sum_exn: not a sum type"
   ]
 ;