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