Commit 88585ae1 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-26 01:35:24 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 01:35:24+00:00
parent d38b0769
......@@ -70,6 +70,29 @@ let rec print_exn ppf = function
| exn ->
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
let debug = function
| `Filter (t,p) ->
Format.fprintf ppf "[DEBUG:filter]@\n";
let t = Typer.typ t
and p = Typer.pat p in
let f = Patterns.filter (Types.descr t) p in
List.iter (fun (x,t) ->
Format.fprintf ppf " x:%a@\n"
print_norm (Types.descr t)) f
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@\n";
let p = Typer.pat p in
let t = Patterns.accept p in
Format.fprintf ppf " %a@\n" Types.Print.print t
| `Compile (t,pl) ->
Format.fprintf ppf "[DEBUG:compile]@\n";
let t = Typer.typ t
and pl = List.map Typer.pat pl in
let pl = Array.of_list
(List.map (fun p -> Patterns.Compile.normal
(Patterns.descr p)) pl) in
Patterns.Compile.show ppf (Types.descr t) pl
| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
......@@ -77,6 +100,7 @@ let phrase ph =
let t = Typer.type_check Typer.Env.empty e Types.any true in
Format.fprintf ppf "%a@\n" print_norm t
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug l
| _ -> assert false
let () =
......
......@@ -11,7 +11,12 @@ and pmodule_item' =
| FunDecl of abstr
| LetDecl of ppat * pexpr
| EvalStatement of pexpr
| Debug of string * ([`Pat of ppat | `Expr of pexpr] list)
| Debug of debug_directive
and debug_directive =
[ `Filter of ppat * ppat
| `Accept of ppat
| `Compile of ppat * ppat list ]
and pexpr = pexpr' located
and pexpr' =
......
......@@ -43,7 +43,16 @@ EXTEND
phrase: [
[ e = expr -> EvalStatement e
| "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
| "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
| "debug"; d = debug_directive -> Debug d
]
];
debug_directive: [
[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| LIDENT "accept"; p = pat -> `Accept p;
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
]
];
expr: [
......
......@@ -4,5 +4,8 @@ let types =
"Any", Types.any;
"Int", Types.Int.any;
"Char", Types.char Chars.any;
"Atom", Types.atom Atoms.any
"Atom", Types.atom Atoms.any;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
];
......@@ -79,5 +79,6 @@ let print =
then fun ppf ->
Unichar.print ppf a
else fun ppf ->
if a = 0 && b = max_char then Format.fprintf ppf "Char" else
Format.fprintf ppf "%a--%a" Unichar.print a Unichar.print b
)
......@@ -67,7 +67,7 @@ let rec iadd_bounded l a b = match l with
iadd_bounded l' (min_big_int a a1) (max_big_int b b1)
| Left b1 :: l' ->
iadd_left l' b
| Right a1 :: _ -> [Right a]
| Right a1 :: _ -> [Right (min_big_int a a1)]
| Any :: _ -> any
let rec iadd_right l a = match l with
......
......@@ -114,9 +114,8 @@ let filter t p =
(* Normal forms for patterns and compilation *)
module NF =
module Normal =
struct
type 'a sl = 'a SortedList.t
type ('a,'b) sm = ('a,'b) SortedMap.t
......@@ -142,7 +141,7 @@ struct
| `Fail
| `Dispatch of (nf * record) list
| `Label of Types.label * (nf * record) list * record ]
type normal = {
type t = {
nfv : fv;
na : Types.descr;
nbasic : Types.descr nline;
......@@ -271,7 +270,6 @@ struct
let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any
let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
let normal nf =
let basic =
......@@ -319,88 +317,97 @@ struct
nrecord = record nf.record;
}
end
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
]
module Compile =
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 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
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 return_code =
Types.descr * int * (* accepted type, arity *)
(int * (capture, int) SortedMap.t) list
and interface =
[ `Result of int * Types.descr * int (* code, accepted type, arity *)
| `Switch of (capture, int) SortedMap.t * interface * interface
| `None ]
and dispatcher = {
id : int;
t : Types.descr;
pl : Normal.t array;
interface : interface;
codes : return_code array;
mutable actions : actions option
}
let cur_id = ref 0
module DispMap = Map.Make(
struct
type t = Types.descr * normal array
type t = Types.descr * Normal.t array
let compare = compare
end
)
let dispatchers = ref DispMap.empty
let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
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
let nb = ref 0 in
let rec aux t arity i =
if Types.is_empty t then `None
else
if i = Array.length pl
then res := (t, arity, Array.of_list (List.rev bindings)) :: !res
then (incr nb; `Result (!nb - 1, t, arity))
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)
let tp = p.Normal.na in
let v = p.Normal.nfv in
`Switch
(num arity v,
aux (Types.cap t tp) (arity + (List.length v)) (i+1),
aux (Types.diff t tp) arity (i+1)
)
in
let iface = aux t 0 0 in
let codes = Array.create !nb (Types.empty,0,[]) in
let rec aux i accu = function
| `None -> ()
| `Switch (pos, yes, no) ->
aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
| `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)
in
aux t [] 0 0;
aux 0 [] iface;
let res = { id = !cur_id;
t = t;
pl = pl;
interface = Array.of_list !res;
interface = iface;
codes = codes;
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
......@@ -411,47 +418,69 @@ struct
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
let find_code d a =
let rec aux i = function
| `Result (code,_,_) -> code
| `None -> assert false
| `Switch (_,yes,no) ->
match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
in
aux 0 d.interface
let create_result pl =
Array.fold_right
(fun x accu -> match x with
| Some b -> b @ accu
| None -> accu)
pl []
let return disp pl f =
let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
let final = Array.map aux pl in
(find_code disp final, create_result final)
let conv_source_basic (v,s) = match s with
| (`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 conv_source_prod left right (v,s) = match s with
| (`Catch | `Const _) as x -> x
| `Left -> `Left (List.assoc v left)
| `Right -> `Right (List.assoc v right)
| `Recompose -> `Recompose (List.assoc v left, List.assoc v right)
| _ -> assert false
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 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 dispatch_basic disp : (Types.descr * result) list =
let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in
let tests =
let accu = ref [] in
let aux i (res,x) = accu := (x, [i,res]) :: !accu in
Array.iteri (fun i -> List.iter (aux i)) pl;
SortedMap.from_list SortedList.cup !accu in
let t = Types.cap Normal.any_basic disp.t in
let accu = ref [] in
let rec aux t l =
let rec aux (success : (int * Normal.result) list) 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
let selected = Array.create (Array.length pl) [] in
let add (i,res) = selected.(i) <- res :: selected.(i) in
List.iter add success;
let aux_final res = List.map conv_source_basic res in
accu := (t, return disp selected aux_final) :: !accu
| (ty,i) :: rem ->
aux (i @ success) (Types.cap t ty) rem;
aux success (Types.diff t ty) rem
in
aux t tests;
aux [] t tests;
!accu
......@@ -461,7 +490,7 @@ struct
let aux i x =
let yes, no = f x in
List.iter (fun (p,info) ->
let p = normal (restrict t p) in
let p = Normal.normal (Normal.restrict t p) in
accu := (p,[i, info]) :: !accu
) yes;
unselect.(i) <- no @ unselect.(i) in
......@@ -469,44 +498,19 @@ struct
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 result (t,_,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;
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
d t selected unselect
in
let res = Array.map result disp.interface in
let res = Array.map result disp.codes 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 rec dispatch_prod disp =
let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
let t = Types.Product.get disp.t in
get_tests pl
(fun (res,(p,q)) -> [p, (res,q)], [])
......@@ -519,15 +523,9 @@ flush stderr;
(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 aux_final (ret2, (ret1, res)) =
List.map (conv_source_prod ret1 ret2) res in
return disp pl aux_final
let dummy_label = Types.label ""
......@@ -560,13 +558,8 @@ flush stderr;
| (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 prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
let pl0 = Array.map prep disp.pl in
let t = Types.Record.get disp.t in
dispatch_record_opt disp t pl0
......@@ -576,15 +569,10 @@ flush stderr;
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)
let aux_final (res, catch, x) =
assert (x = `Success);
List.map (conv_source_record catch) res in
`Result (return disp pl aux_final)
| Some l ->
let present =
let pl = label_found l pl in
......@@ -644,12 +632,15 @@ flush stderr;
let rec print_result ppf = function
| [] -> ()
| [s] -> print_source ppf s
| s::rem -> Format.fprintf ppf "%a," print_source s; print_result ppf rem
| 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
Format.fprintf ppf "$%i" code;
if ret <> [] then Format.fprintf ppf "(%a)" print_result ret in
let print_lhs ppf (code,prefix,d) =
let arity = match d.interface.(code) with (_,a,_) -> a in
let arity = match d.codes.(code) with (_,a,_) -> a in
Format.fprintf ppf "$%i(" code;
for i = 0 to arity - 1 do
if i > 0 then Format.fprintf ppf ",";
......@@ -657,16 +648,16 @@ flush stderr;
done;
Format.fprintf ppf ")" in
let print_basic (t,ret) =
Format.fprintf ppf " | %a ->%a@\n"
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;
Format.fprintf ppf " match v2 with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> %a\n"
Format.fprintf ppf " | %a -> %a\n"
print_lhs (code, "r", d)
print_ret r;
)
......@@ -679,7 +670,7 @@ flush stderr;
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | %a -> @\n"
Format.fprintf ppf " | %a -> @\n"
print_lhs (code, "l", d);
print_prod2 d2;
)
......@@ -723,28 +714,26 @@ flush stderr;
to_print := rem;
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print_descr d.t;
let print_code code (t, arity, m) =
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
code arity
Types.Print.print_descr 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 (i,b) ->
Format.fprintf ppf "[%i:" i;
List.iter
(fun (v,i) -> Format.fprintf ppf "%s=>%i;" v i)
b;
Format.fprintf ppf ")"
Format.fprintf ppf "]"
) m;
Format.fprintf ppf "@\n";
)
d.interface;
*)
Format.fprintf ppf "disp_%i = function@\n" d.id;
Format.fprintf ppf "@\n";
in
Array.iteri print_code d.codes;
Format.fprintf ppf "let disp_%i = function@\n" d.id;
print_actions ppf (actions d);
Format.fprintf ppf "====================================@\n";
print_dispatchers ppf
let show ppf t pl =
......@@ -752,602 +741,12 @@ flush stderr;
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)
let rec map_map f = function
| [] -> []
| x::l ->
try let y = f x in y::(map_map f l)
with Not_found -> map_map f l
let get_option = function [x] -> Some x | [] -> None | _ -> assert false