Commit 38cfb5a6 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-26 15:36:17 by afrisch] New compilation seems to work, but horribly slow...

Original author: afrisch
Date: 2004-12-26 15:36:18+00:00
parent 2ac2cab1
......@@ -34,9 +34,9 @@ let dispatcher2 brs =
match brs.brs_compiled2 with
| Some d -> d
| None ->
Format.fprintf Format.std_formatter "Start compilation...@.";
(* Format.fprintf Format.std_formatter "Start compilation...@."; *)
let x = Patterns.Compile2.make_branches brs.brs_input brs.brs in
Format.fprintf Format.std_formatter "Done.@.";
(* Format.fprintf Format.std_formatter "Done.@."; *)
brs.brs_compiled2 <- Some x;
x
......@@ -174,8 +174,9 @@ and eval_apply_tail_rec f arg =
and eval_branches env brs arg = eval_branches_old env brs arg
and eval_branches env brs arg =
and eval_branches_old env brs arg =
let (disp, rhs) = dispatcher brs in
let (code, bindings) = Run_dispatch.run_dispatcher disp arg in
match rhs.(code) with
......@@ -192,8 +193,8 @@ and eval_branches env brs arg =
v
| Patterns.Compile.Fail -> Value.Absent
(*
and eval_branches env brs arg =
and eval_branches_new env brs arg =
let (disp, rhs) = dispatcher2 brs in
let (code, bindings) = Run_dispatch.run_dispatcher2 disp arg in
match rhs.(code) with
......@@ -209,7 +210,6 @@ and eval_branches env brs arg =
sp := saved_sp;
v
| None -> Value.Absent
*)
and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e)
......
......@@ -165,8 +165,12 @@ and run_disp_kind actions v =
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) -> run_disp_string_latin1 i j s q actions
| String_utf8 (i,j,s,q) -> run_disp_string_utf8 i j s q actions
| String_latin1 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
run_disp_string_latin1 i j s q actions
| String_utf8 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
run_disp_string_utf8 i j s q actions
| Atom a -> make_result_basic v (Atoms.get_map a actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i ->
......@@ -366,7 +370,7 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false),
(match l with
(match r with
| SrcLeft -> v1 | SrcRight -> v2
| SrcFetchLeft i -> buf.(r1+i)
| SrcFetchRight i -> buf.(r2+i) | _ -> assert false))
......@@ -401,20 +405,20 @@ let rec run_dispatcher d v =
(* Format.fprintf Format.std_formatter "Matching (%a)@." Value.print v; *)
(* Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(* print_string "."; flush stdout; *)
incr count;
(* incr count;
print_int !count;
print_string "X"; flush stdout;
if !count = 9685 then
Format.fprintf Format.std_formatter "Matching (%a)@\n with:@\n%a@."
Value.print v
Patterns.Compile2.print_dispatcher d;
Patterns.Compile2.print_dispatcher d;*)
let res =
match actions d with
| AResult r -> make_result_basic v r
| AKind k -> run_disp_kind k v
in
print_string "Y"; flush stdout;
(* print_string "Y"; flush stdout;*)
res
and run_disp_kind actions v =
......@@ -422,10 +426,10 @@ and run_disp_kind actions v =
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) -> assert false
| String_latin1 (i,j,s,q) ->
run_disp_kind actions (Value.normalize v)
(* run_disp_string_latin1 i j s q actions *)
| String_utf8 (i,j,s,q) as v ->
print_string "N"; flush stdout;
run_disp_kind actions (Value.normalize v)
(* run_disp_string_utf8 i j s q actions *)
| Atom a -> make_result_basic v (Atoms.get_map a actions.atoms)
......@@ -439,7 +443,8 @@ and run_disp_kind actions v =
| Abstract (abs,_) ->
run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
actions.basic
| Absent -> assert false
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
| Delayed _ -> assert false
......@@ -471,25 +476,27 @@ and do_pushes v vl = function
| PushField :: rem -> push vl; do_pushes v vl rem
| PushCapture :: rem -> push v; do_pushes v vl rem
and do_record_tr sp other v vl fields (pushes,ct) =
print_string "*"; flush stdout;
and do_record_tr sp other v vl fields tr =
let (pushes,ct) = Lazy.force tr in
(* print_string "*"; flush stdout; *)
do_pushes v vl pushes;
run_disp_record sp other v fields ct
and run_disp_record sp other v fields = function
| RecordLabel (l,d,cts,abs) ->
| RecordLabel (l,d,cts) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l ->
do_record_tr sp other v vl rem cts.(run_dispatcher d vl)
| rem -> do_record_tr sp other v Absent rem abs
| rem ->
do_record_tr sp other v Absent rem cts.(run_dispatcher d Absent)
in
aux other fields
| RecordLabelSkip (l,pr,abs) ->
| RecordLabelSkip (l,pr) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 == l -> do_record_tr sp other v vl rem pr
| rem -> do_record_tr sp other v Absent rem abs
| rem -> do_record_tr sp other v Absent rem pr
in
aux other fields
| RecordResult r ->
......@@ -559,10 +566,10 @@ and run_disp_string_utf8_loop i j s q d =
*)
let run_dispatcher2 d v =
print_string "+"; flush stdout;
(* print_string "+"; flush stdout; *)
let code = run_dispatcher d v in
cursor := 0;
print_string "-\n"; flush stdout;
(* print_string "-\n"; flush stdout; *)
(code,!buffer)
......
......@@ -5,6 +5,7 @@ type Addr = <addr>[ PCDATA ];;
type Tel = <tel>[ PCDATA ];;
(*
<addrbook>[
<name>"Haruo Hosoya"
<addr>"Tokyo"
......@@ -14,22 +15,33 @@ type Tel = <tel>[ PCDATA ];;
<name>"Peter Buneman"
<addr>"Scotland"
];;
*)
(* converting an address book into a telephone list *)
fun mkTelList ([ (Name Addr Tel?)* ] -> [ (Name Tel)* ])
| [ <name>n <addr>a <tel>t ; rest] -> [ <name>n <tel>t ; mkTelList rest]
| [ <name>n <addr>a; rest] -> mkTelList rest
let mkTelList ([ (Name Addr Tel?)* ] -> [ (Name Tel)* ])
| [ <name>n <addr>_ <tel>t ; rest] -> [ <name>n <tel>t ; mkTelList rest]
| [ <name>_ <addr>_; rest] -> mkTelList rest
| [ ] -> [ ]
;;
mkTelList [
<name>"Haruo Hosoya"
<addr>"Tokyo"
<name>"Benjamin Pierce"
<addr>"Philadelphia"
<tel>"123-456-789"
<name>"Peter Buneman"
<addr>"Scotland"
];;
(*
fun mkTelList (Addrbook -> [ (Name Tel)* ])
<_>[ ( ( (x::Name) Addr (x::Tel) ) | _ )* ] -> x
;;
fun (Int -> Addrbook) x ->
fun (Int -> Addrbook) _ ->
<addrbook>[
<name>"Haruo Hosoya"
<addr>"Tokyo"
......@@ -41,7 +53,9 @@ fun (Int -> Addrbook) x ->
]
;;
*)
(*
match <addrbook>[
<name>"Haruo Hosoya"
<addr>"Tokyo"
......@@ -51,8 +65,8 @@ match <addrbook>[
<name>"Peter Buneman"
<addr>"Scotland"
] with
<_>[ ( ( (x::Name) Addr (x::Tel) ) | _ )* ] -> x;;
<_>[ ( ( (x::Name) Addr (x::Tel) ) | _ )* ] -> print (print_xml <doc>x);;
*)
(*
(*
(* the pattern extract the full sequence of subelements *)
......
......@@ -60,9 +60,19 @@ struct
let d1 = X1.diff d1 !resid in
if not (X1.is_empty d1) then add [] d1 d2 accu else accu)
else accu
(* Merge t1's with same t2 *)
let equiv t s = X2.is_empty (X2.diff t s) && X2.is_empty (X2.diff s t)
let cleanup l =
let rec aux accu (t1,t2) =
match accu with
| [] -> [ (t1,t2) ]
| (s1,s2) :: rem when equiv t2 s2 -> (X1.cup s1 t1, s2) :: rem
| (s1,s2) :: rem -> (s1,s2) :: (aux rem (t1,t2)) in
List.fold_left aux [] l
let boolean_normal x =
List.fold_left line [] x
cleanup (List.fold_left line [] x)
let boolean x =
List.fold_left (fun accu x -> (line [] x) @ accu) [] x
......
......@@ -327,7 +327,7 @@ module Print = struct
| Times (q1,q2) ->
Format.fprintf ppf "(%a,%a)" print q1.descr print q2.descr
| Xml (q1,{ descr = (_,_,Times(q2,q3)) }) ->
Format.fprintf ppf "<(%a) (%a)>(%a)" print q1.descr print q2.descr print q2.descr
Format.fprintf ppf "<(%a) (%a)>(%a)" print q1.descr print q2.descr print q3.descr
| Xml _ -> assert false
| Record (l,q) ->
Format.fprintf ppf "{%a=%a}" Label.print (LabelPool.value l) print q.descr
......@@ -1771,6 +1771,9 @@ x=(1,2)
let success pr =
capt pr TSucceed
let success_if_present pr =
capt pr (TConstr (Types.any,any_or_abs))
let rec conj a1 fv1 r1 r2 = match (r1,r2) with
| TSucceed,r | r,TSucceed -> r
| TFail,r | r,TFail -> TFail
......@@ -1834,8 +1837,8 @@ x=(1,2)
| Constr t -> TConstr (t, any_or_abs)
| Cup ((a1,_,_) as p1,p2) -> TAlt (p, a1,mk p1, mk p2)
| Cap ((a1,fv1,_) as p1,p2) -> TConj (a1,fv1,mk p1,mk p2)
| Capture x -> success (TargExpr.capture x)
| Constant (x,c) -> success (TargExpr.cst x c)
| Capture x -> success_if_present (TargExpr.capture x)
| Constant (x,c) -> success_if_present (TargExpr.cst x c)
| Times (q1,q2) ->
TTimes (`Normal,(incr uid; !uid), p, any_or_abs,fv,q1,q2)
| Xml (q1,q2) ->
......@@ -1846,7 +1849,13 @@ x=(1,2)
let constrain a t =
if Types.disjoint a t then TFail
else if Types.subtype t a then TSucceed
else if Types.subtype t a then (
(* Format.fprintf Format.std_formatter
"Optimize constraint -> Succeed a=%a t=%a@."
Types.Print.print a
Types.Print.print t; *)
TSucceed
)
else TConstr (a,t)
let approx_var p t xs f =
......@@ -1864,6 +1873,11 @@ x=(1,2)
let factorize ((a,_,_) as p) t xs f =
if Types.disjoint a t then TFail
else
(* let () = Format.fprintf Format.std_formatter
"Factorize p=%a t=%a a=%a@."
Print.print p
Types.Print.print t
Types.Print.print a in *)
let pr,xs = approx_var p t xs TargExpr.captures in
let pr',xs = approx_cst p t xs TargExpr.constants in
let pr = TargExpr.merge pr pr' in
......@@ -1894,8 +1908,16 @@ x=(1,2)
| TSucceed -> if Types.is_empty t then TFail else TSucceed
| TFail -> TFail
(*
let optimize t xs p =
let p' = optimize t xs p in
Format.fprintf Format.std_formatter
"Optimize %a // (t=%a) ===> %a@."
print p
Types.Print.print t
print p';
p'
*)
let fold f accu = function
| TCapt (_,p) -> f accu p
......@@ -1956,11 +1978,12 @@ x=(1,2)
let t1 = sel t12 in
if not ((Types.subtype s1 t1) || (Types.disjoint s1 t1))
then res := add_req !res (constr t1) s1 IdSet.empty in
let aux2 (t,s) = List.iter (aux3 (pi s)) (get t) in
let aux2 (t,s) = List.iter (aux3 (pi s)) (get (Types.cap t s)) in
let aux z =
let uid,t,xs,q = extract z in
let xs = IdSet.cap xs q.fv and p = q.descr and t = pi t in
(* let p = cap p (constr Types.any) in *)
let pr,xs = approx_var p t xs side in
let pr',xs = approx_cst p t xs TargExpr.constants in
let pr = TargExpr.merge pr pr' in
......@@ -1974,7 +1997,7 @@ x=(1,2)
!extra,!res
let prod_all k side pi sel selq reqs =
get_all pi (Types.Product.get ~kind:k) sel
get_all pi (fun t -> Types.Product.clean_normal (Types.Product.normal ~kind:k t)) sel
(fun (uid,t,xs,q1,q2) -> uid,t,xs,selq (q1,q2))
(iter_times k)
side
......@@ -1990,7 +2013,7 @@ x=(1,2)
let record_all l reqs =
let extra,res =
get_all (Types.Record.pi l) (fun t -> Types.Record.split t l) fst
get_all (Types.Record.pi l) (fun t -> Types.Record.split_normal t l) fst
(fun z -> z)
(iter_field l)
TargExpr.captures_left
......@@ -2074,12 +2097,12 @@ x=(1,2)
record: actions_record;
}
and actions_record =
| RecordLabel of label * dispatcher * record_tr array * record_tr
| RecordLabelSkip of label * record_tr * record_tr
| RecordLabel of label * dispatcher * record_tr array
| RecordLabelSkip of label * record_tr
| RecordResult of result
| RecordMore of result * result (* nomore, more *)
| RecordImpossible
and record_tr = (TargExpr.push list * actions_record)
and record_tr = (TargExpr.push list * actions_record) Lazy.t
and actions_prod =
| LeftRight of result dispatch dispatch
| RightLeft of result dispatch dispatch
......@@ -2113,18 +2136,21 @@ x=(1,2)
Ident.print x i) m;
Format.fprintf ppf ") ";) binds
let print_reqs ppf reqs =
List.iter
(fun (p,t,xs) ->
Format.fprintf ppf "%a. t=%a. xs=%a@."
Derivation.print p
Types.Print.print t
Print.print_xs xs) reqs
let print ppf r =
Format.fprintf ppf "disp_%i:@." r.id;
Array.iteri
(fun i (t,ar,binds) ->
Format.fprintf ppf "[%i]{%i}{%a} %a@." i ar print_binds binds Types.Print.print t
) r.outputs;
List.iter
(fun (p,t,xs) ->
Format.fprintf ppf "%a. t=%a. xs=%a@."
Derivation.print p
Types.Print.print t
Print.print_xs xs) r.reqs;
Array.iteri
(fun i (t,ar,binds) ->
Format.fprintf ppf "[%i]{%i}{%a} @." i ar print_binds binds (*Types.Print.print t*)
) r.outputs;
print_reqs ppf r.reqs;
()
let print_result ppf (code,a) =
......@@ -2214,16 +2240,16 @@ x=(1,2)
and print_field ppf = function
| RecordImpossible ->
Format.fprintf ppf "#"
| RecordLabel (l,d,cts,abs) ->
| RecordLabel (l,d,cts) ->
to_print d;
Format.fprintf ppf "(label:%a,disp_%i" print_lab l d.id;
Array.iteri (fun i x ->
Format.fprintf ppf ";%i->%a" i
print_record_tr x) cts;
Format.fprintf ppf ";abs:%a)" print_record_tr abs
| RecordLabelSkip (l,x,abs) ->
Format.fprintf ppf "(label:%a;%a;abs:%a)" print_lab l
print_record_tr x print_record_tr abs
print_record_tr (Lazy.force x)) cts;
Format.fprintf ppf ")"
| RecordLabelSkip (l,x) ->
Format.fprintf ppf "(label:%a;%a)" print_lab l
print_record_tr (Lazy.force x)
| RecordMore (nomore,more) ->
Format.fprintf ppf "[nomore:%a;more:%a]"
print_result nomore
......@@ -2268,12 +2294,13 @@ x=(1,2)
let disp_id = ref 0
let mk reqs =
let nb = ref (-1) in
let codes = ref [] in
let nb = ref (-1) in let codes = ref [] in
let rec aux t0 ar binds l =
if Types.is_empty t0 then RFail
else match l with
| [] -> incr nb; codes := (t0,ar,List.rev binds) :: !codes; RCode !nb
| [] ->
(* Printf.printf "nb=%i " !nb; flush stdout; *)
incr nb; codes := (t0,ar,List.rev binds) :: !codes; RCode !nb
| ((a,_,_),(t,xs)) :: rem ->
if Types.disjoint t t0
then RIgnore (aux t0 ar (None::binds) rem)
......@@ -2286,6 +2313,7 @@ x=(1,2)
ar (None::binds) rem)
in
let reqs = PatList.Map.get reqs in
(* Printf.printf "reqs:%i " (List.length reqs); flush stdout; *)
let t0 =
List.fold_left
(fun accu (_,(t,_)) -> Types.cup accu t) Types.empty
......@@ -2294,7 +2322,7 @@ x=(1,2)
let rc = aux t0 0 [] reqs in
let reqs =
List.map
(fun (p,(t,xs)) ->
(fun (p,(t,xs)) ->
(Derivation.mkopt p t xs, t, xs)) reqs in
let os = Array.of_list (List.rev !codes) in
{ id = (incr disp_id; !disp_id);
......@@ -2309,7 +2337,16 @@ x=(1,2)
let mk reqs =
try ReqTable.find disps reqs
with Not_found ->
(* print_endline "mk: START"; flush stdout;
List.iter
(fun (p,(t,xs)) ->
Format.fprintf Format.std_formatter "%a. t=%a. xs=%a@."
Print.print p
Types.Print.print t
Print.print_xs xs
) (PatList.Map.get reqs); *)
let d = mk reqs in
(* print_endline "mk: STOP"; flush stdout; *)
ReqTable.add disps reqs d;
d
......@@ -2405,6 +2442,9 @@ x=(1,2)
let extra1,reqs1 = Derivation.prod_all
k TargExpr.captures_left pi1 fst fst' reqs in
let second (t1,ar1,binds1) =
(* Printf.printf "second\n"; flush stdout;
Format.fprintf Format.std_formatter "Restrict t1=%a@."
Types.Print.print t1;*)
let t0 = restr1 t0 t1 in
let reqs = Derivation.opt_all t0 reqs in
let extra2,reqs2 =
......@@ -2434,7 +2474,6 @@ x=(1,2)
let all_labs = Derivation.all_labels reqs in
(* TODO: memoize the field function *)
let rec field t0 reqs locals labs =
(* Printf.printf "field (reste %i)\n" (List.length labs); flush stdout; *)
if Types.is_empty t0 then RecordImpossible
else
try RecordResult (mk_res r reqs)
......@@ -2455,19 +2494,7 @@ x=(1,2)
let aux = Derivation.push_csts pushes locals in
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
(List.rev !pushes, field t0 reqs !locals labs) in
(* absent *)
let absent =
let t0 = Types.cap t0
(Types.record l Types.Record.absent_node) in
let reqs = Derivation.opt_all t0 reqs in
cont t0 locals reqs in
let reqs0 = reqs in
(* present *)
let t0 = Types.cap t0 (Types.record l Types.any_node) in
let reqs = Derivation.opt_all t0 reqs in
let extra1,reqs1 = Derivation.record_all l reqs in
let contin (t1,ar1,binds1) =
let t0 = Types.cap t0 (Types.record l (Types.cons t1)) in
......@@ -2477,60 +2504,67 @@ x=(1,2)
let reqs = List.map (fun (p,t,xs) -> (aux p,t,xs)) reqs in
cont t0 (locals + ar1) reqs
in
let lazy_contin x =
(* print_string "CONTIN\n"; flush stdout;*)
lazy (contin x) in
if PatList.Map.is_empty reqs1
then
(* Check if present or absent does not matter *)
(* other possible algo: compare a posteriori the two continuations *)
let nomat = false in
(*
match absent with
| (_,RecordImpossible) -> true
| ([],_) ->
PatList.Map.is_empty
(snd (Derivation.record_all l reqs0))
| _ -> false in
*)
match contin (any_or_abs,0,[]) with
| ([],c) when nomat -> c
| x -> RecordLabelSkip (l,x,absent)
then RecordLabelSkip (l,lazy_contin (any_or_abs,0,[]))
else
let d = mk reqs1 in
RecordLabel (l, d, Array.map contin d.outputs, absent)
RecordLabel (l, d, Array.map lazy_contin d.outputs)
in
field t0 reqs 0 all_labs
(*
let count = ref 0
let record_disp r =
incr count;
Printf.printf "record_disp:START %i\n" !count; flush stdout;
if !count = 40 then
Format.fprintf Format.std_formatter "%a@." print r;
(* if !count = 42 then
Format.fprintf Format.std_formatter "%a@." print r; *)
let a = record_disp r in
print_string "record_disp:DONE\n"; flush stdout;
a
let times_disp x y r =
incr count;
Printf.printf "times_disp:START %i\n" !count; flush stdout;
if !count = 239 then
Format.fprintf Format.std_formatter "%a@." print r;
let a = times_disp x y r in
print_string "times_disp:DONE\n"; flush stdout;
a
let basic_disp r =
incr count;
Printf.printf "basic_disp:START %i\n" !count; flush stdout;
let a = basic_disp r in
print_string "basic_disp:DONE\n"; flush stdout;
a
*)
let compute_action r =
try AResult (mk_res r r.reqs)
with Derivation.NotAResult ->
let basic = basic_disp r in
let atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic) in
let chars = Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic) in
AKind
{ basic = basic;
atoms =
Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
chars =
Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
atoms = atoms;
chars = chars;
prod = times_disp `LeftRight `Normal r;
xml = times_disp `LeftRight `XML r;
record = record_disp r
}
(*
let compute_action r =
print_string "Compute_action:START\n"; flush stdout;
print_string "Compute_action:START\n"; flush stdout;
let a = compute_action r in
print_string "Compute_action:DONE\n"; flush stdout;
print_string "Compute_action:DONE\n"; flush stdout;
a
*)
let print_action ppf = function
| AKind a ->
......@@ -2553,7 +2587,7 @@ x=(1,2)
let actions r = match r.actions with
| Some a -> a
| None -> let a = compute_action r in
(*Format.fprintf Format.std_formatter "%a%a@." print r print_action a;*)
(* Format.fprintf Format.std_formatter "%a%a@." print r print_action a; *)
r.actions <- Some a; a