[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

driver/cduce.ml

@@ -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
 	

runtime/value.ml

@@ -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

types/patterns.ml

@@ -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";

types/sortedMap.ml

@@ -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

types/sortedMap.mli

@@ -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: