Commit 81df23f2 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 47432157
...@@ -6,8 +6,12 @@ webiface.opt ...@@ -6,8 +6,12 @@ webiface.opt
webiface webiface
validate validate
evaluator evaluator
cdo2ml
mlcduce_wrapper
*.cmi *.cmi
*.cmo *.cmo
*.cmx *.cmx
*.cma *.cma
*.cmxa *.cmxa
META
configure.log
...@@ -3,7 +3,16 @@ Since 0.3.2 ...@@ -3,7 +3,16 @@ Since 0.3.2
* Added char_of_int built_in function. * Added char_of_int built_in function.
* Now int_of also accepts octal binary and hexadecimals. * Now int_of also accepts octal binary and hexadecimals.
* The field access also works for XML element attributes. * 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 0.3.2
* Bug fix in configure * Bug fix in configure
......
...@@ -160,6 +160,6 @@ evaluator: $(EVALUATOR:.cmo=.$(EXTENSION)) ...@@ -160,6 +160,6 @@ evaluator: $(EVALUATOR:.cmo=.$(EXTENSION))
# webiface can be made static to be able to move it more easily # 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) # (to compile it on a machine which is not the web server)
# Seems to be some problems with statically linking curl # 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) ...@@ -16,7 +16,7 @@ ifeq ($(NATIVE),true)
all: cduce_lib.cmxa all: cduce_lib.cmxa
endif 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 # Call make with VERBOSE=true to get a trace of commands
...@@ -39,14 +39,14 @@ SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %) ...@@ -39,14 +39,14 @@ SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %)
CAMLC_P = ocamlc -g CAMLC_P = ocamlc -g
DEPEND_OCAMLDEP = misc/q_symbol.cmo DEPEND_OCAMLDEP = misc/q_symbol.cmo
ifeq ($(PROFILE), true) ifeq ($(PROFILE), true)
CAMLOPT_P = ocamlopt -p CAMLOPT_P = ocamlopt -p -inline 10000
ifeq ($(NATIVE), false) ifeq ($(NATIVE), false)
CAMLC_P = ocamlcp -p a CAMLC_P = ocamlcp -p a
SYNTAX_PARSER = SYNTAX_PARSER =
DEPEND_OCAMLDEP = DEPEND_OCAMLDEP =
endif endif
else else
CAMLOPT_P = ocamlopt -inline 25 CAMLOPT_P = ocamlopt -inline 10000
endif endif
OPT = -warn-error FPS OPT = -warn-error FPS
...@@ -129,58 +129,46 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests ...@@ -129,58 +129,46 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests
# Objects to build # 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 = \ OBJECTS = \
driver/config.cmo \ driver/config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \
misc/stats.cmo \ misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.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 \
\ \
types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \ types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
types/intervals.cmo \ types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/chars.cmo types/atoms.cmo \ types/types.cmo compile/auto_pat.cmo \
types/normal.cmo \ types/sequence.cmo types/builtin_defs.cmo \
types/types.cmo types/sample.cmo types/sequence.cmo types/patterns.cmo \
compile/auto_opt.cmo \
types/builtin_defs.cmo \
\ \
compile/lambda.cmo \
runtime/value.cmo \ runtime/value.cmo \
\ \
parser/location.cmo parser/url.cmo \ schema/schema_pcre.cmo schema/schema_types.cmo \
\ schema/schema_xml.cmo schema/schema_common.cmo \
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \ schema/schema_builtin.cmo schema/schema_validator.cmo \
\ \
types/externals.cmo \ types/patterns.cmo \
typing/typed.cmo typing/typepat.cmo typing/typer.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 \ typing/typed.cmo typing/typepat.cmo types/externals.cmo typing/typer.cmo \
runtime/explain.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
compile/compile.cmo \ compile/compile.cmo \
compile/operators.cmo \
\ \
types/builtin.cmo \ schema/schema_parser.cmo schema/schema_converter.cmo \
driver/librarian.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 \ driver/cduce.cmo \
runtime/system.cmo \
runtime/system.cmo query/query_aggregates.cmo
schema/schema_types.ml: schema/schema_types.mli schema/schema_types.ml: schema/schema_types.mli
cp $^ $@ cp $^ $@
compile/auto_pat.ml: compile/auto_pat.mli
cp $^ $@
compile/lambda.ml: compile/lambda.mli
cp $^ $@
ML_INTERFACE_OBJS = \ ML_INTERFACE_OBJS = \
ocamliface/caml_cduce.cmo \ ocamliface/caml_cduce.cmo \
...@@ -216,16 +204,6 @@ ifeq ($(EXPAT), true) ...@@ -216,16 +204,6 @@ ifeq ($(EXPAT), true)
endif 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 OBJECTS += driver/run.cmo
CDUCE = $(OBJECTS) driver/start.cmo CDUCE = $(OBJECTS) driver/start.cmo
...@@ -265,21 +243,16 @@ dtd2cduce: tools/dtd2cduce.ml ...@@ -265,21 +243,16 @@ dtd2cduce: tools/dtd2cduce.ml
@echo "Build $@" @echo "Build $@"
$(HIDE)$(OCAMLFIND) $(CAML) -o $@ -ccopt -static -package "$(PXP_PACK) cgi" -linkpkg $^ $(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 mlcduce_wrapper: $(OBJECTS) ocamliface/mlcduce_wrapper.ml
@echo "Build $@" @echo "Build $@"
$(HIDE)$(CAMLC) -linkpkg $(INCLUDES) -o $@ odyl.cma camlp4.cma pr_o.cmo $^ $(EXTRA_LINK_OPTS) $(HIDE)$(CAMLC) -linkpkg $(INCLUDES) -o $@ odyl.cma camlp4.cma pr_o.cmo $^ $(EXTRA_LINK_OPTS)
cdo2ml: ocamliface/cdo2ml.ml cdo2ml: ocamliface/cdo2ml.ml
@echo "Build $@" @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 .PHONY: compute_depend
compute_depend: $(DEPEND_OCAMLDEP) compute_depend: $(DEPEND_OCAMLDEP)
echo $(DEPEND)
@echo "Computing dependencies ..." @echo "Computing dependencies ..."
ocamlfind ocamldep -package "$(PACKAGES)" \ ocamlfind ocamldep -package "$(PACKAGES)" \
$(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend $(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 Alain 2005-06-18
......
...@@ -44,7 +44,8 @@ and check_equal_actions a1 a2 = match a1,a2 with ...@@ -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.prod k2.prod;
check_equal_prods k1.xml k2.xml; check_equal_prods k1.xml k2.xml;
match k1.record,k2.record with 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 check_equal_prods p1 p2
| Some(RecNolabel (a1,b1)), Some(RecNolabel (a2,b2)) -> | Some(RecNolabel (a1,b1)), Some(RecNolabel (a2,b2)) ->
check_equal_result_options a1 a2; 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 ...@@ -2,44 +2,19 @@ open Ident
open Lambda open Lambda
type env = { type env = {
cu: Types.CompUnit.t option; (* None: toplevel *) cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t; vars: var_loc Env.t;
stack_size: int; stack_size: int;
max_stack: int ref;
global_size: int global_size: int
} }
let global_size env = env.global_size let global_size env = env.global_size
let dump ppf env = let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; max_stack = ref 0; global_size = 0 }
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 empty_toplevel = mk None let empty_toplevel = mk None
let empty x = mk (Some x) 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 = let find x env =
try Env.find x env.vars try Env.find x env.vars
with Not_found -> with Not_found ->
...@@ -50,44 +25,61 @@ let find_slot x env = ...@@ -50,44 +25,61 @@ let find_slot x env =
| Ext (_,slot) -> slot | Ext (_,slot) -> slot
| _ -> assert false | _ -> assert false
let from_comp_unit = ref (fun cu -> assert false) let from_comp_unit = ref (fun cu -> assert false)
let find_ext cu x = let find_ext cu x =
let env = !from_comp_unit cu in let env = !from_comp_unit cu in
find x env find x env
let enter_local env x =
let rec compile env tail e = compile_aux env tail e.Typed.exp_descr let new_size = env.stack_size + 1 in
and compile_aux env tail = function if new_size > !(env.max_stack) then (env.max_stack) := new_size;
| Typed.Forget (e,_) -> compile env tail e { env with
| Typed.Check (t0,e,t) -> Check (!t0, compile env false e, t) 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.Var x -> Var (find x env)
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x) | 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.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c | Typed.Cst c -> Const (Value.const c)
| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2) | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) -> | 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) -> | 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.Xml _ -> assert false
| Typed.RecordLitt r -> | 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 in
Record (Imap.create (Array.of_list r)) Record (Imap.create (Array.of_list r))
| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q) | Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs) | Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs) | Typed.Map (e,brs) -> Map (compile env e, compile_branches env brs)
| Typed.Transform (e,brs) -> Transform | Typed.Transform (e,brs) -> Transform (compile env e, compile_branches env brs)
(compile env false e, compile_branches env false brs) | Typed.Xtrans (e,brs) -> Xtrans (compile env e, compile_branches env brs)
| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs) | Typed.Validate (e,_,validator) -> Validate (compile env e, validator)
| Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t) | Typed.RemoveField (e,l) -> RemoveField (compile env e,l)
| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l) | Typed.Dot (e,l) -> Dot (compile env e, l)
| Typed.Dot (e,l) -> Dot (compile env tail e, l) | Typed.Try (e,brs) -> Try (compile env e, compile_branches env brs)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs) | Typed.Ref (e,t) -> Ref (compile env e, t)
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
| Typed.External (t,`Ext i) -> | Typed.External (t,`Ext i) ->
(match env.cu with (match env.cu with
| Some cu -> Var (External (cu,i)) | Some cu -> Var (External (cu,i))
...@@ -96,12 +88,12 @@ and compile_aux env tail = function ...@@ -96,12 +88,12 @@ and compile_aux env tail = function
Var (Builtin s) Var (Builtin s)
| Typed.Op (op,_,args) -> | Typed.Op (op,_,args) ->
let rec aux = function let rec aux = function
| [arg] -> [ compile env tail arg ] | [arg] -> [ compile env arg ]
| arg::l -> (compile env false arg) :: (aux l) | arg::l -> (compile env arg) :: (aux l)
| [] -> [] in | [] -> [] in
Op (op, aux args) Op (op, aux args)
| Typed.NsTable (ns,e) -> | Typed.NsTable (ns,e) ->
NsTable (ns, compile_aux env tail e) NsTable (ns, compile_aux env e)
and compile_abstr env a = and compile_abstr env a =
let fun_env = let fun_env =
...@@ -113,7 +105,7 @@ and compile_abstr env a = ...@@ -113,7 +105,7 @@ and compile_abstr env a =
List.fold_left List.fold_left
(fun (slots,nb_slots,fun_env) x -> (fun (slots,nb_slots,fun_env) x ->
match find x env with match find x env with
| (Stack _ | Env _) as p -> | (Local _ | Env _) as p ->
p::slots, p::slots,
succ nb_slots, succ nb_slots,
Env.add x (Env nb_slots) fun_env; Env.add x (Env nb_slots) fun_env;
...@@ -127,80 +119,58 @@ and compile_abstr env a = ...@@ -127,80 +119,58 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in let slots = Array.of_list (List.rev slots) in
let env = { env with vars = fun_env; stack_size = 0 } in let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
let body = compile_branches env true a.Typed.fun_body in let body = compile_branches env a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body) 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 (* Don't compile unused branches, because they have not been
type checked. *) type checked. *)
let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
{ let b = List.map (compile_branch env) used in
brs = List.map (compile_branch env tail) used; let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
brs_tail = tail; { brs_stack_pos = env.stack_size;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept); brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
brs_input = brs.Typed.br_typ; brs_disp = disp;
brs_compiled = None; brs_rhs = rhs }
}
and compile_branch env tail br = and compile_branch env br =
let env = let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
List.fold_left (br.Typed.br_pat, compile env br.Typed.br_body)
(fun env x ->
{ env with