Commit ab02cc0d authored by Pietro Abate's avatar Pietro Abate

[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
This diff is collapsed.
(* From Ast to Lambda. *)
open Ident
open Lambda
type env
val global_size: env -> int
val from_comp_unit: (Types.CompUnit.t -> env) ref
val dump: Format.formatter -> env -> unit
val empty : Types.CompUnit.t -> env
val empty : Compunit.t -> env
val empty_toplevel : env
val serialize: env Serialize.Put.f
val deserialize: env Serialize.Get.f
val find : id -> env -> var_loc
val find_slot : id -> env -> int
val compile_expr : env -> Typed.texpr -> Lambda.expr
val compile_eval_expr : env -> Typed.texpr -> Value.t
val comp_unit:
?run:bool ->
?show:(id option -> Types.t -> Value.t option -> unit) ->
?loading:(Types.CompUnit.t -> unit) ->
?loading:(Compunit.t -> unit) ->
?directive:(Typer.t -> env -> Ast.toplevel_directive -> unit) ->
Typer.t -> env -> Ast.pmodule_item list ->
Typer.t * env * Lambda.code_item list
val from_comp_unit: (Compunit.t -> env) ref
(* Defined in Librarian *)
This diff is collapsed.
(* Representation of programs used by the runtime evaluator.
Similar to the typed abstract syntax tree representation, but:
- the pattern matching is compiled;
- the identifiers locations are resolved. *)
open Ident
type var_loc =
| Stack of int
| Local of int
(* Slot in the table of locals *)
| Env of int
| Ext of Types.CompUnit.t * int (* If pos < 0, the first arg is the value *)
| External of Types.CompUnit.t * int
(* Slot in the environment *)
| 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
(* OCaml External *)
(* If pos < 0, the first arg is the value *)
| Builtin of string
| Global of int (* Only for the toplevel *)
(* OCaml external embedded in the runtime *)
| Global of int
(* Only for the toplevel *)
| Dummy
type schema_component_kind =
[ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
type expr =
| Var of var_loc
| Apply of bool * expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches
| Check of Types.t * expr * Types.Node.t
| Const of Types.Const.t
| Apply of expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int
(* environment, interface, branches, size of locals *)
| Check of expr * Auto_pat.state
| Const of Value.t
| Pair of expr * expr
| Xml of expr * expr * expr
| XmlNs of expr * expr * expr * Ns.table
| Record of expr Imap.t
| String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches
| Map of expr * branches
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * string * Ns.qname
| Validate of expr * Schema_validator.t
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
| Op of string * expr list
| OpResolved of Obj.t * expr list
(* the first arg is the eval function *)
(* type Value.t is not available here ... *)
| OpResolved of (Value.t list -> Value.t) * expr list
| NsTable of Ns.table * expr
and branches = {
brs: (Patterns.node * expr) list;
brs_tail: bool;
brs_input: Types.t;
brs_accept_chars: bool;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option;
brs_disp: Auto_pat.state;
brs_rhs: expr Auto_pat.rhs array;
brs_stack_pos: int
}
type code_item =
| Push of expr
| Pop
| Split of Patterns.node
| SetGlobal of Types.CompUnit.t * int
type code = code_item list
| Eval of expr * int
(* expression, size of locals *)
| LetDecls of expr * int * Auto_pat.state * int
(* expression, size of locals, dispatcher, number of globals to set *)
| LetDecl of expr * int
module Put :
sig
val unary_op : (Serialize.Put.t -> int -> unit) ref
val binary_op : (Serialize.Put.t -> int -> unit) ref
val var_loc : Serialize.Put.t -> var_loc -> unit
val expr : expr Serialize.Put.f
val branches : Serialize.Put.t -> branches -> unit
val code_item : Serialize.Put.t -> code_item -> unit
val codes : code_item list Serialize.Put.f
val compunit : Serialize.Put.t -> code_item list -> unit
end
module Get :
sig
val unary_op : (Serialize.Get.t -> int) ref
val binary_op : (Serialize.Get.t -> int) ref
val var_loc : Serialize.Get.t -> var_loc
val expr : expr Serialize.Get.f
val branches : Serialize.Get.t -> branches
val code_item : Serialize.Get.t -> code_item
val codes : code_item list Serialize.Get.f
val compunit : Serialize.Get.t -> code_item list
end
val print_var_loc : Format.formatter -> var_loc -> unit
type code = code_item list
open Auto_pat
open Ident
let queue = ref []
let printed = Hashtbl.create 1024
let rec_state ppf d =
Format.fprintf ppf "disp_%i" d.uid;
queue := d :: !queue
let rec print_source lhs ppf = function
| Catch -> Format.fprintf ppf "v"
| Const c -> Types.Print.print_const ppf c
| Nil -> Format.fprintf ppf "`nil"
| Left -> Format.fprintf ppf "v1"
| Right -> Format.fprintf ppf "v2"
| Stack i -> Format.fprintf ppf "%s" (List.nth lhs (i-1))
| Recompose (i,j) ->
Format.fprintf ppf "(%s,%s)"
(match i with (-1) -> "v1" | (-2) -> "nil"
| i -> List.nth lhs (i-1))
(match j with (-1) -> "v2" | (-2) -> "nil"
| j -> List.nth lhs (j-1))
let print_result lhs ppf =
Array.iteri
(fun i s ->
if i > 0 then Format.fprintf ppf ",";
print_source lhs ppf s;
)
let print_ret lhs ppf (code,ret,ar) =
Format.fprintf ppf "$%i" code;
if Array.length ret <> 0 then
Format.fprintf ppf "(%a)" (print_result lhs) ret
let print_ret_opt ppf = function
| None -> Format.fprintf ppf "*"
| Some r -> print_ret [] ppf r
let gen_lhs prefix d code =
let arity = d.arity.(code) in
let r = ref [] in
for i = 0 to arity - 1 do r := Format.sprintf "%s%i" prefix i :: !r done;
!r
let print_kind ppf actions =
let print_lhs ppf (code,lhs) =
Format.fprintf ppf "$%i(" code;
let rec aux = function
| [] -> ()
| [x] -> Format.fprintf ppf "%s" x
| x::r -> Format.fprintf ppf "%s,x" x; aux r
in aux lhs;
Format.fprintf ppf ")" in
let print_basic (t,ret) =
Format.fprintf ppf " | %a -> %a@\n"
Types.Print.print t
(print_ret []) ret
in
let print_prod2 lhs = function
| Impossible -> assert false
| Ignore r ->
Format.fprintf ppf "%a\n"
(print_ret lhs) r
| TailCall d ->
Format.fprintf ppf "%a v2@\n" rec_state d
| Dispatch (d, branches) ->
Format.fprintf ppf "@\n match %a v2 with@\n" rec_state d;
Array.iteri
(fun code r ->
let rhs = gen_lhs "r" d code in
Format.fprintf ppf " | %a -> %a@\n"
print_lhs (code,rhs)
(print_ret (rhs@lhs)) r;
)
branches
in
let print_prod prefix ppf = function
| Impossible -> ()
| Ignore d2 ->
Format.fprintf ppf " | %s(v1,v2) -> " prefix;
print_prod2 [] d2
| TailCall d ->
Format.fprintf ppf " | %s(v1,v2) -> %a v1@\n" prefix rec_state d
| Dispatch (d,branches) ->
Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
Format.fprintf ppf " match %a v1 with@\n" rec_state d;
Array.iteri
(fun code d2 ->
let lhs = gen_lhs "l" d code in
Format.fprintf ppf " | %a -> " print_lhs (code,lhs);
print_prod2 lhs d2;
)
branches
in
let rec print_record_opt ppf = function
| None -> ()
| Some (RecLabel (l,d)) ->
print_prod ("record:"^(Label.string_of_attr l)) ppf d
| Some (RecNolabel (r1,r2)) ->
Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " SomeField:%a;NoField:%a@\n"
print_ret_opt r1 print_ret_opt r2
in
List.iter print_basic actions.basic;
print_prod "" ppf actions.prod;
print_prod "XML" ppf actions.xml;
print_record_opt ppf actions.record
let print_actions ppf = function
| AKind k -> print_kind ppf k
| AIgnore r -> Format.fprintf ppf "v -> %a@\n" (print_ret []) r
let print_state_opt ppf d =
if Hashtbl.mem printed d.uid then ()
else (
Hashtbl.add printed d.uid ();
Format.fprintf ppf "State %i = function@\n" d.uid;
print_actions ppf d.actions;
Format.fprintf ppf "====================================@."
)
let print_state ppf d =
Hashtbl.clear printed;
queue := [ d ];
while !queue <> [] do
let d = List.hd !queue in
queue := List.tl !queue;
print_state_opt ppf d
done;
Hashtbl.clear printed
val print_state: Format.formatter -> Auto_pat.state -> unit
This diff is collapsed.
......@@ -25,11 +25,11 @@ let toplevel = ref false
let verbose = ref false
let silent = ref false
let typing_env = State.ref "Cduce.typing_env" Builtin.env
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
let typing_env = ref Builtin.env
let compile_env = ref Compile.empty_toplevel
let get_global_value cenv v =
Eval.var (Compile.find v !compile_env)
Eval.eval_var (Compile.find v !compile_env)
let get_global_type v =
Typer.find_value v !typing_env
......@@ -89,7 +89,7 @@ let rec print_exn ppf = function
print_value v
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection; field %a "
Label.print (LabelPool.value l);
Label.print_attr l;