Skip to content

GitLab

C
cduce
Commit 837c43b8 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

[r2004-06-28 01:16:40 by afrisch] Fix capture in stub gen, registered types, functions 

Original author: afrisch
Date: 2004-06-28 01:16:40+00:00
parent 394baf3c
Hide whitespace changes
Inline Side-by-side
Showing with 147 additions and 77 deletions
Makefile.distrib
View file @ 837c43b8
......@@ -193,7 +193,7 @@ ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \
ALL_INTERFACES = schema/schema_types.mli
ifneq ($(ML_INTERFACE), false)
ALL_INTERFACES += ocamliface/mltypes.mli ocamluface/mlstub.mli
ALL_INTERFACES += ocamliface/mltypes.mli ocamliface/mlstub.mli
endif
DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
......
depend
View file @ 837c43b8
......@@ -220,28 +220,30 @@ driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx parser/parser.cmx misc/serialize.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx driver/librarian.cmi
ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo \
driver/librarian.cmi types/types.cmi ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx \
driver/librarian.cmx types/types.cmx ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi types/ident.cmo ocamliface/mltypes.cmi misc/ns.cmi \
types/sequence.cmi typing/typer.cmi types/types.cmi ocamliface/mlstub.cmi
compile/compile.cmi types/ident.cmo driver/librarian.cmi \
ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi typing/typer.cmi \
types/types.cmi ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
compile/compile.cmx types/ident.cmx ocamliface/mltypes.cmx misc/ns.cmx \
types/sequence.cmx typing/typer.cmx types/types.cmx ocamliface/mlstub.cmi
compile/compile.cmx types/ident.cmx driver/librarian.cmx \
ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
types/types.cmx ocamliface/mlstub.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi ocamliface/mlstub.cmi \
ocamliface/mltypes.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi schema/schema_common.cmi misc/state.cmi typing/typer.cmi \
types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
driver/librarian.cmi parser/location.cmi misc/ns.cmi parser/parser.cmi \
types/patterns.cmi types/sample.cmi schema/schema_common.cmi \
misc/state.cmi typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx runtime/explain.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx ocamliface/mlstub.cmx \
ocamliface/mltypes.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
types/sample.cmx schema/schema_common.cmx misc/state.cmx typing/typer.cmx \
types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
driver/librarian.cmx parser/location.cmx misc/ns.cmx parser/parser.cmx \
types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
query/query.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
parser/parser.cmi types/types.cmi query/query.cmi
......
driver/cduce.ml
View file @ 837c43b8
......@@ -275,18 +275,6 @@ let run rule ppf ppf_err input =
let topinput = run Parser.top_phrases
let script = run Parser.prog
ifdef ML_INTERFACE then
let stub_ml cu id =
try
let name = String.capitalize cu in
let (prolog, values) = Mltypes.read_cmi name in
let stub = Mlstub.stub cu id values in
Some (prolog,stub)
with
| Mltypes.Error s -> raise (Generic s)
| Not_found -> Printf.eprintf "Warning: no caml interface\n"; None
else
let stub_ml cu id = None;;
let compile src out_dir =
try
......@@ -299,9 +287,8 @@ let compile src out_dir =
| Some x -> x in
let out = Filename.concat out_dir (cu ^ ".cdo") in
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
Librarian.compile !verbose id src;
let stub = stub_ml cu id in
Librarian.save id out stub;
Librarian.compile !verbose cu id src;
Librarian.save id out;
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1
......@@ -311,7 +298,7 @@ let compile_run src =
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.compile !verbose cu id src;
Librarian.run id
with exn -> catch_exn Format.err_formatter exn; exit 1
......
driver/librarian.ml
View file @ 837c43b8
open Location
open Ident
type stub_ml
let stub_ml = ref (fun cu ty_env c_env -> None, [| |])
module C = Types.CompUnit
exception InconsistentCrc of C.t
......@@ -13,20 +17,26 @@ type t = {
typing: Typer.t;
compile: Compile.env;
code: Lambda.code_item list;
types: Types.t array;
mutable digest: Digest.t option;
vals: Value.t array;
mutable depends: C.t list;
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ]
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
mutable stub : stub_ml option
}
let mk (typing,compile,code) =
let mk ((typing,compile,code),types) =
{ typing = typing;
compile = compile;
code = code;
types = types;
digest = None;
vals = Array.make (Compile.global_size compile) Value.Absent;
depends = [];
status = `Unevaluated;
stub = None
}
let magic = "CDUCE:compunit:00003"
......@@ -43,14 +53,16 @@ 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
Lambda.Put.codes s cu.code;
Serialize.Put.array Types.serialize s cu.types
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 types = Serialize.Get.array Types.deserialize s in
mk ((typing,compile,code),types)
let serialize_dep=
Serialize.Put.list
......@@ -67,9 +79,11 @@ let find_obj id =
List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
Filename.concat p base
let save id out extra =
let save id out =
protect_op "Save compilation unit";
let cu = find id in
C.enter id;
let raw = Serialize.Put.run serialize cu in
let depend = C.close_serialize () in
......@@ -92,7 +106,7 @@ let save id out extra =
let depend = Serialize.Put.run serialize_dep depend in
let digest = Digest.string raw in
let oc = open_out out in
Marshal.to_channel oc (digest,depend,raw,extra) [];
Marshal.to_channel oc (digest,depend,raw,cu.stub) [];
close_out oc
......@@ -123,7 +137,9 @@ let show ppf id t v =
Types.Print.print t
| None -> ()
let rec compile verbose id src =
let rec compile verbose name id src =
check_loop id;
protect_op "Compile external file";
let ic =
......@@ -145,14 +161,16 @@ let rec compile verbose id src =
if verbose
then Some (show Format.std_formatter)
else None in
let cu =
let (ty_env,c_env,_) as cu =
Compile.comp_unit
?show
Builtin.env
(Compile.empty id)
p
in
let cu = mk cu in
let stub,types = !stub_ml name ty_env c_env in
let cu = mk (cu,types) in
cu.stub <- stub;
C.Tbl.add tbl id cu;
C.leave ();
during_compile := false;
......@@ -233,3 +251,4 @@ let () =
| _ -> assert false);;
let registered_types cu = (load cu).types
driver/librarian.mli
View file @ 837c43b8
......@@ -6,9 +6,15 @@ exception NoImplementation of Types.CompUnit.t
val obj_path: string list ref
val compile: bool -> Types.CompUnit.t -> string -> unit
val compile: bool -> string -> Types.CompUnit.t -> string -> 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 -> 'a -> unit
val save: Types.CompUnit.t -> string -> unit
val registered_types: Types.CompUnit.t -> Types.t array
type stub_ml
val stub_ml : (string -> Typer.t -> Compile.env ->
stub_ml option * Types.t array) ref
ocamliface/mlstub.ml
View file @ 837c43b8
......@@ -67,10 +67,12 @@ and variant = function
(* Syntactic tools *)
let var_counter = ref 0
let mk_var _ =
incr var_counter;
Printf.sprintf "x%i" !var_counter
let mk_vars l =
let i = ref 0 in
List.map (fun t -> incr i; Printf.sprintf "x%i" !i) l
let mk_vars = List.map mk_var
let loc = (-1,-1)
......@@ -93,15 +95,39 @@ let rec matches ine oute = function
| [v1;v2] ->
let_in <:patt<($lid:v1$,$lid:v2$)>> <:expr< Value.get_pair $ine$ >> oute
| v::vl ->
let oute = matches <:expr< r >> oute vl in
let_in <:patt<($lid:v$,r)>> <:expr< Value.get_pair $ine$ >> oute
let r = mk_var () in
let oute = matches <:expr< $lid:r$ >> oute vl in
let_in <:patt<($lid:v$,$lid:r$)>> <:expr< Value.get_pair $ine$ >> oute
| [] -> assert false
let list_lit el =
List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
(* Registered types *)
module HashTypes = Hashtbl.Make(Types)
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0
let register_type t =
let n =
try HashTypes.find registered_types t
with Not_found ->
let i = !nb_registered_types in
HashTypes.add registered_types t i;
incr nb_registered_types;
i
in
<:expr< types.($int:string_of_int n$) >>
let get_registered_types () =
let a = Array.make !nb_registered_types Types.empty in
HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
a
(* OCaml -> CDuce conversions *)
let to_cd_gen = ref []
let to_cd_fun_name t =
......@@ -111,6 +137,15 @@ let to_cd_fun t =
to_cd_gen := t :: !to_cd_gen;
to_cd_fun_name t
let to_ml_gen = ref []
let to_ml_fun_name t =
Printf.sprintf "to_ml_%i" t.uid
let to_ml_fun t =
to_ml_gen := t :: !to_ml_gen;
to_ml_fun_name t
let rec tuple = function
| [v] -> v
| v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
......@@ -129,7 +164,15 @@ let rec to_cd e t =
and to_cd_descr e = function
| Link t -> to_cd e t
| Arrow (t,s) -> failwith "to_cd: Arrow. TODO"
| Arrow (t,s) ->
(* Value.Abstraction (t,s, fun x -> s(<...> (t(x))) *)
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd <:expr< $e$ $arg$ >> s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Value.Abstraction ($tt$,$ss$,$abs$) >>
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let vars = mk_vars tl in
......@@ -165,14 +208,15 @@ and to_cd_descr e = function
pmatch e cases
| Record (l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
let x = mk_var () in
let l =
List.map
(fun (lab,t) ->
let e = to_cd <:expr<x.$lid:lab$>> t in
let e = to_cd <:expr<$lid:x$.$lid:lab$>> t in
<:expr< ($label_ascii lab$, $e$) >>)
l
in
let_in <:patt< x >> e <:expr< Value.record $list_lit l$ >>
let_in <:patt< $lid:x$ >> e <:expr< Value.record $list_lit l$ >>
| Abstract "int" -> <:expr< ocaml2cduce_int $e$ >>
| Abstract "char" -> <:expr< ocaml2cduce_char $e$ >>
......@@ -191,16 +235,9 @@ and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl
(* CDuce -> OCaml conversions *)
let to_ml_gen = ref []
let to_ml_fun_name t =
Printf.sprintf "to_ml_%i" t.uid
let to_ml_fun t =
to_ml_gen := t :: !to_ml_gen;
to_ml_fun_name t
let rec to_ml e t =
and to_ml e t =
(* Format.fprintf Format.std_formatter "to_ml %a@."
Mltypes.print t; *)
if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
......@@ -210,9 +247,10 @@ and to_ml_descr e = function
| Link t -> to_ml e t
| Arrow (t,s) ->
(* fun x -> s(Eval.eval_apply <...> (t(x))) *)
let arg = to_cd <:expr< x >> t in
let x = mk_var () in
let arg = to_cd <:expr< $lid:x$ >> t in
let res = to_ml <:expr< Eval.eval_apply $e$ $arg$ >> s in
<:expr< fun x -> $res$ >>
<:expr< fun $lid:x$ -> $res$ >>
| Tuple tl ->
(* let (x1,r) = Value.get_pair <...> in
......@@ -229,6 +267,7 @@ and to_ml_descr e = function
| "A",None -> `A
| "B",Some x -> `B (t(x))
*)
let x = mk_var () in
let cases =
List.map
(function
......@@ -236,8 +275,10 @@ and to_ml_descr e = function
<:patt< ($str: String.escaped lab$, None) >>,
<:expr< `$lid:lab$ >>
| (lab,Some t) ->
<:patt< ($str: String.escaped lab$, Some x) >>,
<:expr< `$lid:lab$ $to_ml <:expr< x >> t$ >>
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< `$lid:lab$ $to_ml ex t$ >>
) l in
pmatch <:expr< Value.get_variant $e$ >> cases
| Variant (l,false) ->
......@@ -257,13 +298,17 @@ and to_ml_descr e = function
| "false" -> <:expr< False >>
| lab -> <:expr< $lid:lab$ >>)
| (lab,[t]) ->
<:patt< ($str: String.escaped lab$, Some x) >>,
<:expr< $lid:lab$ $to_ml <:expr< x >> t$ >>
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< $lid:lab$ $to_ml ex t$ >>
| (lab,tl) ->
let vars = mk_vars tl in
let el = tuple_to_ml tl vars in
<:patt< ($str: String.escaped lab$, Some x) >>,
matches <:expr< x >> <:expr< $lid:lab$ ($list:el$) >> vars
let x = mk_var () in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
matches <:expr< $lid:x$ >>
<:expr< $lid:lab$ ($list:el$) >> vars
) l in
pmatch <:expr< Value.get_variant $e$ >> cases
| Record (l,false) ->
......@@ -271,12 +316,13 @@ and to_ml_descr e = function
| Record (l,true) ->
(* let x = <...> in
{ l1 = t1(Value.get_field x "l1"); ... } *)
let x = mk_var () in
let l =
List.map
(fun (lab,t) ->
(<:patt< $uid:lab$>>,
to_ml <:expr< Value.get_field x $label_ascii lab$ >> t)) l in
let_in <:patt< x >> e <:expr< {$list:l$} >>
to_ml <:expr< Value.get_field $lid:x$ $label_ascii lab$ >> t)) l in
let_in <:patt< $lid:x$ >> e <:expr< {$list:l$} >>
| Abstract "int" -> <:expr< cduce2ocaml_int $e$ >>
| Abstract "char" -> <:expr< cduce2ocaml_char $e$ >>
......@@ -359,11 +405,10 @@ let check_value ty_env c_env (s,caml_t,t) =
let e = to_ml <:expr< Eval.get_slot cu $int:string_of_int slot$ >> t in
<:patt< $uid:s$ >>, e
let stub name cu values =
let ty_env = !Typer.from_comp_unit cu in
let c_env = !Compile.from_comp_unit cu in
let stub name ty_env c_env values =
let items = List.map (check_value ty_env c_env) values in
let g = global_transl () in
(* open Cdml
open CDuce_all
......@@ -374,9 +419,22 @@ let stub name cu values =
[ <:str_item< open Cdml >>;
<:str_item< open CDuce_all >>;
<:str_item< value cu = Cdml.initialize $str: String.escaped name$ >> ] @
<:str_item< value cu = Cdml.initialize $str: String.escaped name$ >>;
<:str_item< value types = Librarian.registered_types cu >>
] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
[ <:str_item< value $list:items$ >> ]
let () =
Librarian.stub_ml := fun cu ty_env c_env ->
try
let name = String.capitalize cu in
let (prolog, values) = Mltypes.read_cmi name in
let code = stub cu ty_env c_env values in
Some (Obj.magic (prolog,code)),
get_registered_types ()
with
| Mltypes.Error s -> raise (Location.Generic s)
| Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||]
ocamliface/mlstub.mli
View file @ 837c43b8
val stub:
string -> Types.CompUnit.t -> (string * OCaml_all.Types.type_expr * Mltypes.t ) list ->
MLast.str_item list
(* nothing *)
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