[r2004-03-15 14:29:18 by afrisch] Opt

Original author: afrisch
Date: 2004-03-15 14:29:18+00:00

compile/compile.ml

@@ -38,7 +38,7 @@ let from_comp_unit = ref (fun cu -> assert false)
 let find_ext cu x =
   let env = !from_comp_unit cu in
   match find x env with
-    | Global i -> ExtVar (cu,i)
+    | Ext(_,_) as v -> Var v
     | _ -> assert false
 
 let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
@@ -82,7 +82,7 @@ and compile_abstr env a =
 	       p::slots,
 	       succ nb_slots,
 	       Env.add x (Env nb_slots) fun_env;
-	   | Global _ as p -> 
+	   | Global _ | Ext _ as p -> 
 	       slots,
 	       nb_slots,
 	       Env.add x p fun_env

compile/lambda.ml

@@ -4,12 +4,14 @@ type var_loc =
   | Stack of int
   | Env of int
   | Global of int
+  | Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
   | Dummy
 
 let print_var_loc ppf = function
   | Stack i -> Format.fprintf ppf "Stack %i" i
   | Env i -> Format.fprintf ppf "Env %i" i
   | Global i -> Format.fprintf ppf "Global %i" i
+  | Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
   | Dummy -> Format.fprintf ppf "Dummy"
 
 type schema_component_kind =
@@ -17,7 +19,6 @@ type schema_component_kind =
 
 type expr = 
   | Var of var_loc
-  | ExtVar of Types.CompUnit.t * int
   | Apply of bool * expr * expr
   | Abstraction of var_loc array * (Types.t * Types.t) list * branches
 
@@ -50,7 +51,6 @@ and branches = {
 
 let rec dump_expr ppf = function
   | Var v -> print_var_loc ppf v
-  | ExtVar (cu,i) -> Format.fprintf ppf "Extvar (_,%i)" i
   | Apply (tr,f,x) -> Format.fprintf ppf "Apply (%b,%a,%a)" tr dump_expr f dump_expr x
   | Abstraction (env,iface,brs) ->
       Format.fprintf ppf "Abstraction ([";
@@ -94,7 +94,13 @@ module Put = struct
 	bits 2 s 0;
 	int s i
     | Global i ->
-	assert false;
+	bits 2 s 1;
+	Types.CompUnit.serialize s !current_cu;
+	int s i
+    | Ext (cu,i) ->
+	bits 2 s 1;
+	Types.CompUnit.serialize s cu;
+	int s i
     | Env i ->
 	bits 2 s 2;
 	int s i
@@ -102,14 +108,6 @@ module Put = struct
 	bits 2 s 3
 	
   let rec expr s = function
-    | ExtVar (cu,pos) ->
-	bits nbits s 19;
-	Types.CompUnit.serialize s cu;
-	int s pos
-    | Var (Global pos) ->
-	bits nbits s 19;
-	Types.CompUnit.serialize s !current_cu;
-	int s pos
     | Var v -> 
 	bits nbits s 0;
 	var_loc s v
@@ -214,6 +212,10 @@ module Get = struct
   let var_loc s =
     match bits 2 s with
       | 0 -> Stack (int s)
+      | 1 ->
+	  let cu = Types.CompUnit.deserialize s in
+	  let pos = int s in
+	  Ext (cu,pos)
       | 2 -> Env (int s)
       | 3 -> Dummy
       | _ -> assert false
@@ -288,10 +290,6 @@ module Get = struct
 	  let e = expr s in
 	  let t = Types.Node.deserialize s in
 	  Ref (e,t)
-      | 19 ->
-	  let cu = Types.CompUnit.deserialize s in
-	  let pos = int s in
-	  ExtVar (cu,pos)
       | _ -> assert false
 
   and branches s =

runtime/eval.ml

@@ -64,10 +64,16 @@ let eval_var env = function
   | Global i -> !stack.(i)
   | Stack i -> !stack.(!frame + i) 
   | Dummy -> Value.Absent
+  | Ext (cu,pos) as x ->
+      if pos < 0 then (Obj.magic cu : Value.t) else
+	let v = !from_comp_unit cu pos in
+	let x = Obj.repr x in
+	Obj.set_field x 0 (Obj.repr v);
+	Obj.set_field x 1 (Obj.repr (-1));
+	v
 
 let rec eval env = function
   | Var x -> eval_var env x
-  | ExtVar (cu,pos) -> !from_comp_unit cu pos
   | Apply (false,e1,e2) -> 
       let v1 = eval env e1 in
       let v2 = eval env e2 in