+

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/treematch@8836 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Makefile

@@ -36,7 +36,7 @@ INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
 
 UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
   utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
-  utils/consistbl.cmo
+  utils/consistbl.cmo utils/extarray.cmo
 
 OPTUTILS=$(UTILS)
 

bytecomp/automatch.ml

@@ -493,12 +493,12 @@ let rec simplify_cases args cls = match args with
       | ((pat :: patl, action) as cl) :: rem ->
           begin match pat.pat_desc with
           | Tpat_var id ->
-              (omega :: patl, bind StrictOpt id arg action) ::
+              (omega :: patl, bind Alias id arg action) ::
               simplify rem
           | Tpat_any ->
               cl :: simplify rem
           | Tpat_alias(p, id) ->
-              simplify ((p :: patl, bind StrictOpt id arg action) :: rem)
+              simplify ((p :: patl, bind Alias id arg action) :: rem)
           | Tpat_record [] ->
               (omega :: patl, action)::
               simplify rem
@@ -1111,9 +1111,9 @@ let make_constr_matching p def ctx = function
       let newargs =
         match cstr.cstr_tag with
           Cstr_constant _ | Cstr_block _ ->
-            make_field_args StrictOpt arg 0 (cstr.cstr_arity - 1) argl
+            make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
         | Cstr_exception _ ->
-            make_field_args StrictOpt arg 1 cstr.cstr_arity argl in
+            make_field_args Alias arg 1 cstr.cstr_arity argl in
       {pm=
         {cases = []; args = newargs;
           default = make_default (matcher_constr cstr) def} ;
@@ -1164,7 +1164,7 @@ let make_variant_matching_nonconst p lab def ctx = function
       let def = make_default (matcher_variant_nonconst lab) def
       and ctx = filter_ctx p ctx in
       {pm=
-        {cases = []; args = (Lprim(Pfield 1, [arg]), StrictOpt) :: argl;
+        {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
           default=def} ;
         ctx=ctx ;
         pat = normalize_pat p}
@@ -1236,7 +1236,7 @@ let make_tuple_matching arity def = function
       let rec make_args pos =
         if pos >= arity
         then argl
-        else (Lprim(Pfield pos, [arg]), StrictOpt) :: make_args (pos + 1) in
+        else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
       {cases = []; args = make_args 0 ;
         default=make_default (matcher_tuple arity) def}
 
@@ -1279,7 +1279,7 @@ let make_record_matching all_labels def = function
             | Record_float -> Pfloatfield lbl.lbl_pos in
           let str =
             match lbl.lbl_mut with
-              Immutable -> StrictOpt
+              Immutable -> Alias
             | Mutable -> StrictOpt in
           (Lprim(access, [arg]), str) :: make_args(pos + 1)
         end in
@@ -1574,7 +1574,7 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
           match raw_action r with
           | Lstaticraise (j,args) ->
               if i=j then
-                List.fold_right2 (bind StrictOpt) vars args handler_i,
+                List.fold_right2 (bind Alias) vars args handler_i,
                 jumps_map (ctx_rshift_num (ncols mat)) total_i
               else
                 do_rec r total_r rem
@@ -1613,7 +1613,7 @@ let rec approx_present v = function
       List.exists (fun lam -> approx_present v lam) args
   | Lprim (_,args) ->
       List.exists (fun lam -> approx_present v lam) args
-  | Llet (StrictOpt, _, l1, l2) ->
+  | Llet (Alias, _, l1, l2) ->
       approx_present v l1 || approx_present v l2
   | Lvar vv -> Ident.same v vv
   | _ -> true
@@ -1633,25 +1633,25 @@ let rec lower_bind v arg lam = match lam with
         Lifthenelse (cond, lower_bind v arg ifso, ifnot)
     | false, false, true ->
         Lifthenelse (cond, ifso, lower_bind v arg ifnot)
-    | _,_,_ -> bind StrictOpt v arg lam
+    | _,_,_ -> bind Alias v arg lam
     end
 | Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
     when not (approx_present v ls) ->
       Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})
 | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
     when not (approx_present v ls) ->
       Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
-| Llet (StrictOpt, vv, lv, l) ->
+| Llet (Alias, vv, lv, l) ->
     if approx_present v lv then
-      bind StrictOpt v arg lam
+      bind Alias v arg lam
     else
-      Llet (StrictOpt, vv, lv, lower_bind v arg l)
+      Llet (Alias, vv, lv, lower_bind v arg l)
 | _ -> 
-    bind StrictOpt v arg lam
+    bind Alias v arg lam
 
 let bind_check str v arg lam = match str,arg with
 | _, Lvar _ ->bind str v arg lam
-(* | StrictOpt,_ -> lower_bind v arg lam *)
+| Alias,_ -> lower_bind v arg lam
 | _,_     -> bind str v arg lam
 
 let rec comp_exit ctx m = match m.default with
@@ -1719,7 +1719,7 @@ let rec compile_match repr partial ctx m = match m with
     let v,newarg = arg_to_var arg m.cases in
     let first_match,rem =
       split_precompile (Some v)
-        { m with args = (newarg, StrictOpt) :: argl } in
+        { m with args = (newarg, Alias) :: argl } in
     let (lam, total) =
       comp_match_handlers
         (do_compile_matching repr) partial ctx newarg first_match rem in

bytecomp/discr.ml

@@ -259,12 +259,10 @@ let no_switch cls = match cls with
 | [_,act] -> act
 | _ -> assert false
 
-let switch ds x cls fail =
-  if DSet.is_empty ds then match fail with
-  | Some lam -> lam
-  | None -> assert false
-  else
-    let d = DSet.choose ds in
+let switch x cls fail = match cls, fail with
+| [],Some lam -> lam
+| [],None -> assert false
+| (d,_)::_,_ ->
     match d with
     | Constant c -> sw_constant c x cls fail
     | Construct c ->

bytecomp/printlambda.ml

@@ -180,6 +180,12 @@ let primitive ppf = function
   | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout
   | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout
 
+let p_str ppf = function
+  | Variable -> fprintf ppf "{v}"
+  | Alias -> fprintf ppf "{a}"
+  | Strict -> fprintf ppf "{s}"
+  | StrictOpt -> fprintf ppf "{o}"
+
 let rec lam ppf = function
   | Lvar id ->
       Ident.print ppf id
@@ -207,10 +213,11 @@ let rec lam ppf = function
   | Llet(str, id, arg, body) ->
       let rec letbody = function
         | Llet(str, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+            fprintf ppf "@ @[<2>%a%a@ %a@]" p_str str Ident.print id lam arg;
             letbody body
         | expr -> expr in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%a@ %a@]"
+	p_str str Ident.print id lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->

bytecomp/treematch.ml

@@ -33,6 +33,42 @@ let alpha p lam =
   let ids = IdentSet.elements (extract_vars IdentSet.empty p) in
   alpha_ids alpha_pat ids p lam
 
+(* Out module, can produce lambda code or a dag *)
+module type Out = sig
+  type out
+  (* forth and back *)
+  val final : lambda -> out
+  val to_lambda : out -> lambda
+
+  (* need that for guards *)
+  val is_guarded : out -> bool
+  val patch_guarded : out -> out -> out
+  val event_branch : int ref option -> out -> out
+
+  (* constructors *)
+  val alias : Ident.t -> Ident.t -> out -> out
+  val field_ids : Discr.discr -> Ident.t ->
+    Ident.t list * (let_kind * lambda) list
+  val get_fields : Ident.t list -> (let_kind * lambda) list -> out -> out
+  val switch : Ident.t -> (Discr.discr * out) list -> out option -> out
+end
+
+module OutLambda = struct
+  type out = lambda
+  let final lam = lam
+  let to_lambda lam = lam
+
+  let is_guarded = is_guarded
+  let patch_guarded = patch_guarded
+  let event_branch = event_branch
+
+  let alias = Discr.alias
+  let field_ids = Discr.field_ids
+  let get_fields = Discr.get_fields
+  let switch = Discr.switch
+end
+
+module Out : Out = OutLambda
 
 (* Variables, aliases and or-pattern
    are handled by preprocessing,
@@ -45,12 +81,12 @@ let precompile x cls =
     | ((pat :: patl, action) as cl) :: rem ->
         begin match pat.pat_desc with
         | Tpat_var id ->
-            (omega :: patl, Discr.alias id x action) ::
+            (omega :: patl, Out.alias id x action) ::
             simplify rem
         | Tpat_any ->
             cl :: simplify rem
         | Tpat_alias(p, id) ->
-            simplify ((p :: patl, Discr.alias id x action) :: rem)
+            simplify ((p :: patl, Out.alias id x action) :: rem)
         | Tpat_record [] ->
             (omega :: patl, action)::
             simplify rem
@@ -60,7 +96,9 @@ let precompile x cls =
             (full_pat::patl,action)::
             simplify rem
         | Tpat_or (p1,p2,_) -> (* or expansion *)
-	    let p2,act2 = alpha p2 action in
+	    let p2,act2 = (* alpha p2 action *) p2,action in
+	    (* alpha-conversion not needed, all variables in pat
+	       will be bound to another variable *)
             simplify ((p1::patl,action)::(p2::patl,act2) :: rem)
         | _ -> cl :: simplify rem
         end
@@ -88,27 +126,25 @@ let rec compile_match repr xs pss lam_fail = match pss with
 
 and compile_row repr xs ps act ys pss lam_fail = match xs,ps with
 | [],[] ->
-    if is_guarded act then
-      let lam = compile_match repr ys pss lam_fail in
-      event_branch repr (patch_guarded lam act)
+    if Out.is_guarded act then
+      let lam = compile_match None ys pss lam_fail in
+      Out.event_branch repr (Out.patch_guarded lam act)
     else
-      act
+      Out.event_branch repr act
 | x::xs,p::ps ->
     begin match p.pat_desc with
     | Tpat_any -> compile_row repr xs ps act ys pss lam_fail
     | Tpat_var id ->
-	compile_row repr xs ps (Discr.alias id x act) ys pss lam_fail
+	compile_row repr xs ps (Out.alias id x act) ys pss lam_fail
     | Tpat_alias (p,id) ->
-	compile_row repr (x::xs) (p::ps) (Discr.alias id x act) ys pss lam_fail
+	compile_row repr (x::xs) (p::ps) (Out.alias id x act) ys pss lam_fail
     | Tpat_or (p,_,_) ->
 	compile_row repr (x::xs) (p::ps) act ys pss lam_fail
     | _ -> assert false
     end
 | _,_ -> assert false
 
 and do_compile_matching repr x xs pss lam_fail =
-
-
   let pss = precompile x pss in
   let ds = Discr.collect pss in
 (*
@@ -120,11 +156,11 @@ and do_compile_matching repr x xs pss lam_fail =
     Discr.DSet.fold
       (fun d k ->
 	let pss = Discr.specialize d pss in
-	let ys,es = Discr.field_ids d x in
+	let ys,es = Out.field_ids d x in
 	let lam = compile_match repr (ys@xs) pss lam_fail in
-	(d,Discr.get_fields ys es lam)::k)
+	(d,Out.get_fields ys es lam)::k)
       ds [] in
-  Discr.switch ds x cls
+  Out.switch x cls
     (if Discr.has_default ds then
       Some (compile_match repr xs (Discr.default pss) lam_fail)
     else
@@ -171,6 +207,14 @@ let split alpha_ids vars_pat pat_act_list =
     pat_act_list []
 ;;
 
+(* Translate actions to out.out and back *)
+
+let compile_match_out repr xs pss fail =
+  let pss = List.map (fun (ps,lam) -> ps,Out.final lam) pss
+  and fail = Out.final fail in
+  let out = compile_match repr xs pss fail in
+  Out.to_lambda out
+
 (******************)
 
 let add_defs lam defs =
@@ -186,7 +230,7 @@ let compile_matching loc repr handler_fun arg pat_act_list _partial =
   let pss = List.map (fun (p,act)  -> [p],act) pat_act_list
   and num_fail = next_raise_count () in
   let lam =
-    compile_match repr [v] pss (Lstaticraise (num_fail,[])) in
+    compile_match_out repr [v] pss (Lstaticraise (num_fail,[])) in
   let lam = bind Strict v arg lam in
   let lam = add_defs lam defs in
   Lstaticcatch (lam,(num_fail,[]),handler_fun ())
@@ -214,7 +258,7 @@ let for_multiple_match loc args pat_act_list _partial =
 	(function | Lvar v -> v | lam -> Ident.create "m")
 	args in
     let num_fail = next_raise_count () in
-    let lam = compile_match repr xs pss (Lstaticraise (num_fail,[])) in
+    let lam = compile_match_out repr xs pss (Lstaticraise (num_fail,[])) in
     let lam =
       List.fold_right2
 	(fun x arg lam -> bind Strict x arg lam)
@@ -235,7 +279,7 @@ let for_tupled_function loc xs pats_act_list  _partial =
       vars_pats pats_act_list in
   let pss,defs =  List.split pats_exits in 
   let num_fail = next_raise_count () in
-  let lam = compile_match None xs pss (Lstaticraise (num_fail,[])) in
+  let lam = compile_match_out None xs pss (Lstaticraise (num_fail,[])) in
   let lam =  add_defs lam defs in
   Lstaticcatch (lam,(num_fail,[]),partial_function loc ())
 

utils/extarray.ml

@@ -0,0 +1,59 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Luc Maranget, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type 'a t = {mutable next : int ; mutable data : 'a array}
+
+let default_size = 32
+;;
+
+let create x = {next = 0 ; data = Array.create default_size x}
+and reset t = t.next <- 0
+;;
+
+let size t = t.next
+
+let incr_table table new_size =
+  let t = Array.create new_size table.data.(0) in
+  Array.blit table.data 0 t 0 (Array.length table.data) ;
+  table.data <- t
+
+let do_emit table i =
+ let size = Array.length table.data in
+ if table.next >= size then
+    incr_table table (2*size);
+ table.data.(table.next) <- i ;
+ table.next <- table.next + 1
+;;
+
+let emit t x = do_emit t x ; t.next-1
+
+exception Error
+
+let get t i =
+  if 0 <= i && i < t.next then
+    t.data.(i)
+  else
+    raise Error
+
+let trim t =
+  let r = Array.sub t.data 0 t.next in
+  reset t ;
+  r
+
+let iter t f =
+  let size = t.next
+  and data = t.data in
+  for i = 0 to size-1 do
+    f data.(i)
+  done