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

Original author: afrisch
Date: 2005-07-05 13:49:26+00:00

.cvsignore

@@ -6,8 +6,12 @@ webiface.opt
 webiface
 validate
 evaluator
+cdo2ml
+mlcduce_wrapper
 *.cmi
 *.cmo
 *.cmx
 *.cma
 *.cmxa
+META
+configure.log

CHANGES

@@ -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

Makefile

@@ -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
 
 

Makefile.distrib

@@ -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

TODO

+- 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
 

compile/auto_opt.ml

@@ -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;

compile/auto_pat.ml

+(* 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

compile/auto_pat.mli

+(* 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

compile/compile.mli

+(* 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 *)

compile/lambda.mli

+(* 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

compile/print_auto.ml

+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
+ 

compile/print_auto.mli

+val print_state: Format.formatter -> Auto_pat.state -> unit

driver/cduce.ml

@@ -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;