Skip to content

GitLab

Commit 4aca145e authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-05-05 23:56:31 by afrisch] Revu compilation des globals 

Original author: afrisch
Date: 2004-05-05 23:56:32+00:00
parent 57badc36
Hide whitespace changes
Inline Side-by-side
Showing with 187 additions and 153 deletions
compile/compile.ml
View file @ 4aca145e
......@@ -2,10 +2,14 @@ open Ident
open Lambda
type env = {
cu: Types.CompUnit.t option; (* None: toplevel *)
vars: var_loc Env.t;
stack_size: int
stack_size: int;
global_size: int
}
let global_size env = env.global_size
let dump ppf env =
Env.iter
(fun id loc ->
......@@ -13,19 +17,25 @@ let dump ppf env =
env.vars
let empty = { vars = Env.empty; stack_size = 0 }
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 =
assert (env.stack_size = 0);
(match env.cu with
| Some cu -> Types.CompUnit.serialize s cu
| None -> assert false);
Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
Serialize.Put.int s env.stack_size
Serialize.Put.int s env.global_size
let deserialize s =
let cu = Types.CompUnit.deserialize s in
let vars =
Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
let size = Serialize.Get.int s in
{ vars = vars; stack_size = size }
{ cu = Some cu; vars = vars; stack_size = 0; global_size = size }
let find x env =
......@@ -37,15 +47,14 @@ 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
| Ext(_,_) as v -> Var v
| _ -> assert false
find x env
let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function
| Typed.Forget (e,_) -> compile env tail e
| Typed.Var x -> Var (find x env)
| Typed.ExtVar (cu,x) -> find_ext cu x
| Typed.ExtVar (cu,x) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
......@@ -92,7 +101,7 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in
let env = { vars = fun_env; stack_size = 0 } in
let env = { env with vars = fun_env; stack_size = 0 } in
let body = compile_branches env true a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body)
......@@ -112,39 +121,59 @@ and compile_branch env tail br =
let env =
List.fold_left
(fun env x ->
{ vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
{ env with
vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
) env (Patterns.fv_list br.Typed.br_pat) in
(br.Typed.br_pat, compile env tail br.Typed.br_body)
let enter_global env x =
{ vars = Env.add x (Global env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
let enter_globals = List.fold_left enter_global
let compile_eval env e = Eval (compile env false e)
let enter_globals env n =
match env.cu with
| None ->
let env =
List.fold_left
(fun env x ->
{ env with
vars = Env.add x (Global env.stack_size) env.vars;
stack_size = env.stack_size + 1 })
env n in
(env,[])
| Some cu ->
List.fold_left
(fun (env,code) x ->
let code = SetGlobal (cu, env.global_size) :: code in
let env =
{ env with
vars = Env.add x (Ext (cu, env.global_size)) env.vars;
global_size = env.global_size + 1 } in
(env,code)
)
(env,[])
n
let compile_expr env = compile env false
let compile_eval env e = [ Push (compile_expr env e); Pop ]
let compile_let_decl env decl =
let pat = decl.Typed.let_pat in
let code = Let_decl (pat, compile env false (decl.Typed.let_body)) in
let env = enter_globals env (Patterns.fv_list pat) in
(env, code)
let (env,code) = enter_globals env (Patterns.fv_list pat) in
(env, (Push (compile_expr env decl.Typed.let_body)) :: (Split pat) :: code)
let compile_rec_funs env funs =
let fun_name = function
| { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
| _ -> assert false in
let fun_a = function
| { Typed.exp_descr=Typed.Abstraction a } -> a
let fun_a env = function
| { Typed.exp_descr=Typed.Abstraction a } ->
Push (compile_abstr env a)
| _ -> assert false in
let names = List.map fun_name funs in
let env = enter_globals env names in
let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
(env, Let_funs exprs)
let (env,code) = enter_globals env names in
let exprs = List.map (fun_a env) funs in
(env, exprs @ code)
(****************************************)
......@@ -153,17 +182,17 @@ open Location
let eval ~run ~show (tenv,cenv,codes) e =
let (e,t) = Typer.type_expr tenv e in
let code = compile_eval cenv e in
let expr = compile_expr cenv e in
if run then
let v = Eval.expr code in
let v = Eval.expr expr in
show None t (Some v)
else
show None t None;
(tenv,cenv,code::codes)
(tenv,cenv, Pop :: Push expr ::codes)
let run_show ~run ~show tenv cenv code ids =
let run_show ~run ~show tenv cenv codes ids =
if run then
let () = Eval.eval code in
let () = Eval.code_items codes in
List.iter
(fun (id,_) -> show (Some id)
(Typer.find_value id tenv)
......@@ -178,13 +207,13 @@ let let_decl ~run ~show (tenv,cenv,codes) p e =
let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
let (cenv,code) = compile_let_decl cenv decl in
run_show ~run ~show tenv cenv code ids;
(tenv,cenv,code::codes)
(tenv,cenv,List.rev_append code codes)
let let_funs ~run ~show (tenv,cenv,codes) funs =
let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
let (cenv,code) = compile_rec_funs cenv funs in
run_show ~run ~show tenv cenv code ids;
(tenv,cenv,code::codes)
(tenv,cenv,List.rev_append code codes)
let type_defs (tenv,cenv,codes) typs =
let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
......
compile/compile.mli
View file @ 4aca145e
......@@ -2,21 +2,24 @@ open Ident
open Lambda
type env
val global_size: env -> int
val from_comp_unit: (Types.CompUnit.t -> env) ref
val dump: Format.formatter -> env -> unit
val empty : env
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 compile_eval : env -> Typed.texpr -> code_item
val compile_let_decl : env -> Typed.let_decl -> env * code_item
val compile_rec_funs : env -> Typed.texpr list -> env * code_item
val compile_expr : env -> Typed.texpr -> Lambda.expr
val comp_unit:
......@@ -25,5 +28,5 @@ val comp_unit:
?loading:(Types.CompUnit.t -> unit) ->
?directive:(Typer.t -> env -> Ast.toplevel_directive -> unit) ->
Typer.t -> env ->
Ast.pmodule_item list -> Typer.t * env * Lambda.code_item list
Typer.t -> env -> Ast.pmodule_item list ->
Typer.t * env * Lambda.code_item list
compile/lambda.ml
View file @ 4aca145e
......@@ -3,15 +3,15 @@ open Ident
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 *)
| Global of int (* Only for the toplevel *)
| 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
| Global i -> Format.fprintf ppf "Global %i" i
| Dummy -> Format.fprintf ppf "Dummy"
type schema_component_kind =
......@@ -64,21 +64,23 @@ and dump_branches ppf brs =
List.iter (fun (p,e) -> Format.fprintf ppf "_ -> %a |" dump_expr e) brs.brs
type code_item =
| Eval of expr
| Let_decl of Patterns.node * expr
| Let_funs of expr list
| Push of expr
| Pop
| Split of Patterns.node
| SetGlobal of Types.CompUnit.t * int
let print_code_item ppf = function
| Eval _ -> Format.fprintf ppf "Eval@."
| Let_decl _ -> Format.fprintf ppf "Let_decl@."
| Let_funs _ -> Format.fprintf ppf "Let_funs@."
| Push _ -> Format.fprintf ppf "Push@."
| Pop -> Format.fprintf ppf "Pop@."
| Split _ -> Format.fprintf ppf "Split@."
| SetGlobal (_,_) -> Format.fprintf ppf "SetGlobal@."
type code = code_item list
let nbits = 5
let magic_compunit = "CDUCE:0.2:COMPUNIT"
let magic_compunit = "CDUCE:0.3:COMPUNIT"
module Put = struct
let unary_op = ref (fun _ _ -> assert false; ())
......@@ -86,17 +88,10 @@ module Put = struct
open Serialize.Put
let current_cu = ref Types.CompUnit.pervasives
(* Used to create self reference when saving *)
let var_loc s = function
| Stack i ->
bits 2 s 0;
int s i
| Global i ->
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;
......@@ -106,6 +101,7 @@ module Put = struct
int s i
| Dummy ->
bits 2 s 3
| Global _ -> assert false
let rec expr s = function
| Var v ->
......@@ -191,9 +187,10 @@ module Put = struct
bool s brs.brs_accept_chars
let code_item s = function
| Eval e -> bits 2 s 0; expr s e
| Let_decl (p,e) -> bits 2 s 1; Patterns.Node.serialize s p; expr s e
| Let_funs e -> bits 2 s 2; list expr s e
| Push e -> bits 2 s 0; expr s e
| Pop -> bits 2 s 1
| Split p -> bits 2 s 2; Patterns.Node.serialize s p
| SetGlobal (cu,i) -> bits 2 s 3; Types.CompUnit.serialize s cu; int s i
let codes = list code_item
......@@ -304,13 +301,13 @@ module Get = struct
let code_item s =
match bits 2 s with
| 0 -> Eval (expr s)
| 1 ->
let p = Patterns.Node.deserialize s in
let e = expr s in
Let_decl (p,e)
| 2 ->
Let_funs (list expr s)
| 0 -> Push (expr s)
| 1 -> Pop
| 2 -> Split (Patterns.Node.deserialize s)
| 3 ->
let cu = Types.CompUnit.deserialize s in
let pos = int s in
SetGlobal (cu,pos)
| _ -> assert false
let codes = list code_item
......
driver/cduce.ml
View file @ 4aca145e
......@@ -22,7 +22,7 @@ let toplevel = ref false
let verbose = ref false
let typing_env = State.ref "Cduce.typing_env" Builtin.env
let compile_env = State.ref "Cduce.compile_env" Compile.empty
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
let get_global_value cenv v =
Eval.var (Compile.find v !compile_env)
......@@ -30,11 +30,6 @@ let get_global_value cenv v =
let get_global_type v =
Typer.find_value v !typing_env
let enter_global_value x v t =
typing_env := Typer.enter_value x t !typing_env;
compile_env := Compile.enter_global !compile_env x;
Eval.push v
let rec is_abstraction = function
| Ast.Abstraction _ -> true
| Ast.LocatedExpr (_,e) -> is_abstraction e
......@@ -165,7 +160,7 @@ let rec print_exn ppf = function
let eval_quiet tenv cenv e =
let (e,_) = Typer.type_expr tenv e in
let e = Compile.compile_eval cenv e in
let e = Compile.compile_expr cenv e in
Eval.expr e
let debug ppf tenv cenv = function
......@@ -255,7 +250,7 @@ let phrases ppf phs =
let (tenv,cenv,_) =
Compile.comp_unit
~run:true ~show:(show ppf)
~loading:(fun cu -> Librarian.import cu; Librarian.run Value.nil cu)
~loading:Librarian.import_and_run
~directive:(directive ppf)
!typing_env !compile_env phs in
typing_env := tenv;
......@@ -279,7 +274,6 @@ let run rule ppf ppf_err input =
try phrases ppf (parse rule input); true
with exn -> catch_exn ppf_err exn; false
let script = run Parser.prog
let topinput = run Parser.top_phrases
ifdef ML_INTERFACE then
......@@ -330,24 +324,23 @@ let compile src out_dir =
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1
let compile_run src argv =
let compile_run src =
try
if not (Filename.check_suffix src ".cd")
then raise (InvalidInputFilename src);
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
Librarian.compile !verbose id src;
Librarian.run argv id
Librarian.run id
with exn -> catch_exn Format.err_formatter exn; exit 1
let run obj argv =
let run obj =
try
if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
then raise (InvalidObjectFilename obj);
let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
Librarian.import id;
Librarian.run argv id
Librarian.import_and_run id
with exn -> catch_exn Format.err_formatter exn; exit 1
......
driver/cduce.mli
View file @ 4aca145e
val toplevel: bool ref
val verbose: bool ref
val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit
val compile: string -> string option -> unit
val compile_run: string -> Value.t -> unit
val run: string -> Value.t -> unit
val compile_run: string -> unit
val run: string -> unit
driver/librarian.ml
View file @ 4aca145e
......@@ -14,8 +14,9 @@ type t = {
compile: Compile.env;
code: Lambda.code_item list;
mutable digest: Digest.t option;
mutable vals: Value.t array option;
mutable depends: C.t list
vals: Value.t array;
mutable depends: C.t list;
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ]
}
let mk (typing,compile,code) =
......@@ -23,11 +24,12 @@ let mk (typing,compile,code) =
compile = compile;
code = code;
digest = None;
vals = None;
vals = Array.make (Compile.global_size compile) Value.Absent;
depends = [];
status = `Unevaluated;
}
let magic = "CDUCE:compunit:00001"
let magic = "CDUCE:compunit:00002"
let obj_path = ref [ "" ]
......@@ -67,7 +69,6 @@ let find_obj id =
let save id out =
protect_op "Save compilation unit";
Lambda.Put.current_cu := id;
let cu = find id in
C.enter id;
let raw = Serialize.Put.run serialize cu in
......@@ -147,8 +148,8 @@ let rec compile verbose id src =
let cu =
Compile.comp_unit
?show
(Typer.enter_value argv (Sequence.star Sequence.string) Builtin.env)
(Compile.enter_global Compile.empty argv)
Builtin.env
(Compile.empty id)
p
in
let cu = mk cu in
......@@ -195,28 +196,40 @@ and load_check id exp =
let cu = load id in
check_digest id exp cu.digest
let rec run argv id =
let rec run id =
let cu = find id in
match cu.vals with
| None ->
List.iter (run argv) cu.depends;
let vals = Eval.comp_unit [argv] cu.code in
match cu.status with
| `Unevaluated ->
List.iter run cu.depends;
cu.status <- `Evaluating;
Eval.code_items cu.code;
cu.status <- `Evaluated
(*
Compile.dump Format.std_formatter cu.compile;
Array.iter (fun v ->
Format.fprintf Format.std_formatter "%a@."
Value.print v) vals;
*)
cu.vals <- Some vals
| Some _ -> ()
| `Evaluating ->
(*
failwith
("Librarian.run. Already running:" ^ (U.to_string (C.value id)))
*)
()
| `Evaluated -> ()
let import id = ignore (load id)
let import_and_run id = import id; run id
let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.from_comp_unit :=
(fun cu i ->
match (load cu).vals with
| None -> !Eval.stack.(i) (* TODO: check that cu is being evaluated *)
| Some a -> a.(i))
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
match cu.status with
| `Evaluating -> cu.vals.(i) <- v
| _ -> assert false);;
driver/librarian.mli
View file @ 4aca145e
......@@ -7,7 +7,8 @@ exception NoImplementation of Types.CompUnit.t
val obj_path: string list ref
val compile: bool -> Types.CompUnit.t -> string -> unit
val run: Value.t -> Types.CompUnit.t -> unit
val run: Types.CompUnit.t -> unit
val import: Types.CompUnit.t -> unit
val import_and_run: Types.CompUnit.t -> unit
val save: Types.CompUnit.t -> string -> unit
driver/run.ml
View file @ 4aca145e
......@@ -169,7 +169,7 @@ let toploop () =
let argv args =
Value.sequence (List.rev_map Value.string_latin1 args)
let restore argv =
let restore () =
match !load_dump with
| Some f ->
(try
......@@ -182,8 +182,7 @@ let restore argv =
with Sys_error _ ->
Format.fprintf ppf "failed ...@.")
| None ->
let t = Sequence.star Sequence.string in
Cduce.enter_global_value (ident (U.mk "argv")) argv t
()
let save () =
match !save_dump with
......@@ -198,15 +197,18 @@ let save () =
let main () =
match mode () with
| `Toplevel args ->
restore (argv args);
Builtin.argv := argv args;
restore ();
toploop ();
save ()
| `Script (f,args) ->
Cduce.compile_run f (argv args)
Builtin.argv := argv args;
Cduce.compile_run f
| `Compile (f,o) ->
Cduce.compile f o
| `Run (f,args) ->
Cduce.run f (argv args)
Builtin.argv := argv args;
Cduce.run f
let () =
(* Hum... *)
......
parser/parser.ml
View file @ 4aca145e
......@@ -271,7 +271,7 @@ EXTEND
| IDENT "load_xml"
| IDENT "load_file" | IDENT "load_file_utf8"
| IDENT "float_of"
| IDENT "getenv"
| IDENT "getenv" | IDENT "argv"
| IDENT "load_html"
| IDENT "print_xml" | IDENT "print_xml_utf8"
| IDENT "print"
......
runtime/eval.ml
View file @ 4aca145e
......@@ -57,16 +57,22 @@ let push x =
set stack !sp x;
incr sp
let from_comp_unit = ref (fun cu pos -> assert false)
let pop () =
decr sp;
!stack.(!sp)
let get_global = ref (fun cu pos -> assert false)
let set_global = ref (fun cu pos -> assert false)
let eval_var env = function
| Env i -> env.(i)
| Global i