Commit 242608ca authored by Pietro Abate's avatar Pietro Abate

[r2004-06-28 18:24:35 by afrisch] Delay the allocation of slots for externals

Original author: afrisch
Date: 2004-06-28 18:24:35+00:00
parent e9cec6a2
......@@ -17,9 +17,9 @@ let dump ppf env =
env.vars
let mk cu g = { cu = cu; vars = Env.empty; stack_size = 0; global_size = g }
let empty_toplevel = mk None 0
let empty x g = mk (Some x) g
let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
let empty_toplevel = mk None
let empty x = mk (Some x)
let serialize s env =
......@@ -84,7 +84,7 @@ and compile_aux env tail = function
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
| Typed.External (t,i) ->
(match env.cu with
| Some cu -> Var (Ext (cu,i))
| Some cu -> Var (External (cu,i))
| None -> failwith "Cannot compile externals in the toplevel")
and compile_abstr env a =
......@@ -101,7 +101,7 @@ and compile_abstr env a =
p::slots,
succ nb_slots,
Env.add x (Env nb_slots) fun_env;
| Global _ | Ext _ as p ->
| Global _ | Ext _ | External _ as p ->
slots,
nb_slots,
Env.add x p fun_env
......
......@@ -7,17 +7,11 @@ val from_comp_unit: (Types.CompUnit.t -> env) ref
val dump: Format.formatter -> env -> unit
val empty : Types.CompUnit.t -> int -> env
(* integer: number of already allocated globals *)
val empty : Types.CompUnit.t -> env
val empty_toplevel : env
val serialize: env Serialize.Put.f
val deserialize: env Serialize.Get.f
(*
val enter_global : env -> id -> env
val enter_globals : env -> id list -> env
*)
val find : id -> env -> var_loc
val find_slot : id -> env -> int
......
......@@ -4,6 +4,8 @@ type var_loc =
| Stack of int
| Env of int
| Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
| External of Types.CompUnit.t * int
(* If pos < 0, the first arg is the value *)
| Global of int (* Only for the toplevel *)
| Dummy
......@@ -11,6 +13,7 @@ let print_var_loc ppf = function
| Stack i -> Format.fprintf ppf "Stack %i" i
| Env i -> Format.fprintf ppf "Env %i" i
| Ext (cu,i) -> Format.fprintf ppf "Ext (_,%i)" i
| External (cu,i) -> Format.fprintf ppf "External (_,%i)" i
| Global i -> Format.fprintf ppf "Global %i" i
| Dummy -> Format.fprintf ppf "Dummy"
......@@ -90,17 +93,21 @@ module Put = struct
let var_loc s = function
| Stack i ->
bits 2 s 0;
bits 3 s 0;
int s i
| Ext (cu,i) ->
bits 2 s 1;
bits 3 s 1;
Types.CompUnit.serialize s cu;
int s i
| External (cu,i) ->
bits 3 s 2;
Types.CompUnit.serialize s cu;
int s i
| Env i ->
bits 2 s 2;
bits 3 s 3;
int s i
| Dummy ->
bits 2 s 3
bits 3 s 4
| Global _ -> assert false
let rec expr s = function
......@@ -207,14 +214,18 @@ module Get = struct
open Serialize.Get
let var_loc s =
match bits 2 s with
match bits 3 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
| 2 ->
let cu = Types.CompUnit.deserialize s in
let pos = int s in
External (cu,pos)
| 3 -> Env (int s)
| 4 -> Dummy
| _ -> assert false
let rec expr s =
......
......@@ -18,22 +18,26 @@ type t = {
compile: Compile.env;
code: Lambda.code_item list;
types: Types.t array;
has_ext: bool;
mutable digest: Digest.t option;
vals: Value.t array;
mutable exts: Value.t array;
mutable depends: C.t list;
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
mutable stub : stub_ml option
}
let mk ((typing,compile,code),types) =
let mk ((typing,compile,code),types,ext) =
{ typing = typing;
compile = compile;
code = code;
types = types;
has_ext = ext;
digest = None;
vals = Array.make (Compile.global_size compile) Value.Absent;
exts = [| |];
depends = [];
status = `Unevaluated;
stub = None
......@@ -54,7 +58,8 @@ let serialize s cu =
Typer.serialize s cu.typing;
Compile.serialize s cu.compile;
Lambda.Put.codes s cu.code;
Serialize.Put.array Types.serialize s cu.types
Serialize.Put.array Types.serialize s cu.types;
Serialize.Put.bool s cu.has_ext
let deserialize s =
Serialize.Get.magic s magic;
......@@ -62,7 +67,8 @@ let deserialize s =
let compile = Compile.deserialize s in
let code = Lambda.Get.codes s in
let types = Serialize.Get.array Types.deserialize s in
mk ((typing,compile,code),types)
let ext = Serialize.Get.bool s in
mk ((typing,compile,code),types,ext)
(*
let serialize_dep=
......@@ -167,11 +173,12 @@ let rec compile verbose name id src =
Compile.comp_unit
?show
Builtin.env
(Compile.empty id (Externals.nb ()))
(Compile.empty id)
p
in
let stub,types = !stub_ml name ty_env c_env in
let cu = mk (cu,types) in
let ext = Externals.nb () > 0 in
let cu = mk (cu,types,ext) in
cu.stub <- stub;
C.Tbl.add tbl id cu;
C.leave ();
......@@ -238,6 +245,10 @@ let rec run id =
let cu = find id in
match cu.status with
| `Unevaluated ->
if cu.has_ext && (Array.length cu.exts = 0) then
failwith
("Librarian.run. This module needs externals:" ^
(U.to_string (C.value id)));
List.iter run cu.depends;
cu.status <- `Evaluating;
Eval.code_items cu.code;
......@@ -268,10 +279,10 @@ let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
Eval.set_global := (fun cu i v -> import cu;
let cu = load cu in
cu.vals.(i) <- v)
Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
Eval.get_external := (fun cu i -> (load cu).exts.(i))
let set_externals cu a = (load cu).exts <- a
let registered_types cu = (load cu).types
......@@ -21,6 +21,8 @@ val save: string -> Types.CompUnit.t -> string -> unit
val registered_types: Types.CompUnit.t -> Types.t array
val set_externals: Types.CompUnit.t -> Value.t array -> unit
type stub_ml
val stub_ml : (string -> Typer.t -> Compile.env ->
......
......@@ -461,14 +461,8 @@ let check_value ty_env c_env (s,caml_t,t) =
let stub name ty_env c_env values =
let items = List.map (check_value ty_env c_env) values in
let exts =
List.map
(fun (s,i,t) ->
let c = to_cd <:expr< $lid:s$ >> t in
<:str_item< Eval.set_slot cu $int:string_of_int i$ $c$ >>
) !exts in
let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
let g = global_transl () in
(*
......@@ -492,7 +486,7 @@ let stub name ty_env c_env values =
[ <:str_item< open CDuce_all >>;
<:str_item< value types = Librarian.registered_types cu >> ] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
[ <:str_item< declare $list:exts$ end >>;
[ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
<:str_item< Librarian.run cu >> ] @
(if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
......@@ -520,7 +514,7 @@ let () =
with Mltypes.Error s -> raise (Location.Generic s)
);
Externals.resolve :=
Externals.register :=
(fun i s args ->
let (t,n) =
try Mltypes.find_value s
......@@ -534,12 +528,10 @@ let () =
Printf.eprintf "Wrong arity for external symbol %s (real arity = %i; given = %i)\n" s n m;
exit 1
);
exts := (s, i, t) :: !exts;
exts := (s, t) :: !exts;
vars := Array.of_list args;
let cdt = Types.descr (typ t) in
(* Format.fprintf Format.std_formatter "Instance: %a@."
Types.Print.print cdt; *)
vars := [| |];
cdt
)
......@@ -72,7 +72,7 @@ and pexpr =
| Forget of pexpr * ppat
| Op of string * pexpr list
| Ref of pexpr * ppat
| External of string * ppat list * int
| External of string * ppat list
......
......@@ -218,9 +218,9 @@ EXTEND
| "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| "external"; s = STRING2 ->
exp loc (External (s,[],Externals.alloc ()))
exp loc (External (s,[]))
| "external"; "{"; s = STRING2; pl = LIST0 pat; "}" ->
exp loc (External (s,pl,Externals.alloc ()))
exp loc (External (s,pl))
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......
......@@ -63,6 +63,8 @@ let pop () =
let get_global = ref (fun cu pos -> assert false)
let set_global = ref (fun cu pos -> assert false)
let get_external = ref (fun cu pos -> assert false)
let set_external = ref (fun cu pos -> assert false)
let get_slot cu pos = !get_global cu pos
let set_slot cu pos v = !set_global cu pos v
......@@ -79,6 +81,13 @@ let eval_var env = function
Obj.set_field x 0 (Obj.repr v);
Obj.set_field x 1 (Obj.repr (-1));
v
| External (cu,pos) as x ->
if pos < 0 then (Obj.magic cu : Value.t) else
let v = !get_external 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
......
......@@ -7,6 +7,8 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
val get_global: (Types.CompUnit.t -> int -> t) ref
val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
val get_external: (Types.CompUnit.t -> int -> t) ref
val set_external: (Types.CompUnit.t -> int -> t -> unit) ref
val get_slot : Types.CompUnit.t -> int -> t
val set_slot : Types.CompUnit.t -> int -> t -> unit
......
# Do "make install_cdml" before running this test
STATIC=-static
CAML=ocamlopt
STATIC=
CAML=ocamlc
CDUCE=../../cduce
CDO2ML=../../cdo2ml
......
let nb_ext_syms = ref 0
let alloc () =
let i = !nb_ext_syms in
incr nb_ext_syms;
i
let nb () = !nb_ext_syms
let resolve = ref (fun i s args -> assert false)
let register = ref (fun i s args -> assert false)
let resolve s args =
let i = !nb_ext_syms in
incr nb_ext_syms;
(i, !register i s args)
val alloc : unit -> int
val nb: unit -> int
val resolve: ref (int -> string -> Types.Node.t list -> Types.t)
val register: ref (int -> string -> Types.Node.t list -> Types.t)
val resolve: string -> Types.Node.t list -> int * Types.t
......@@ -939,9 +939,9 @@ let rec expr env loc = function
| Ref (e,t) ->
let (fv,e) = expr env loc e and t = typ env t in
exp loc fv (Typed.Ref (e,t))
| External (s,args,i) ->
| External (s,args) ->
let args = List.map (typ env) args in
let t = !Externals.resolve i s args in
let (i,t) = Externals.resolve s args in
exp loc Fv.empty (Typed.External (t,i))
and branches env b =
......
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