summaryrefslogtreecommitdiffstats
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml13
-rw-r--r--bytecomp/lambda.ml12
-rw-r--r--bytecomp/lambda.mli3
-rw-r--r--bytecomp/matching.ml127
-rw-r--r--bytecomp/matching.mli8
-rw-r--r--bytecomp/printlambda.ml13
-rw-r--r--bytecomp/simplif.ml25
7 files changed, 186 insertions, 15 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 6ecd41dde..3b25c3db3 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -275,6 +275,10 @@ let compunit_name = ref ""
let max_stack_used = ref 0
+
+(* Sequence of string tests *)
+
+
(* Translate a primitive to a bytecode instruction (possibly a call to a C
function) *)
@@ -618,7 +622,7 @@ let rec comp_expr env exp sz cont =
comp_args env args sz (comp_primitive p args :: cont)
| Lprim(p, args) ->
comp_args env args sz (comp_primitive p args :: cont)
- | Lstaticcatch (body, (i, vars) , handler) ->
+ | Lstaticcatch (body, (i, vars) , handler) ->
let nvars = List.length vars in
let branch1, cont1 = make_branch cont in
let r =
@@ -703,7 +707,6 @@ let rec comp_expr env exp sz cont =
(fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts;
List.iter
(fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks;
-
(* Compile and label actions *)
let acts = store.act_get () in
let lbls = Array.create (Array.length acts) 0 in
@@ -723,6 +726,8 @@ let rec comp_expr env exp sz cont =
lbl_consts.(i) <- lbls.(act_consts.(i))
done;
comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
+ | Lstringswitch (arg,sw,d) ->
+ comp_expr env (Matching.expand_stringswitch arg sw d) sz cont
| Lassign(id, expr) ->
begin try
let pos = Ident.find_same id env.ce_stack in
@@ -827,6 +832,10 @@ and comp_binary_test env cond ifso ifnot sz cont =
comp_expr env cond sz cont_cond
+(* Compile string switch *)
+
+and comp_string_switch env arg cases default sz cont = ()
+
(**** Compilation of a code block (with tracking of stack usage) ****)
let comp_block env exp sz cont =
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 1c82898c6..83c00a32d 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -166,6 +166,7 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
+ | Lstringswitch of lambda * (string * lambda) list * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@@ -297,6 +298,10 @@ let iter f = function
| None -> ()
| Some l -> f l
end
+ | Lstringswitch (arg,cases,default) ->
+ f arg ;
+ List.iter (fun (_,act) -> f act) cases ;
+ f default
| Lstaticraise (_,args) ->
List.iter f args
| Lstaticcatch(e1, (_,vars), e2) ->
@@ -347,7 +352,7 @@ let free_ids get l =
| Lassign(id, e) ->
fv := IdentSet.add id !fv
| Lvar _ | Lconst _ | Lapply _
- | Lprim _ | Lswitch _ | Lstaticraise _
+ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
| Lifthenelse _ | Lsequence _ | Lwhile _
| Lsend _ | Levent _ | Lifused _ -> ()
in free l; !fv
@@ -430,7 +435,9 @@ let subst_lambda s lam =
match sw.sw_failaction with
| None -> None
| Some l -> Some (subst l)})
-
+ | Lstringswitch (arg,cases,default) ->
+ Lstringswitch
+ (subst arg,List.map subst_strcase cases,subst default)
| Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
@@ -445,6 +452,7 @@ let subst_lambda s lam =
| Lifused (v, e) -> Lifused (v, subst e)
and subst_decl (id, exp) = (id, subst exp)
and subst_case (key, case) = (key, subst case)
+ and subst_strcase (key, case) = (key, subst case)
in subst lam
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 904ea6fd7..6748fefe1 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -175,6 +175,9 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
+(* switch on strings, clauses are sorted by string order,
+ strings are pairwise distinct *)
+ | Lstringswitch of lambda * (string * lambda) list * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 5e01d4f4b..e98148319 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1652,10 +1652,110 @@ let divide_array kind ctx pm =
(make_array_matching kind)
(=) get_key_array get_args_array ctx pm
+(*
+ Specific string test sequence
+ Will be called by the bytecode compiler, from bytegen.ml.
+ The strategy is first dichotomic search (we perform 3-way tests
+ with compare_string), then sequence of equality tests
+ when there are less then T=strings_test_threshold static strings to match.
+
+ Increasing T entails (slightly) less code, decreasing T
+ (slightly) favors runtime speed.
+ T=8 looks a decent tradeoff.
+*)
+
+(* Utlities *)
+
+let strings_test_threshold = 8
+
+let prim_string_notequal =
+ Pccall{prim_name = "caml_string_notequal";
+ prim_arity = 2; prim_alloc = false;
+ prim_native_name = ""; prim_native_float = false}
+
+let prim_string_compare =
+ Pccall{prim_name = "caml_string_compare";
+ prim_arity = 2; prim_alloc = false;
+ prim_native_name = ""; prim_native_float = false}
+
+let bind_sw arg k = match arg with
+| Lvar _ -> k arg
+| _ ->
+ let id = Ident.create "switch" in
+ Llet (Strict,id,arg,k (Lvar id))
+
+
+(* Sequential equality tests *)
+
+let make_test_sequence arg sw d =
+ bind_sw arg
+ (fun arg ->
+ List.fold_right
+ (fun (s,lam) k ->
+ Lifthenelse
+ (Lprim
+ (prim_string_notequal,
+ [arg; Lconst (Const_immstring s)]),
+ k,lam))
+ sw d)
+
+let catch_sw d k = match d with
+| Lstaticraise (_,[]) -> k d
+| _ ->
+ let e = next_raise_count () in
+ Lstaticcatch (k (Lstaticraise (e,[])),(e,[]),d)
+
+let rec split k xs = match xs with
+| [] -> assert false
+| x0::xs ->
+ if k <= 1 then [],x0,xs
+ else
+ let xs,y0,ys = split (k-2) xs in
+ x0::xs,y0,ys
+
+let zero_lam = Lconst (Const_base (Const_int 0))
+
+let tree_way_test arg lt eq gt =
+ Lifthenelse
+ (Lprim (Pintcomp Clt,[arg;zero_lam]),lt,
+ Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq))
+
+(* Dichotomic tree *)
+
+let rec do_make_tree arg sw d =
+ let len = List.length sw in
+ if len <= strings_test_threshold then make_test_sequence arg sw d
+ else
+ let lt,(s,act),gt = split len sw in
+ bind_sw
+ (Lprim
+ (prim_string_compare,
+ [arg; Lconst (Const_immstring s)];))
+ (fun r ->
+ tree_way_test r
+ (do_make_tree arg lt d)
+ act
+ (do_make_tree arg gt d))
+
+(* Entry point *)
+let expand_stringswitch arg sw d =
+ bind_sw arg (fun arg -> catch_sw d (fun d -> do_make_tree arg sw d))
+
+(*************************************)
(* To combine sub-matchings together *)
+(*************************************)
+
+(* Note: dichotomic search requires sorted input with no duplicates *)
+let rec uniq_lambda_list sw = match sw with
+ | []|[_] -> sw
+ | (c1,_ as p1)::((c2,_)::sw2 as sw1) ->
+ if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2)
+ else p1::uniq_lambda_list sw1
let sort_lambda_list l =
- List.sort (fun (x,_) (y,_) -> const_compare x y) l
+ let l =
+ List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in
+ uniq_lambda_list l
let rec cut n l =
if n = 0 then [],l
@@ -1698,13 +1798,6 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])
-
-
-let prim_string_notequal =
- Pccall{prim_name = "caml_string_notequal";
- prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false}
-
let rec explode_inter offset i j act k =
if i <= j then
explode_inter offset i (j-1) act ((j-offset,act)::k)
@@ -2101,8 +2194,22 @@ let combine_constant arg cst partial ctx def
(fun i -> Lconst (Const_base (Const_int i)))
fail arg 0 255 int_lambda_list
| Const_string _ ->
- make_test_sequence
- fail prim_string_notequal Pignore arg const_lambda_list
+(* Note as the bytecode compiler may resort to dichotmic search,
+ the clauses of strinswitch are sorted with duplicate removed.
+ This partly applies to the native code compiler, which requires
+ no duplicates *)
+ let fail,const_lambda_list = match fail with
+ | Some fail -> fail,sort_lambda_list const_lambda_list
+ | None ->
+ let cls,(_,lst) = Misc.split_last const_lambda_list in
+ lst,sort_lambda_list cls in
+ let sw =
+ List.map
+ (fun (c,act) -> match c with
+ | Const_string (s,_) -> s,act
+ | _ -> assert false)
+ const_lambda_list in
+ Lstringswitch (arg,sw,fail)
| Const_float _ ->
make_test_sequence
fail
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 5c8577b26..398143778 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -15,6 +15,8 @@
open Typedtree
open Lambda
+
+(* Entry points to match compiler *)
val for_function:
Location.t -> int ref option -> lambda -> (pattern * lambda) list ->
partial -> lambda
@@ -34,8 +36,14 @@ exception Cannot_flatten
val flatten_pattern: int -> pattern -> pattern list
+(* Expand stringswitch to string test tree *)
+
+val expand_stringswitch: lambda -> (string * lambda) list -> lambda -> lambda
+
+(*
val make_test_sequence:
lambda option -> primitive -> primitive -> lambda ->
(Asttypes.constant * lambda) list -> lambda
+*)
val inline_lazy_force : lambda -> Location.t -> lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index beb268480..e02196f9b 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -299,11 +299,22 @@ let rec lam ppf = function
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<hv 1>default:@ %a@]" lam l
end in
-
fprintf ppf
"@[<1>(%s %a@ @[<v 0>%a@])@]"
(match sw.sw_failaction with None -> "switch*" | _ -> "switch")
lam larg switch sw
+ | Lstringswitch(arg, cases, default) ->
+ let switch ppf cases =
+ let spc = ref false in
+ List.iter
+ (fun (s, l) ->
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l)
+ cases;
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>default:@ %a@]" lam default in
+ fprintf ppf
+ "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases
| Lstaticraise (i, ls) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index e60bb6d16..c03cd857e 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -54,6 +54,11 @@ let rec eliminate_ref id = function
sw_failaction = match sw.sw_failaction with
| None -> None
| Some l -> Some (eliminate_ref id l)})
+ | Lstringswitch(e, sw, default) ->
+ Lstringswitch
+ (eliminate_ref id e,
+ List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
+ eliminate_ref id default)
| Lstaticraise (i,args) ->
Lstaticraise (i,List.map (eliminate_ref id) args)
| Lstaticcatch(e1, i, e2) ->
@@ -115,6 +120,10 @@ let simplify_exits lam =
count l;
List.iter (fun (_, l) -> count l) sw.sw_consts;
List.iter (fun (_, l) -> count l) sw.sw_blocks
+ | Lstringswitch(l, sw, d) ->
+ count l;
+ List.iter (fun (_, l) -> count l) sw;
+ count d
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
| Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
(* i will be replaced by j in l1, so each occurence of i in l1
@@ -216,6 +225,9 @@ let simplify_exits lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
+ | Lstringswitch(l,sw,d) ->
+ Lstringswitch
+ (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d)
| Lstaticraise (i,[]) as l ->
begin try
let _,handler = Hashtbl.find subst i in
@@ -361,6 +373,10 @@ let simplify_lets lam =
count bv l;
List.iter (fun (_, l) -> count bv l) sw.sw_consts;
List.iter (fun (_, l) -> count bv l) sw.sw_blocks
+ | Lstringswitch(l, sw, d) ->
+ count bv l ;
+ List.iter (fun (_, l) -> count bv l) sw ;
+ count bv d
| Lstaticraise (i,ls) -> List.iter (count bv) ls
| Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
| Ltrywith(l1, v, l2) -> count bv l1; count bv l2
@@ -460,6 +476,9 @@ let simplify_lets lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
+ | Lstringswitch (l,sw,d) ->
+ Lstringswitch
+ (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d)
| Lstaticraise (i,ls) ->
Lstaticraise (i, List.map simplif ls)
| Lstaticcatch(l1, (i,args), l2) ->
@@ -521,6 +540,12 @@ let rec emit_tail_infos is_tail lambda =
emit_tail_infos false lam;
list_emit_tail_infos_fun snd is_tail sw.sw_consts;
list_emit_tail_infos_fun snd is_tail sw.sw_blocks
+ | Lstringswitch (lam, sw, d) ->
+ emit_tail_infos false lam;
+ List.iter
+ (fun (_,lam) -> emit_tail_infos is_tail lam)
+ sw ;
+ emit_tail_infos is_tail d
| Lstaticraise (_, l) ->
list_emit_tail_infos false l
| Lstaticcatch (body, _, handler) ->
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 11:58:54 +0000