Attached Files | ocaml-4.01.0-strmatch.diff [^] (30,047 bytes) 2013-12-13 12:45 [Show Content] [Hide Content]diff -Naur ocaml-4.01.0-old/asmcomp/cmmgen.ml ocaml-4.01.0-new/asmcomp/cmmgen.ml
--- ocaml-4.01.0-old/asmcomp/cmmgen.ml 2013-05-22 15:59:24.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/cmmgen.ml 2013-12-12 16:51:56.678865796 +0100
@@ -1205,6 +1205,17 @@
Ccatch(nfail, ids, transl body, transl handler)
| Utrywith(body, exn, handler) ->
Ctrywith(transl body, exn, transl handler)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifnot, ifso) ->
+ transl_string_match id s lbl ifso ifnot
| Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
transl (Uifthenelse(arg, ifnot, ifso))
| Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
@@ -1273,6 +1284,27 @@
| Uassign(id, exp) ->
return_unit(Cassign(id, transl exp))
+and transl_string_match id s lbl ifso ifnot =
+ let rec aggregate_cases ulambda acc = match ulambda with
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifnot, ifso) when id' = id ->
+ let new_acc =
+ if List.mem_assoc s acc then acc else (s, transl ifnot) :: acc in
+ Compilenv.del_structured_constant lbl;
+ aggregate_cases ifso new_acc
+ | _ -> (ulambda, acc) in
+ Compilenv.del_structured_constant lbl;
+ let (default, cases) = aggregate_cases ifso [ (s, transl ifnot) ] in
+ Strmatch.compile (transl (Uvar id)) (transl default) cases
+
and transl_prim_1 p arg dbg =
match p with
(* Generic operations *)
diff -Naur ocaml-4.01.0-old/asmcomp/compilenv.ml ocaml-4.01.0-new/asmcomp/compilenv.ml
--- ocaml-4.01.0-old/asmcomp/compilenv.ml 2013-07-23 16:48:47.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/compilenv.ml 2013-12-12 16:51:56.678865796 +0100
@@ -219,6 +219,13 @@
structured_constants := (lbl, global, cst) :: !structured_constants;
lbl
+let del_structured_constant lbl =
+ let rec f lbl lst = match lst with
+ | [] -> []
+ | (lbl', _, _) as binding :: rest when lbl' <> lbl -> binding :: f lbl rest
+ | _ :: rest -> rest in
+ structured_constants := f lbl !structured_constants
+
let structured_constants () = !structured_constants
(* Error report *)
diff -Naur ocaml-4.01.0-old/asmcomp/compilenv.mli ocaml-4.01.0-new/asmcomp/compilenv.mli
--- ocaml-4.01.0-old/asmcomp/compilenv.mli 2013-04-29 16:57:38.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/compilenv.mli 2013-12-12 16:51:56.679865797 +0100
@@ -51,6 +51,7 @@
val new_const_symbol : unit -> string
val new_const_label : unit -> int
val new_structured_constant : Lambda.structured_constant -> bool -> string
+val del_structured_constant : string -> unit
val structured_constants :
unit -> (string * bool * Lambda.structured_constant) list
diff -Naur ocaml-4.01.0-old/asmcomp/strmatch.ml ocaml-4.01.0-new/asmcomp/strmatch.ml
--- ocaml-4.01.0-old/asmcomp/strmatch.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-4.01.0-new/asmcomp/strmatch.ml 2013-12-12 17:54:59.298796294 +0100
@@ -0,0 +1,214 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+open Lambda
+open Cmm
+
+let min_key = Nativeint.min_int
+let max_key = Nativeint.max_int
+
+let gen_cell_id () = Ident.create "cell"
+let gen_size_id () = Ident.create "size"
+
+(***)
+
+let mk_let_size id str body =
+ let hd = Cop(Cload Word, [Cop(Cadda, [str; Cconst_int(-Arch.size_int)])]) in
+ let sz = Cop(Clsr, [hd; Cconst_int 10]) in
+ Clet(id, sz, body)
+
+let mk_let_cell id str ind body =
+ let cell = Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in
+ Clet(id, cell, body)
+
+let mk_exit n = Cexit (n, [])
+
+let mk_cmp_gen cmp_op id nat ifso ifnot =
+ let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in
+ Cifthenelse (test, ifso, ifnot)
+
+let mk_lt = mk_cmp_gen Clt
+let mk_eq = mk_cmp_gen Ceq
+let mk_gt = mk_cmp_gen Cgt
+
+(***)
+
+let rec compile_pats str default pats checked size_id min_sz max_sz =
+ match pats with
+ | [] -> default
+ | [ (pat, ifso_exit) ] ->
+ let pat_sz = Array.length pat in
+ check_one_pat str default pat ifso_exit checked size_id pat_sz 0 min_sz
+ | _ :: _ ->
+ let (col_ind, col) =
+ search_most_discriminant pats checked 0 (min_sz - 1) (-1, []) (-1) in
+ if col_ind <> -1 then
+ discriminate_col str default checked size_id col_ind col min_sz max_sz
+ else
+ let id, size_id, get_id = match size_id with
+ | None ->
+ let id = gen_size_id () in
+ (id, Some id, fun body -> mk_let_size id str body)
+ | Some id -> (id, size_id, fun body -> body) in
+ let pat_sizes =
+ Array.of_list (List.map (fun (pat, _) -> Array.length pat) pats) in
+ Array.sort Pervasives.compare pat_sizes;
+ let pat_nb = Array.length pat_sizes in
+ let med_sz = pat_sizes.(pat_nb / 2) in
+ let med_sz_nat = Nativeint.of_int med_sz in
+ if med_sz <> pat_sizes.(0) then
+ let lt_pats =
+ List.filter (fun (pat, _) -> Array.length pat < med_sz) pats
+ and ge_pats =
+ List.filter (fun (pat, _) -> Array.length pat >= med_sz) pats in
+ let iflt =
+ compile_pats str default lt_pats checked size_id min_sz (med_sz - 1)
+ and ifge =
+ compile_pats str default ge_pats checked size_id med_sz max_sz in
+ get_id (mk_lt id med_sz_nat iflt ifge)
+ else if med_sz <> pat_sizes.(pat_nb - 1) then
+ let le_pats =
+ List.filter (fun (pat, _) -> Array.length pat <= med_sz) pats
+ and gt_pats =
+ List.filter (fun (pat, _) -> Array.length pat > med_sz) pats in
+ let ifle =
+ compile_pats str default le_pats checked size_id min_sz med_sz
+ and ifgt =
+ compile_pats str default gt_pats checked size_id (med_sz+1) max_sz in
+ get_id (mk_gt id med_sz_nat ifgt ifle)
+ else
+ let ifeq =
+ compile_pats str default pats checked size_id med_sz med_sz in
+ get_id (mk_eq id med_sz_nat ifeq default)
+
+and discriminate_col str default checked size_id col_ind col min_sz max_sz =
+ let col = Array.of_list col in
+ let cell_id = gen_cell_id () in
+ Array.sort (fun (k1, _) (k2, _) -> Pervasives.compare k1 k2) col;
+ mk_let_cell cell_id str col_ind
+ (make_col_checks str default (col_ind :: checked) size_id col cell_id 0
+ (Array.length col) min_sz max_sz)
+
+and make_col_checks str default checked size_id col cell_id i j min_sz max_sz =
+ match j - i with
+ | 0 -> default
+ | 1 | 2 | 3 ->
+ let (key, pats) = col.(i) in
+ let ifeq = compile_pats str default pats checked size_id min_sz max_sz in
+ let ifne =
+ make_col_checks str default checked size_id col cell_id (i + 1) j
+ min_sz max_sz in
+ mk_eq cell_id key ifeq ifne
+ | _ ->
+ let m = (i + j) / 2 in
+ let (key, pats) = col.(m) in
+ let iflt =
+ make_col_checks str default checked size_id col cell_id i m min_sz
+ max_sz
+ and ifge =
+ make_col_checks str default checked size_id col cell_id m j min_sz
+ max_sz in
+ mk_lt cell_id key iflt ifge
+
+and search_most_discriminant pats checked min_i max_i best best_cnt =
+ if min_i > max_i then best else
+ if List.mem min_i checked then
+ search_most_discriminant pats checked (min_i + 1) max_i best best_cnt
+ else
+ let col = extract_distinct pats min_i [] in
+ let cnt = List.length col in
+ if cnt > best_cnt then
+ search_most_discriminant pats checked (min_i + 1) max_i (min_i, col) cnt
+ else
+ search_most_discriminant pats checked (min_i + 1) max_i best best_cnt
+
+and extract_distinct pats i acc = match pats with
+ | [] -> acc | (pat, ifso_exit) :: rest ->
+ try
+ let lst = List.assoc pat.(i) acc in
+ let new_acc = List.remove_assoc pat.(i) acc in
+ let new_acc = (pat.(i), ((pat, ifso_exit) :: lst)) :: new_acc in
+ extract_distinct rest i new_acc
+ with Not_found ->
+ extract_distinct rest i ((pat.(i), [ (pat, ifso_exit) ]) :: acc)
+
+and check_size_eq str default size_id sz ifeq =
+ let id, size_id, get_id = match size_id with
+ | None ->
+ let id = gen_size_id () in
+ (id, Some id, fun body -> mk_let_size id str body)
+ | Some id -> (id, size_id, fun body -> body) in
+ let sz_nat = Nativeint.of_int sz in
+ get_id (mk_eq id sz_nat (ifeq size_id) default)
+
+and check_one_pat str default pat ifso_exit checked size_id pat_sz i min_sz =
+ if i >= pat_sz then
+ if min_sz < pat_sz then
+ check_size_eq str default size_id pat_sz
+ (fun _size_id -> mk_exit ifso_exit)
+ else
+ mk_exit ifso_exit
+ else
+ if List.mem i checked then
+ check_one_pat str default pat ifso_exit checked size_id pat_sz (i + 1)
+ min_sz
+ else if i < min_sz then
+ let cell_id = gen_cell_id () in
+ let ifeq =
+ check_one_pat str default pat ifso_exit checked size_id pat_sz (i + 1)
+ min_sz in
+ mk_let_cell cell_id str i (mk_eq cell_id pat.(i) ifeq default)
+ else
+ check_size_eq str default size_id pat_sz (fun size_id ->
+ check_one_pat str default pat ifso_exit checked size_id pat_sz i pat_sz)
+
+(***)
+
+let pat_of_string str =
+ let len = String.length str in
+ let n = len / Arch.size_addr + 1 in
+ let get_byte i =
+ if i < len then int_of_char str.[i]
+ else if i < n * Arch.size_addr - 1 then 0
+ else n * Arch.size_addr - 1 - len in
+ let mk_word ind =
+ let w = ref 0n in
+ let imin = ind * Arch.size_addr and imax = (ind + 1) * Arch.size_addr - 1 in
+ if Arch.big_endian then
+ for i = imin to imax do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done
+ else
+ for i = imax downto imin do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done;
+ !w in
+ Array.init n mk_word
+
+(***)
+
+let compile str default cases =
+ let default_exit = next_raise_count () in
+ let rec mk_pats cases pats withs = match cases with
+ | [] -> (pats, withs)
+ | (str, ifso) :: rest ->
+ let ifso_exit = next_raise_count () in
+ let pat = pat_of_string str in
+ mk_pats rest ((pat, ifso_exit) :: pats) ((ifso_exit, ifso) :: withs) in
+ let (pats, withs) = mk_pats cases [] [ (default_exit, default) ] in
+ let body = compile_pats str (mk_exit default_exit) pats [] None 1 max_int in
+ let mk_catch acc (ifso_exit, ifso) = Ccatch (ifso_exit, [], acc, ifso) in
+ List.fold_left mk_catch body withs
diff -Naur ocaml-4.01.0-old/asmcomp/strmatch.mli ocaml-4.01.0-new/asmcomp/strmatch.mli
--- ocaml-4.01.0-old/asmcomp/strmatch.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-4.01.0-new/asmcomp/strmatch.mli 2013-12-12 16:51:56.680865800 +0100
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+val compile : Cmm.expression -> Cmm.expression ->
+ (string * Cmm.expression) list -> Cmm.expression
diff -Naur ocaml-4.01.0-old/.depend ocaml-4.01.0-new/.depend
--- ocaml-4.01.0-old/.depend 2013-08-15 18:13:16.000000000 +0200
+++ ocaml-4.01.0-new/.depend 2013-12-12 16:51:56.682865801 +0100
@@ -84,10 +84,10 @@
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
parsing/asttypes.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
-typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/ident.cmi :
typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
@@ -105,10 +105,10 @@
typing/path.cmi : typing/ident.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmi :
+typing/printtyped.cmi : typing/typedtree.cmi
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
typing/env.cmi
-typing/printtyped.cmi : typing/typedtree.cmi
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
@@ -122,11 +122,11 @@
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includecore.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi
+typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
+typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
-typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
-typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includemod.cmi typing/ident.cmi typing/env.cmi
@@ -166,6 +166,12 @@
typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/datarepr.cmi
+typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
+ typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
+ parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
+ typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
+ parsing/asttypes.cmi typing/envaux.cmi
typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -178,12 +184,6 @@
typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/env.cmi
-typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
- typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
- parsing/asttypes.cmi typing/envaux.cmi
-typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
- typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
- parsing/asttypes.cmi typing/envaux.cmi
typing/ident.cmo : typing/ident.cmi
typing/ident.cmx : typing/ident.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
@@ -238,6 +238,12 @@
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi
typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
+typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ parsing/asttypes.cmi typing/printtyped.cmi
+typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+ parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
@@ -250,12 +256,6 @@
parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/printtyp.cmi
-typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
- parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
- parsing/asttypes.cmi typing/printtyped.cmi
-typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
- parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
- parsing/asttypes.cmi typing/printtyped.cmi
typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
@@ -316,12 +316,6 @@
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/typedecl.cmi
-typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
-typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \
typing/typedtreeIter.cmi
typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \
@@ -330,6 +324,12 @@
parsing/asttypes.cmi typing/typedtreeMap.cmi
typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
parsing/asttypes.cmi typing/typedtreeMap.cmi
+typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
+ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
+typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
+ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+ typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
@@ -567,9 +567,9 @@
asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.cmi
+asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmx_format.cmi : asmcomp/clambda.cmi
asmcomp/codegen.cmi : asmcomp/cmm.cmi
asmcomp/coloring.cmi :
@@ -577,8 +577,8 @@
asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi
asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
-asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi
+asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/interf.cmi : asmcomp/mach.cmi
asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/debuginfo.cmi
@@ -591,8 +591,8 @@
asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi : asmcomp/cmm.cmi
-asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
@@ -600,8 +600,9 @@
asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
asmcomp/spill.cmi : asmcomp/mach.cmi
asmcomp/split.cmi : asmcomp/mach.cmi
-asmcomp/arch.cmo :
-asmcomp/arch.cmx :
+asmcomp/strmatch.cmi :
+asmcomp/arch.cmo : utils/config.cmi
+asmcomp/arch.cmx : utils/config.cmx
asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
@@ -662,22 +663,22 @@
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
+asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \
+ asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
+ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \
+ parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi
+asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \
+ asmcomp/strmatch.cmx asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
+ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \
+ parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi
asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
asmcomp/cmm.cmi
-asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
- typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
- asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
- asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
- typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
- asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
- asmcomp/cmmgen.cmi
asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
@@ -704,6 +705,10 @@
asmcomp/debuginfo.cmi
asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
asmcomp/debuginfo.cmi
+asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -712,10 +717,6 @@
asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
- utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
- utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/interf.cmi
asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
@@ -764,14 +765,14 @@
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
- asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
-asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
- asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
+asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+ asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+ asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
@@ -789,11 +790,11 @@
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/selectgen.cmi
asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
- utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/arch.cmo asmcomp/selection.cmi
+ utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
+ asmcomp/selection.cmi
asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
- utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/arch.cmx asmcomp/selection.cmi
+ utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
+ asmcomp/selection.cmi
asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@@ -802,12 +803,14 @@
asmcomp/split.cmi
asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/split.cmi
+asmcomp/strmatch.cmo : typing/ident.cmi asmcomp/strmatch.cmi
+asmcomp/strmatch.cmx : typing/ident.cmx asmcomp/strmatch.cmi
driver/compenv.cmi :
driver/compile.cmi :
driver/compmisc.cmi : typing/env.cmi
driver/errors.cmi :
-driver/main.cmi :
driver/main_args.cmi :
+driver/main.cmi :
driver/optcompile.cmi :
driver/opterrors.cmi :
driver/optmain.cmi :
@@ -854,6 +857,8 @@
typing/includemod.cmx typing/env.cmx typing/ctype.cmx \
typing/cmi_format.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/errors.cmi
+driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
+driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi driver/errors.cmi utils/config.cmi \
driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
@@ -864,8 +869,6 @@
driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
-driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
-driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
diff -Naur ocaml-4.01.0-old/Makefile ocaml-4.01.0-new/Makefile
--- ocaml-4.01.0-old/Makefile 2013-06-17 15:15:18.000000000 +0200
+++ ocaml-4.01.0-new/Makefile 2013-12-12 16:51:56.682865801 +0100
@@ -79,7 +79,7 @@
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
- asmcomp/closure.cmo asmcomp/cmmgen.cmo \
+ asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo asmcomp/liveness.cmo \
asmcomp/spill.cmo asmcomp/split.cmo \
ocaml-4.01.0-strmatch-v2.diff [^] (29,873 bytes) 2013-12-16 00:28 [Show Content] [Hide Content]diff -Naur ocaml-4.01.0-old/asmcomp/cmmgen.ml ocaml-4.01.0-new/asmcomp/cmmgen.ml
--- ocaml-4.01.0-old/asmcomp/cmmgen.ml 2013-05-22 15:59:24.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/cmmgen.ml 2013-12-15 17:44:58.704981473 +0100
@@ -1205,6 +1205,17 @@
Ccatch(nfail, ids, transl body, transl handler)
| Utrywith(body, exn, handler) ->
Ctrywith(transl body, exn, transl handler)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifnot, ifso) ->
+ transl_string_match id s lbl ifso ifnot
| Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
transl (Uifthenelse(arg, ifnot, ifso))
| Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
@@ -1273,6 +1284,27 @@
| Uassign(id, exp) ->
return_unit(Cassign(id, transl exp))
+and transl_string_match id s lbl ifso ifnot =
+ let rec aggregate_cases ulambda acc = match ulambda with
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifnot, ifso) when id' = id ->
+ let new_acc =
+ if List.mem_assoc s acc then acc else (s, transl ifnot) :: acc in
+ Compilenv.del_structured_constant lbl;
+ aggregate_cases ifso new_acc
+ | _ -> (ulambda, acc) in
+ Compilenv.del_structured_constant lbl;
+ let (default, cases) = aggregate_cases ifso [ (s, transl ifnot) ] in
+ Strmatch.compile (transl (Uvar id)) (transl default) cases
+
and transl_prim_1 p arg dbg =
match p with
(* Generic operations *)
diff -Naur ocaml-4.01.0-old/asmcomp/compilenv.ml ocaml-4.01.0-new/asmcomp/compilenv.ml
--- ocaml-4.01.0-old/asmcomp/compilenv.ml 2013-07-23 16:48:47.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/compilenv.ml 2013-12-15 17:44:58.704981473 +0100
@@ -219,6 +219,13 @@
structured_constants := (lbl, global, cst) :: !structured_constants;
lbl
+let del_structured_constant lbl =
+ let rec f lbl lst = match lst with
+ | [] -> []
+ | (lbl', _, _) as binding :: rest when lbl' <> lbl -> binding :: f lbl rest
+ | _ :: rest -> rest in
+ structured_constants := f lbl !structured_constants
+
let structured_constants () = !structured_constants
(* Error report *)
diff -Naur ocaml-4.01.0-old/asmcomp/compilenv.mli ocaml-4.01.0-new/asmcomp/compilenv.mli
--- ocaml-4.01.0-old/asmcomp/compilenv.mli 2013-04-29 16:57:38.000000000 +0200
+++ ocaml-4.01.0-new/asmcomp/compilenv.mli 2013-12-15 17:44:58.705981473 +0100
@@ -51,6 +51,7 @@
val new_const_symbol : unit -> string
val new_const_label : unit -> int
val new_structured_constant : Lambda.structured_constant -> bool -> string
+val del_structured_constant : string -> unit
val structured_constants :
unit -> (string * bool * Lambda.structured_constant) list
diff -Naur ocaml-4.01.0-old/asmcomp/strmatch.ml ocaml-4.01.0-new/asmcomp/strmatch.ml
--- ocaml-4.01.0-old/asmcomp/strmatch.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-4.01.0-new/asmcomp/strmatch.ml 2013-12-15 17:45:10.999981773 +0100
@@ -0,0 +1,213 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+open Lambda
+open Cmm
+
+let min_key = Nativeint.min_int
+let max_key = Nativeint.max_int
+
+let gen_cell_id () = Ident.create "cell"
+let gen_size_id () = Ident.create "size"
+
+(***)
+
+let mk_let_size id str body =
+ let hd = Cop(Cload Word, [Cop(Cadda, [str; Cconst_int(-Arch.size_int)])]) in
+ let sz = Cop(Clsr, [hd; Cconst_int 10]) in
+ Clet(id, sz, body)
+
+let mk_let_cell id str ind body =
+ let cell = Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in
+ Clet(id, cell, body)
+
+let mk_exit n = Cexit (n, [])
+
+let mk_cmp_gen cmp_op id nat ifso ifnot =
+ let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in
+ Cifthenelse (test, ifso, ifnot)
+
+let mk_lt = mk_cmp_gen Clt
+let mk_eq = mk_cmp_gen Ceq
+let mk_gt = mk_cmp_gen Cgt
+
+(***)
+
+let rec compile_pats str default pats checked size_id min_sz max_sz =
+ match pats with
+ | [] -> default
+ | [ (pat, ifso_exit) ] ->
+ let pat_sz = Array.length pat in
+ check_one_pat str default pat ifso_exit checked size_id pat_sz 0 min_sz
+ | _ :: _ ->
+ let (col_ind, col) =
+ search_less_discriminant pats checked 0 (min_sz - 1) (-1, [||]) max_int in
+ if col_ind <> -1 then
+ discriminate_col str default checked size_id col_ind col min_sz max_sz
+ else
+ let id, size_id, get_id = match size_id with
+ | None ->
+ let id = gen_size_id () in
+ (id, Some id, fun body -> mk_let_size id str body)
+ | Some id -> (id, size_id, fun body -> body) in
+ let pat_sizes =
+ Array.of_list (List.map (fun (pat, _) -> Array.length pat) pats) in
+ Array.sort Pervasives.compare pat_sizes;
+ let pat_nb = Array.length pat_sizes in
+ let med_sz = pat_sizes.(pat_nb / 2) in
+ let med_sz_nat = Nativeint.of_int med_sz in
+ if med_sz <> pat_sizes.(0) then
+ let (lt_pats, ge_pats) =
+ List.partition (fun (pat, _) -> Array.length pat < med_sz) pats in
+ let iflt =
+ compile_pats str default lt_pats checked size_id min_sz (med_sz - 1)
+ and ifge =
+ compile_pats str default ge_pats checked size_id med_sz max_sz in
+ get_id (mk_lt id med_sz_nat iflt ifge)
+ else if med_sz <> pat_sizes.(pat_nb - 1) then
+ let (le_pats, gt_pats) =
+ List.partition (fun (pat, _) -> Array.length pat <= med_sz) pats in
+ let ifle =
+ compile_pats str default le_pats checked size_id min_sz med_sz
+ and ifgt =
+ compile_pats str default gt_pats checked size_id (med_sz+1) max_sz in
+ get_id (mk_gt id med_sz_nat ifgt ifle)
+ else
+ let ifeq =
+ compile_pats str default pats checked size_id med_sz med_sz in
+ get_id (mk_eq id med_sz_nat ifeq default)
+
+and discriminate_col str default checked size_id col_ind col min_sz max_sz =
+ let cell_id = gen_cell_id () in
+ Array.sort (fun (k1, _) (k2, _) -> Pervasives.compare k1 k2) col;
+ mk_let_cell cell_id str col_ind
+ (make_col_checks str default (col_ind :: checked) size_id col cell_id 0
+ (Array.length col) min_sz max_sz)
+
+and make_col_checks str default checked size_id col cell_id i j min_sz max_sz =
+ match j - i with
+ | 0 -> default
+ | 1 | 2 | 3 ->
+ let (key, pats) = col.(i) in
+ let ifeq = compile_pats str default pats checked size_id min_sz max_sz in
+ let ifne =
+ make_col_checks str default checked size_id col cell_id (i + 1) j
+ min_sz max_sz in
+ mk_eq cell_id key ifeq ifne
+ | _ ->
+ let m = (i + j) / 2 in
+ let (key, pats) = col.(m) in
+ let iflt =
+ make_col_checks str default checked size_id col cell_id i m min_sz
+ max_sz
+ and ifge =
+ make_col_checks str default checked size_id col cell_id m j min_sz
+ max_sz in
+ mk_lt cell_id key iflt ifge
+
+and search_less_discriminant pats checked min_i max_i best best_cnt =
+ if min_i > max_i then best else
+ if List.mem min_i checked then
+ search_less_discriminant pats checked (min_i + 1) max_i best best_cnt
+ else
+ let col = extract_distinct pats min_i in
+ let cnt = Array.length col in
+ if cnt < best_cnt then
+ search_less_discriminant pats checked (min_i + 1) max_i (min_i, col) cnt
+ else
+ search_less_discriminant pats checked (min_i + 1) max_i best best_cnt
+
+and extract_distinct pats i =
+ let col = Hashtbl.create (List.length pats) in
+ let handle ((pat, _) as data) =
+ let old_lst =
+ try
+ let lst = Hashtbl.find col pat.(i) in
+ Hashtbl.remove col pat.(i);
+ lst
+ with Not_found ->
+ [] in
+ Hashtbl.add col pat.(i) (data :: old_lst) in
+ List.iter handle pats;
+ Array.of_list (Hashtbl.fold (fun k v acc -> (k, v) :: acc) col [])
+
+and check_size_eq str default size_id sz ifeq =
+ let id, size_id, get_id = match size_id with
+ | None ->
+ let id = gen_size_id () in
+ (id, Some id, fun body -> mk_let_size id str body)
+ | Some id -> (id, size_id, fun body -> body) in
+ let sz_nat = Nativeint.of_int sz in
+ get_id (mk_eq id sz_nat (ifeq size_id) default)
+
+and check_one_pat str default pat ifso_exit checked size_id pat_sz i min_sz =
+ if i >= pat_sz then
+ if min_sz < pat_sz then
+ check_size_eq str default size_id pat_sz
+ (fun _size_id -> mk_exit ifso_exit)
+ else
+ mk_exit ifso_exit
+ else
+ if List.mem i checked then
+ check_one_pat str default pat ifso_exit checked size_id pat_sz (i + 1)
+ min_sz
+ else if i < min_sz then
+ let cell_id = gen_cell_id () in
+ let ifeq =
+ check_one_pat str default pat ifso_exit checked size_id pat_sz (i + 1)
+ min_sz in
+ mk_let_cell cell_id str i (mk_eq cell_id pat.(i) ifeq default)
+ else
+ check_size_eq str default size_id pat_sz (fun size_id ->
+ check_one_pat str default pat ifso_exit checked size_id pat_sz i pat_sz)
+
+(***)
+
+let pat_of_string str =
+ let len = String.length str in
+ let n = len / Arch.size_addr + 1 in
+ let get_byte i =
+ if i < len then int_of_char str.[i]
+ else if i < n * Arch.size_addr - 1 then 0
+ else n * Arch.size_addr - 1 - len in
+ let mk_word ind =
+ let w = ref 0n in
+ let imin = ind * Arch.size_addr and imax = (ind + 1) * Arch.size_addr - 1 in
+ if Arch.big_endian then
+ for i = imin to imax do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done
+ else
+ for i = imax downto imin do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done;
+ !w in
+ Array.init n mk_word
+
+(***)
+
+let compile str default cases =
+ let default_exit = next_raise_count () in
+ let rec mk_pats cases pats withs = match cases with
+ | [] -> (pats, withs)
+ | (str, ifso) :: rest ->
+ let ifso_exit = next_raise_count () in
+ let pat = pat_of_string str in
+ mk_pats rest ((pat, ifso_exit) :: pats) ((ifso_exit, ifso) :: withs) in
+ let (pats, withs) = mk_pats cases [] [ (default_exit, default) ] in
+ let body = compile_pats str (mk_exit default_exit) pats [] None 1 max_int in
+ let mk_catch acc (ifso_exit, ifso) = Ccatch (ifso_exit, [], acc, ifso) in
+ List.fold_left mk_catch body withs
diff -Naur ocaml-4.01.0-old/asmcomp/strmatch.mli ocaml-4.01.0-new/asmcomp/strmatch.mli
--- ocaml-4.01.0-old/asmcomp/strmatch.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-4.01.0-new/asmcomp/strmatch.mli 2013-12-15 17:44:58.705981473 +0100
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+val compile : Cmm.expression -> Cmm.expression ->
+ (string * Cmm.expression) list -> Cmm.expression
diff -Naur ocaml-4.01.0-old/.depend ocaml-4.01.0-new/.depend
--- ocaml-4.01.0-old/.depend 2013-08-15 18:13:16.000000000 +0200
+++ ocaml-4.01.0-new/.depend 2013-12-15 17:44:58.706981473 +0100
@@ -84,10 +84,10 @@
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
parsing/asttypes.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
typing/path.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
-typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
typing/ident.cmi :
typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
@@ -105,10 +105,10 @@
typing/path.cmi : typing/ident.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmi :
+typing/printtyped.cmi : typing/typedtree.cmi
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
typing/env.cmi
-typing/printtyped.cmi : typing/typedtree.cmi
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
@@ -122,11 +122,11 @@
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includecore.cmi typing/ident.cmi typing/env.cmi \
parsing/asttypes.cmi
+typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
+typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
-typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
-typing/typedtreeMap.cmi : typing/typedtree.cmi
typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/includemod.cmi typing/ident.cmi typing/env.cmi
@@ -166,6 +166,12 @@
typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/datarepr.cmi
+typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
+ typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
+ parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
+ typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
+ parsing/asttypes.cmi typing/envaux.cmi
typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -178,12 +184,6 @@
typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/env.cmi
-typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
- typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
- parsing/asttypes.cmi typing/envaux.cmi
-typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
- typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
- parsing/asttypes.cmi typing/envaux.cmi
typing/ident.cmo : typing/ident.cmi
typing/ident.cmx : typing/ident.cmi
typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
@@ -238,6 +238,12 @@
typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi
typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
+typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+ parsing/asttypes.cmi typing/printtyped.cmi
+typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+ parsing/asttypes.cmi typing/printtyped.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
@@ -250,12 +256,6 @@
parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/printtyp.cmi
-typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \
- parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
- parsing/asttypes.cmi typing/printtyped.cmi
-typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \
- parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
- parsing/asttypes.cmi typing/printtyped.cmi
typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
@@ -316,12 +316,6 @@
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/typedecl.cmi
-typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
-typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \
typing/typedtreeIter.cmi
typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \
@@ -330,6 +324,12 @@
parsing/asttypes.cmi typing/typedtreeMap.cmi
typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
parsing/asttypes.cmi typing/typedtreeMap.cmi
+typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
+ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi
+typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
+ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+ typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi
typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
@@ -567,9 +567,9 @@
asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/debuginfo.cmi parsing/asttypes.cmi
asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
asmcomp/clambda.cmi
+asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
asmcomp/cmx_format.cmi : asmcomp/clambda.cmi
asmcomp/codegen.cmi : asmcomp/cmm.cmi
asmcomp/coloring.cmi :
@@ -577,8 +577,8 @@
asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/cmx_format.cmi asmcomp/clambda.cmi
asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
-asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi
+asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
asmcomp/interf.cmi : asmcomp/mach.cmi
asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/debuginfo.cmi
@@ -591,8 +591,8 @@
asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi : asmcomp/cmm.cmi
-asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/reload.cmi : asmcomp/mach.cmi
asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi : asmcomp/linearize.cmi
asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
@@ -600,8 +600,9 @@
asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
asmcomp/spill.cmi : asmcomp/mach.cmi
asmcomp/split.cmi : asmcomp/mach.cmi
-asmcomp/arch.cmo :
-asmcomp/arch.cmx :
+asmcomp/strmatch.cmi :
+asmcomp/arch.cmo : utils/config.cmi
+asmcomp/arch.cmx : utils/config.cmx
asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
@@ -662,22 +663,22 @@
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi
+asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \
+ asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
+ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \
+ parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi
+asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \
+ asmcomp/strmatch.cmx asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
+ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \
+ parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi
asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
asmcomp/cmm.cmi
asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
asmcomp/cmm.cmi
-asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
- typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
- asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
- asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
- typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
- asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
- asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
- asmcomp/cmmgen.cmi
asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
@@ -704,6 +705,10 @@
asmcomp/debuginfo.cmi
asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
asmcomp/debuginfo.cmi
+asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
+ utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -712,10 +717,6 @@
asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
- utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
- utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/interf.cmi
asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
@@ -764,14 +765,14 @@
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
- asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
-asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
- asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
+asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+ asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+ asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
@@ -789,11 +790,11 @@
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/selectgen.cmi
asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
- utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \
- asmcomp/arch.cmo asmcomp/selection.cmi
+ utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
+ asmcomp/selection.cmi
asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
- utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \
- asmcomp/arch.cmx asmcomp/selection.cmi
+ utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
+ asmcomp/selection.cmi
asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@@ -802,12 +803,14 @@
asmcomp/split.cmi
asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/split.cmi
+asmcomp/strmatch.cmo : typing/ident.cmi asmcomp/strmatch.cmi
+asmcomp/strmatch.cmx : typing/ident.cmx asmcomp/strmatch.cmi
driver/compenv.cmi :
driver/compile.cmi :
driver/compmisc.cmi : typing/env.cmi
driver/errors.cmi :
-driver/main.cmi :
driver/main_args.cmi :
+driver/main.cmi :
driver/optcompile.cmi :
driver/opterrors.cmi :
driver/optmain.cmi :
@@ -854,6 +857,8 @@
typing/includemod.cmx typing/env.cmx typing/ctype.cmx \
typing/cmi_format.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/errors.cmi
+driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
+driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi driver/errors.cmi utils/config.cmi \
driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
@@ -864,8 +869,6 @@
driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
-driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
-driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \
diff -Naur ocaml-4.01.0-old/Makefile ocaml-4.01.0-new/Makefile
--- ocaml-4.01.0-old/Makefile 2013-06-17 15:15:18.000000000 +0200
+++ ocaml-4.01.0-new/Makefile 2013-12-15 17:44:58.706981473 +0100
@@ -79,7 +79,7 @@
asmcomp/cmm.cmo asmcomp/printcmm.cmo \
asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
- asmcomp/closure.cmo asmcomp/cmmgen.cmo \
+ asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
asmcomp/comballoc.cmo asmcomp/liveness.cmo \
asmcomp/spill.cmo asmcomp/split.cmo \
ocaml-4.01.0-strmatch-v3.diff [^] (16,629 bytes) 2014-03-18 16:43 [Show Content] [Hide Content]Index: asmcomp/compilenv.mli
===================================================================
--- asmcomp/compilenv.mli (revision 14465)
+++ asmcomp/compilenv.mli (working copy)
@@ -51,6 +51,7 @@
val new_const_symbol : unit -> string
val new_const_label : unit -> int
val new_structured_constant : Lambda.structured_constant -> bool -> string
+val del_structured_constant : string -> unit
val structured_constants :
unit -> (string * bool * Lambda.structured_constant) list
Index: asmcomp/compilenv.ml
===================================================================
--- asmcomp/compilenv.ml (revision 14465)
+++ asmcomp/compilenv.ml (working copy)
@@ -219,6 +219,13 @@
structured_constants := (lbl, global, cst) :: !structured_constants;
lbl
+let del_structured_constant lbl =
+ let rec f lbl lst = match lst with
+ | [] -> []
+ | (lbl', _, _) as binding :: rest when lbl' <> lbl -> binding :: f lbl rest
+ | _ :: rest -> rest in
+ structured_constants := f lbl !structured_constants
+
let structured_constants () = !structured_constants
(* Error report *)
Index: asmcomp/cmmgen.ml
===================================================================
--- asmcomp/cmmgen.ml (revision 14465)
+++ asmcomp/cmmgen.ml (working copy)
@@ -360,13 +360,17 @@
(* String length *)
+(* Length of string block *)
+
+let string_block_length str = Cop(Clsr, [header str; Cconst_int 10])
+
let string_length exp =
bind "str" exp (fun str ->
let tmp_var = Ident.create "tmp" in
Clet(tmp_var,
Cop(Csubi,
[Cop(Clsl,
- [Cop(Clsr, [header str; Cconst_int 10]);
+ [string_block_length str;
Cconst_int log2_size_addr]);
Cconst_int 1]),
Cop(Csubi,
@@ -938,6 +942,41 @@
module SwitcherBlocks = Switch.Make(SArgBlocks)
+(* Int switcher, arg in [low..high],
+ cases is list of individual cases, and is sorted by first component *)
+
+let transl_int_switch arg low high cases default = match cases with
+| [] -> assert false
+| (k0,_)::_ ->
+ let nacts = List.length cases + 1 in
+ let actions = Array.create nacts default in
+ let rec set_acts idx = function
+ | [] -> assert false
+ | [i,act] ->
+ actions.(idx) <- act ;
+ if i = high then [(i,i,idx)]
+ else [(i,i,idx); (i+1,max_int,0)]
+ | (i,act)::((j,_)::_ as rem) ->
+ actions.(idx) <- act ;
+ let inters = set_acts (idx+1) rem in
+ (i,i,idx)::
+ begin
+ if j = i+1 then inters
+ else (i+1,j-1,0)::inters
+ end in
+ let inters = set_acts 1 cases in
+ let inters =
+ if k0 = low then inters else (low,k0-1,0)::inters in
+ bind "switcher" arg
+ (fun a ->
+ SwitcherBlocks.zyva
+ (low,high)
+ (fun i -> Cconst_int i)
+ a
+ (Array.of_list inters) actions)
+
+
+
(* Auxiliary functions for optimizing "let" of boxed numbers (floats and
boxed integers *)
@@ -1029,6 +1068,15 @@
let functions = (Queue.create() : ufunction Queue.t)
+let strmatch_compile =
+ let module S =
+ Strmatch.Make
+ (struct
+ let string_block_length = string_block_length
+ let transl_switch = transl_int_switch
+ end) in
+ S.compile
+
let rec transl = function
Uvar id ->
Cvar id
@@ -1212,6 +1260,17 @@
Ccatch(nfail, ids, transl body, transl handler)
| Utrywith(body, exn, handler) ->
Ctrywith(transl body, exn, transl handler)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id ]), _dbg),
+ ifnot, ifso) ->
+ transl_string_match id s lbl ifso ifnot
| Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
transl (Uifthenelse(arg, ifnot, ifso))
| Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
@@ -1280,6 +1339,27 @@
| Uassign(id, exp) ->
return_unit(Cassign(id, transl exp))
+and transl_string_match id s lbl ifso ifnot =
+ let rec aggregate_cases ulambda acc = match ulambda with
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_notequal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifso, ifnot)
+ | Uifthenelse (Uprim (
+ Pccall { Primitive.prim_name = "caml_string_equal"; _ },
+ ([ Uvar id'; Uconst (Const_base (Const_string s), Some lbl) ]
+ |[ Uconst (Const_base (Const_string s), Some lbl); Uvar id' ]), _dbg),
+ ifnot, ifso) when id' = id ->
+ let new_acc =
+ if List.mem_assoc s acc then acc else (s, transl ifnot) :: acc in
+ Compilenv.del_structured_constant lbl;
+ aggregate_cases ifso new_acc
+ | _ -> (ulambda, acc) in
+ Compilenv.del_structured_constant lbl;
+ let (default, cases) = aggregate_cases ifso [ (s, transl ifnot) ] in
+ strmatch_compile (transl (Uvar id)) (transl default) cases
+
and transl_prim_1 p arg dbg =
match p with
(* Generic operations *)
Index: asmcomp/strmatch.ml
===================================================================
--- asmcomp/strmatch.ml (revision 0)
+++ asmcomp/strmatch.ml (revision 0)
@@ -0,0 +1,310 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+open Lambda
+open Cmm
+
+module type I = sig
+ val string_block_length : Cmm.expression -> Cmm.expression
+ val transl_switch :
+ Cmm.expression -> int -> int ->
+ (int * Cmm.expression) list -> Cmm.expression ->
+ Cmm.expression
+end
+
+module Make(I:I) =
+ struct
+
+(* Debug *)
+
+ let verbose = false
+
+ let pp_match chan tag idxs cases =
+ Printf.eprintf
+ "%s: idx=[%s]\n" tag
+ (String.concat "; " (List.map string_of_int idxs)) ;
+ List.iter
+ (fun (ps,_) ->
+ Printf.fprintf chan " [%s]\n"
+ (String.concat "; " (List.map Nativeint.to_string ps)))
+ cases
+
+
+(* Utilities *)
+
+ let gen_cell_id () = Ident.create "cell"
+ let gen_size_id () = Ident.create "size"
+
+ let mk_let_cell id str ind body =
+ let cell =
+ Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in
+ Clet(id, cell, body)
+
+ let mk_let_size id str body =
+ let size = I.string_block_length str in
+ Clet(id, size, body)
+
+ let mk_cmp_gen cmp_op id nat ifso ifnot =
+ let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in
+ Cifthenelse (test, ifso, ifnot)
+
+ let mk_lt = mk_cmp_gen Clt
+ let mk_eq = mk_cmp_gen Ceq
+
+(*****************************************************)
+(* Compile strings to a lists of words [native ints] *)
+(*****************************************************)
+
+ let pat_of_string str =
+ let len = String.length str in
+ let n = len / Arch.size_addr + 1 in
+ let get_byte i =
+ if i < len then int_of_char str.[i]
+ else if i < n * Arch.size_addr - 1 then 0
+ else n * Arch.size_addr - 1 - len in
+ let mk_word ind =
+ let w = ref 0n in
+ let imin = ind * Arch.size_addr
+ and imax = (ind + 1) * Arch.size_addr - 1 in
+ if Arch.big_endian then
+ for i = imin to imax do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done
+ else
+ for i = imax downto imin do
+ w := Nativeint.logor (Nativeint.shift_left !w 8)
+ (Nativeint.of_int (get_byte i));
+ done;
+ !w in
+ let rec mk_words ind =
+ if ind >= n then []
+ else mk_word ind::mk_words (ind+1) in
+ mk_words 0
+
+(*****************************)
+(* Discriminating heuristics *)
+(*****************************)
+
+ module NativeSet = Set.Make(Nativeint)
+
+ let rec add_one sets ps = match sets,ps with
+ | [],[] -> []
+ | set::sets,p::ps ->
+ let sets = add_one sets ps in
+ NativeSet.add p set::sets
+ | _,_ -> assert false
+
+ let count_arities cases = match cases with
+ | [] -> assert false
+ | (ps,_)::_ ->
+ let sets =
+ List.fold_left
+ (fun sets (ps,_) -> add_one sets ps)
+ (List.map (fun _ -> NativeSet.empty) ps) cases in
+ List.map NativeSet.cardinal sets
+
+ let best_col =
+ let rec do_rec kbest best k = function
+ | [] -> kbest
+ | x::xs ->
+ if x < best then
+ do_rec k x (k+1) xs
+ else
+ do_rec kbest best (k+1) xs in
+ let smallest = do_rec (-1) max_int 0 in
+ fun cases ->
+ let ars = count_arities cases in
+ smallest ars
+
+ let swap_list =
+ let rec do_rec k xs = match xs with
+ | [] -> assert false
+ | x::xs ->
+ if k <= 0 then [],x,xs
+ else
+ let xs,mid,ys = do_rec (k-1) xs in
+ x::xs,mid,ys in
+ fun k xs ->
+ let xs,x,ys = do_rec k xs in
+ x::xs @ ys
+
+ let swap k idxs cases =
+ if k = 0 then idxs,cases
+ else
+ let idxs = swap_list k idxs
+ and cases =
+ List.map
+ (fun (ps,act) -> swap_list k ps,act)
+ cases in
+ if verbose then begin
+ pp_match stderr "SWAP" idxs cases
+ end ;
+ idxs,cases
+
+ let best_first idxs cases = match idxs with
+ | []|[_] -> idxs,cases (* optimisation: one column only *)
+ | _ ->
+ let k = best_col cases in
+ swap k idxs cases
+
+(***************)
+(* Compilation *)
+(***************)
+
+(* Group by cell *)
+
+ module NativeMap = Map.Make(Nativeint)
+
+ let do_find key env =
+ try NativeMap.find key env
+ with Not_found -> assert false
+
+ let bycell cases =
+ let rec do_rec env = function
+ | [] -> env
+ | ([],_)::_ -> assert false
+ | (p::ps,act)::cases ->
+ let old =
+ try NativeMap.find p env
+ with Not_found -> [] in
+ do_rec
+ (NativeMap.add p ((ps,act)::old) env)
+ cases in
+ let env = do_rec NativeMap.empty cases in
+ let r =
+ NativeMap.fold (fun key v k -> (key,v)::k) env [] in
+ List.rev r (* Now sorted *)
+
+(* Split into two halves *)
+
+ let rec do_split idx env = match env with
+ | [] -> assert false
+ | (midkey,_ as x)::rem ->
+ if idx <= 0 then [],midkey,env
+ else
+ let lt,midkey,ge = do_split (idx-1) rem in
+ x::lt,midkey,ge
+
+ let split_env len env = do_split (len/2) env
+
+(* Switch according to one cell *)
+
+(*
+ Top cell compile function:
+ - choose the matched cell and switch on it
+ - notice: patterns (and idx) all have the same length
+*)
+
+ let rec do_compile_pats str default idxs cases =
+ if verbose then begin
+ pp_match stderr "COMPILE" idxs cases
+ end ;
+ match idxs with
+ | [] ->
+ begin match cases with
+ | [] -> default
+ | (_,e)::_ -> e
+ end
+ | _::_ ->
+ let idxs,cases = best_first idxs cases in
+ begin match idxs with
+ | [] -> assert false
+ | idx::idxs ->
+ let env = bycell cases in
+ match_oncell str default idx idxs env
+ end
+
+(* Emit the switch, here as a comparison tree *)
+ and match_oncell str default idx idxs env =
+ let id = gen_cell_id () in
+ let rec comp_rec env =
+ let len = List.length env in
+ if len <= 3 then
+ List.fold_right
+ (fun (key,cases) ifnot ->
+ mk_eq id key
+ (do_compile_pats str default idxs cases)
+ ifnot)
+ env default
+ else
+ let lt,midkey,ge = split_env len env in
+ mk_lt id midkey (comp_rec lt) (comp_rec ge) in
+ mk_let_cell id str idx (comp_rec env)
+
+
+ let upto n =
+ let rec do_rec m =
+ if m >= n then []
+ else m::do_rec (m+1) in
+ do_rec 0
+
+(* entry point to cell switcher *)
+ let compile_pats str default len cases =
+ do_compile_pats str default (upto len) cases
+
+(* Group by size *)
+
+ module IntArg =
+ struct
+ type t = int
+ let compare (x:int) (y:int) = Pervasives.compare x y
+ end
+
+ module IntMap = Map.Make(IntArg)
+
+ let by_size cases =
+ let env =
+ List.fold_left
+ (fun env (pat,_ as case) ->
+ let len = List.length pat in
+ let old =
+ try IntMap.find len env
+ with Not_found -> [] in
+ IntMap.add len (case::old) env)
+ IntMap.empty cases in
+ let cases =
+ IntMap.fold
+ (fun len cases k -> (len,cases)::k)
+ env [] in
+ List.rev cases (* will sort *)
+
+(* Entry point *)
+
+ let top_compile str default cases =
+ let pats_by_size = by_size cases in
+ let rec comp_size_match = function
+ | [] -> []
+ | (len,pats)::rem ->
+ let act = compile_pats str default len pats in
+ (len,act)::comp_size_match rem in
+ let size_cases = comp_size_match pats_by_size in
+ let id = gen_size_id () in
+ let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in
+ mk_let_size id str switch
+
+
+(* Module entry point *)
+ let compile str default cases =
+ let default_exit = next_raise_count () in
+
+ let rec mk_pats cases pats = match cases with
+ | [] -> pats
+ | (str, ifso) :: rest ->
+ let pat = pat_of_string str in
+ mk_pats rest ((pat, ifso) :: pats) in
+ let pats = mk_pats cases [] in
+ let body = top_compile str (Cexit (default_exit,[])) pats in
+ Ccatch (default_exit, [], body, default)
+ end
Index: asmcomp/strmatch.mli
===================================================================
--- asmcomp/strmatch.mli (revision 0)
+++ asmcomp/strmatch.mli (revision 0)
@@ -0,0 +1,26 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 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. *)
+(* *)
+(***********************************************************************)
+
+(* Translation of string matching from closed lambda to C-- *)
+
+module type I = sig
+ val string_block_length : Cmm.expression -> Cmm.expression
+ val transl_switch :
+ Cmm.expression -> int -> int ->
+ (int * Cmm.expression) list -> Cmm.expression ->
+ Cmm.expression
+end
+
+module Make(I:I) : sig
+ val compile : Cmm.expression -> Cmm.expression ->
+ (string * Cmm.expression) list -> Cmm.expression
+end
|