[r2003-03-16 11:35:09 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-16 11:35:09+00:00

Makefile

@@ -46,6 +46,10 @@ PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
 OCAMLCP = ocamlc
 OCAMLC = ocamlfind $(OCAMLCP) -package $(PACKAGES)
 OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
+# extra options:  
+#    -inline 25 
+#    -p (profiling)
+#    -noassert
 
 DEPEND = $(DIRS:=/*.ml) $(DIRS:=/*.mli)
 INCLUDES = $(DIRS:%=-I %)

runtime/eval.ml

@@ -55,6 +55,8 @@ let rec eval env e0 =
     | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
     | Typed.Try (arg,brs) -> 
 	(try eval env arg with CDuceExn v -> eval_branches env brs v)
+    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (arg,brs)}]) -> 
+	eval_transform env brs (eval env arg) 
     | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
     | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
     | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
@@ -112,6 +114,11 @@ and eval_flatten = function
   | Pair (x,y) -> eval_concat x (eval_flatten y)
   | q -> q
 
+and eval_transform env brs = function
+  | Pair (x,y) -> eval_concat (eval_branches env brs x) (eval_transform env brs y)
+  | String (_,_,_,_) as v -> eval_transform env brs (normalize v)
+  | q -> q
+
 and eval_concat l1 l2 = match l1 with
   | Pair (x,y) -> Pair (x, eval_concat y l2)
   | String (s,i,j,q) -> String (s,i,j, eval_concat q l2)

runtime/run_dispatch.ml

 (* Running dispatchers *)
 
+(* Possible simple optimizations:
+     - in make_result_prod, see if buffer can be simply overwritten
+       (precompute this ...)
+*)
+
 open Value
 open Ident
 open Patterns.Compile
 
-(*
-module Array = struct
-  include Array
-  let get = unsafe_get
-end
-*)
+
+let buffer = ref (Array.create 127 Absent)
+let cursor = ref 0
+
+let blit a1 ofs1 a2 ofs2 len =
+  for i = 0 to len - 1 do
+    Array.unsafe_set a2 (ofs2 + i) (Array.unsafe_get a1 (ofs1 + i))
+  done
+
+
+let ensure_room n =
+  let l = Array.length !buffer in
+  if !cursor + n > l then
+    let buffer' = Array.create (l * 2 + n) Absent in
+    blit !buffer 0 buffer' 0 !cursor;
+    buffer := buffer'
+    
 
 let make_result_prod v1 r1 v2 r2 v (code,r) = 
-  let ret = Array.map
-    (function
-       | Catch -> v
-       | Const c -> const c
-       | Left i -> if (i < 0) then v1 else r1.(i)
-       | Right j -> if (j < 0) then v2 else r2.(j)
-       | Recompose (i,j) -> 
-	   Pair ((if (i < 0) then v1 else r1.(i)),
-		 (if (j < 0) then v2 else r2.(j)))
-    ) r in
-  (code,ret)
+  let n = Array.length r in
+  if n = 0 then code else (
+  ensure_room n;
+  let buf = !buffer in
+  for a = 0 to n - 1 do
+    let x = match Array.unsafe_get r a with
+      | Catch -> v
+      | Const c -> const c
+      | Left i -> if (i < 0) then v1 else buf.(r1 + i)
+      | Right j -> if (j < 0) then v2 else buf.(r2 + j)
+      | Recompose (i,j) -> 
+	  Pair ((if (i < 0) then v1 else buf.(r1 + i)),
+		(if (j < 0) then v2 else buf.(r2 + j))) 
+    in
+    buf.(!cursor + a) <- x
+  done;
+  (* if r1 <> !cursor then *) blit buf !cursor buf r1 n;
+  cursor := r1 + n;  (* clean space for GC ? *)
+  code )
 
 let make_result_basic v (code,r) = 
-  let ret = Array.map
-    (function
-       | Catch -> v
-       | Const c -> const c
-       | _ -> assert false
-    ) r in
-  (code,ret)
+  let n = Array.length r in
+  if n = 0 then code else (
+  ensure_room n;
+  let buf = !buffer in
+  for a = 0 to n - 1 do
+    let x = match Array.unsafe_get r a with
+      | Catch -> v
+      | Const c -> const c 
+      | _ -> assert false
+    in
+    buf.(!cursor + a) <- x
+  done;
+  code )
+
 
 let make_result_char ch (code,r) = 
-  let ret = Array.map
-    (function
-       | Catch -> Char ch
-       | Const c -> const c
-       | _ -> assert false
-    ) r in
-  (code,ret)
+  let n = Array.length r in
+  if n = 0 then code else (
+  ensure_room n;
+  let buf = !buffer in
+  for a = 0 to n - 1 do
+    let x = match Array.unsafe_get r a with
+      | Catch -> Char ch
+      | Const c -> const c
+      | _ -> assert false
+    in
+    buf.(!cursor + a) <- x
+  done;
+  code )
 
 let tail_string i j s q =
   if i + 1 = j then q else String (i + 1,j,s,q)
 
 let make_result_string i j s q r1 r2 (code,r) = 
-  let ret = Array.map
-    (function
-       | Catch -> String (i,j,s,q)
-       | Const c -> const c
-       | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else r1.(n)
-       | Right m -> if (m < 0) then tail_string i j s q else r2.(m)
-       | Recompose (n,m) -> 
-	   Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else r1.(n)),
-		 (if (m < 0) then tail_string i j s q else r2.(m)))
-    ) r in
-  (code,ret)
+  let n = Array.length r in
+  if n = 0 then code else (
+  ensure_room n;
+  let buf = !buffer in
+  for a = 0 to n - 1 do
+    let x = match Array.unsafe_get r a with
+      | Catch -> String (i,j,s,q)
+      | Const c -> const c
+      | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)
+      | Right m -> if (m < 0) then tail_string i j s q else buf.(r2 + m)
+      | Recompose (n,m) -> 
+	  Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)),
+		(if (m < 0) then tail_string i j s q else buf.(r2 + m))) 
+    in
+    buf.(!cursor + a) <- x
+  done;
+  blit buf !cursor buf r1 n;
+  cursor := r1 + n;
+  code )
 
 
 let rec run_disp_basic v f =  function
@@ -64,7 +109,7 @@ let rec run_disp_basic v f =  function
   | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
   | _ -> assert false
 
-let dummy_r = [||]
+let dummy_r = 0
 
 let rec run_dispatcher d v = 
 (*
@@ -90,9 +135,9 @@ and run_disp_kind actions v =
         actions.basic
   | Absent ->
       run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
-  | v ->
+(*  | v ->
       run_disp_kind actions (normalize v) 
-
+*)
 
 
 and run_disp_prod v v1 v2 = function
@@ -100,7 +145,8 @@ and run_disp_prod v v1 v2 = function
   | TailCall d1 -> run_dispatcher d1 v1
   | Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
   | Dispatch (d1,b1) ->
-      let (code1,r1) = run_dispatcher d1 v1 in
+      let r1 = !cursor in
+      let code1 = run_dispatcher d1 v1 in
       run_disp_prod2 v1 r1 v v2 b1.(code1)
 
 and run_disp_prod2 v1 r1 v v2 = function
@@ -108,7 +154,8 @@ and run_disp_prod2 v1 r1 v v2 = function
   | Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
   | TailCall d2 -> run_dispatcher d2 v2
   | Dispatch (d2,b2) ->
-      let (code2,r2) = run_dispatcher d2 v2 in
+      let r2 = !cursor in
+      let code2 = run_dispatcher d2 v2 in
       make_result_prod v1 r1 v2 r2 v b2.(code2)
 	    
 and run_disp_record other v fields = function
@@ -133,7 +180,8 @@ and run_disp_record1 other v1 rem = function
   | TailCall d1 -> run_dispatcher d1 v1
   | Ignore d2 ->  run_disp_record2 other v1 dummy_r rem d2
   | Dispatch (d1,b1) ->
-      let (code1,r1) = run_dispatcher d1 v1 in
+      let r1 = !cursor in
+      let code1 = run_dispatcher d1 v1 in
       run_disp_record2 other v1 r1 rem b1.(code1)
 
 and run_disp_record2 other v1 r1 rem = function
@@ -141,7 +189,8 @@ and run_disp_record2 other v1 r1 rem = function
   | Ignore r -> make_result_prod v1 r1 Absent dummy_r Absent r
   | TailCall d2 -> run_disp_record_loop other rem d2
   | Dispatch (d2,b2) ->
-      let (code2,r2) = run_disp_record_loop other rem d2 in
+      let r2 = !cursor in
+      let code2 = run_disp_record_loop other rem d2 in
       make_result_prod v1 r1 Absent r2 Absent b2.(code2)
 
 and run_disp_record_loop other rem d =
@@ -157,7 +206,8 @@ and run_disp_string i j s q actions =
     | TailCall d1 -> run_disp_string_char d1 (Chars.mk_char s.[i])
     | Ignore d2 -> run_disp_string2 dummy_r i j s q d2
     | Dispatch (d1,b1) ->
-	let (code1,r1) = run_disp_string_char d1 (Chars.mk_char s.[i]) in
+	let r1 = !cursor in
+	let code1 = run_disp_string_char d1 (Chars.mk_char s.[i]) in
 	run_disp_string2 r1 i j s q b1.(code1)
 and run_disp_string_char d ch =
   match actions d with
@@ -169,12 +219,37 @@ and run_disp_string2 r1 i j s q = function
       make_result_string i j s q r1 dummy_r r
   | TailCall d2 -> run_disp_string_loop i j s q d2
   | Dispatch (d2,b2) ->
-      let (code2,r2) = run_disp_string_loop i j s q d2 in
+      let r2 = !cursor in
+      let code2 = run_disp_string_loop i j s q d2 in
       make_result_string i j s q r1 r2 b2.(code2)
 and run_disp_string_loop i j s q d =
   match actions d with
     | AIgnore r -> make_result_basic Absent r
     | AKind k -> run_disp_string (succ i) j s q k
+
+let run_dispatcher d v =
+  let code = run_dispatcher d v in
+(* for unknown reasons, it seems to be faster to copy the intersting prefix... *)
+(*  cursor := 0;
+  (code,!buffer) *)
+  let r = Array.create !cursor Absent in
+  blit !buffer 0 r 0 !cursor;
+  cursor := 0;
+  (code,r)
+    
+
   
+(*
+let rec check_overwrite_aux r i =
+  if i < 0 then true
+  else match r.(i) with
+    | Right j | Recompose (_,j) -> 
+	if (j < 0) || (j >=i ) then check_overwrite_aux r (i - 1) else false
+    | _ -> check_overwrite_aux r (i - 1)
 
- (* TODO: finir d'implmenter les capture pour les string ... *)
+
+let check_overwrite r2 r =
+  (Array.length r2 = Array.length r) && (check_overwrite_aux r (Array.length r - 1))
+
+
+*)

types/atoms.ml

@@ -92,7 +92,10 @@ let equal t1 t2 = match (t1,t2) with
   
 
 
-(* TODO: optimize map lookup *)
+(* Optimize lookup:
+   - decision tree
+   - merge adjacent segment with same result
+*)
 type 'a map = (v * 'a) list * 'a option
 
 let mk_map l =

types/chars.ml

@@ -100,6 +100,10 @@ let print =
     )
 
 type 'a map = (int * 'a) list
+(* Optimize lookup:
+   - decision tree
+   - merge adjacent segment with same result
+*)
 
 let mk_map l =
   let m = 

types/types.ml

@@ -461,6 +461,7 @@ let rec iter_s s f = function
 let set s =
   s.status <- NEmpty;
   notify s.notify;
+(*  s.notify <- Nothing; *)
   raise NotEmpty
 
 let rec big_conj f l n =