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

[r2005-07-05 13:49:21 by afrisch] Merging cduce_serialize branch

Original author: afrisch
Date: 2005-07-05 13:49:26+00:00
parent 01d1289a
......@@ -6,8 +6,12 @@ webiface.opt
webiface
validate
evaluator
cdo2ml
mlcduce_wrapper
*.cmi
*.cmo
*.cmx
*.cma
*.cmxa
META
configure.log
......@@ -3,7 +3,16 @@ Since 0.3.2
* Added char_of_int built_in function.
* Now int_of also accepts octal binary and hexadecimals.
* The field access also works for XML element attributes.
* More efficient implementation of records at runtime
* More efficient implementation of records at runtime.
* Clean-up of the internal representation.
* The functionality of cdo2ml is now assured by cduce itself, with
the --mlstub option.
* The XML Schemas are now parsed only at compile time.
* The automata for pattern matching are now produced at compile time.
* Remove the --dump option (which was deprecated).
* Remove support for sessions in the web prototype.
* More catchable exceptions (for load_xml, load_file, etc).
* Correct handling of external references with expat.
0.3.2
* Bug fix in configure
......
......@@ -160,6 +160,6 @@ evaluator: $(EVALUATOR:.cmo=.$(EXTENSION))
# webiface can be made static to be able to move it more easily
# (to compile it on a machine which is not the web server)
# Seems to be some problems with statically linking curl
# EXTRA_OPTS_WEBIFACE = -ccopt -static
# EXTRA_OPTS_WEBIFACE += -ccopt -static
......@@ -16,7 +16,7 @@ ifeq ($(NATIVE),true)
all: cduce_lib.cmxa
endif
PACKAGES = ulex camlp4 cgi pcre num netstring
PACKAGES = ulex camlp4 pcre num netstring cgi
# Call make with VERBOSE=true to get a trace of commands
......@@ -39,14 +39,14 @@ SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %)
CAMLC_P = ocamlc -g
DEPEND_OCAMLDEP = misc/q_symbol.cmo
ifeq ($(PROFILE), true)
CAMLOPT_P = ocamlopt -p
CAMLOPT_P = ocamlopt -p -inline 10000
ifeq ($(NATIVE), false)
CAMLC_P = ocamlcp -p a
SYNTAX_PARSER =
DEPEND_OCAMLDEP =
endif
else
CAMLOPT_P = ocamlopt -inline 25
CAMLOPT_P = ocamlopt -inline 10000
endif
OPT = -warn-error FPS
......@@ -129,58 +129,46 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests
# Objects to build
SCHEMA_OBJS = \
schema/schema_pcre.cmo \
schema/schema_types.cmo \
schema/schema_xml.cmo \
schema/schema_common.cmo \
schema/schema_builtin.cmo \
schema/schema_validator.cmo \
schema/schema_parser.cmo \
schema/schema_converter.cmo
OBJECTS = \
driver/config.cmo \
misc/stats.cmo \
misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo \
misc/upool.cmo \
misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
misc/html.cmo \
driver/config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo \
\
types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo \
types/chars.cmo types/atoms.cmo \
types/normal.cmo \
types/types.cmo types/sample.cmo types/sequence.cmo types/patterns.cmo \
compile/auto_opt.cmo \
types/builtin_defs.cmo \
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/types.cmo compile/auto_pat.cmo \
types/sequence.cmo types/builtin_defs.cmo \
\
compile/lambda.cmo \
runtime/value.cmo \
\
parser/location.cmo parser/url.cmo \
\
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
schema/schema_pcre.cmo schema/schema_types.cmo \
schema/schema_xml.cmo schema/schema_common.cmo \
schema/schema_builtin.cmo schema/schema_validator.cmo \
\
types/externals.cmo \
typing/typed.cmo typing/typepat.cmo typing/typer.cmo \
types/patterns.cmo \
\
$(SCHEMA_OBJS) \
compile/lambda.cmo \
runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
\
parser/location.cmo parser/url.cmo \
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/explain.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
typing/typed.cmo typing/typepat.cmo types/externals.cmo typing/typer.cmo \
compile/compile.cmo \
compile/operators.cmo \
\
types/builtin.cmo \
driver/librarian.cmo \
schema/schema_parser.cmo schema/schema_converter.cmo \
runtime/load_xml.cmo runtime/print_xml.cmo compile/operators.cmo types/builtin.cmo \
driver/librarian.cmo types/sample.cmo \
compile/print_auto.cmo \
driver/cduce.cmo \
runtime/system.cmo
\
runtime/system.cmo query/query_aggregates.cmo
schema/schema_types.ml: schema/schema_types.mli
cp $^ $@
compile/auto_pat.ml: compile/auto_pat.mli
cp $^ $@
compile/lambda.ml: compile/lambda.mli
cp $^ $@
ML_INTERFACE_OBJS = \
ocamliface/caml_cduce.cmo \
......@@ -216,16 +204,6 @@ ifeq ($(EXPAT), true)
endif
#CQL_OBJECTS= query/query_aggregates.cmo query/query.cmo query/query_parse.cmo
#CQL_OBJECTS_RUN = query/query_run.cmo
CQL_OBJECTS= query/query_aggregates.cmo
CQL_OBJECTS_RUN=
OBJECTS += $(CQL_OBJECTS)
VALIDATE_OBJECTS := $(shell for o in $(OBJECTS); do echo $$o; if [ "$$o" = "schema/schema_parser.cmo" ]; then exit 0; fi; done) # all objects until schema_parser.cmo
OBJECTS += $(CQL_OBJECTS_RUN)
OBJECTS += driver/run.cmo
CDUCE = $(OBJECTS) driver/start.cmo
......@@ -265,21 +243,16 @@ dtd2cduce: tools/dtd2cduce.ml
@echo "Build $@"
$(HIDE)$(OCAMLFIND) $(CAML) -o $@ -ccopt -static -package "$(PXP_PACK) cgi" -linkpkg $^
cduce_validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^
mlcduce_wrapper: $(OBJECTS) ocamliface/mlcduce_wrapper.ml
@echo "Build $@"
$(HIDE)$(CAMLC) -linkpkg $(INCLUDES) -o $@ odyl.cma camlp4.cma pr_o.cmo $^ $(EXTRA_LINK_OPTS)
cdo2ml: ocamliface/cdo2ml.ml
@echo "Build $@"
$(HIDE)ocamlc -o $@ -pp camlp4o -I +camlp4 odyl.cma camlp4.cma pr_o.cmo $^
$(HIDE)ocamlc -o $@ -I +camlp4 camlp4.cma pr_o.cmo $<
.PHONY: compute_depend
compute_depend: $(DEPEND_OCAMLDEP)
echo $(DEPEND)
@echo "Computing dependencies ..."
ocamlfind ocamldep -package "$(PACKAGES)" \
$(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
......
- Ne pas serialiser les dispatchers (qui contiennent des infos inutiles au runtime),
seulement les actions.
- Dans l'evaluateur, pour les appels en position terminale, essayer de réutiliser
l'environnement (si c'est la bonne taille, réutiliser le bloc; si c'est les bonnes
valeurs, juste utiliser le même bloc).
- Problem: a custom toplevel doesn't find ./cdo2ml (should put the path
to cduce's directory in the toplevel?)
======================================================================
Alain 2005-06-18
......
......@@ -44,7 +44,8 @@ and check_equal_actions a1 a2 = match a1,a2 with
check_equal_prods k1.prod k2.prod;
check_equal_prods k1.xml k2.xml;
match k1.record,k2.record with
| Some(RecLabel(l1,p1)), Some(RecLabel(l2,p2)) when LabelPool.equal l1 l2 ->
| Some(RecLabel(l1,p1)), Some(RecLabel(l2,p2))
when Label.equal l1 l2 ->
check_equal_prods p1 p2
| Some(RecNolabel (a1,b1)), Some(RecNolabel (a2,b2)) ->
check_equal_result_options a1 a2;
......
(* The automata for pattern matching *)
open Ident
type source =
| Catch | Const of Types.const
| Stack of int | Left | Right | Nil | Recompose of int * int
type result = int * source array * int
(* Return code, result values, number of values to pop *)
type actions =
| AIgnore of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
atoms: result Atoms.map;
chars: result Chars.map;
prod: result dispatch dispatch;
xml: result dispatch dispatch;
record: record option;
}
and record =
| RecLabel of label * result dispatch dispatch
| RecNolabel of result option * result option
and 'a dispatch =
| Dispatch of state * 'a array
| TailCall of state
| Ignore of 'a
| Impossible
and state = {
uid : int;
arity : int array;
mutable actions: actions;
mutable fail_code: int;
mutable expected_type: Types.t
}
type 'a rhs = Match of int * 'a | Fail
(* The automata for pattern matching *)
open Ident
type source =
| Catch | Const of Types.const
| Stack of int | Left | Right | Nil | Recompose of int * int
type result = int * source array * int
(* Return code, result values, number of values to pop *)
type actions =
| AIgnore of result
| AKind of actions_kind
and actions_kind = {
basic: (Types.t * result) list;
atoms: result Atoms.map;
chars: result Chars.map;
prod: result dispatch dispatch;
xml: result dispatch dispatch;
record: record option;
}
and record =
| RecLabel of label * result dispatch dispatch
| RecNolabel of result option * result option
and 'a dispatch =
| Dispatch of state * 'a array
| TailCall of state
| Ignore of 'a
| Impossible
and state = {
uid : int;
arity : int array;
mutable actions: actions;
mutable fail_code: int;
mutable expected_type: Types.t
}
type 'a rhs = Match of int * 'a | Fail
<
......@@ -2,44 +2,19 @@ open Ident
open Lambda
type env = {
cu: Types.CompUnit.t option; (* None: toplevel *)
cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t;
stack_size: int;
max_stack: int ref;
global_size: int
}
let global_size env = env.global_size
let dump ppf env =
Env.iter
(fun id loc ->
Format.fprintf ppf "Var %a : %a@\n"
Ident.print id
Lambda.print_var_loc loc)
env.vars
let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; global_size = 0 }
let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; max_stack = ref 0; global_size = 0 }
let empty_toplevel = mk None
let empty x = mk (Some x)
let serialize s env =
assert (env.stack_size = 0);
(match env.cu with
| Some cu -> Types.CompUnit.serialize s cu
| None -> assert false);
Serialize.Put.env Id.serialize Lambda.Put.var_loc Env.iter s env.vars;
Serialize.Put.int s env.global_size
let deserialize s =
let cu = Types.CompUnit.deserialize s in
let vars =
Serialize.Get.env Id.deserialize Lambda.Get.var_loc Env.add Env.empty s in
let size = Serialize.Get.int s in
{ cu = Some cu; vars = vars; stack_size = 0; global_size = size }
let find x env =
try Env.find x env.vars
with Not_found ->
......@@ -50,44 +25,61 @@ let find_slot x env =
| Ext (_,slot) -> slot
| _ -> assert false
let from_comp_unit = ref (fun cu -> assert false)
let find_ext cu x =
let env = !from_comp_unit cu in
find x env
let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function
| Typed.Forget (e,_) -> compile env tail e
| Typed.Check (t0,e,t) -> Check (!t0, compile env false e, t)
let enter_local env x =
let new_size = env.stack_size + 1 in
if new_size > !(env.max_stack) then (env.max_stack) := new_size;
{ env with
vars = Env.add x (Local env.stack_size) env.vars;
stack_size = new_size }
let enter_global_toplevel env x =
{ env with
vars = Env.add x (Global env.global_size) env.vars;
global_size = env.global_size + 1 }
let enter_global_cu cu env x =
{ env with
vars = Env.add x (Ext (cu,env.global_size)) env.vars;
global_size = env.global_size + 1 }
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
| Typed.Check (t0,e,t) ->
let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
Check (compile env e, d)
| Typed.Var x -> Var (find x env)
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
| Typed.Cst c -> Const (Value.const c)
| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) ->
Xml (compile env false e1, compile env false e2, compile env tail e3)
Xml (compile env e1, compile env e2, compile env e3)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) ->
XmlNs (compile env false e1, compile env false e2, compile env tail e3,t)
XmlNs (compile env e1, compile env e2, compile env e3,t)
| Typed.Xml _ -> assert false
| Typed.RecordLitt r ->
let r = List.map (fun (l,e) -> (l, compile env false e)) (LabelMap.get r)
let r = List.map (fun (l,e) -> (Upool.int l, compile env e))
(LabelMap.get r)
in
Record (Imap.create (Array.of_list r))
| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
| Typed.Transform (e,brs) -> Transform
(compile env false e, compile_branches env false brs)
| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
| Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
| Typed.Dot (e,l) -> Dot (compile env tail e, l)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
| Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
| Typed.Map (e,brs) -> Map (compile env e, compile_branches env brs)
| Typed.Transform (e,brs) -> Transform (compile env e, compile_branches env brs)
| Typed.Xtrans (e,brs) -> Xtrans (compile env e, compile_branches env brs)
| Typed.Validate (e,_,validator) -> Validate (compile env e, validator)
| Typed.RemoveField (e,l) -> RemoveField (compile env e,l)
| Typed.Dot (e,l) -> Dot (compile env e, l)
| Typed.Try (e,brs) -> Try (compile env e, compile_branches env brs)
| Typed.Ref (e,t) -> Ref (compile env e, t)
| Typed.External (t,`Ext i) ->
(match env.cu with
| Some cu -> Var (External (cu,i))
......@@ -96,12 +88,12 @@ and compile_aux env tail = function
Var (Builtin s)
| Typed.Op (op,_,args) ->
let rec aux = function
| [arg] -> [ compile env tail arg ]
| arg::l -> (compile env false arg) :: (aux l)
| [arg] -> [ compile env arg ]
| arg::l -> (compile env arg) :: (aux l)
| [] -> [] in
Op (op, aux args)
| Typed.NsTable (ns,e) ->
NsTable (ns, compile_aux env tail e)
NsTable (ns, compile_aux env e)
and compile_abstr env a =
let fun_env =
......@@ -113,7 +105,7 @@ and compile_abstr env a =
List.fold_left
(fun (slots,nb_slots,fun_env) x ->
match find x env with
| (Stack _ | Env _) as p ->
| (Local _ | Env _) as p ->
p::slots,
succ nb_slots,
Env.add x (Env nb_slots) fun_env;
......@@ -127,80 +119,58 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in
let env = { env with vars = fun_env; stack_size = 0 } in
let body = compile_branches env true a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body)
let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
let body = compile_branches env a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack))
and compile_branches env tail (brs : Typed.branches) =
and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been
type checked. *)
let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
{
brs = List.map (compile_branch env tail) used;
brs_tail = tail;
let b = List.map (compile_branch env) used in
let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
{ brs_stack_pos = env.stack_size;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
brs_input = brs.Typed.br_typ;
brs_compiled = None;
}
brs_disp = disp;
brs_rhs = rhs }
and compile_branch env tail br =
let env =
List.fold_left
(fun env x ->
{ env with
vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
) env (Patterns.fv br.Typed.br_pat) in
(br.Typed.br_pat, compile env tail br.Typed.br_body)
let enter_globals env n =
match env.cu with
| None ->
let env =
List.fold_left
(fun env x ->
{ env with
vars = Env.add x (Global env.stack_size) env.vars;
stack_size = env.stack_size + 1 })
env n in
(env,[])
| Some cu ->
List.fold_left
(fun (env,code) x ->
let code = SetGlobal (cu, env.global_size) :: code in
let env =
{ env with
vars = Env.add x (Ext (cu, env.global_size)) env.vars;
global_size = env.global_size + 1 } in
(env,code)
)
(env,[])
n
let compile_expr env = compile env false
let compile_eval env e = [ Push (compile_expr env e); Pop ]
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
(br.Typed.br_pat, compile env br.Typed.br_body)
let enter_globals env n = match env.cu with
| None -> List.fold_left enter_global_toplevel env n
| Some cu -> List.fold_left (enter_global_cu cu) env n
let compile_expr env e =
let env = { env with max_stack = ref 0; stack_size = 0 } in
let e = compile env e in
(e,!(env.max_stack))
let compile_let_decl env decl =
let pat = decl.Typed.let_pat in
let e = compile_expr env decl.Typed.let_body in
let (env,code) = enter_globals env (Patterns.fv pat) in
(env, (Push e) :: (Split pat) :: code)
let e,lsize = compile_expr env decl.Typed.let_body in
let env = enter_globals env (Patterns.fv pat) in
let comp =
Patterns.Compile.make_branches
(Types.descr (Patterns.accept pat)) [ pat, () ] in
let (disp, n) =
match comp with
| (disp, [| Auto_pat.Match (n, ()) |]) -> (disp,n)
| _ -> assert false in
(env, [ LetDecls (e,lsize,disp,n) ])
let compile_rec_funs env funs =
let fun_name = function
| { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
| _ -> assert false in
let fun_a env = function
| { Typed.exp_descr=Typed.Abstraction a } ->
Push (compile_abstr env a)
| _ -> assert false in
let names = List.map fun_name funs in
let (env,code) = enter_globals env names in
let exprs = List.map (fun_a env) funs in
(env, exprs @ code)
let fun_a env e =
let e,lsize = compile_expr env e in
LetDecl (e,lsize) in
let env = enter_globals env (List.map fun_name funs) in
let code= List.map (fun_a env) funs in
(env, code)
(****************************************)
......@@ -209,21 +179,21 @@ open Location
let eval ~run ~show (tenv,cenv,codes) e =
let (e,t) = Typer.type_expr tenv e in
let expr = compile_expr cenv e in
let e,lsize = compile_expr cenv e in
if run then
let v = Eval.expr expr in
let v = Eval.expr e lsize in
show None t (Some v)
else
show None t None;
(tenv,cenv, Pop :: Push expr ::codes)
(tenv,cenv, Eval (e,lsize) :: codes)
let run_show ~run ~show tenv cenv codes ids =
if run then
let () = Eval.code_items codes in
let () = Eval.eval_toplevel codes in
List.iter
(fun (id,_) -> show (Some id)