[r2003-11-21 09:27:59 by afrisch] Opt

Original author: afrisch
Date: 2003-11-21 09:27:59+00:00

Makefile.distrib

@@ -127,7 +127,7 @@ OBJECTS = \
  \
  types/builtin.cmo driver/librarian.cmo driver/cduce.cmo \
  \
- query/query_parse.cmo
+# query/query_parse.cmo
 
 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
 
@@ -158,7 +158,7 @@ webiface: $(WEBIFACE:.cmo=.$(EXTENSION))
 dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
 	$(LINK) $(INCLUDES) -o $@ $^
 
-validate: $(VALIDATE_OBJECTS) tools/validate.cmo
+validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
 	$(LINK) $(INCLUDES) -o $@ $^
 
 .PHONY: compute_depend

driver/cduce.ml

@@ -95,9 +95,6 @@ let rec print_exn ppf = function
   | Value.CDuceExn v ->
       Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
         print_value v
-  | Eval.MultipleDeclaration v ->
-      Format.fprintf ppf "Multiple declaration for global value %a@." 
-        U.print (Id.value v)
   | Typer.WrongLabel (t,l) ->
       Format.fprintf ppf "Wrong record selection; field %a " 
         Label.print (LabelPool.value l);

runtime/eval.ml

@@ -2,7 +2,6 @@ open Value
 open Run_dispatch
 open Ident
 
-exception MultipleDeclaration of id
 type env = t Env.t
 
 let empty = Env.empty
@@ -289,7 +288,14 @@ let dispatcher brs =
   match brs.brs_compiled with
     | Some d -> d
     | None ->
+(*	Format.fprintf Format.std_formatter "Start compilation...@."; 
+	let time = Unix.gettimeofday() in*)
 	let x = Patterns.Compile.make_branches brs.brs_input brs.brs in
+(*	let time = Unix.gettimeofday() -. time in
+	if time > 1.0 then 
+	  Format.fprintf Format.std_formatter "%a@." 
+	    Patterns.Compile.print_dispatcher (fst x); 
+	Format.fprintf Format.std_formatter "(%f ms).@." time; *)
 	brs.brs_compiled <- Some x;
 	x
 

runtime/eval.mli

 open Value
 open Ident
 
-exception MultipleDeclaration of id
 type env
 
 val empty: env

types/patterns.ml

@@ -872,30 +872,53 @@ struct
     (* Try with a hash-table ! *)
     
   let dispatchers = ref DispMap.empty
-		      
+		
+  let timer_disp = Stats.Timer.create "Patterns.dispatcher loop"
+      
   let dispatcher t pl lab : dispatcher =
     try DispMap.find (t,pl) !dispatchers
     with Not_found ->
       let nb = ref 0 in
       let codes = ref [] in
       let rec aux t arity i accu = 
-	if Types.is_empty t then `None
+	if i == Array.length pl 
+	then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
 	else
-	  if i == Array.length pl 
-	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
+	  let p = pl.(i) in
+	  let tp = p.Normal.na in
+(*	  let tp = Types.normalize tp in *)
+
+	  let a1 = Types.cap t tp in
+	  if Types.is_empty a1 then
+	    `Switch (`None,aux t arity (i+1) accu)
 	  else
-	    let p = pl.(i) in
-	    let tp = p.Normal.na in
 	    let v = p.Normal.nfv in
-(*	    let tp = Types.normalize tp in *)
+	    let a2 = Types.diff t tp in
 	    let accu' = (i,IdMap.num arity v) :: accu in
+	    if Types.is_empty a2 then
+	      `Switch (aux t (arity + (IdSet.length v)) (i+1) accu',`None)
+	    else
+	      `Switch (aux a1 (arity + (IdSet.length v)) (i+1) accu',
+		       aux a2 arity (i+1) accu)
+
+(* Unopt version:
 	    `Switch 
 	      (
 	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
 	       aux (Types.diff t tp) arity (i+1) accu
 	      )
+*)
+
       in
-      let iface = aux t 0 0 [] in
+(*      Array.iteri (fun i p ->
+		     Format.fprintf Format.std_formatter
+		       "Pattern %i/%i accepts %a@." i (Array.length pl)
+		       Types.Print.print p.Normal.na) pl; *)
+      
+      Stats.Timer.start timer_disp;
+      let iface = 
+	if Types.is_empty t then `None else aux t 0 0 [] in
+      Stats.Timer.stop timer_disp ();
       let res = { id = !cur_id; 
 		  t = t;
 		  label = lab;
@@ -1029,6 +1052,10 @@ struct
       List.fold_left
 	(fun (t,brs) (p,e) ->
 	   let p' = (Normal.NodeSet.singleton p,t) in
+(*	   let td = Types.descr (accept p) in
+	   let t' = 
+	     if Types.is_empty (Types.cap t td) then t else
+	       Types.diff t td in*)
 	   let t' = Types.diff t (Types.descr (accept p)) in
 	   (t', (p',(fv_list p, e)) :: brs)
 	) (t,[]) brs in