Commit 13f74890 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-27 08:40:32 by cvscast] Optimisation for toplevel capture variables in pm compilation

Original author: cvscast
Date: 2002-10-27 08:40:32+00:00
parent 12866377
......@@ -117,7 +117,7 @@ let () =
Typer.register_global_types type_decls;
List.iter phrase p
with
| (Failure _ | Not_found) as e ->
| (Failure _ | Not_found | Invalid_argument _) as e ->
raise e (* To get the ocamlrun stack trace *)
| exn -> print_exn ppf exn
......
......@@ -7,6 +7,7 @@ type t =
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| String of int * string * t (* position in string *)
| Fun of abstr
and env = t Env.t
and abstr = {
......@@ -40,6 +41,7 @@ let rec print ppf v =
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c -> Chars.Unichar.print ppf c
| Fun c -> Format.fprintf ppf "<fun>"
| String (i,s,y) -> Format.fprintf ppf "<str:%S;%i>%a" s i print y
and print_quoted_str ppf = function
| Pair (Char c, y) ->
Chars.Unichar.print_in_string ppf c;
......@@ -81,24 +83,28 @@ let const = function
| Types.Atom a -> Atom a
| Types.Char c -> Char c
let make_result_prod r1 r2 v (code,r) =
let make_result_prod v1 r1 v2 r2 v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Left i -> r1.(i)
| `Right j -> r2.(j)
| `Recompose (i,j) -> Pair (r1.(i), r2.(j))
| `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)))
| _ -> assert false
) r in
(code,ret)
let make_result_record v fields (code,r) =
let make_result_record fields v bindings (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Field (l,i) -> (List.assoc l fields).(i)
| `Field (l,i) ->
if (l < 0) then List.assoc l fields
else (List.assoc l bindings).(i)
| _ -> assert false
) r in
(code,ret)
......@@ -122,7 +128,7 @@ let rec run_dispatcher d v =
and run_disp_kind actions v = match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Record r -> run_disp_record v [] r actions.Patterns.Compile.record
| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
actions.Patterns.Compile.basic
......@@ -135,6 +141,8 @@ and run_disp_kind actions v = match v with
| Fun f ->
run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t)
actions.Patterns.Compile.basic
| String (i,s,y) ->
failwith "Dispatch on string not yet implemented"
and run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
......@@ -145,41 +153,41 @@ and run_disp_basic v f = function
and run_disp_prod v v1 v2 = function
| `None -> assert false
| `TailCall d1 -> run_dispatcher d1 v1
| `Ignore d2 -> run_disp_prod2 dummy_r v v2 d2
| `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
| `Dispatch (d1,b1) ->
let (code1,r1) = run_dispatcher d1 v1 in
run_disp_prod2 r1 v v2 b1.(code1)
run_disp_prod2 v1 r1 v v2 b1.(code1)
and run_disp_prod2 r1 v v2 = function
and run_disp_prod2 v1 r1 v v2 = function
| `None -> assert false
| `Ignore r -> make_result_prod r1 dummy_r v r
| `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
make_result_prod r1 r2 v b2.(code2)
make_result_prod v1 r1 v2 r2 v b2.(code2)
and run_disp_record v bindings fields = function
and run_disp_record f v bindings fields = function
| None -> assert false
| Some record -> run_disp_record' v bindings fields record
| Some record -> run_disp_record' f v bindings fields record
and run_disp_record' v bindings fields = function
| `Result r -> make_result_record v bindings r
and run_disp_record' f v bindings fields = function
| `Result r -> make_result_record f v bindings r
| `Label (l, present, absent) ->
let rec aux = function
| (l1,_) :: rem when l1 < l -> aux rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field v bindings rem l vl present
| _ -> run_disp_record v bindings fields absent
run_disp_field f v bindings rem l vl present
| _ -> run_disp_record f v bindings fields absent
in
aux fields
and run_disp_field v bindings fields l vl = function
and run_disp_field f v bindings fields l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' v bindings fields r
| `Ignore r -> run_disp_record' f v bindings fields r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' v ((l,rl)::bindings) fields bl.(codel)
run_disp_record' f v ((l,rl)::bindings) fields bl.(codel)
(* Evaluation of expressions *)
......@@ -225,11 +233,14 @@ and eval_branches env brs arg =
let (code, bindings) = run_dispatcher disp arg in
let (bind, e) = rhs.(code) in
let env =
List.fold_left (fun env (x,i) -> Env.add x bindings.(i) env) env bind in
List.fold_left (fun env (x,i) ->
if (i = -1) then Env.add x arg env
else Env.add x bindings.(i) env) env bind in
eval env e
and eval_map env brs = function
| Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
| String (i,s,y) -> failwith "map on string not implemented"
| q -> q
and eval_flatten = function
......@@ -238,6 +249,7 @@ and eval_flatten = function
and eval_concat l1 l2 = match l1 with
| Pair (x,y) -> Pair (x, eval_concat y l2)
| String (i,s,y) -> String(i,s, eval_concat y l2)
| q -> l2
and eval_dot l = function
......
......@@ -131,6 +131,7 @@ struct
type 'a line = (result * 'a, Types.descr) sm
type nf = {
v : fv;
catchv: fv; (* Variables catching the value *)
a : Types.descr;
basic : unit line;
prod : (node sl * node sl) line;
......@@ -145,13 +146,16 @@ struct
| `Label of Types.label * (nf * record) list * record ]
type t = {
nfv : fv;
ncatchv: fv;
na : Types.descr;
nbasic : Types.descr nline;
nprod : (nf * nf) nline;
nrecord: record nline
}
let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }
let empty = { v = []; catchv = [];
a = Types.empty;
basic = []; prod = []; record = [] }
let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)
......@@ -163,6 +167,7 @@ struct
| [] -> []
in
{ v = nf.v;
catchv = nf.catchv;
a = Types.cap t nf.a;
basic = filter nf.basic;
prod = filter nf.prod;
......@@ -190,6 +195,7 @@ struct
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;
catchv = SortedList.cup nf1.catchv nf2.catchv;
a = Types.cap nf1.a nf2.a;
basic = merge merge_basic nf1.basic nf2.basic;
prod = merge merge_prod nf1.prod nf2.prod;
......@@ -201,6 +207,7 @@ struct
let cup acc1 nf1 nf2 =
let nf2 = restrict (Types.neg acc1) nf2 in
{ v = nf1.v; (* = nf2.v *)
catchv = SortedList.cap nf1.catchv nf2.catchv;
a = Types.cup nf1.a nf2.a;
basic = SortedMap.union Types.cup nf1.basic nf2.basic;
prod = SortedMap.union Types.cup nf1.prod nf2.prod;
......@@ -224,7 +231,8 @@ struct
record = [ (src, [l,[p]]), acc ] }
let any =
{ v = [];
{ v = [];
catchv = [];
a = Types.any;
basic = [ ([],()), any_basic ];
prod = [ ([],([],[])), Types.Product.any ];
......@@ -234,6 +242,7 @@ struct
let capture x =
let l = [x,`Catch] in
{ v = [x];
catchv = [x];
a = Types.any;
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
......@@ -243,6 +252,7 @@ struct
let constant x c =
let l = [x,`Const c] in
{ v = [x];
catchv = [];
a = Types.any;
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
......@@ -251,6 +261,7 @@ struct
let constr t =
{ v = [];
catchv = [];
a = t;
basic = [ ([],()), Types.cap t any_basic ];
prod = [ ([],([],[])), Types.cap t Types.Product.any ];
......@@ -312,13 +323,15 @@ struct
| x -> (res,x) :: accu in
List.fold_left line []
in
{ nfv = nf.v;
let nlines l =
List.map (fun (res,x) -> (SortedMap.diff res nf.catchv,x)) l in
{ nfv = SortedList.diff nf.v nf.catchv;
ncatchv = nf.catchv;
na = nf.a;
nbasic = basic nf.basic;
nprod = prod nf.prod;
nrecord = record nf.record;
nbasic = nlines (basic nf.basic);
nprod = nlines (prod nf.prod);
nrecord = nlines (record nf.record);
}
end
......@@ -397,7 +410,11 @@ struct
| Some (`Result r) -> r :: rs
| _ -> raise Exit in
match rs with
| r :: rs when List.for_all ( (=) r ) rs -> `Ignore r
| ((_, ret) as r) :: rs when
List.for_all ( (=) r ) rs
&& array_for_all
(function `Catch | `Const _ -> true | _ -> false) ret
-> `Ignore r
| _ -> raise Exit
)
with Exit -> `Kind { basic = basic; prod = prod; record = record }
......@@ -463,6 +480,7 @@ struct
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
......@@ -477,6 +495,15 @@ struct
let p = pl.(i) in
let tp = p.Normal.na in
let v = p.Normal.nfv in
let v = SortedList.diff v p.Normal.ncatchv in
(*
Printf.eprintf "ncatchv = (";
List.iter (fun s -> Printf.eprintf "%s;" s) p.Normal.ncatchv;
Printf.eprintf ")\n";
flush stderr;
*)
(* let tp = Types.normalize tp in *)
`Switch
(num arity v,
......@@ -540,16 +567,19 @@ struct
| (`Catch | `Const _) as x -> x
| _ -> assert false
let assoc v l =
try List.assoc v l with Not_found -> -1
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)
| `Left -> `Left (assoc v left)
| `Right -> `Right (assoc v right)
| `Recompose -> `Recompose (assoc v left, assoc v right)
| _ -> assert false
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))
| `Field l -> `Field (l, assoc v (List.assoc l catch))
| _ -> assert false
......@@ -612,7 +642,7 @@ struct
(fun (t,brs) (p,e) ->
let p = Normal.restrict t (Normal.nf p) in
let t = Types.diff t (p.Normal.a) in
(t, (p,e) :: brs)
(t, (p,(p.Normal.catchv,e)) :: brs)
) (t,[]) brs in
let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
......@@ -623,7 +653,9 @@ struct
(fun _ pl _ ->
let r = ref None in
let aux = function
| [x] -> assert (!r = None); r := Some x
| [(res,(catchv,e))] -> assert (!r = None);
let catchv = List.map (fun v -> (v,-1)) catchv in
r := Some (SortedMap.union_disj catchv res,e)
| [] -> () | _ -> assert false in
Array.iter aux pl;
let r = match !r with None -> assert false | Some x -> x in
......@@ -746,12 +778,18 @@ struct
to_print := d :: !to_print
)
let print_source ppf = function
let rec print_source ppf = function
| `Catch -> Format.fprintf ppf "v"
| `Const c -> Types.Print.print_const ppf c
| `Left (-1) -> Format.fprintf ppf "v1"
| `Right (-1) -> Format.fprintf ppf "v2"
| `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.label_name l)
| `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
| `Recompose (i,j) ->
Format.fprintf ppf "(%a,%a)"
print_source (`Left i)
print_source (`Right j)
| `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
let print_result ppf =
......@@ -875,7 +913,7 @@ struct
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
code arity
Types.Print.print_descr (Types.normalize t);
(*
List.iter
(fun (i,b) ->
Format.fprintf ppf "[%i:" i;
......@@ -884,10 +922,10 @@ struct
b;
Format.fprintf ppf "]"
) m;
*)
Format.fprintf ppf "@\n";
in
(* Array.iteri print_code d.codes; *)
(* 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";
......
......@@ -41,6 +41,15 @@ let add f x y m =
let change x f =
add (fun _ -> f) x
let rec diff l1 l2 =
match (l1,l2) with
| (((x1,y1) as t1)::q1, x2::q2) ->
let c = compare x1 x2 in
if c = 0 then diff q1 q2
else if c < 0 then t1::(diff q1 l2)
else diff l1 q2
| _ -> l1
let rec iter f = function
| [] -> ()
| (x,y)::q -> f x y; iter f q
......
......@@ -8,6 +8,8 @@ val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t
val change: 'a -> ('b -> 'b) -> 'b -> ('a,'b) t -> ('a,'b) t
val diff: ('a,'b) t -> 'a SortedList.t -> ('a,'b) t
val iter: ('a -> 'b -> unit) -> ('a,'b) t -> unit
val iter2:
......
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