Commits

camlspotter committed d35fa44

refactor Smemo + Stoken

  • Participants
  • Parent commits ab38d72

Comments (0)

Files changed (6)

File lib/OMakefile

    pmemo
    pstate
    pfile
+   stoken
    op_prec
 
 LIB = planck

File lib/pbuffer.mli

 end
 
 
-module Extend(Sbuffer : sig
+module Extend(SBase : sig
   include Stream_intf.S with type Elem.t = char
                         and  type Pos.t = Position.File.t
   val substr : t -> int -> int -> string * t
   val takeWhile : (char -> bool) -> t -> string * t
   val bytes : t -> int
-end)(Base : Planck_intf.S 
-     with type Str.desc   = Sbuffer.desc (* I want to say Str.t = Sbuffer.t but not possible *)
+end)(PBase : Planck_intf.S 
+     with type Str.desc   = SBase.desc (* I want to say Str.t = SBase.t but not possible *)
      and  type Str.Elem.t = char
      and  type Str.Pos.t  = Position.File.t
-     and  type Str.Attr.t = Sbuffer.Attr.t )
-  : X with type 'a t := 'a Base.t
+     and  type Str.Attr.t = SBase.Attr.t )
+  : X with type 'a t := 'a PBase.t
 
 
-module Make(Sbuffer : sig
+module Make(SBase : sig
   include Stream_intf.S with type Elem.t = char
                         and  type Pos.t = Position.File.t
   val substr : t -> int -> int -> string * t
   val bytes : t -> int
 end) : sig
   include Pbase.S 
-    with type Str.desc   = Sbuffer.desc (* I want to say Str.t = Sbuffer.t but not possible *)
+    with type Str.desc   = SBase.desc (* I want to say Str.t = SBase.t but not possible *)
     and  type Str.Elem.t = char
     and  type Str.Pos.t  = Position.File.t
-    and  type Str.Attr.t = Sbuffer.Attr.t
-    and  type error = Sbuffer.Pos.t * string
-    and  type 'a t = Sbuffer.t -> ('a * Sbuffer.t, Sbuffer.Pos.t * string (* =error *)) Result.t
-  include X with type 'a t := 'a Pbase.Make(Sbuffer).t
+    and  type Str.Attr.t = SBase.Attr.t
+    and  type error = SBase.Pos.t * string
+    and  type 'a t = SBase.t -> ('a * SBase.t, SBase.Pos.t * string (* =error *)) Result.t
+  include X with type 'a t := 'a Pbase.Make(SBase).t
 end

File lib/pfile.mli

   include Pbase.S with type Str.desc   = Stream.desc
                   and  type Str.Elem.t = char
                   and  type Str.Pos.t  = Position.File.t
-                  and  type Str.desc   = Stream.desc
                   and  type Str.Attr.t = Stream.Attr.t
                   and  type error = Stream.Pos.t * string
                   and  type 'a t = 'a t

File lib/smemo.ml

+open Spotlib.Spot
 open Result
 
 type memo_result = (Obj.t, exn) Result.t
+type memo = (int, memo_result) Hashtbl.t
+let create () = Hashtbl.create 31 (* We should not have so many input tokens *)
 
-module Extend(Base : sig
+module type X = sig
+  type stream
+  module Memo : sig
+    type 'a t  (* abstract memoized function *)
+    val register : (stream -> 'a) -> 'a t
+    val call : 'a t -> stream -> 'a
+  end
+end
+
+module type S = sig
   include Stream_intf.S
-  module Memo : Hashtbl.S
-  val memo : t -> memo_result Memo.t
-end) = struct
+  include X with type stream := t
+end                            
+
+module Extend
+  (Base : sig
+    include Stream_intf.S
+    val memo : Attr.t -> memo
+  end) = struct
+
   open Base
 
-  type _t = (Obj.t, exn) Result.t Memo.t
+  module Memo = struct
 
-  (* CR jfuruse: key equality is by polymoprhic equal!!! 
-     Possible bottle neck!
-  *)
-  (* key uniqueness is the user's responsibility *)
-  let memoize (key : Memo.key) (f : (Base.t -> 'a)) (str : Base.t) : 'a =
-    let m = memo str in
-    let res = 
-      try Memo.find m key with
-      | Not_found ->
-          let res = 
-            try Ok (Obj.repr (f str)) with
-            | exn -> Error exn
-          in
-          Memo.replace m key res;
-          res
-    in
-    match res with
-    | Ok res -> Obj.obj res (* Type safe! Only if the key is unique... *)
-    | Error exn -> raise exn
+    type 'a t = int * (Base.t -> 'a)
+  
+    let cntr = ref 0
+  
+    let register (f : (Base.t -> 'a)) : 'a t = 
+      incr cntr;
+      if !cntr > 1000 then assert false; (* Too much memoization. Something must be wrong! *) 
+      (!cntr, f)
+  
+    let call (id, f) str =
+      let m = memo (attr str) in
+      let res = 
+        try Hashtbl.find m id with
+        | Not_found ->
+            let res = 
+              try Ok (Obj.repr (f str)) with
+              | exn -> Error exn
+            in
+            Hashtbl.replace m id res;
+            res
+      in
+      match res with
+      | Ok res -> Obj.obj res
+      | Error exn -> raise exn
+  end
 
 end
+
+module Make(Base : sig
+  include Stream_intf.S
+  val memo : Attr.t -> memo
+end) = struct
+  include Base
+  include Extend(Base)
+end
+

File lib/smemo.mli

     This module is very preliminary.
 *)
 
-(** Extend(Base) extends Base with memoization over each stream element.
-    Typical usage is:
+type memo (** Abstract type for memoization table *)
+val create : unit -> memo (** Create an empty memo table *)
 
-    module MyStream = struct
-      module Base = ... (* creation of Base *)
-      include Base
-      include Smemo.Extend(Base)
-    end
+module type X = sig
+  type stream
+  module Memo : sig
+    type 'a t  (* abstract memoized function *)
+    val register : (stream -> 'a) -> 'a t
+    val call : 'a t -> stream -> 'a
+  end
+end
 
-    See a use example in ocaml/token.ml
-*)
-
-type memo_result = (Obj.t, exn) Result.t
-(** Type unsafe representation of generic memoization table *)
+module type S = sig
+  include Stream_intf.S
+  include X with type stream := t
+end                            
 
 module Extend(Base : sig
   include Stream_intf.S
-  module Memo : Hashtbl.S (** Memo is hashtable *)    
-  val memo : t -> memo_result Memo.t
-  (** Memo table must be attached to each stream position, and it must be retrievable. *)    
-end) : sig
-  open Base
-  val memoize : Memo.key -> (t -> 'a) -> t -> 'a
-  (** [memoize key f] creates memoized version of function [f] with [key]. 
-      Function identification is not by the pointer equality of functions, but keys.
+  val memo : Attr.t -> memo
+  (** Each attribute of stream element must have a [memo] table, 
+      which must be created by [create ()].
+
+      Note that each stream element must have independent [memo] value.
+      Sharing memo tables between stream elements causes unexpected result
+      at [Memo.call].
   *)
-end
+end) : X with type stream := Base.t
+
+module Make(Base : sig
+  include Stream_intf.S
+  val memo : Attr.t -> memo
+end) : S with type desc   = Base.desc
+         and  type Elem.t = Base.Elem.t
+         and  type Pos.t  = Base.Pos.t
+         and  type Attr.t = Base.Attr.t
+

File lib/stoken.ml

+(** Stream of parser result, i.e. results of a lowr parser, or a lexer.
+   With memoization.
+*)
+
+module Make(P : sig 
+  include Planck_intf.S
+  val run : 'a t -> Str.t -> ('a * Str.t, error) Result.t
+end)(Elem : Elem.S)= struct
+
+  module Base = struct
+    module Elem = Elem
+    module Pos = P.Str.Pos
+    module Attr = struct
+      type t = { last_position : Pos.t option (* last consumed token position *);
+                 position      : Pos.t;
+                 memo          : Smemo.memo
+               }
+      let position t = t.position
+      let last_position t = t.last_position
+      let memo t = t.memo
+    end
+  end
+
+  module Str = Stream.Make(Base)
+  include Str
+
+  include Smemo.Extend(struct
+    include Str
+    let memo = Base.Attr.memo
+  end)
+
+  open Base
+
+  let create (m : ('a option * Pos.t) P.t) = fun st ->
+    let rec f last_pos st = lazy begin
+      match P.run m st with
+      | Result.Ok ((None, pos), _st') -> 
+          null_desc { Attr.last_position = last_pos; 
+                      position      = pos; 
+                      memo          = Smemo.create () } (* EOS case *)
+      | Result.Ok ((Some v, pos), st') -> 
+          cons_desc v { Attr.last_position = last_pos;
+                        position = pos;
+                        memo = Smemo.create () } (f (Some pos) st')
+      | Result.Error (pos, s) -> raise (P.Critical_error (pos, s))
+    end
+    in
+    f None st
+  ;;
+
+  let last_position st : Pos.t option = Base.Attr.last_position (attr st)
+end
+
+
+