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

[r2003-10-08 21:24:38 by cvscast] Separate compilation

Original author: cvscast
Date: 2003-10-08 21:25:22+00:00
parent 352961ec
...@@ -66,7 +66,7 @@ uninstall: ...@@ -66,7 +66,7 @@ uninstall:
# Source directories # Source directories
DIRS = misc parser schema typing types compile runtime driver module DIRS = misc parser schema typing types compile runtime driver
CLEAN_DIRS = $(DIRS) tools tests CLEAN_DIRS = $(DIRS) tools tests
# Objects to build # Objects to build
...@@ -75,7 +75,7 @@ OBJECTS = \ ...@@ -75,7 +75,7 @@ OBJECTS = \
misc/stats.cmo \ misc/stats.cmo \
misc/serialize.cmo misc/custom.cmo \ misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \ misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo misc/ns.cmo \ misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo \
\ \
types/sortedList.cmo types/boolean.cmo types/ident.cmo \ types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \ types/intervals.cmo types/chars.cmo types/atoms.cmo \
...@@ -100,7 +100,7 @@ OBJECTS = \ ...@@ -100,7 +100,7 @@ OBJECTS = \
compile/compile.cmo \ compile/compile.cmo \
compile/operators.cmo \ compile/operators.cmo \
\ \
types/builtin.cmo driver/cduce.cmo types/builtin.cmo driver/librarian.cmo driver/cduce.cmo
CDUCE = $(OBJECTS) driver/run.cmo CDUCE = $(OBJECTS) driver/run.cmo
WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
...@@ -173,10 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml ...@@ -173,10 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml
(cd web/examples; ../../cduce --quiet build.cd --arg examples.xml) (cd web/examples; ../../cduce --quiet build.cd --arg examples.xml)
webpages: cduce web/site.cdo webpages: cduce web/site.cdo
(cd web; ../cduce --run site.cdo --arg site.xml) (cd web; ../cduce --run site --arg site.xml)
web/site.cdo: cduce web/site.cd web/site.cdo: cduce web/xhtml.cdo web/site.cd
./cduce --compile web/site.cd (cd web; ../cduce --compile site)
web/xhtml.cdo: cduce web/xhtml.cd
(cd web; ../cduce --compile xhtml)
website: webpages webiface website: webpages webiface
......
...@@ -26,10 +26,19 @@ let find x env = ...@@ -26,10 +26,19 @@ let find x env =
with Not_found -> with Not_found ->
failwith ("Compile: cannot find " ^ (Ident.to_string x)) failwith ("Compile: cannot find " ^ (Ident.to_string x))
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)
| _ -> assert false
let rec compile env tail e = compile_aux env tail e.Typed.exp_descr let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function and compile_aux env tail = function
| Typed.Forget (e,_) -> compile env tail e | Typed.Forget (e,_) -> compile env tail e
| Typed.Var x -> Var (find x env) | Typed.Var x -> Var (find x env)
| Typed.ExtVar (cu,x) -> find_ext cu x
| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2) | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
| Typed.Abstraction a -> compile_abstr env a | Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c | Typed.Cst c -> Const c
...@@ -155,6 +164,10 @@ let namespace (tenv,cenv,codes) pr ns = ...@@ -155,6 +164,10 @@ let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in let tenv = Typer.enter_ns pr ns tenv in
(tenv,cenv,codes) (tenv,cenv,codes)
let using (tenv,cenv,codes) x cu =
let tenv = Typer.enter_cu x cu tenv in
(tenv,cenv,codes)
let rec collect_funs accu = function let rec collect_funs accu = function
| { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest | { descr = Ast.FunDecl e } :: rest -> collect_funs (e::accu) rest
| rest -> (accu,rest) | rest -> (accu,rest)
...@@ -176,6 +189,8 @@ let rec phrases accu phs = match phs with ...@@ -176,6 +189,8 @@ let rec phrases accu phs = match phs with
phrases accu rest phrases accu rest
| { descr = Ast.Namespace (pr,ns) } :: rest -> | { descr = Ast.Namespace (pr,ns) } :: rest ->
phrases (namespace accu pr ns) rest phrases (namespace accu pr ns) rest
| { descr = Ast.Using (x,cu) } :: rest ->
phrases (using accu x cu) rest
| { descr = Ast.EvalStatement e } :: rest -> | { descr = Ast.EvalStatement e } :: rest ->
phrases (eval accu e) rest phrases (eval accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest -> | { descr = Ast.LetDecl (p,e) } :: rest ->
......
...@@ -2,7 +2,12 @@ open Ident ...@@ -2,7 +2,12 @@ open Ident
open Lambda open Lambda
type env type env
val from_comp_unit: (Types.CompUnit.t -> env) ref
val empty : env val empty : env
val serialize: env Serialize.Put.f
val deserialize: env Serialize.Get.f
val enter_global : env -> id -> env val enter_global : env -> id -> env
val enter_globals : env -> id list -> env val enter_globals : env -> id list -> env
val find : id -> env -> var_loc val find : id -> env -> var_loc
......
...@@ -8,6 +8,7 @@ type var_loc = ...@@ -8,6 +8,7 @@ type var_loc =
type expr = type expr =
| Var of var_loc | Var of var_loc
| ExtVar of Types.CompUnit.t * int
| Apply of bool * expr * expr | Apply of bool * expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches | Abstraction of var_loc array * (Types.t * Types.t) list * branches
...@@ -150,6 +151,10 @@ module Put = struct ...@@ -150,6 +151,10 @@ module Put = struct
bits nbits s 18; bits nbits s 18;
expr s e; expr s e;
Types.Node.serialize s t Types.Node.serialize s t
| ExtVar (cu,pos) ->
bits nbits s 19;
Types.CompUnit.serialize s cu;
int s pos
and branches s brs = and branches s brs =
list (pair Patterns.Node.serialize expr) s brs.brs; list (pair Patterns.Node.serialize expr) s brs.brs;
...@@ -254,6 +259,10 @@ module Get = struct ...@@ -254,6 +259,10 @@ module Get = struct
let e = expr s in let e = expr s in
let t = Types.Node.deserialize s in let t = Types.Node.deserialize s in
Ref (e,t) Ref (e,t)
| 19 ->
let cu = Types.CompUnit.deserialize s in
let pos = int s in
ExtVar (cu,pos)
| _ -> assert false | _ -> assert false
and branches s = and branches s =
......
...@@ -20,6 +20,8 @@ misc/ns.cmo: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/pool.cmi ...@@ -20,6 +20,8 @@ misc/ns.cmo: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/pool.cmi
misc/serialize.cmi misc/state.cmi misc/ns.cmi misc/serialize.cmi misc/state.cmi misc/ns.cmi
misc/ns.cmx: misc/q_symbol.cmo misc/custom.cmx misc/encodings.cmx misc/pool.cmx \ misc/ns.cmx: misc/q_symbol.cmo misc/custom.cmx misc/encodings.cmx misc/pool.cmx \
misc/serialize.cmx misc/state.cmx misc/ns.cmi misc/serialize.cmx misc/state.cmx misc/ns.cmi
misc/inttbl.cmo: misc/q_symbol.cmo misc/inttbl.cmi
misc/inttbl.cmx: misc/q_symbol.cmo misc/inttbl.cmi
types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi
types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi
...@@ -40,12 +42,14 @@ types/normal.cmo: misc/q_symbol.cmo types/normal.cmi ...@@ -40,12 +42,14 @@ types/normal.cmo: misc/q_symbol.cmo types/normal.cmi
types/normal.cmx: misc/q_symbol.cmo types/normal.cmi types/normal.cmx: misc/q_symbol.cmo types/normal.cmi
types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \ types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \ misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \
types/normal.cmi misc/ns.cmi misc/pretty.cmi misc/serialize.cmi \ misc/inttbl.cmi types/normal.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi misc/state.cmi misc/stats.cmi types/types.cmi misc/pretty.cmi misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
misc/stats.cmi types/types.cmi
types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \ types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \ misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
types/normal.cmx misc/ns.cmx misc/pretty.cmx misc/serialize.cmx \ misc/inttbl.cmx types/normal.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx misc/state.cmx misc/stats.cmx types/types.cmi misc/pretty.cmx misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
misc/stats.cmx types/types.cmi
types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \ types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo misc/serialize.cmi types/sortedList.cmi misc/state.cmi \ types/ident.cmo misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi types/types.cmi types/patterns.cmi
...@@ -159,11 +163,11 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi ...@@ -159,11 +163,11 @@ runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compi
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \ schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \ compile/compile.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
parser/location.cmi types/patterns.cmi typing/typed.cmo typing/typer.cmi \ parser/location.cmi types/patterns.cmi misc/serialize.cmi \
types/types.cmi compile/compile.cmi typing/typed.cmo typing/typer.cmi types/types.cmi compile/compile.cmi
compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx compile/lambda.cmx \ compile/compile.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx types/patterns.cmx typing/typed.cmx typing/typer.cmx \ parser/location.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx compile/compile.cmi 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 \ 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 \ parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi runtime/value.cmi compile/operators.cmi
...@@ -180,18 +184,26 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type ...@@ -180,18 +184,26 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
parser/location.cmx misc/ns.cmx compile/operators.cmx \ parser/location.cmx misc/ns.cmx compile/operators.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \ runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx types/builtin.cmi runtime/value.cmx types/builtin.cmi
driver/librarian.cmo: misc/q_symbol.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi types/ident.cmo compile/lambda.cmo \
parser/location.cmi parser/parser.cmi types/sequence.cmi \
misc/serialize.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
driver/librarian.cmi
driver/librarian.cmx: misc/q_symbol.cmo types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx parser/parser.cmx types/sequence.cmx \
misc/serialize.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
driver/librarian.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmi \ driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmi \
runtime/eval.cmi runtime/explain.cmi types/ident.cmo compile/lambda.cmo \ runtime/eval.cmi runtime/explain.cmi types/ident.cmo driver/librarian.cmi \
parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \ parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi types/sequence.cmi misc/serialize.cmi misc/state.cmi \ types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi parser/ulexer.cmi \ types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx compile/compile.cmx \ driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx compile/compile.cmx \
runtime/eval.cmx runtime/explain.cmx types/ident.cmx compile/lambda.cmx \ runtime/eval.cmx runtime/explain.cmx types/ident.cmx driver/librarian.cmx \
parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \ parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
types/sample.cmx types/sequence.cmx misc/serialize.cmx misc/state.cmx \ types/sample.cmx misc/state.cmx typing/typed.cmx typing/typer.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \ types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
runtime/value.cmx driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \ driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/state.cmi misc/stats.cmi \ parser/location.cmi types/sequence.cmi misc/state.cmi misc/stats.cmi \
parser/ulexer.cmi runtime/value.cmi parser/ulexer.cmi runtime/value.cmi
...@@ -212,7 +224,7 @@ types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo ...@@ -212,7 +224,7 @@ types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo
types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
types/atoms.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi types/atoms.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \ types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi types/ident.cmo types/intervals.cmi misc/inttbl.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \ types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/types.cmi types/ident.cmo types/types.cmi
types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi
...@@ -234,11 +246,11 @@ runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi ...@@ -234,11 +246,11 @@ runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi 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/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/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
runtime/value.cmi types/types.cmi runtime/value.cmi
compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \ compile/compile.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo compile/lambda.cmo \
typing/typed.cmo typing/typer.cmi misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi
compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.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 typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi
driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo misc/serialize.cmi types/types.cmi \ driver/librarian.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
runtime/value.cmi driver/cduce.cmi: misc/q_symbol.cmo types/ident.cmo types/types.cmi runtime/value.cmi
...@@ -250,6 +250,9 @@ let rec phrases ppf phs = match phs with ...@@ -250,6 +250,9 @@ let rec phrases ppf phs = match phs with
| { descr = Ast.Namespace (pr,ns) } :: rest -> | { descr = Ast.Namespace (pr,ns) } :: rest ->
typing_env := Typer.enter_ns pr ns !typing_env; typing_env := Typer.enter_ns pr ns !typing_env;
phrases ppf rest phrases ppf rest
| { descr = Ast.Using (x,cu) } :: rest ->
typing_env := Typer.enter_cu x cu !typing_env;
phrases ppf rest
| { descr = Ast.EvalStatement e } :: rest -> | { descr = Ast.EvalStatement e } :: rest ->
ignore (eval ppf e); ignore (eval ppf e);
phrases ppf rest phrases ppf rest
...@@ -298,55 +301,25 @@ let run rule ppf ppf_err input = ...@@ -298,55 +301,25 @@ let run rule ppf ppf_err input =
let script = run Parser.prog let script = run Parser.prog
let topinput = run Parser.top_phrases let topinput = run Parser.top_phrases
let comp_unit src = let compile 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 try
Eval.L.push argv; let id = Types.CompUnit.mk (U.mk_latin1 src) in
List.iter Eval.L.eval codes Librarian.compile id;
Librarian.save id;
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1 with exn -> catch_exn Format.err_formatter exn; exit 1
let compile src =
let codes = comp_unit src in
let oc = open_out ((prefix src ".cd") ^ ".cdo") 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 = let compile_run src argv =
run_code argv (comp_unit src) try
let id = Types.CompUnit.mk (U.mk_latin1 src) in
Librarian.compile id;
Librarian.run argv id
with exn -> catch_exn Format.err_formatter exn; exit 1
let run obj argv = let run obj argv =
let ic = open_in obj in try
let len = in_channel_length ic in let id = Types.CompUnit.mk (U.mk_latin1 obj) in
let codes = String.create len in Librarian.import id;
really_input ic codes 0 len; Librarian.run argv id
close_in ic; with exn -> catch_exn Format.err_formatter exn; exit 1
let codes = Serialize.Get.run Lambda.Get.compunit codes in
run_code argv codes
let serialize_typing_env t () =
Typer.serialize t !typing_env
let deserialize_typing_env t =
typing_env := Typer.deserialize t
...@@ -8,9 +8,6 @@ val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool ...@@ -8,9 +8,6 @@ val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit 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: string -> unit
val compile_run: string -> Value.t -> unit val compile_run: string -> Value.t -> unit
val run: string -> Value.t -> unit val run: string -> Value.t -> unit
open Location
open Ident
module C = Types.CompUnit
type t = {
typing: Typer.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
}
let mk (typing,compile,code) =
{ typing = typing;
compile = compile;
code = code;
digest = None;
vals = None;
depends = [];
}
let magic = "CDUCE:compunit:00001"
let tbl = C.Tbl.create ()
let find id =
try C.Tbl.find tbl id
with Not_found -> assert false
let serialize s cu =
Serialize.Put.magic s magic;
Typer.serialize s cu.typing;
Compile.serialize s cu.compile;
Lambda.Put.codes s cu.code
let deserialize s =
Serialize.Get.magic s magic;
let typing = Typer.deserialize s in
let compile = Compile.deserialize s in
let code = Lambda.Get.codes s in
mk (typing,compile,code)
let serialize_dep=
Serialize.Put.list
(Serialize.Put.pair Encodings.Utf8.serialize Serialize.Put.string)
let deserialize_dep =
Serialize.Get.list
(Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
let source_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cd"
let object_filename id = Encodings.Utf8.to_string (C.value id) ^ ".cdo"
let save id =
let cu = find id in
C.enter id;
let raw = Serialize.Put.run serialize cu in
let depend = C.close_serialize () in
C.leave ();
(*
print_endline "Dependencies:";
List.iter (fun x -> print_endline (object_filename x)) depend;
flush stdout;
*)
let depend =
try List.map
(fun id ->
match (C.Tbl.find tbl id).digest with
| Some d -> (C.value id, d)
| None -> assert false
) depend
with Not_found -> assert false in
let depend = Serialize.Put.run serialize_dep depend in
let digest = Digest.string raw in
let oc = open_out (object_filename id) in
output_value oc (digest,depend,raw);
close_out oc
let check_digest exp digest =
match digest with
| Some x ->
if exp <> x then failwith "Inconsistent checksum"
| None ->
assert false
let loop = C.Tbl.create ()
let check_loop id =
try
C.Tbl.find loop id;
failwith "Loop between compilation units"
with Not_found ->
C.Tbl.add loop id ()
let depends = ref []
let during_compile = ref false
let rec compile id =
check_loop id;
let src = source_filename id in
let ic = open_in src in
Location.push_source (`File src);
let input = Stream.of_channel ic in
let p =
try Parser.prog input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
in
close_in ic;
let argv = ident (U.mk "argv") in
during_compile := true;
C.enter id;
let cu = mk
(
Compile.comp_unit
(Typer.enter_value argv (Sequence.star Sequence.string)
Builtin.env)
(Compile.enter_global Compile.empty argv)
p
) in
C.Tbl.add tbl id cu;
C.leave ();
during_compile := false;
cu.depends <- !depends;
depends := []
let rec load id =
try
C.Tbl.find tbl id
with Not_found ->
check_loop id;
if !during_compile then depends := id :: !depends;
(* Printf.eprintf "load %s: start\n" (object_filename id);
flush stderr; *)
let ic = open_in (object_filename id) in
let (dig, depend, raw) = input_value ic in
close_in ic;
let depend = Serialize.Get.run deserialize_dep depend in
List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
C.enter id;
let cu = Serialize.Get.run deserialize raw in
C.leave ();
cu.depends <- List.map (fun (id,_) -> C.mk id) depend;
cu.digest <- Some dig;
C.Tbl.add tbl id cu;
cu
and load_check id exp =
let cu = load id in
check_digest exp cu.digest
let rec run argv id =
let cu = find id in
List.iter (run argv) cu.depends;
Eval.L.push argv;
List.iter Eval.L.eval cu.code;
cu.vals <- Some (Eval.L.comp_unit ())
let import id = ignore (load id)
let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.L.from_comp_unit := (fun cu i ->
match (load cu).vals with
| None -> assert false
| Some a -> a.(i))
val compile: Types.CompUnit.t -> unit
val run: Value.t -> Types.CompUnit.t -> unit
val import: Types.CompUnit.t -> unit
val save: Types.CompUnit.t -> unit
module type S = sig
type key
type 'a t
val create: unit -> 'a t
val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
val clear: 'a t -> unit
val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a
end