Commit a52e7583 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2003-03-16 11:35:09+00:00
parent eea1d6fb
......@@ -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 %)
......
......@@ -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)
......
(* 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))
*)
......@@ -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 =
......
......@@ -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 =
......
......@@ -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 =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment