[r2005-02-01 13:10:25 by afrisch] Cleanup

Original author: afrisch
Date: 2005-02-01 13:10:26+00:00

Makefile.distrib

@@ -210,7 +210,7 @@ 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
 
-CDUCE = $(OBJECTS) driver/run.cmo $(CQL_OBJECTS_RUN)
+CDUCE = $(OBJECTS) $(CQL_OBJECTS_RUN) driver/run.cmo 
 DTD2CDUCE = tools/dtd2cduce.cmo
 
 ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \

Makefile.types

@@ -54,7 +54,7 @@ else
  CAML=$(CAMLC)
 endif
 
-cduce_types: $(OBJECTS)
+cduce_types.cmo: $(OBJECTS)
 	$(CAML) -pack -o cduce_types.$(EXT) $(INCLUDES) $^
 	$(CAML) -a -o cduce_types.$(EXTA) $(INCLUDES) cduce_types.$(EXT)
 
@@ -62,10 +62,10 @@ HIDE=@
 INCLUDES = $(DIRS:%=-I %)
 
 
-types/intervals.$(EXT): types/intervals.ml cat1
+types/intervals.$(EXT): types/intervals.ml cat1 types/intervals_int.ml
 	$(CAML) -c $(INCLUDES) -pp './cat1 types/intervals_int.ml' $<
 
-types/intervals.cmi: types/intervals.mli cat1
+types/intervals.cmi: types/intervals.mli cat1 types/intervals_int.mli
 	$(CAML) -c $(INCLUDES) -pp './cat1 types/intervals_int.mli' $<
 
 misc/stats.$(EXT): misc/stats.ml

driver/cduce.ml

@@ -5,6 +5,8 @@ exception Escape of exn
 exception InvalidInputFilename of string
 exception InvalidObjectFilename of string
 
+let extra_specs = ref []
+
 (* if set to false toplevel exception aren't cought. 
  * Useful for debugging with OCAMLRUNPARAM="b" *)
 let catch_exceptions = true

driver/cduce.mli

@@ -3,6 +3,8 @@ exception Escape of exn
 val toplevel: bool ref
 val verbose: bool ref
 
+val extra_specs: (string * Arg.spec * string) list ref
+
 val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
 val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
 

driver/run.ml

@@ -29,7 +29,7 @@ been modified from the original Q Public.\n\n
 "; 
   exit 0
 
-let specs = ref
+let specs =
   [ "--compile", Arg.Set compile,
              "compile the given CDuce file";
     "--run", Arg.Set run,
@@ -78,7 +78,7 @@ let err s =
   exit 1
 
 let mode () =
-  Arg.parse !specs (fun s -> src := s :: !src) 
+  Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src) 
     "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
   match (!compile,!out_dir,!run,!src,!args) with
     | false, _::_, _,  _, _   -> 
@@ -203,9 +203,5 @@ let main () =
 	Cduce.run f
 	 
 let () = 
-(* Hum... *)
-  let b = ref true in
-  at_exit (fun () -> if !b then (b := false; main ()));
-  at_exit (fun () -> Stats.dump Format.std_formatter)
-
-
+  at_exit (fun () -> Stats.dump Format.std_formatter);
+  main ()

misc/stats.ml

@@ -21,7 +21,7 @@ module Timer = struct
   }
 
   let print ppf c =
-    Format.fprintf ppf "Timer %s. Total time: %f. Count: %i@\n"
+    Format.fprintf ppf "Timer %s. Total time: %f. Count: %i@."
       c.name c.total c.count
       
   let create s = 
@@ -49,7 +49,7 @@ module Counter = struct
   }
 
   let print ppf c =
-    Format.fprintf ppf "Counter %s: %i@\n"
+    Format.fprintf ppf "Counter %s: %i@."
       c.name c.count
       
   let create s = 

query/query_run.ml

-let () = Run.specs := !Run.specs @
-      [  "--noquery-optim", Arg.Set Query.nooptim,
-         " do not optimize queries " ]
+let () = Cduce.extra_specs := 
+      (  "--noquery-optim", Arg.Set Query.nooptim,
+         " do not optimize queries " ) :: 
+	!Cduce.extra_specs

types/intervals_int.ml

@@ -97,7 +97,23 @@ let print =
 	 | false,true -> Format.fprintf ppf "%i--*" a
     )
 
-let add l1 l2 = any
+let may_add x y =
+  (x = 0) || (y = 0) || (
+    if (x > 0) && (y > 0) then x + y > y
+    else if (x < 0) && (y < 0) then x + y < y
+    else true
+  )
+
+let add l1 l2 =
+  List.fold_left 
+    (fun accu (a,b) ->
+       List.fold_left
+	 (fun accu (c,d) ->
+	    if (may_add a c) && (may_add b d) then iadd accu (a+c,b+d)
+	    else any)
+	 accu l2)
+    [] l1
+
 let negat l = any
 let sub l1 l2 = any
 let mul l1 l2 = any

types/patterns.ml

@@ -1115,6 +1115,9 @@ struct
     
   let dispatchers = ref DispMap.empty
 		
+
+  let generated = ref 0
+  let to_generate = ref []
   let timer_disp = Stats.Timer.create "Patterns.dispatcher loop"
 
   let rec print_iface ppf = function
@@ -1253,15 +1256,16 @@ struct
     !accu
 
 
-  let first_lab pl =
+  let first_lab t pl =
     let aux l (req,_) = min l (Normal.Nnf.first_label req) in
     let lab = Array.fold_left (List.fold_left aux) LabelPool.dummy_max pl in
+    let lab = min lab (Types.Record.first_label t) in
     if lab == LabelPool.dummy_max then None else Some lab
 
 
   let get_tests facto pl f t d post =
     let pl = Array.map (List.map f) pl in
-    let lab = first_lab pl in
+    let lab = first_lab t pl in
     let pl = Array.map (List.map (fun (x,info) -> Normal.nnf facto lab t x,info)) pl
     in
     (* Collect all subrequests *)
@@ -1364,6 +1368,22 @@ struct
 				  | _ -> assert false) disp.pl in
 	    Some (RecLabel (lab,dispatch_prod0 disp t pl))
       
+  let iter_disp_disp f g = function
+    | Dispatch (d,a) -> f d; Array.iter g a
+    | TailCall d -> f d
+    | Ignore a -> g a
+    | Impossible -> ()
+
+  let iter_disp_prod f = iter_disp_disp f (iter_disp_disp f (fun _ -> ()))
+
+  let rec iter_disp_actions f = function
+    | AIgnore _ -> ()
+    | AKind k ->
+	iter_disp_prod f k.prod;
+	iter_disp_prod f k.xml;
+	(match k.record with Some (RecLabel (_,p)) -> iter_disp_prod f p 
+	   | _ -> ())
+    
   let actions disp =
     match disp.actions with
       | Some a -> a
@@ -1375,10 +1395,14 @@ struct
 		    (dispatch_record disp)
 	  in
 	  disp.actions <- Some a;
+	  iter_disp_actions (fun d -> to_generate := d :: !to_generate) a;
+	  incr generated;
 	  a
 
   let to_print = ref []
 
+
+
   module DSET = Set.Make (struct type t = int let compare (x:t) (y:t) = x - y end)
   let printed = ref DSET.empty
 
@@ -1555,7 +1579,20 @@ struct
 			      | _ -> assert false
 			 ) pl) in
     show ppf t pl lab;
-(*    Format.fprintf ppf "# compiled dispatchers: %i@\n" !cur_id *)
+    Format.fprintf ppf "# compiled states: %i@\n" !generated
+
+    let () =
+      Stats.register Stats.Summary
+	(fun ppf ->
+	   let i = !generated in
+	   Format.fprintf ppf "Number of compiled states: %i@." i;
+	   while !to_generate != [] do
+	     let d = List.hd !to_generate in
+	     to_generate := List.tl !to_generate;
+	     ignore (actions d)
+	   done;
+	   let j = !generated in
+	   Format.fprintf ppf "Total number of states: %i@." j)
 end
 
 

types/types.ml

@@ -454,6 +454,8 @@ type descr = Descr.t
 type node = Node.t
 include Descr
 
+let forward_print = ref (fun _ _ -> assert false)
+
 let hash_cons = DescrHash.create 17000  
 
 let count = State.ref "Types.count" 0
@@ -1657,6 +1659,8 @@ struct
     DescrHash.clear memo
 
   let print_node ppf n = print ppf (descr n)
+
+  let () = forward_print := print
 end
 
 module Positive =