Commits

Dmitry Grebeniuk  committed b39661a

new 'universal type' mechanism

  • Participants
  • Parent commits 86911b3

Comments (0)

Files changed (12)

 Library cadastr
   Path:       src
   BuildDepends: num
-  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings, Cd_Array, Cd_Typeinfo, Cdt, Cd_Types, Cd_Option, Cd_Num, Cd_Tuples, Cd_Bool, TlsArray, TlsArray_st, TlsArray_mt, TlsRef, Cd_Ref, Cd_Partapp, Cd_Int64, Cd_Ser, Cd_SortedArray, Cd_SortedArraySet, Cd_Utf8, Cd_Buffer, Cd_StringsCommon, Cd_Exn
+  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings, Cd_Array, Cd_Typeinfo, Cdt, Cd_Types, Cd_Option, Cd_Num, Cd_Tuples, Cd_Bool, Cd_Ref, Cd_Partapp, Cd_Int64, Cd_Ser, Cd_SortedArray, Cd_SortedArraySet, Cd_Utf8, Cd_Buffer, Cd_StringsCommon, Cd_Exn
   NativeOpt:       -w A
   ByteOpt:         -w A
 
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: f3d70939fddf5a40ec41e5fcf538da97) *)
+(* DO NOT EDIT (digest: 2f5d878b47e98c9339fec9d2100ce19c) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                            "Cd_Num";
                            "Cd_Tuples";
                            "Cd_Bool";
-                           "TlsArray";
-                           "TlsArray_st";
-                           "TlsArray_mt";
-                           "TlsRef";
                            "Cd_Ref";
                            "Cd_Partapp";
                            "Cd_Int64";

File src/cadastr.mllib

 # OASIS_START
-# DO NOT EDIT (digest: 0b93266e208c375a9ffa2adc10ed7940)
+# DO NOT EDIT (digest: 6c0d6c348445da4b0f7ba2a64728a48c)
 Cadastr
 Monoid
 Cd_All
 Cd_Num
 Cd_Tuples
 Cd_Bool
-TlsArray
-TlsArray_st
-TlsArray_mt
-TlsRef
 Cd_Ref
 Cd_Partapp
 Cd_Int64

File src/cd_Typeinfo.ml

           failwith "Typeinfo.ti_no#meths: can't use methods of ti_no"
         ;
 
-        method temp_store _ _ =
-          failwith "Typeinfo.ti_no#temp_store: can't store"
+        method put_func _ =
+          failwith "Typeinfo.ti_no#put_func: no storage"
         ;
 
-        method temp_get = 
-          failwith "Typeinfo.ti_no#temp_store: can't get"
+        method get_exn _ = 
+          failwith "Typeinfo.ti_no#get_exn: no_storage"
         ;
       end
     ;
  and meth_name = string
 ;
 
-type ub_store_cmd =
-  [ UB_ST_Set
-  | UB_ST_Clear
-  ]
-;
-
 
 exception TTI_GET
 ;
   end
 ;
 
+
 module rec R
  :
   sig
     type meth_table = Meths.t
     ;
 
-    class type tti ['a]
-     =
-      object
-        inherit uti;
-
-        (* value mutable temp_storage : TlsRef.t (option 'a); *)
-        method temp_store : 'a -> ub_store_cmd -> unit;  (* для част.прим. *)
-        method temp_get : 'a;  (* raises TTI_GET *)
-      end
-    ;
-
     type type_desc =
       [ Simple of type_name
       | Sum_type
          and array field_name
          and (array R.ubox -> R.ubox)
       | Dispatch_method of (meth_name -> type_desc)
-      | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      | Lambda of R.uti and R.uti and (R.ubox -> R.ubox -> R.ubox)
       | Tuple
           of (R.ubox -> array R.ubox)
          and array uti
          and (array R.ubox -> R.ubox)
       ]
-    and ubox =
-      { ub_store : ub_store_cmd -> unit
+    ;
+
+    type ubox =
+      { ub_store : unit -> unit
       ; ub_uti : R.uti
       }
     ;
 
+    class type tti ['a]
+     =
+      object
+        inherit uti;
+
+        method put_func : 'a -> (unit -> unit);
+        method get_exn : ubox -> 'a;
+      end
+    ;
+
   end
  =
   struct
       end
     ;
 
-    class type tti ['a]
-     =
-      object
-        inherit uti;
-
-        (* value mutable temp_storage : TlsRef.t (option 'a); *)
-        method temp_store : 'a -> ub_store_cmd -> unit;  (* для част.прим. *)
-        method temp_get : 'a;  (* raises TTI_GET *)
-      end
-    ;
-
     module Meths
      :
       sig
          and array field_name
          and (array R.ubox -> R.ubox)
       | Dispatch_method of (meth_name -> type_desc)
-      | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      | Lambda of R.uti and R.uti and (R.ubox -> R.ubox -> R.ubox)
       | Tuple
           of (R.ubox -> array R.ubox)
          and array uti
     ;
 
     type ubox =
-      { ub_store : ub_store_cmd -> unit
+      { ub_store : unit -> unit
       ; ub_uti : R.uti
       }
     ;
 
+    class type tti ['a]
+     =
+      object
+        inherit uti;
+
+        method put_func : 'a -> (unit -> unit);
+        method get_exn : ubox -> 'a;
+      end
+    ;
+
   end
 ;
 
 value ubox
  : #tti 'a -> 'a -> ubox
  = fun tti a ->
-  { ub_store = tti#temp_store a
-  ; ub_uti = (tti :> uti)
-  }
+     { ub_store = tti#put_func a
+     ; ub_uti = (tti :> uti)
+     }
 ;
 
 
    | Record_type (* type_desc_record *) _destr _utis _fields _constr
        -> "(some record type)"
    | Dispatch_method dm -> type_name_of_type_desc (dm "type_name")
-   | Lambda uti_a uti_b _do_apply ->
+   | Lambda uti_a uti_b _apply ->
        let spine = get_lambda_spine uti_b uti_b#type_desc in
        let arrow_components = [uti_a :: spine] in
        Printf.sprintf "(%s)"
    | Dispatch_method dm ->
        get_lambda_spine uti (dm "type_name")
 
-   | Lambda uti_a uti_b _do_apply ->
+   | Lambda uti_a uti_b _apply ->
        [uti_a :: get_lambda_spine uti_b uti_b#type_desc]
    ]
 
 value uget_exn
  : #tti 'a -> ubox -> 'a
  = fun tti ub ->
-     let exp_uti = (tti :> uti)
-     and ub_uti = ub.ub_uti in
-     if exp_uti#type_id != ub_uti#type_id
-     then
-       failwith "Cdt.uget_exn: expected %S, got %S"
-         (uti_type_name exp_uti)
-         (uti_type_name ub_uti)
-     else
-       let store = ub.ub_store in
-       let finally () =
-         ( store UB_ST_Clear
-         )
-       in
-       try
-         let () = store UB_ST_Set in
-         let r = tti#temp_get in
-         let () = finally () in
-         r
-       with
-       [ TTI_GET -> assert False
-       | e -> ( finally () ; raise e )
-       ]
+     try
+       tti#get_exn ub
+     with
+     [ TTI_GET ->
+         let exp_uti = (tti :> uti)
+         and ub_uti = ub.ub_uti in
+         failwith "Cdt.uget_exn: expected %S/%i, got %S/%i"
+           (uti_type_name exp_uti)
+           (exp_uti#type_id :> int)
+           (uti_type_name ub_uti)
+           (ub_uti#type_id :> int)
+     ]
+;
+
+
+value make_storage (type a) () =
+  let module Storage =
+    struct
+      exception Val of a;
+      value raise_ x : unit -> unit = fun () -> raise (Val x);
+      value catch_ raisefunc =
+        try (raisefunc (); assert False)
+        with [ Val x -> x | _ -> raise TTI_GET ];
+    end
+  in
+    (Storage.raise_, Storage.catch_)
 ;
 
 
 class virtual ti ['a] () =
   let meths = Meths.create () in
-  let temp_storage = TlsRef.make (None : option 'a) in
   let type_id = Type_id.next () in
 (*
   let () = Printf.printf
-    "DBG: new ti: creating storage for type %S (id=%i)\n%!"
-    (Lazy.force type_name)
-    (type_id :> int) in
+    "DBG: new ti: creating storage for type_id=%i\n%!"
+    (type_id :> int)
+  in
 *)
-  object (self)
+  let ( (raise_ : 'a -> unit -> unit)
+      , (catch_ : (unit -> unit) -> 'a)
+      ) = make_storage () in
+  object (self : #tti 'a)
     method virtual type_desc : type_desc
     ;
     value v_type_name = ref None
 
     method meths = meths
     ;
-    method temp_get =
-      match TlsRef.get temp_storage with
-      [ None -> raise TTI_GET
-      | Some a -> a
-      ]
+
+    method put_func = raise_
     ;
-    method temp_store a =
-      let some_a = Some a in
-      fun
-      [ UB_ST_Set -> TlsRef.set temp_storage some_a
-      | UB_ST_Clear -> TlsRef.set temp_storage None
-      ]
+
+    method get_exn u = catch_ u.ub_store
     ;
+
     method type_id = type_id
     ;
+
   end
 ;
 
     | Some d -> d
     ]
   and meths = Meths.create ()
-  and temp_store = tti#temp_store
-  and type_id = tti#type_id
+  and put_func = tti#put_func
+  and get_exn = tti#get_exn
+  and type_id = Type_id.next ()
   in
     object (_ : #tti 'a)
       method type_id = type_id;
       method type_desc = type_desc;
       method type_name = tti#type_name;
       method meths = meths;
-      method temp_store = temp_store;
-      method temp_get = tti#temp_get;
+      method put_func = put_func;
+      method get_exn = get_exn;
   end
 ;
 
 
 value ti_abs
- : tti 'a -> tti 'b -> tti ('a -> 'b)
- = fun ta tb ->
-     let rec do_apply
-      : unit -> ubox
-      = fun () ->
+ : tti 'arg -> tti 'res -> tti ('arg -> 'res)
+ = fun ti_arg ti_res ->
+     let rec apply
+      : ubox -> ubox -> ubox
+      = fun ufunc uarg ->
           let ti_func = Lazy.force ti_lazy in
-          let func = ti_func#temp_get in
-          let arg = ta#temp_get in
-          let res = func arg in
-          ubox tb res
+          ubox ti_res ((uget_exn ti_func ufunc) (uget_exn ti_arg uarg))
      and
      ti_lazy = lazy (
-       (* todo: тут ta/tb развернуть, если они Dispatch_method *)
-       new ti_type_descd (Lambda (ta :> uti) (tb :> uti) do_apply)
+       (* todo: тут ti_arg/ti_res развернуть, если они Dispatch_method *)
+       new ti_type_descd (Lambda (ti_arg :> uti) (ti_res :> uti) apply)
      )
      in
        Lazy.force ti_lazy
 
 
 value expect_abs
- : uti -> ubox -> (uti * (unit -> ubox))
+ : uti -> ubox -> (uti * (ubox -> ubox -> ubox))
  = fun uti_arg ubox_func ->
      match ubox_func.ub_uti#type_desc with
-     [ Lambda exp_arg exp_res do_apply ->
+     [ Lambda exp_arg exp_res apply ->
          if uti_arg#type_id != exp_arg#type_id
          then
            failwith "Cdt.expect_abs: bad argument type"
          else
-           (exp_res, do_apply)
+           (exp_res, apply)
 
      | Simple _
      | Sum_type _
 
 value rec u_app
  : ubox -> ubox -> ubox
- = fun uf ua ->
-     let uti_a = ua.ub_uti in
-     let (exp_res, do_apply) = expect_abs uti_a uf
+ = fun ufunc uarg ->
+     let uti_arg = uarg.ub_uti in
+     let (exp_res, apply) = expect_abs uti_arg ufunc
      in
-       ( uf.ub_store UB_ST_Set
-       ; ua.ub_store UB_ST_Set
-       ; let res = do_apply () in
-         let () = uf.ub_store UB_ST_Clear
-         and () = ua.ub_store UB_ST_Clear
-         in
-         if exp_res#type_id != res.ub_uti#type_id
-         then failwith "u_app: bad result type"
-         else res
-       )
+     let res = apply ufunc uarg in
+     let () = assert (exp_res#type_id == res.ub_uti#type_id) in
+     res
 ;
 
 
   Printexc.register_printer
     (fun [ No (meth_name, uti) ->
              Some
-               (Printf.sprintf "Cdt.No: method %S on type %S"
+               (Printf.sprintf "Cdt.No: method %S on type %S (type_id=%i)"
                   meth_name
-                  (* (uti_type_name uti) *)
                   uti#type_name
+                  (uti#type_id :> int)
                )
          | _ -> None
          ])
  = fun uti meth_name uf ->
 (*
   let () =
-    Printf.printf "adding method %S to type %S\n%!"
-      meth_name uti#type_name
+    Printf.printf "adding method %S to type %S (type_id=%i)\n%!"
+      meth_name uti#type_name (uti#type_id :> int)
   in
 *)
   try
   with
   [ Meth_exists ->
       failwith
-        "can't add method %S to type %S (id=%i): method already exists"
+        "can't add method %S to type %S (type_id=%i): method already exists"
         meth_name
         (uti#type_name)
         (uti#type_id :> int)

File src/tlsArray.ml

-include TlsArray_st;

File src/tlsArray.mli

-(*
-  TlsArray is an array that has size, default value and allows
-  to set/get its items from any thread, giving each thread a
-  separate array to work with.
-  An unset items are assigned the default value.
- *)
-
-type t 'a;
-
-value make : int -> 'a -> t 'a;
-
-value length : t 'a -> int;
-
-value get : t 'a -> int -> 'a;
-
-value set : t 'a -> int -> 'a -> unit;
-
-(* returns current thread's array, which can be mutated in-place *)
-value get_array : t 'a -> array 'a;
-
-(* open this module to use the usual "arr.(i)" and "arr.(i) := x"
-   notation. *)
-module Ops
- :
-  sig
-    module Array
-     :
-      sig
-        value get : t 'a -> int -> 'a;
-        value set : t 'a -> int -> 'a -> unit;
-      end
-    ;
-  end
-;

File src/tlsArray_mt.ml

-(*
-implementation of multithreaded TlsArray
-*)

File src/tlsArray_st.ml

-(*
-implementation of singlethreaded TlsArray
-*)
-
-type t 'a = array 'a;
-
-value make = Array.make;
-
-value set = Array.set;
-
-value get = Array.get;
-
-value length = Array.length;
-
-value get_array x = x;
-
-module Ops
- =
-  struct
-    module Array
-     =
-      struct
-        value get = get;
-        value set = set;
-      end
-    ;
-  end
-;

File src/tlsRef.ml

-(* reference with semantics of TlsArray.t; built on TlsArray. *)
-
-type ref 'a = TlsArray.t 'a;
-type t 'a = ref 'a;
-
-value make x = TlsArray.make 1 x;
-
-value get r = TlsArray.get r 0;
-
-value set r x = TlsArray.set r 0 x;

File src/tlsRef.mli

-(* reference with semantics of TlsArray.t *)
-
-type ref 'a;
-type t 'a;
-
-value make : 'a -> ref 'a;
-
-value get : ref 'a -> 'a;
-
-value set : ref 'a -> 'a -> unit;

File test/test.ml

 open Typeinfo;
 
 
-
-
 (****************)
 
 value cdt_test1 () =
       test_values
 ;
 
-
 value my_ti_list_option_int = new List.ti my_ti_option_int ()
 ;