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

Strengthen the dynamic loading of OCaml objects.

parent f01aadb2
......@@ -200,7 +200,7 @@ parser/cduce_loc.cmo parser/cduce_url.cmo \
types/patterns.cmo \
compile/print_auto.cmo \
\
compile/lambda.cmo \
compile/lambda.cmo compile/dlink.cmo \
runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
\
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
......
......@@ -375,10 +375,6 @@ let rec collect_types accu = function
| rest -> (accu,rest)
let link file =
Dynlink.(loadfile (adapt_filename (file ^ ".cmo")))
let rec phrases ~run ~show ~directive =
let rec loop accu phs =
match phs with
......@@ -407,10 +403,9 @@ let rec phrases ~run ~show ~directive =
directive tenv cenv d;
loop accu rest
| { descr = Ast.Link f } :: rest ->
link f;
let aname, digest = Dlink.load (f ^ ".cmo") in
let (tenv, cenv, codes) = accu in
link f;
loop (tenv, cenv, (Lambda.Link f) :: codes) rest
loop (tenv, cenv, (Lambda.Link (digest,aname, f)) :: codes) rest
| [] ->
accu
in
......
......@@ -24,7 +24,5 @@ val comp_unit:
Typer.t -> env -> Ast.pmodule_item list ->
Typer.t * env * Lambda.code_item list
val link : string -> unit
val from_comp_unit: (Compunit.t -> env) ref
(* Defined in Librarian *)
let obj_table = Hashtbl.create 17
let resolve_file digest real_name name =
let aname = Dynlink.adapt_filename name in
match real_name with
Some real_name when real_name <> aname ->
failwith (Printf.sprintf "Trying to load %s while %s is expected" aname real_name)
| _ ->
let path = Cduce_loc.resolve_filename aname in
if not (Sys.file_exists path) then
failwith (Printf.sprintf "Cannot find OCaml object file %s" path);
let new_digest = Digest.file path in
match digest with
Some digest when digest <> new_digest ->
failwith (Printf.sprintf "Checksum error while loading %s" path)
| _ -> (path, aname, new_digest)
let load ?digest ?real_name name =
let path, aname, digest = resolve_file digest real_name name in
try
let saved_digest = Hashtbl.find obj_table path in
if saved_digest <> digest then
failwith (Printf.sprintf "Inconsistent assumptions over OCaml object file %s" path);
(aname, digest)
with Not_found ->
Hashtbl.add obj_table path digest;
Dynlink.loadfile aname;
(aname, digest)
val load : ?digest:Digest.t -> ?real_name:string -> string -> (string * Digest.t)
......@@ -10,29 +10,29 @@ type var_loc =
(* Slot in the table of locals *)
| Env of int
(* Slot in the environment *)
| Ext of Compunit.t * int
| Ext of Compunit.t * int
(* Global slot from a given compilation unit *)
(* If pos < 0, the first arg is the value *)
| External of Compunit.t * int
| External of Compunit.t * int
(* OCaml External *)
(* If pos < 0, the first arg is the value *)
| Builtin of string
(* OCaml external embedded in the runtime *)
| Global of int
| Global of int
(* Only for the toplevel *)
| Dummy
type iface = (Types.descr * Types.descr) list
type sigma =
type sigma =
| Identity (* this is basically as Types.Tallying.CS.sat *)
| List of Types.Subst.t list
| Comp of (sigma * sigma)
| Sel of (var_loc * iface * sigma)
| Sel of (var_loc * iface * sigma)
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type expr =
type expr =
| Var of var_loc
| TVar of (var_loc * sigma)
| Apply of expr * expr
......@@ -55,7 +55,7 @@ type expr =
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
| Op of string * expr list
| Op of string * expr list
| OpResolved of (Value.t list -> Value.t) * expr list
| NsTable of Ns.table * expr
......@@ -72,8 +72,8 @@ type code_item =
| LetDecls of expr * int * Auto_pat.state * int
(* expression, size of locals, dispatcher, number of globals to set *)
| LetDecl of expr * int
| Link of string
| Link of (Digest.t * string * string)
type code = code_item list
module Print = struct
......
......@@ -72,7 +72,7 @@ type code_item =
| LetDecls of expr * int * Auto_pat.state * int
(* expression, size of locals, dispatcher, number of globals to set *)
| LetDecl of expr * int
| Link of string
| Link of (Digest.t * string * string)
type code = code_item list
......
......@@ -138,6 +138,8 @@ compile/lambda.cmx : runtime/value.cmx misc/utils.cmx misc/upool.cmx \
types/types.cmx types/type_tallying.cmx schema/schema_validator.cmx \
misc/ns.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
types/compunit.cmx compile/auto_pat.cmx compile/lambda.cmi
compile/dlink.cmo : parser/cduce_loc.cmi compile/dlink.cmi
compile/dlink.cmx : parser/cduce_loc.cmx compile/dlink.cmi
runtime/run_dispatch.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
types/type_tallying.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/chars.cmi compile/auto_pat.cmi types/atoms.cmi \
......@@ -155,11 +157,13 @@ runtime/explain.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
runtime/eval.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
schema/schema_validator.cmi schema/schema_common.cmi \
runtime/run_dispatch.cmi misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
types/ident.cmo runtime/explain.cmi compile/auto_pat.cmi runtime/eval.cmi
types/ident.cmo runtime/explain.cmi compile/dlink.cmi \
compile/auto_pat.cmi runtime/eval.cmi
runtime/eval.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
schema/schema_validator.cmx schema/schema_common.cmx \
runtime/run_dispatch.cmx misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
types/ident.cmx runtime/explain.cmx compile/auto_pat.cmx runtime/eval.cmi
types/ident.cmx runtime/explain.cmx compile/dlink.cmx \
compile/auto_pat.cmx runtime/eval.cmi
parser/ulexer.cmo : parser/cduce_loc.cmi parser/ulexer.cmi
parser/ulexer.cmx : parser/cduce_loc.cmx parser/ulexer.cmi
parser/ast.cmo : types/types.cmi types/sequence.cmi misc/ns.cmi \
......@@ -207,13 +211,15 @@ typing/typer.cmx : types/var.cmx misc/utils.cmx types/types.cmx \
compile/compile.cmo : types/var.cmi runtime/value.cmi misc/upool.cmi \
types/types.cmi typing/typer.cmi typing/typed.cmo types/type_tallying.cmi \
types/patterns.cmi misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
types/ident.cmo runtime/eval.cmi types/compunit.cmi parser/cduce_loc.cmi \
compile/auto_pat.cmi parser/ast.cmo compile/compile.cmi
types/ident.cmo runtime/eval.cmi compile/dlink.cmi types/compunit.cmi \
parser/cduce_loc.cmi compile/auto_pat.cmi parser/ast.cmo \
compile/compile.cmi
compile/compile.cmx : types/var.cmx runtime/value.cmx misc/upool.cmx \
types/types.cmx typing/typer.cmx typing/typed.cmx types/type_tallying.cmx \
types/patterns.cmx misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
types/ident.cmx runtime/eval.cmx types/compunit.cmx parser/cduce_loc.cmx \
compile/auto_pat.cmx parser/ast.cmx compile/compile.cmi
types/ident.cmx runtime/eval.cmx compile/dlink.cmx types/compunit.cmx \
parser/cduce_loc.cmx compile/auto_pat.cmx parser/ast.cmx \
compile/compile.cmi
schema/schema_parser.cmo : schema/schema_xml.cmi schema/schema_validator.cmi \
schema/schema_utils.cmi schema/schema_types.cmi schema/schema_common.cmi \
schema/schema_builtin.cmi misc/ns.cmi misc/encodings.cmi \
......@@ -332,14 +338,12 @@ plugins/expat_plugin.cmo : runtime/value.cmi schema/schema_xml.cmi \
plugins/expat_plugin.cmx : runtime/value.cmx schema/schema_xml.cmx \
runtime/load_xml.cmx parser/cduce_url.cmx driver/cduce_config.cmx \
plugins/expat_plugin.cmi
plugins/jsoo_plugin.cmo : runtime/value.cmi types/types.cmi \
compile/operators.cmi misc/ns.cmi runtime/load_xml.cmi \
types/intervals.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
driver/cduce_config.cmi types/builtin_defs.cmi plugins/jsoo_plugin.cmi
plugins/jsoo_plugin.cmx : runtime/value.cmx types/types.cmx \
compile/operators.cmx misc/ns.cmx runtime/load_xml.cmx \
types/intervals.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
driver/cduce_config.cmx types/builtin_defs.cmx plugins/jsoo_plugin.cmi
plugins/dummy_js_plugin.cmo : runtime/value.cmi types/types.cmi \
compile/operators.cmi misc/ns.cmi driver/cduce_config.cmi \
types/builtin_defs.cmi
plugins/dummy_js_plugin.cmx : runtime/value.cmx types/types.cmx \
compile/operators.cmx misc/ns.cmx driver/cduce_config.cmx \
types/builtin_defs.cmx
driver/run.cmo : runtime/value.cmi parser/ulexer.cmi misc/stats.cmi \
misc/ns.cmi driver/librarian.cmi types/ident.cmo misc/html.cmi \
parser/cduce_loc.cmi driver/cduce_config.cmi driver/cduce.cmi \
......@@ -458,6 +462,7 @@ compile/print_auto.cmi : compile/auto_pat.cmi
compile/lambda.cmi : runtime/value.cmi types/types.cmi \
schema/schema_validator.cmi misc/ns.cmi misc/imap.cmi types/ident.cmo \
types/compunit.cmi compile/auto_pat.cmi
compile/dlink.cmi :
runtime/run_dispatch.cmi : runtime/value.cmi compile/auto_pat.cmi
runtime/explain.cmi : runtime/value.cmi compile/auto_pat.cmi
runtime/eval.cmi : runtime/value.cmi misc/ns.cmi compile/lambda.cmi \
......@@ -488,7 +493,6 @@ driver/cduce.cmi : runtime/value.cmi types/atoms.cmi
plugins/pxp_plugin.cmi :
plugins/pxp_plugin.cmi :
plugins/expat_plugin.cmi :
plugins/jsoo_plugin.cmi :
plugins/expat_plugin.cmi :
plugins/pxp_plugin.cmi :
plugins/jsoo_plugin.cmi :
......
(* TODO: handle encodings of the input for pretty printing
fragments of code *)
type source = [ `None | `File of string | `Stream | `String of string
type source = [ `None | `File of string | `Stream | `String of string
| `Buffer of Buffer.t ]
type loc = source * int * int
type precise = [ `Full | `Char of int ]
let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
if s1 = s2 then
if i1 = -1 then loc2 else if i2 = -1 then loc1 else
if s1 = s2 then
if i1 = -1 then loc2 else if i2 = -1 then loc1 else
(s1, min i1 i2, max j1 j2)
else loc1
......@@ -16,7 +16,7 @@ let source = ref `None
let get_source () = !source
let source_stack = ref []
let push_source s = source_stack := !source :: !source_stack; source := s
let pop_source () =
let pop_source () =
match !source_stack with
| [] -> assert false
| s::rem -> source_stack := rem; source := s
......@@ -87,7 +87,7 @@ let print_precise ppf = function
| `Full -> ()
| `Char i -> Format.fprintf ppf "Char %i of the string:@\n" i
let print_loc ppf ((src,i,j),w) =
let print_loc ppf ((src,i,j),w) =
match src with
| `None -> () (*Format.fprintf ppf "somewhere (no source defined !)"*)
| `Stream | `String _ ->
......@@ -135,7 +135,7 @@ let html_hilight ((src,i,j),w) =
match (src, Html.is_html v) with
| `String s, true ->
if (i < 0) then
Html.markup v "b"
Html.markup v "b"
(fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else
let i0 = beg_of_line s i in
......@@ -149,7 +149,7 @@ let html_hilight ((src,i,j),w) =
Format.fprintf ppf "%s@." (extr s j j0);
)
| _ -> ()
type 'a located = { loc : loc; descr : 'a }
......@@ -164,18 +164,20 @@ let is_protected () = !protected
let protect_op op =
if (!protected) then
raise
raise
(Generic (op ^ ": operation not authorized in the web prototype"))
let obj_path = ref [ "" ; <:symbol<cduce_libdir>> ]
let resolve_filename s =
let resolve_filename ?(test=(fun (_:string) -> true)) s =
if Filename.is_relative s then
try
let p =
List.find
(fun p -> Sys.file_exists (Filename.concat p s))
let p =
List.find
(fun p ->
let path = Filename.concat p s in
Sys.file_exists path && test path)
(current_dir () :: !obj_path) in
Filename.concat p s
with Not_found -> s
......
......@@ -55,4 +55,4 @@ val protect_op : string -> unit
val obj_path: string list ref
val resolve_filename: string -> string
val resolve_filename: ?test:(string -> bool) -> string -> string
......@@ -280,7 +280,6 @@ and eval_remove_field l = function
| _ -> assert false
let expr e lsize = eval [||] (Array.create lsize Value.Absent) e
let link s = Dynlink.(loadfile (adapt_filename (s ^ ".cmo")))
(* Evaluation in the toplevel *)
let eval_toplevel = function
......@@ -296,7 +295,8 @@ let eval_toplevel = function
let v = expr e lsize in
set globs !nglobs v;
incr nglobs
| Link s -> link s
| Link (digest, aname, s) ->
ignore (Dlink.load ~digest ~real_name:aname ( s ^ ".cmo"))
let eval_toplevel items =
let n = !nglobs in
......@@ -320,8 +320,9 @@ let eval_unit globs nglobs = function
let v = expr e lsize in
globs.(!nglobs) <- v;
incr nglobs
| Link s -> link s
| Link (digest, aname, s) ->
ignore (Dlink.load ~digest ~real_name:aname ( s ^ ".cmo"))
let eval_unit globs items =
let nglobs = ref 0 in
List.iter (eval_unit globs nglobs) items;
......
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