Skip to content

GitLab

C
cduce
Commit 3385c1e7 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

[r2003-10-04 02:00:15 by cvscast] Compilation + serialization 

Original author: cvscast
Date: 2003-10-04 02:01:37+00:00
parent 109fe5d6
Hide whitespace changes
Inline Side-by-side
Showing with 534 additions and 206 deletions
Makefile.distrib
View file @ 3385c1e7
......@@ -26,7 +26,7 @@ endif
SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %)
CAMLC_P = ocamlc
CAMLC_P = ocamlc -g
DEPEND_OCAMLDEP = misc/q_symbol.cmo
ifeq ($(PROFILE), true)
CAMLOPT_P = ocamlopt -p
......@@ -117,6 +117,9 @@ INCLUDES = $(DIRS:%=-I %)
cduce: $(CDUCE:.cmo=.$(EXTENSION))
$(LINK) $(INCLUDES) -o $@ $^
bug: $(OBJECTS) bug.cmo
$(LINK) $(INCLUDES) -o $@ $^
webiface: $(WEBIFACE:.cmo=.$(EXTENSION))
$(LINK) $(INCLUDES) -o $@ $^ -ccopt -static
# webiface is made static to be able to move it more easily
......
compile/compile.ml
View file @ 3385c1e7
......@@ -83,7 +83,7 @@ and compile_branch env tail br =
{ vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
) env (Patterns.fv_list br.Typed.br_pat) in
(br.Typed.br_pat, compile env tail br.Typed.br_body)
......@@ -93,12 +93,13 @@ let enter_global env x =
let enter_globals = List.fold_left enter_global
let compile_eval env e = Eval (compile env false e)
let compile_let_decl env decl =
let pat = decl.Typed.let_pat in
let decl = { let_pat = pat; let_expr = compile env false (decl.Typed.let_body) } in
let names = IdSet.get (Patterns.fv pat) in
let env = enter_globals env names in
(env, decl)
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 compile_rec_funs env funs =
......@@ -111,4 +112,67 @@ let compile_rec_funs env funs =
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, exprs)
(env, Let_funs exprs)
(****************************************)
open Location
let eval (tenv,cenv,codes) e =
let (e,_) = Typer.type_expr tenv e in
let code = compile_eval cenv e in
(tenv,cenv,code :: codes)
let let_decl (tenv,cenv,codes) p e =
let (tenv,decl,_) = Typer.type_let_decl tenv p e in
let (cenv,code) = compile_let_decl cenv decl in
(tenv,cenv,code :: codes)
let let_funs (tenv,cenv,codes) funs =
let (tenv,funs,_) = Typer.type_let_funs tenv funs in
let (cenv,code) = compile_rec_funs cenv funs in
(tenv,cenv,code :: codes)
let type_defs (tenv,cenv,codes) typs =
let tenv = Typer.enter_types (Typer.type_defs tenv typs) tenv in
(tenv,cenv,codes)
let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in
(tenv,cenv,codes)
let rec collect_funs accu = function
| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
| rest -> (accu,rest)
let rec collect_types accu = function
| { descr = Ast.TypeDecl (x,t) } :: rest ->
collect_types ((x,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases accu phs = match phs with
| { descr = Ast.FunDecl _ } :: _ ->
let (funs,rest) = collect_funs [] phs in
phrases (let_funs accu funs) rest
| { descr = Ast.TypeDecl (_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in
phrases (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, schema) } :: rest ->
Typer.register_schema name schema;
phrases accu rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
phrases (namespace accu pr ns) rest
| { descr = Ast.EvalStatement e } :: rest ->
phrases (eval accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
phrases (let_decl accu p e) rest
| { descr = Ast.Debug l } :: rest ->
phrases accu rest
| { descr = Ast.Directive _ } :: rest ->
phrases accu rest
| [] -> accu
let comp_unit tenv cenv phs =
let (tenv,cenv,codes) = phrases (tenv,cenv,[]) phs in
(tenv,cenv,List.rev codes)
compile/compile.mli
View file @ 3385c1e7
open Ident
open Lambda
type env
val empty : env
val enter_global : env -> id -> env
val enter_globals : env -> id list -> env
val find : id -> env -> Lambda.var_loc
val find : id -> env -> var_loc
val compile : env -> bool -> Typed.texpr -> Lambda.expr
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_let_decl : env -> Typed.let_decl -> env * Lambda.let_decl
val compile_rec_funs : env -> Typed.texpr list -> env * Lambda.expr list
val comp_unit:
Typer.t -> env ->
Ast.pmodule_item list -> Typer.t * env * Lambda.code_item list
compile/lambda.ml
View file @ 3385c1e7
......@@ -38,14 +38,23 @@ and branches = {
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}
type let_decl = {
let_pat : Patterns.node;
let_expr : expr;
}
type code_item =
| Eval of expr
| Let_decl of Patterns.node * expr
| Let_funs of expr list
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@."
type code = code_item list
let nbits = 5
let magic_compunit = "CDUCE:0.2:COMPUNIT"
module Put = struct
let unary_op = ref (fun _ _ -> assert false; ())
let binary_op = ref (fun _ _ -> assert false; ())
......@@ -119,7 +128,7 @@ module Put = struct
expr s e;
branches s brs
| Validate (e,sch,t) ->
assert false (* Need to store a pointer to the schema ... *)
assert false (* TODO:Need to store a pointer to the schema ... *)
| RemoveField (e,l) ->
bits nbits s 14;
expr s e;
......@@ -147,7 +156,17 @@ module Put = struct
bool s brs.brs_tail;
Types.serialize s brs.brs_input;
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
let codes = list code_item
let compunit s c =
magic s magic_compunit;
codes s c
end
......@@ -247,4 +266,21 @@ module Get = struct
brs_compiled = None
}
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)
| _ -> assert false
let codes = list code_item
let compunit s =
magic s magic_compunit;
codes s
end
depend
View file @ 3385c1e7
......@@ -158,10 +158,12 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
types/patterns.cmx runtime/run_dispatch.cmx schema/schema_validator.cmx \
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx types/types.cmx compile/compile.cmi
compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi types/ident.cmo \
compile/lambda.cmo parser/location.cmi types/patterns.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx types/ident.cmx \
compile/lambda.cmx parser/location.cmx types/patterns.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx compile/compile.cmi
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
......@@ -231,7 +233,8 @@ runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
runtime/value.cmi
compile/compile.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo
compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
typing/typed.cmo typing/typer.cmi
compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi
......
driver/cduce.ml
View file @ 3385c1e7
......@@ -12,7 +12,7 @@ let do_compile = ref false
let get_global_value v =
if !do_compile
then Eval.L.eval_var (Compile.find v !compile_env)
then Eval.L.var (Compile.find v !compile_env)
else Eval.find_value v !eval_env
let get_global_type v =
......@@ -119,17 +119,15 @@ let display ppf l =
l
let eval ppf e =
let e = Typer.expr !typing_env e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
let (e,t) = Typer.type_expr !typing_env e in
if not !quiet then
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
let v =
if !do_compile then
let e = Compile.compile !compile_env false e in
Eval.L.eval e
let e = Compile.compile_eval !compile_env e in
Eval.L.expr e
else
Eval.eval !eval_env e
in
......@@ -139,36 +137,32 @@ let eval ppf e =
v
let let_decl ppf p e =
let decl = Typer.let_decl !typing_env p e in
let typs = Typer.type_let_decl !typing_env decl in
Typer.report_unused_branches ();
let (tenv,decl,typs) = Typer.type_let_decl !typing_env p e in
let () =
if !do_compile then
let (env,decl) = Compile.compile_let_decl !compile_env decl in
Eval.L.eval_let_decl decl;
Eval.L.eval decl;
compile_env := env
else
eval_env := Eval.eval_let_decl !eval_env decl
in
typing_env := Typer.enter_values typs !typing_env;
typing_env := tenv;
display ppf typs
let let_funs ppf funs =
let funs = List.map (Typer.expr !typing_env) funs in
let typs = Typer.type_rec_funs !typing_env funs in
Typer.report_unused_branches ();
let (tenv,funs,typs) = Typer.type_let_funs !typing_env funs in
let () =
if !do_compile then
let (env,funs) = Compile.compile_rec_funs !compile_env funs in
Eval.L.eval_rec_funs funs;
Eval.L.eval funs;
compile_env := env;
else
eval_env := Eval.eval_rec_funs !eval_env funs
in
typing_env := Typer.enter_values typs !typing_env;
typing_env := tenv;
display ppf typs
......@@ -259,31 +253,78 @@ let rec phrases ppf phs = match phs with
phrases ppf rest
| [] -> ()
let catch_exn ppf_err = function
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
as e ->
raise e
| exn ->
print_exn ppf_err exn;
Format.fprintf ppf_err "@."
let parse rule input =
try Some (rule input)
with
| Stdpp.Exc_located (_, (Location _ as e)) ->
Parser.sync (); raise e
| Stdpp.Exc_located ((i,j), e) ->
Parser.sync (); raise_loc i j e
let run rule ppf ppf_err input =
Typer.clear_unused_branches ();
try
let p =
try rule input
with
| Stdpp.Exc_located (_, (Location _ as e)) ->
Parser.sync (); raise e
| Stdpp.Exc_located ((i,j), e) ->
Parser.sync (); raise_loc i j e
in
phrases ppf p;
true
with
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
as e ->
raise e
| exn ->
print_exn ppf_err exn;
Format.fprintf ppf_err "@.";
false
try match parse rule input with
| Some phs -> phrases ppf phs; true
| None -> false
with exn -> catch_exn ppf_err exn; false
let script = run Parser.prog
let topinput = run Parser.top_phrases
let comp_unit src =
try
let ic = open_in src in
Location.push_source (`File src);
let input = Stream.of_channel ic in
match parse Parser.prog input with
| Some p ->
close_in ic;
let argv = ident (U.mk "argv") in
let (tenv,cenv,codes) =
Compile.comp_unit
(Typer.enter_value argv (Sequence.star Sequence.string)
Builtin.env)
(Compile.enter_global Compile.empty argv)
p in
codes
| None -> exit 1
with exn -> catch_exn Format.err_formatter exn; exit 1
let run_code argv codes =
try
Eval.L.push argv;
List.iter Eval.L.eval codes
with exn -> catch_exn Format.err_formatter exn; exit 1
let compile src =
let codes = comp_unit src in
let oc = open_out (src ^ ".out") in
let codes_s = Serialize.Put.run Lambda.Put.compunit codes in
output_string oc codes_s;
close_out oc;
exit 0
let compile_run src argv =
run_code argv (comp_unit src)
let run obj argv =
let ic = open_in obj in
let len = in_channel_length ic in
let codes = String.create len in
really_input ic codes 0 len;
close_in ic;
let codes = Serialize.Get.run Lambda.Get.compunit codes in
run_code argv codes
let serialize_typing_env t () =
Typer.serialize t !typing_env
......
driver/cduce.mli
View file @ 3385c1e7
......@@ -10,3 +10,7 @@ val dump_env : Format.formatter -> unit
val serialize_typing_env : Serialize.Put.t -> unit -> unit
val deserialize_typing_env : Serialize.Get.t -> unit
val compile: string -> unit
val compile_run: string -> Value.t -> unit
val run: string -> Value.t -> unit
driver/run.ml
View file @ 3385c1e7
......@@ -8,6 +8,9 @@ let save_dump = ref None
let src = ref []
let args = ref []
let compile = ref false
let run = ref false
let version () =
Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
Printf.eprintf "built on %s\n" <:symbol<build_date>>;
......@@ -32,8 +35,10 @@ let specs =
" specify persistency file for loading and saving";
"--quiet", Arg.Set Cduce.quiet,
" suppress normal output (typing, results)";
"--compile", Arg.Set Cduce.do_compile,
" activate compilation";
"--compile", Arg.Set compile,
" compilate the given CDuce file";
"--run", Arg.Set run,
" compilate the given CDuce file";
"--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input";
"--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
......@@ -54,6 +59,7 @@ let ppf =
else Format.std_formatter
let ppf_err = Format.err_formatter
let specs =
if Load_xml.expat_support then
("--expat", Arg.Unit (fun () -> Load_xml.use_parser := `Expat),
......@@ -69,9 +75,33 @@ let specs =
specs
let () =
let err s =
prerr_endline s;
exit 1
let mode =
Arg.parse specs (fun s -> src := s :: !src)
"\nUsage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:"
"Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
match (!compile,!run,!src,!args) with
| false, false, [], args -> `Toplevel args
| false, false, [x], args -> `Script (x,args)
| false, false, _, _ ->
err "Only one CDuce program can be executed at a time"
| true, false, [x], [] -> `Compile x
| true, false, [], [] ->
err "Please specifiy the CDuce program to be compiled"
| true, false, _, [] ->
err "Only one CDuce program can be compiled at a time"
| true, false, _, _ ->
err "No argument can be passed to programs at compile time"
| false, true, [x], args -> `Run (x,args)
| false, true, [], _ ->
err "Please specifiy the CDuce program to be executed"
| false, true, _, _ ->
err "Only one CDuce program can be executed at a time"
| true, true, _, _ ->
err "The options --compile and --run are incompatible"
let bol = ref true
......@@ -137,41 +167,51 @@ let do_stdin () =
let run s =
if s = "" then do_stdin () else do_file s
let main () =
(match !load_dump with
| Some f ->
(try
Format.fprintf ppf "Restoring state: ";
let chan = open_in_bin f in
let s = Marshal.from_channel chan in
close_in chan;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State.set s;
Format.fprintf ppf "done ...@."
with Sys_error _ ->
Format.fprintf ppf "failed ...@.")
| None ->
let l = List.rev_map Value.string_latin1 !args in
let l = Value.sequence l in
let t = Sequence.star Sequence.string in
Cduce.enter_global_value (ident (U.mk "argv")) l t
);
(match !src with
| [] -> toploop ()
| l -> List.iter run l);
(match !save_dump with
| Some f ->
Format.fprintf ppf "Saving state ...@\n";
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let s = State.get () in
let chan = open_out_bin f in
Marshal.to_channel chan s [ Marshal.Closures ];
close_out chan
| None -> ())
let () =
let argv args =
Value.sequence (List.rev_map Value.string_latin1 args)
let restore argv =
match !load_dump with
| Some f ->
(try
Format.fprintf ppf "Restoring state: ";
let chan = open_in_bin f in
let s = Marshal.from_channel chan in
close_in chan;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State.set s;
Format.fprintf ppf "done ...@."
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
| Some f ->
Format.fprintf ppf "Saving state ...@\n";
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let s = State.get () in
let chan = open_out_bin f in
Marshal.to_channel chan s [ Marshal.Closures ];
close_out chan
| None -> ()
let main () =
match mode with
| `Toplevel args ->
restore (argv args);
toploop ();
save ()
| `Script (f,args) ->
Cduce.compile_run f (argv args)
| `Compile f ->
Cduce.compile f
| `Run (f,args) ->
Cduce.run f (argv args)
let () =
at_exit (fun () -> Stats.dump Format.std_formatter);
main ()
......
misc/bool.ml
View file @ 3385c1e7
......@@ -32,8 +32,6 @@ struct
| False
| Split of int * elem * t * t * t
include Custom.Dummy
let rec equal a b =
(a == b) ||
match (a,b) with
......@@ -78,7 +76,7 @@ struct
(match p with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
(match i with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
(match n with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
check p; check i; check n
X.check x; check p; check i; check n
let atom x =
let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
......
misc/custom.ml
View file @ 3385c1e7
......@@ -21,7 +21,7 @@ module Dummy = struct
let equal t1 t2 = failwith "equal not implemented"
let hash t = failwith "hash not implemented"
let compare t1 t2 = failwith "compare not implemented"
let serialize t = failwith "serialize not implemented"
let serialize t = failwith "serialize not implemented"
let deserialize t = failwith "deserialize not implemented"
end
......
misc/serialize.ml
View file @ 3385c1e7
......@@ -51,6 +51,7 @@ module Put = struct
(* TODO: handle negative ints better !! *)
let rec int t i =
assert (i >= 0);
bits 4 t i;
let i = i lsr 4 in
if i <> 0 then (bool t true; int t i) else (bool t false)
......@@ -64,6 +65,11 @@ module Put = struct
let string t s =
substring t s 0 (String.length s)
let magic t s =
for i = 0 to String.length s - 1 do
bits 8 t (Char.code (s.[i]))
done
let rec list f t = function
| [] -> bool t false
| hd::tl -> bool t true; f t hd; list f t tl
......@@ -140,6 +146,12 @@ module Get = struct
done;
s
let magic t s =
for i = 0 to String.length s - 1 do
let c = bits 8 t in
if (Char.code (s.[i]) != c) then failwith "Invalid magic code."
done
let rec list f t =
if bool t then let hd = f t in hd::(list f t)
else []
......