Commit 3a5f2694 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-20 23:20:10 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-20 23:20:11+00:00
parent 1a96118d
......@@ -89,16 +89,14 @@ let debug ppf = function
List.iter (fun (x,t) ->
Format.fprintf ppf " %s:%a@\n" x
print_norm (Types.descr t)) f
| `Restrict (p,t) ->
Format.fprintf ppf "[DEBUG:restrict]@\n";
| `Compile2 (t,pl) ->
Format.fprintf ppf "[DEBUG:compile2]@\n";
let t = Typer.typ !glb_env t
and p = Typer.pat !glb_env p in
(* let f = Patterns.restrict (Patterns.descr p) (Types.descr t) in
(match f with
| `Pat q -> Format.fprintf ppf "Pat: %a@\n" Patterns.print q
| `Accept -> Format.fprintf ppf "Accept@\n"
| `Reject -> Format.fprintf ppf "Reject@\n") *)
Patterns.demo ppf (Patterns.descr p) (Types.descr t)
and pl = List.map (fun p -> (`Pat (Typer.pat !glb_env p), Types.any)) pl in
let d = Patterns.Compiler.make_dispatcher
(Types.descr t) pl in
Patterns.Compiler.print_disp ppf d
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@\n";
let p = Typer.pat !glb_env p in
......
......@@ -17,7 +17,7 @@ and debug_directive =
| `Accept of ppat
| `Compile of ppat * ppat list
| `Normal_record of ppat
| `Restrict of ppat * ppat
| `Compile2 of ppat * ppat list
]
......
......@@ -75,7 +75,7 @@ EXTEND
| LIDENT "accept"; p = pat -> `Accept p
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
| LIDENT "normal_record"; t = pat -> `Normal_record t
| LIDENT "restrict"; p = pat; t = pat -> `Restrict (p,t)
| LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
]
];
......
......@@ -178,16 +178,32 @@ let filter t p =
module Compiler =
struct
type p = [ `Pat of node | `Typ of Types.descr ]
type disp = {
did : int;
type dispatcher = {
did : int;
nb_codes : int;
results : res;
results : res;
t : Types.descr;
pats : (p,Types.descr) SortedMap.t;
mutable actions : actions option;
}
and bind = (capture, int) SortedMap.t
and res = [ `Return of int | `Fail | `Branch of (bind * res * res) ]
and res = [ `Return of Types.descr * int
| `Fail
| `Branch of (bind * res * res) ]
and 'a dispatch = dispatcher * 'a array
and actions = {
act_basic: basic_actions;
act_prod : prod_actions
}
and prod_actions = (int * prod_src list) dispatch dispatch
and basic_actions = (Types.descr * (int * basic_src list)) SortedList.t
and prod_src = [ `Capture | `Const of Types.const
| `Combine of int * int | `Left of int | `Right of int ]
and basic_src = [ `Capture | `Const of Types.const ]
type p = [ `Pat of node | `Typ of Types.descr ]
module DispMap = Map.Make(
struct
......@@ -202,7 +218,8 @@ struct
let rec make_res codes pos t l =
if Types.is_empty t then `Fail
else match l with
| [] -> incr codes; `Return (!codes - 1)
| [] ->
incr codes; `Return (t, !codes - 1)
| (p,restr)::rem ->
let (pos,bind,a) = match p with
| `Pat p ->
......@@ -212,23 +229,40 @@ struct
| `Typ a -> (pos,[],a)
in
let oth = Types.diff t restr in
(* Format.fprintf Format.std_formatter
"<<<%a>>>@\n" Types.Print.print_descr (Types.cap t a);
*)
(* assert (Types.subtype restr t);*)
let yes = make_res codes pos (Types.cup (Types.cap t a) oth) rem
and no = make_res codes pos (Types.cup (Types.diff t a) oth) rem in
`Branch (bind,yes,no)
let make_dispatcher t pats : disp =
let make_dispatcher t pats =
try DispMap.find (t,pats) !dispatchers
with Not_found ->
incr nb_disp;
let nbc = ref 0 in
let res = make_res nbc 0 t pats in
let d = { did = !nb_disp; results = res; nb_codes = !nbc } in
let d = { did = !nb_disp;
pats = pats;
t = t;
results = res;
nb_codes = !nbc;
actions = None } in
dispatchers := DispMap.add (t,pats) d !dispatchers;
d
let rec find_code accu = function
| (`Return (_,c),[]) ->
(c,List.rev accu)
| (`Branch (_,_,no),None::rem) ->
find_code accu (no,rem)
| (`Branch (_,yes,_),Some x::rem) ->
find_code (List.rev_append x accu) (yes,rem)
| _ -> assert false
let dispatcher t (args : (p * Types.descr * bind option ref) list) f =
let args =
List.map
......@@ -242,7 +276,7 @@ struct
let res = Array.create d.nb_codes (Obj.magic 0) in
let rec aux = function
| (`Fail,_) -> ()
| (`Return c, []) -> res.(c) <- f ()
| (`Return (t,c), []) -> res.(c) <- f t
| (`Branch (bind,yes,no), (_,(_,fl))::rem) ->
List.iter (fun r -> r := Some bind) fl; aux (yes,rem);
List.iter (fun r -> r := None) fl; aux (no,rem)
......@@ -283,18 +317,20 @@ struct
| (One,p) | (p,One) -> p
| (p1,p2) -> And (p1,p2)
(*
let atom s a p =
if Types.is_empty (Types.cap s a) then Zero else
Atom (s, p)
*)
let rec map f = function
| One -> One
| Zero -> Zero
| Capt x -> Capt x
| Const (x,c) -> Const (x,c)
| Alt (p1,p2) -> Alt (map f p1, map f p2)
| And (p1,p2) -> And (map f p1, map f p2)
| Atom a -> Atom (f a)
| Alt (p1,p2) -> alt (map f p1, map f p2)
| And (p1,p2) -> and_ (map f p1, map f p2)
| Atom a -> f a
let rec get f (a,_,d) s =
if Types.is_empty (Types.cap s a) then Zero
......@@ -315,49 +351,239 @@ struct
Const (x,c)
| d -> f d s
let prepare_prod =
let rec get_final f = function
| Atom x -> f x
| One -> Some []
| Zero -> None
| Capt x -> Some [x, `Capture]
| Const (x,c) -> Some [x, `Const c]
| Alt (p1,p2) ->
(match get_final f p1 with
| Some _ as x -> x
| None -> get_final f p2)
| And (p1,p2) ->
(match get_final f p1 with
| Some x ->
(match get_final f p2 with
| Some y -> Some (SortedMap.union_disj x y)
| None -> None)
| None -> None)
let get_final f p =
match get_final f p with
| None -> None
| Some l -> Some (List.map snd l)
let map_list f =
List.map (map f)
let pi1 d = Types.Product.pi1 (Types.Product.get d)
let pi2 d d1 = Types.Product.pi2 (Types.Product.restrict_1
(Types.Product.get d) d1)
let prepare_prod' =
get (fun d r ->
match d with
| Times (n1,n2) ->
let r = Types.Product.normal r in
Atom (`Pat (n1,n2,r))
| Constr t ->
Atom (`Typ (t,r))
Atom (`Typ (Types.cap t r,r))
| _ -> Zero
)
let dispatch_record t pats =
let pats = List.map (fun (p,restr) ->
match p with
| `Pat p -> prepare_prod (descr p) restr
| `Typ s -> Atom (`Typ (s,restr))
(* TODO: special case here ... restr<=t...*)
) pats in
(* Make dispatcher on first component *)
let prepare_prod (p,restr) =
match p with
| `Pat p -> prepare_prod' (descr p) restr
| `Typ s -> Atom (`Typ (s,restr))
(* TODO: special case here ... restr<=t...*)
let map_prod1 collect = function
| `Pat (n1,n2,r) ->
let fl = ref None in
collect := (`Pat n1,pi1 r,fl) :: !collect;
Atom (`Pat (fl, n2, r))
| `Typ (s,r) ->
let r1 = pi1 r in
let l =
List.map
(fun (s1,s2) ->
let fl = ref None in
collect := (`Typ s1,r1,fl) :: !collect;
(fl, s2)
) (Types.Product.normal s) in
(* would be ok with Types.Product.get ... *)
Atom (`Typ (l,r))
let map_prod2 t1 collect = function
| `Pat (fl1,n2,r) ->
(match !fl1 with
| None -> Zero
| Some bind ->
let fl2 = ref None in
collect := (`Pat n2, pi2 r t1,fl2) :: !collect;
Atom (`Pat (bind,fl2))
)
| `Typ (l,r) ->
let r2 = pi2 r t1 in
let l =
List.fold_left
(fun accu (fl1,s2) ->
match !fl1 with
| None -> accu
| Some bind ->
assert(bind = []);
let fl2 = ref None in
collect := (`Typ s2, r2, fl2) :: !collect;
fl2::accu
) [] l in
Atom (`Typ l)
let prod_final =
get_final (
function
| `Pat (bind1,{ contents = Some bind2 }) ->
let x =
SortedMap.combine
(fun x -> `Left x) (fun x -> `Right x)
(fun x y -> `Combine (x,y))
bind1 bind2
in
Some x
| `Typ l when List.exists (fun fl -> !fl <> None) l -> Some []
| _ -> None
)
let dispatch_prod (res:res) t (pats:(p*Types.descr) list) : prod_actions =
let pats = List.map prepare_prod pats in
let lefts = ref [] in
let pats =
List.map (map (
function
| `Pat (n1,n2,r) ->
let pat =
List.map (fun (r1,r2) ->
let fl = ref None in
lefts := (`Pat n1,r1,fl) :: !lefts;
(fl, n2, r2)
) r in
`Pat pat
| `Typ (s,r) ->
(*...*)
assert false
)) pats in
let (disp1,f1) = dispatcher
(Types.Product.pi1 (Types.Product.get t))
!lefts
(fun () -> 0)
let pats = map_list (map_prod1 lefts) pats in
dispatcher (pi1 t) !lefts
(fun t1 ->
let rights = ref [] in
let pats = map_list (map_prod2 t1 rights) pats in
dispatcher (pi2 t t1) !rights
(fun t2 ->
let pats = List.map prod_final pats in
find_code [] (res,pats)
)
)
let any_basic = Types.neg (List.fold_left Types.cup Types.empty
[Types.Product.any_xml;
Types.Product.any;
Types.Record.any])
let prepare_basic' =
get (fun d r ->
match d with
| Constr t -> Atom t
| _ -> Zero)
let prepare_basic (p,restr) =
match p with
| `Pat p -> prepare_basic' (descr p) restr
| `Typ s -> Atom s
let basic_final t =
get_final (
fun s ->
if Types.subtype t s then Some []
else (assert (Types.is_empty (Types.cap t s)); None)
)
let dispatch_basic res t pats : basic_actions =
let types = ref [] in
let rec aux = function
| `Fail -> ()
| `Branch (bind,yes,no) -> aux yes; aux no
| `Return (t,_) ->
let t = Types.cap t any_basic in
if not (Types.is_empty t) then types := t :: !types in
aux res;
let pats = List.map prepare_basic pats in
List.map
(fun t ->
let pats = List.map (basic_final t) pats in
(t, find_code [] (res,pats))
) !types
let get_actions disp =
match disp.actions with
| Some a -> a
| None ->
let a = {
act_basic = dispatch_basic disp.results disp.t disp.pats;
act_prod = dispatch_prod disp.results disp.t disp.pats
} in
disp.actions <- Some a;
a
let to_print = ref ([] : dispatcher list)
let printed = ref ([] : dispatcher list)
let print_act_basic ppf b =
List.iter
(fun (d,(code,bind)) ->
Format.fprintf ppf "| %a -> %i( "
Types.Print.print_descr d
code;
List.iter
(function
| `Capture ->
Format.fprintf ppf "v "
| `Const c ->
Format.fprintf ppf "%a " Types.Print.print_const c)
bind;
Format.fprintf ppf ")@\n"
) b
let print_act_prod ppf (disp1,b1) =
Format.fprintf ppf "| (v1,v2) -> match v1 with disp%i@\n" disp1.did;
to_print := disp1 :: !to_print;
for i = 0 to Array.length b1 - 1 do
let (disp2,b2) = b1.(i) in
to_print := disp2 :: !to_print;
Format.fprintf ppf " | %i(l) -> match v2 with disp%i@\n" i disp2.did;
for j = 0 to Array.length b2 - 1 do
let (code,bind) = b2.(j) in
Format.fprintf ppf " | %i(r) -> %i(" j code;
List.iter
(function
| `Capture ->
Format.fprintf ppf "v "
| `Const c ->
Format.fprintf ppf "%a " Types.Print.print_const c
| `Left x ->
Format.fprintf ppf "l%i " x
| `Right x ->
Format.fprintf ppf "r%i " x
| `Combine (x,y) ->
Format.fprintf ppf "(l%i,r%i) " x y
)
bind;
Format.fprintf ppf ")@\n"
done;
done
let rec print_disp ppf disp =
Format.fprintf ppf "Dispatcher [%i]: 0..%i@\n" disp.did (disp.nb_codes - 1);
let a = get_actions disp in
print_act_basic ppf a.act_basic;
print_act_prod ppf a.act_prod;
let rec loop () =
match !to_print with
| [] -> ()
| d::q ->
to_print := q;
if List.memq d !printed then loop ()
else (printed := d :: !printed; print_disp ppf d)
in
()
loop ()
(*
let rec collect typ f (a,_,d) s =
......
......@@ -37,6 +37,14 @@ val demo: Format.formatter -> descr -> Types.descr -> unit
val accept : node -> Types.node
val filter : Types.descr -> node -> (capture,Types.node) SortedMap.t
module Compiler: sig
type p = [ `Pat of node | `Typ of Types.descr ]
type dispatcher
val make_dispatcher : Types.descr -> (p,Types.descr) SortedMap.t -> dispatcher
val print_disp: Format.formatter -> dispatcher -> unit
end
(* Pattern matching: compilation *)
module Compile: sig
......
......@@ -30,6 +30,15 @@ let rec union_disj l1 l2 =
| ([],l2) -> l2
| (l1,[]) -> l1
let rec combine f1 f2 f12 l1 l2 =
match (l1,l2) with
| (x1,y1)::q1, (x2,y2)::q2 ->
let c = compare x1 x2 in
if c = 0 then (x1,(f12 y1 y2))::(combine f1 f2 f12 q1 q2)
else if c < 0 then (x1, f1 y1)::(combine f1 f2 f12 q1 l2)
else (x2, f2 y2)::(combine f1 f2 f12 l1 q2)
| ([],q2) -> List.map (fun (x2,y2) -> (x2,f2 y2)) l2
| (l1,[]) -> List.map (fun (x1,y1) -> (x1,f1 y1)) l1
let rec map f = function
| [] -> []
......
......@@ -3,6 +3,9 @@ val union: ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val unioni: ('a -> 'b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val union_disj: ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val combine: ('b -> 'd) -> ('c -> 'd) -> ('b -> 'c -> 'd) ->
('a,'b) t -> ('a,'c) t -> ('a,'d) t
val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t
......
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