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

[r2002-10-25 19:16:26 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-25 19:16:27+00:00
parent ba33b148
......@@ -143,6 +143,8 @@ struct
| `Dispatch of (nf * record) list
| `Label of Types.label * (nf * record) list * record ]
type normal = {
nfv : fv;
na : Types.descr;
nbasic : Types.descr nline;
nprod : (nf * nf) nline;
nrecord: record nline
......@@ -184,7 +186,7 @@ struct
SortedMap.from_list Types.cup m
in
let merge_basic () () = ()
and merge_prod (p1,q1) (p2,q2) = slcup p1 p1, slcup q1 q2
and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
{ v = SortedList.cup nf1.v nf2.v;
a = Types.cap nf1.a nf2.a;
......@@ -271,27 +273,6 @@ struct
let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
module Dispatch = struct
type t = {
fv : fv list;
masks : (mask * int) list;
basic : (Types.descr * (result option list)) list;
prod : prod;
record: record option;
}
and prod = disp * (mask * disp * (mask * prod_result) list) list
and prod_result = (result * (int * int)) option list
and record =
[ `Label of Types.label * disp * (mask * record) list * record option
| `Result of record_result ]
and record_result = (result * (Types.label * int) list) option list
and mask = bool list
and disp = Types.descr * nf SortedList.t
end
let normal nf =
let basic =
List.map (fun ((res,()),acc) -> (res,acc))
......@@ -331,11 +312,452 @@ struct
| x -> (res,x) :: accu in
List.fold_left line []
in
{ nbasic = basic nf.basic;
{ nfv = nf.v;
na = nf.a;
nbasic = basic nf.basic;
nprod = prod nf.prod;
nrecord = record nf.record;
}
module Disp = struct
type actions = {
basic: (Types.descr * result) list;
prod: result dispatch dispatch;
record: record option;
}
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result ]
and 'a dispatch = dispatcher * 'a array
and result = int * source list
and source =
[ `Catch | `Const of Types.const
| `Left of int | `Right of int | `Recompose of int * int
| `Field of Types.label * int
]
and dispatcher = {
id : int;
t : Types.descr;
pl : normal array;
interface : (Types.descr * int * (capture, int) sm option array) array;
mutable actions : actions option
}
let cur_id = ref 0
module DispMap = Map.Make(
struct
type t = Types.descr * normal array
let compare = compare
end
)
let dispatchers = ref DispMap.empty
let dispatcher t pl : dispatcher =
try DispMap.find (t,pl) !dispatchers
with Not_found ->
let res = ref [] in
let rec aux t bindings arity i =
if Types.non_empty t
then
if i = Array.length pl
then res := (t, arity, Array.of_list (List.rev bindings)) :: !res
else
let p = pl.(i) in
aux (Types.cap t p.na) (Some (num arity p.nfv) :: bindings)
(arity + (List.length p.nfv)) (i+1);
aux (Types.diff t p.na) (None :: bindings) arity (i+1)
in
aux t [] 0 0;
let res = { id = !cur_id;
t = t;
pl = pl;
interface = Array.of_list !res;
actions = None } in
incr cur_id;
dispatchers := DispMap.add (t,pl) res !dispatchers;
res
let flatten pl =
let accu = ref [] and idx = ref [] in
let aux i x = accu := x :: !accu; idx := i :: !idx in
Array.iteri (fun i -> List.iter (aux i)) pl;
Array.of_list !idx,
Array.of_list !accu
let collect f pl =
let accu = ref [] in
let aux (res,x) = try accu := (f x) :: !accu with Exit -> () in
Array.iter (List.iter aux) pl;
SortedList.from_list (!accu)
let rec find_uniq f = function
| [] -> None
| (res,x) :: rem -> if (f x) then Some res else find_uniq f rem
let compare_masks a1 a2 =
try
for i = 0 to Array.length a1 - 1 do
match a1.(i),a2.(i) with
| None,Some _| Some _, None -> raise Exit
| _ -> ()
done;
true
with Exit -> false
let find_code (d : dispatcher) a =
let rec aux i =
if i = Array.length d.interface
then raise Not_found
else
match d.interface.(i) with
| (_,_,m) when compare_masks m a -> i
| _ -> aux (i + 1) in
aux 0
let conv_source_basic = function
| (`Catch | `Const _) as x -> x
| _ -> assert false
let create_result f pl =
let res = ref [] in
Array.iter
(function
| Some b -> List.iter (fun x -> res := f x :: !res) b
| None -> ()
) pl;
List.rev !res
let filter f = Array.map (find_uniq f)
let dispatch_basic d : (Types.descr * result) list =
let pl = Array.map (fun p -> p.nbasic) d.pl in
let tests = collect (fun x -> x) pl in
let t = Types.cap any_basic d.t in
let accu = ref [] in
let rec aux t l =
if Types.non_empty t
then match l with
| [] ->
let pl = filter (Types.subtype t) pl in
let code = find_code d pl in
let res = create_result (fun (v,s) -> conv_source_basic s) pl in
accu := (t, (code,res)) :: !accu
| ty :: rem -> aux (Types.cap t ty) rem; aux (Types.diff t ty) rem
in
aux t tests;
!accu
let get_tests pl f t d =
let accu = ref [] in
let unselect = Array.create (Array.length pl) [] in
let aux i x =
let yes, no = f x in
List.iter (fun (p,info) ->
let p = normal (restrict t p) in
accu := (p,[i, info]) :: !accu
) yes;
unselect.(i) <- no @ unselect.(i) in
Array.iteri (fun i -> List.iter (aux i)) pl;
let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
let infos = Array.map snd sorted in
let disp = dispatcher t (Array.map fst sorted) in
let result (t,arity,m) =
let selected = Array.create (Array.length pl) [] in
let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
Array.iteri
(fun j -> function Some r -> List.iter (add r) infos.(j) | None -> ())
m;
d t selected unselect
in
let res = Array.map result disp.interface in
(disp,res)
let conv_source_prod left right (v,s) = match s with
| (`Catch | `Const _) as x -> x
| `Left ->
(*
Printf.eprintf "Left %s\n" v;
List.iter (fun (v,i) -> Printf.eprintf " LEFT(%s => %i)\n" v i) left;
List.iter (fun (v,i) -> Printf.eprintf " RIGHT(%s => %i)\n" v i) right;
flush stderr;
*)
`Left (List.assoc v left)
| `Right -> `Right (List.assoc v right)
| `Recompose -> `Recompose (List.assoc v left, List.assoc v right)
| _ -> assert false
let rec dispatch_prod disp : (result dispatch dispatch) =
(*
Printf.eprintf "dispatch_prod %i: " disp.id;
Array.iteri (fun i p ->
Printf.eprintf "(%i:" i;
List.iter (fun v -> Printf.eprintf "%s" v) p.nfv;
Printf.eprintf ")";
) disp.pl;
Printf.eprintf "\n";
flush stderr;
*)
let pl = Array.map (fun p -> p.nprod) disp.pl in
let t = Types.Product.get disp.t in
get_tests pl
(fun (res,(p,q)) -> [p, (res,q)], [])
(Types.Product.pi1 t)
(dispatch_prod1 disp t)
and dispatch_prod1 disp t t1 pl _ =
let t = Types.Product.restrict_1 t t1 in
get_tests pl
(fun (ret1, (res,q)) -> [q, (ret1,res)], [] )
(Types.Product.pi2 t)
(dispatch_prod2 disp t)
and dispatch_prod2 disp t t2 pl _ =
let aux_final = function
| [] -> None
| [(ret2, (ret1, res))] ->
Some (List.map (conv_source_prod ret1 ret2) res)
| _ -> assert false in
let final = Array.map aux_final pl in
let code = find_code disp final in
let ret = create_result (fun s -> s) final in
(code,ret)
let dummy_label = Types.label ""
let collect_first_label pl =
let f = ref true and m = ref dummy_label in
let aux = function
| (res, _, `Label (l, _, _)) ->
if (!f) then (f := false; m := l) else if (l < !m) then m:= l;
| _ -> () in
Array.iter (List.iter aux) pl;
if !f then None else Some !m
let map_record f =
let rec aux = function
| [] -> []
| h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
Array.map aux
let label_found l =
map_record
(function
| (res, catch, `Label (l1, pr, _)) when l1 = l ->
(res, catch, `Dispatch pr)
| x -> x)
let label_not_found l =
map_record
(function
| (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
| x -> x)
let conv_source_record catch (v,s) = match s with
| (`Catch | `Const _) as x -> x
| `Field l -> `Field (l, List.assoc v (List.assoc l catch))
| _ -> assert false
let rec dispatch_record disp : record option =
let prep p = List.map (fun (res,r) -> (res,[],r)) p.nrecord in
let pl0 = Array.map prep disp.pl in
let t = Types.Record.get disp.t in
dispatch_record_opt disp t pl0
and dispatch_record_opt disp t pl =
if Types.Record.is_empty t then None
else Some (dispatch_record_label disp t pl)
and dispatch_record_label disp t pl =
match collect_first_label pl with
| None ->
let aux_final = function
| [(res, catch, `Success)] ->
Some (List.map (conv_source_record catch) res)
| [] -> None
| _ -> assert false in
let final = Array.map aux_final pl in
let code = find_code disp final in
let ret = create_result (fun s -> s) final in
`Result (code,ret)
| Some l ->
let present =
let pl = label_found l pl in
let t = Types.Record.restrict_label_present t l in
get_tests pl
(function
| (res,catch, `Dispatch d) ->
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t)
in
let absent =
let pl = label_not_found l pl in
let t = Types.Record.restrict_label_absent t l in
dispatch_record_opt disp t pl
in
`Label (l, present, absent)
and dispatch_record_field l disp t tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
let pl = Array.map (List.map aux) pl in
Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
dispatch_record_label disp t pl
let actions disp =
match disp.actions with
| Some a -> a
| None ->
let a = {
basic = dispatch_basic disp;
prod = dispatch_prod disp;
record = dispatch_record disp;
} in
disp.actions <- Some a;
a
let to_print = ref []
let printed = ref []
let queue d =
if not (List.mem d.id !printed) then (
printed := d.id :: !printed;
to_print := d :: !to_print
)
let print_actions ppf actions =
let print_source ppf = function
| `Catch -> Format.fprintf ppf "v"
| `Const c -> Types.Print.print_const ppf c
| `Left i -> Format.fprintf ppf "l%i" i
| `Right j -> Format.fprintf ppf "r%i" j
| `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
| `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
in
let rec print_result ppf = function
| [] -> ()
| [s] -> print_source ppf s
| s::rem -> Format.fprintf ppf "%a," print_source s; print_result ppf rem
in
let print_ret ppf (code,ret) =
Format.fprintf ppf "$%i(%a)" code print_result ret in
let print_lhs ppf (code,prefix,d) =
let arity = match d.interface.(code) with (_,a,_) -> a in
Format.fprintf ppf "$%i(" code;
for i = 0 to arity - 1 do
if i > 0 then Format.fprintf ppf ",";
Format.fprintf ppf "%s%i" prefix i;
done;
Format.fprintf ppf ")" in
let print_basic (t,ret) =
Format.fprintf ppf " | %a ->%a@\n"
Types.Print.print_descr t
print_ret ret
in
let print_prod2 (d,rem) =
queue d;
Format.fprintf ppf " match v2 with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> %a\n"
print_lhs (code, "r", d)
print_ret r;
)
rem
in
let print_prod (d,rem) =
if Array.length rem > 0 then (
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | %a -> @\n"
print_lhs (code, "l", d);
print_prod2 d2;
)
rem
)
in
let rec print_record_opt ppf = function
| None -> ()
| Some r ->
Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| `Result r -> print_ret ppf r
| `Label (l, (d,present), absent) ->
let l = Types.label_name l in
queue d;
Format.fprintf ppf " check label %s:@\n" l;
Format.fprintf ppf " Present => match with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> @\n"
print_lhs (code, l, d);
Format.fprintf ppf " @[%a@]@\n"
print_record r
) present;
match absent with
| Some r ->
Format.fprintf ppf " Absent => @[%a@]@\n"
print_record r
| None -> ()
in
List.iter print_basic actions.basic;
print_prod actions.prod;
print_record_opt ppf actions.record
let rec print_dispatchers ppf =
match !to_print with
| [] -> ()
| d :: rem ->
to_print := rem;
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print_descr d.t;
(*
Array.iteri
(fun code (t, arity, m) ->
Format.fprintf ppf " $%i(arity=%i) accepts [%a]"
code arity
Types.Print.print_descr t;
Array.iter
(function
| None -> Format.fprintf ppf " None"
| Some b ->
Format.fprintf ppf " Some(";
List.iter
(fun (v,i) -> Format.fprintf ppf "%s=>%i;" v i)
b;
Format.fprintf ppf ")"
) m;
Format.fprintf ppf "@\n";
)
d.interface;
*)
Format.fprintf ppf "disp_%i = function@\n" d.id;
print_actions ppf (actions d);
print_dispatchers ppf
let show ppf t pl =
let disp = dispatcher t pl in
queue disp;
print_dispatchers ppf
end
(***************************************************************
let collect f pp =
let aux accu (res,x) = (f x) :: accu in
SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)
......@@ -350,6 +772,40 @@ struct
let extract_unique f l = get_option (map_map f l)
(* Could optimize to extract directly the first (and single) *)
module Dispatch = struct
type t = {
id : int;
fv : fv list;
masks : (mask * (int * int * (capture, int) sm option array)) list;
basic : (Types.descr * (result option list)) list;
prod : prod;
record: record option;
mutable basic' : (Types.descr * result') list option;
mutable prod' : result' disp' disp' option
}
and prod = prod_result disp disp
and prod_result = (result * (int * int)) option list
and record =
[ `Label of Types.label * record disp * record option
| `Result of record_result ]
and record_result = (result * (Types.label * int) list) option list
and mask = bool list
and 'a disp = (Types.descr * nf SortedList.t) * (mask * 'a) list
and 'a disp' = t * (int * 'a) list
and result' = int * source' list
and source' =
[ `Catch | `Const of Types.const
| `Left of int | `Right of int | `Recompose of int * int
| `Field of Types.label * int
]
end
(* Basic (and arrow) types *)
let filter_basic ty =
......@@ -415,7 +871,7 @@ struct
let tests = collect (fun (_,q)-> q) pl in
let disp = aux_prod2 t pl [] [] [] 0 tests in
let mask = List.rev mask in
(mask, (t,tests), disp) :: accu
(mask, ((t,tests), disp)) :: accu
| p :: rem ->
let accu =
let t = Types.Product.restrict_1 t p.a in
......@@ -508,7 +964,7 @@ struct
if Types.Record.is_empty t then None
else Some (aux_record1 t pl)
in
`Label (l, disp, pr, ab)
`Label (l, (disp, pr), ab)
and aux_record2 t pl l accu mask success i tests =
if Types.Record.is_empty t then accu
......@@ -528,27 +984,160 @@ struct
let mask l = List.map (function None -> false | Some _ -> true) l
let rec dispatch (t : Types.descr) (pl : nf list) =
let fv = List.map (fun p -> p.v) pl in
let pl = List.map (fun p -> normal (restrict t p)) pl in
let basic = dispatch_basic t pl
and prod = dispatch_prod t pl
and record = dispatch_record t pl in
let masks =
let accu = ref [] in
let acc r = accu := (mask r) :: !accu in
List.iter (fun (_,r) -> acc r) basic;
List.iter (fun (_,_,l) -> List.iter (fun (_,r) -> acc r) l) (snd prod);
num 0 (SortedList.from_list !accu) in
{
Dispatch.fv = fv;
Dispatch.masks = masks;
Dispatch.basic = basic;
Dispatch.prod = prod;
Dispatch.record = record;
}
module D = Map.Make(
struct
type t = Types.descr * normal list
let compare = compare
end
)
let dispatchers = ref D.empty
let id = ref 0
let rec dispatch (t : Types.descr) (pl : normal list) =
try D.find (t,pl) !dispatchers
with Not_found ->
let basic = dispatch_basic t pl
and prod = dispatch_prod t pl
and record = dispatch_record t pl in
let alloc mask =
let arity = ref 0 in
let rec aux pl mask =
match (pl,mask) with
| ([],[]) -> []
| (p :: pl, true :: mask) ->
let l =
List.map (fun v -> incr arity; (v,!arity-1)) p.nfv in
Some l :: aux pl mask
| (_ :: pl, false :: mask) -> None :: aux pl mask
| _ -> assert false
in
let r = aux pl mask in