Commit 26968681 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-03-15 14:29:18+00:00
parent 3909931e
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
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