Skip to content

GitLab

Commit fd986283 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Implement recursive compilation of needed dependencies (like the javac compiler). 

If A.cd relies on B.cdo and B.cd is found in the object path, then B.cd is compiled automatically.
parent c25636ac
Hide whitespace changes
Inline Side-by-side
driver/cduce.ml
View file @ fd986283
......@@ -142,6 +142,9 @@ let rec print_exn ppf = function
Format.fprintf ppf "Unbound external identifier %a:%a@."
U.print (Librarian.name cu)
Ident.print x
| Typer.UnboundCompUnit (cu) ->
Format.fprintf ppf "Unbound compilation unit %a@."
U.print cu
| Ulexer.Error (i,j,s) ->
let loc = Cduce_loc.loc_of_pos (i,j), `Full in
Cduce_loc.print_loc ppf loc;
......
driver/librarian.ml
View file @ fd986283
......@@ -7,6 +7,7 @@ exception CannotOpen of string
exception NoImplementation of U.t
let run_loaded = ref false
let depends = ref false
type t = {
name: U.t;
......@@ -47,20 +48,22 @@ let mk name descr typing compile code ext_info depends =
status = `Unevaluated;
}
let magic = "CDUCE:compunit:00008"
let magic = "CDUCE:compunit:00009"
let has_obj n =
let base = U.to_string n ^ ".cdo" in
List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path
let find_obj n =
let base = U.to_string n ^ ".cdo" in
let find_obj ?(ext=".cdo") n =
let base = U.to_string n ^ ext in
let p =
List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
Filename.concat p base
let check_digest c dig =
if digest c <> dig then raise (InconsistentCrc c.name)
let check_digest ?(loc="") c dig =
let d = digest c in
let res = U.mk ((U.to_string c.name) ^ " "^ loc ^" : " ^ (String.escaped d) ^ ", " ^ (String.escaped dig)) in
if digest c <> dig then raise (InconsistentCrc (*c.name*) res)
let show ppf id t v =
match id with
......@@ -71,63 +74,6 @@ let show ppf id t v =
| None -> ()
let compile verbose name src =
protect_op "Compile external file";
let ic =
if src = "" then (Cduce_loc.push_source `Stream; stdin)
else
try Cduce_loc.push_source (`File src); open_in src
with Sys_error _ -> raise (CannotOpen src) in
let input = Stream.of_channel ic in
let p =
try Parser.prog input
with
| Ulexer.Loc.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
| Ulexer.Loc.Exc_located ((i,j), e) ->
raise_loc i j e
in
if src <> "" then close_in ic;
let show =
if verbose
then Some (show Format.std_formatter)
else None in
Compunit.enter ();
let descr = Compunit.current () in
let (ty_env,c_env,code) =
Compile.comp_unit
?show
Builtin.env
(Compile.empty descr)
p in
Compunit.leave ();
let ext = Externals.get () in
let depends = Tbl.fold (fun name c accu -> (name,digest c) :: accu) tbl [] in
mk name descr ty_env c_env code ext depends
let set_hash c =
let h = Hashtbl.hash_param 1000 10000 (c.typing,c.name) in
let max_rank =
Tbl.fold
(fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0 in
Compunit.set_hash c.descr (succ max_rank) h
(* This invalidates all hash tables on types ! *)
let compile_save verbose name src out =
protect_op "Save compilation unit";
let c = compile verbose name src in
set_hash c;
let pools = Value.extract_all () in
let ints = Intervals.V.extract () in
let oc = open_out_bin out in
output_string oc magic;
Marshal.to_channel oc (pools,c, ints) [Marshal.Compat_32];
let digest = Digest.file out in
Marshal.to_channel oc digest [Marshal.Compat_32];
close_out oc
let from_descr descr : t =
try CTbl.find ctbl descr
with Not_found ->
......@@ -150,10 +96,9 @@ let rec real_load src =
let s = String.copy magic in
really_input ic s 0 (String.length s);
if s <> magic then raise (InvalidObject src);
let pools, c, ints = Marshal.from_channel ic in
let pools, c = Marshal.from_channel ic in
let digest = Marshal.from_channel ic in
c.digest <- Some digest;
Intervals.V.intract ints;
Value.intract_all pools;
close_in ic;
c
......@@ -172,10 +117,93 @@ and load name =
if !reg_types then
Typer.register_types (U.to_string c.name ^ ".") c.typing;
(* Load dependencies *)
List.iter (fun (name,dig) -> check_digest (load name) dig) c.depends;
List.iter (fun (name,dig) -> check_digest ~loc:"load" (load name) dig) c.depends;
Tbl.add tbl name c;
c
let set_hash c =
let h = Hashtbl.hash_param 1000 10000 (c.typing,c.name) in
let max_rank =
Tbl.fold
(fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0 in
Compunit.set_hash c.descr (succ max_rank) h
(* This invalidates all hash tables on types ! *)
let rec compile verbose name src =
protect_op "Compile external file";
let ic =
if src = "" then (Cduce_loc.push_source `Stream; stdin)
else
try Cduce_loc.push_source (`File src); open_in src
with Sys_error _ -> raise (CannotOpen src) in
let input = Stream.of_channel ic in
let p =
try Parser.prog input
with
| Ulexer.Loc.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
| Ulexer.Loc.Exc_located ((i,j), e) ->
raise_loc i j e
in
if src <> "" then close_in ic;
let show =
if verbose
then Some (show Format.std_formatter)
else None
in
let rec loop deps =
match begin
Compunit.enter ();
let descr = Compunit.current () in
try
`Principal (descr, Compile.comp_unit
?show
Builtin.env
(Compile.empty descr)
p)
with Location (loc, _, Typer.UnboundCompUnit (name2)) when !depends ->
Compunit.leave ();
let src2 = find_obj ~ext:".cd" name2 in
let c, deps = compile verbose name2 src2 in
set_hash c;
let pools = Value.extract_all () in
assert (c.digest == None);
let bytecode = Marshal.to_string (pools, c) [Marshal.Compat_32] in
c.digest <- Some (Digest.string (magic ^ bytecode));
register c;
Tbl.add tbl name2 c;
`Depends ((c, pools, src2 ^ "o")::deps)
end
with
`Principal (descr, cu) -> descr, cu, deps
| `Depends (new_deps) -> loop (new_deps @ deps)
in
let descr, (ty_env, c_env, code), l = loop [] in
Cduce_loc.pop_source ();
Compunit.leave ();
let ext = Externals.get () in
let depends = Tbl.fold (fun name c accu -> (name,digest c) :: accu) tbl [] in
mk name descr ty_env c_env code ext depends, l
let compile_save verbose name src out =
protect_op "Save compilation unit";
let c, deps = compile verbose name src in
set_hash c;
let pools = Value.extract_all () in
let deps = deps @ [ (c, pools, out) ] in
List.iter (fun (c, pools, out) ->
let oc = open_out_bin out in
output_string oc magic;
c.digest <- None;
Marshal.to_channel oc (pools,c) [Marshal.Compat_32];
flush oc;
let digest = Digest.file out in
Marshal.to_channel oc digest [Marshal.Compat_32];
close_out oc) deps
let rec run c =
match c.status with
| `Unevaluated ->
......@@ -196,7 +224,7 @@ let rec run c =
| `Evaluated -> ()
let compile_run verbose name src =
let c = compile verbose name src in
let c,_ = compile verbose name src in
register c;
run c
......@@ -213,7 +241,7 @@ let get_builtins () =
let () =
Typer.from_comp_unit := (fun d -> (from_descr d).typing);
Typer.load_comp_unit := (fun name ->
if has_obj name then
if has_obj name || Tbl.mem tbl name then
let cu = load name in
if !run_loaded then run cu;
cu.descr
......@@ -256,7 +284,7 @@ let ocaml_stub stub =
with Not_found ->
failwith ("CDuce unit " ^ (U.get_str name) ^ " not loaded")
in
check_digest c dig) c.depends;
check_digest ~loc:"ocaml_stub" c dig) c.depends;
Tbl.add tbl c.name c;
types,
(fun a -> c.exts <- a),
......
driver/librarian.mli
View file @ fd986283
......@@ -7,6 +7,7 @@ exception NoImplementation of U.t
val name: Compunit.t -> U.t
val run_loaded: bool ref
val depends: bool ref
val compile_save: bool -> U.t -> string -> string -> unit
val compile_run: bool -> U.t -> string -> unit
......
driver/run.ml
View file @ fd986283
......@@ -9,7 +9,6 @@ let run = ref false
let script = ref false
let mlstub = ref false
let topstub = ref false
let version () =
Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
Printf.eprintf "built on %s\n" <:symbol<build_date>>;
......@@ -18,40 +17,44 @@ let version () =
List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
exit 0
let specs =
let specs = Arg.align
[ "--compile", Arg.Set compile,
"compile the given CDuce file";
" compile the given CDuce file";
"-c", Arg.Set compile,
" same as --compile";
" same as --compile";
"--depends", Arg.Set Librarian.depends,
" (for --compile) recursively compile needed compilation units";
"-d", Arg.Set Librarian.depends,
" same as --depends";
"--run", Arg.Set run,
" execute the given .cdo files";
" execute the given .cdo files";
"--verbose", Arg.Set Cduce.verbose,
"(for --compile) show types of exported values";
" (for --compile) show types of exported values";
"--obj-dir", Arg.String (fun s -> out_dir := s :: !out_dir),
"(for --compile) directory for the compiled .cdo file";
" (for --compile) directory for the compiled .cdo file";
"-I", Arg.String (fun s -> Cduce_loc.obj_path := s::!Cduce_loc.obj_path),
" add one directory to the lookup path for .cdo/.cmi and include files";
" add one directory to the lookup path for .cdo/.cmi and include files";
"--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input";
" read CDuce script on standard input";
"--arg", Arg.Rest (fun s -> args := s :: !args),
" following arguments are passed to the CDuce program";
"--script", Arg.Rest (fun s ->
" following arguments are passed to the CDuce program";
"--script", Arg.Rest (fun s ->
if not !script then (script := true;
src := s :: !src)
else args := s :: !args),
" the first argument after is the source, then the arguments";
" the first argument after is the source, then the arguments";
"--no", Arg.String Cduce_config.inhibit,
" disable a feature (cduce -v to get a list of features)";
" disable a feature (cduce -v to get a list of features)";
"--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
" print profiling/debugging information";
"-v", Arg.Unit version,
" print CDuce version, and list built-in optional features";
" print profiling/debugging information";
"--version", Arg.Unit version,
"print CDuce version, and list built-in optional features";
" print CDuce version, and list built-in optional features";
"-v", Arg.Unit version,
" same as --version";
"--mlstub", Arg.Set mlstub,
" produce stub ML code from a compiled unit";
" produce stub ML code from a compiled unit";
"--topstub", Arg.Set topstub,
"produce stub ML code for a toplevel from a primitive file";
" produce stub ML code for a toplevel from a primitive file";
]
let ppf = Format.std_formatter
......@@ -62,7 +65,7 @@ let err s =
exit 1
let mode () =
Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src)
Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src)
"Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
if (!mlstub) then (
match !src with [x] -> `Mlstub x | _ ->
......@@ -71,14 +74,14 @@ let mode () =
match !src with [x] -> `Topstub x | _ ->
err "Please specify one primitive file"
) else match (!compile,!out_dir,!run,!src,!args) with
| false, _::_, _, _, _ ->
| false, _::_, _, _, _ ->
err "--obj-dir option can be used only with --compile"
| 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, [o], false, [x], [] -> `Compile (x,Some o)
| true, [], false, [x], [] -> `Compile (x,None)
| true, [o], false, [x], [] -> `Compile (x,Some o)
| true, [], false, [x], [] -> `Compile (x,None)
| true, [], false, [], [] ->
err "Please specify the CDuce program to be compiled"
| true, [], false, _, [] ->
......@@ -94,7 +97,7 @@ let mode () =
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
......@@ -116,16 +119,16 @@ let has_newline b =
let toploop () =
let restore =
try
let restore =
try
let tcio = Unix.tcgetattr Unix.stdin in
Unix.tcsetattr
Unix.tcsetattr
Unix.stdin Unix.TCSADRAIN { tcio with Unix.c_vquit = '\004' };
fun () -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio
with Unix.Unix_error (_,_,_) ->
with Unix.Unix_error (_,_,_) ->
fun () -> ()
in
let quit () =
let quit () =
outflush "\n";
restore ();
exit 0
......@@ -138,14 +141,14 @@ let toploop () =
let buf_in = Buffer.create 1024 in
Cduce_loc.push_source (`Buffer buf_in);
let read _i =
if !bol then
if !bol then
if !Ulexer.in_comment then outflush "* " else outflush "> ";
try
try
let c = input_char stdin in
Buffer.add_char buf_in c;
bol := c = '\n';
Some c
with Sys.Break -> quit ()
with Sys.Break -> quit ()
in
let input = Stream.from read in
let rec loop () =
......@@ -160,10 +163,10 @@ let toploop () =
(try loop () with End_of_file -> ());
restore ()
let argv args =
let argv args =
Value.sequence (List.rev_map Value.string_latin1 args)
let main () =
let main () =
at_exit (fun () -> Stats.dump Format.std_formatter);
Cduce_loc.set_viewport (Html.create false);
match mode () with
......
runtime/value.ml
View file @ fd986283
......@@ -975,12 +975,14 @@ let apply f arg = match f with
| Abstraction (_,f,_) -> f arg
| _ -> assert false
type pools = Ns.Uri.value array * Ns.Label.value array
type pools = Ns.Uri.value array * Ns.Label.value array * Intervals.V.ext_pool
let extract_all () =
Ns.Uri.extract (),
Ns.Label.extract ()
Ns.Label.extract (),
Intervals.V.extract ()
let intract_all (uri,label) =
let intract_all (uri,label, ints) =
Ns.Uri.intract uri;
Ns.Label.intract label
Ns.Label.intract label;
Intervals.V.intract ints
tests/loader/A.cd 0 → 100644
View file @ fd986283
let a : D.t = B.b []
\ No newline at end of file
tests/loader/B.cd 0 → 100644
View file @ fd986283
let b (_ : []) : D.t = C.c1 [] + C.c2 []
\ No newline at end of file
tests/loader/C.cd 0 → 100644
View file @ fd986283
let c1 ( _ : []) : Int = 41
let c2 ( _ : []) : Int = 1
\ No newline at end of file
tests/loader/D.cd 0 → 100644
View file @ fd986283
type t = Int
\ No newline at end of file
typing/typer.ml
View file @ fd986283
......@@ -17,6 +17,7 @@ exception UnboundId of id * bool
exception UnboundExtId of Compunit.t * id
exception Error of string
exception Warning of string * Types.t
exception UnboundCompUnit of U.t
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
......@@ -136,7 +137,7 @@ let type_using env loc x cu =
let cu = !load_comp_unit cu in
enter_id (ident env loc x) (ECDuce cu) env
with Not_found ->
error loc ("Cannot find external unit " ^ (U.to_string cu))
raise_loc loc (UnboundCompUnit cu)
let enter_type id t env = enter_id id (Type (t,[])) env
let enter_types l env =
......@@ -152,7 +153,7 @@ let find_id env0 env loc head x =
with Not_found when head ->
try ECDuce (!load_comp_unit x)
with Not_found ->
error loc "Cannot resolve this identifier"
raise_loc loc (UnboundCompUnit x)
let find_id_comp env0 env loc x =
if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
......
typing/typer.mli
View file @ fd986283
......@@ -11,6 +11,7 @@ exception UnboundExtId of Compunit.t * id
exception ShouldHave2 of Types.descr * string * Types.descr
exception Error of string
exception Warning of string * Types.t
exception UnboundCompUnit of U.t
val empty_env: t
val pp_env : Format.formatter -> t -> unit
......
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