diff options
| -rw-r--r-- | bytecomp/bytegen.ml | 141 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 70 | ||||
| -rw-r--r-- | bytecomp/instruct.ml | 1 | ||||
| -rw-r--r-- | bytecomp/instruct.mli | 1 | ||||
| -rw-r--r-- | bytecomp/lambda.ml | 40 | ||||
| -rw-r--r-- | bytecomp/lambda.mli | 12 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 778 | ||||
| -rw-r--r-- | bytecomp/printinstr.ml | 1 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 21 | ||||
| -rw-r--r-- | bytecomp/simplif.ml | 129 | ||||
| -rw-r--r-- | bytecomp/switch.ml | 750 | ||||
| -rw-r--r-- | bytecomp/switch.mli | 76 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 1 | ||||
| -rw-r--r-- | byterun/fix_code.c | 6 | ||||
| -rw-r--r-- | byterun/instrtrace.c | 2 | ||||
| -rw-r--r-- | byterun/instruct.h | 7 | ||||
| -rw-r--r-- | byterun/interp.c | 41 | ||||
| -rw-r--r-- | driver/optmain.ml | 3 | ||||
| -rw-r--r-- | tools/Makefile | 6 | ||||
| -rw-r--r-- | tools/cvt_emit.mll | 2 | ||||
| -rw-r--r-- | typing/parmatch.ml | 64 | ||||
| -rw-r--r-- | typing/typecore.ml | 64 | ||||
| -rw-r--r-- | typing/typecore.mli | 2 | ||||
| -rw-r--r-- | typing/typedtree.ml | 39 | ||||
| -rw-r--r-- | typing/typedtree.mli | 5 | ||||
| -rw-r--r-- | utils/clflags.ml | 3 | ||||
| -rw-r--r-- | utils/config.mlp | 2 |
27 files changed, 1946 insertions, 321 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index cb31467cb..5837d9719 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -43,7 +43,7 @@ let add_var id pos env = let rec add_vars idlist pos env = match idlist with [] -> env - | id :: rem -> add_vars rem (pos + 1) (add_var id pos env) + | id :: rem -> add_vars rem (pos + 1) (add_var id pos env) (**** Examination of the continuation ****) @@ -79,6 +79,12 @@ let make_branch cont = | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont +(* Avoid a branch to a label that follows immediately *) + +let branch_to label cont = match cont with +| Klabel label0::_ when label = label0 -> cont +| _ -> Kbranch label::cont + (* Discard all instructions up to the next label. This function is to be applied to the continuation before adding a non-terminating instruction (branch, raise, return) in front of it. *) @@ -106,6 +112,25 @@ let rec add_pop n cont = | Kraise :: _ -> cont | _ -> Kpop n :: cont +(* Translates the accumulator + n-1 positions, m places down on the stack *) +let rec squeeze_rec i n m cont = + if i <= 1 then + Kacc 0::add_pop (if m <= n then m+1 else m-n+1) (Kpush::cont) + else + Kacc (i-1):: + Kassign (m+i-1):: + squeeze_rec (i-1) n m cont + + +let add_squeeze n m cont = + if n=0 then add_pop m cont + else if n=1 then add_pop m (Kpush::cont) + else if m=0 then Kpush::cont + else + Kpush:: + squeeze_rec n n m cont + + (* Add the constant "unit" in front of a continuation *) let add_const_unit = function @@ -204,6 +229,30 @@ and sz_staticfail = ref 0 (* Same information as a stack for Lstaticraise *) let sz_static_raises = ref [] +let find_raise_label i = + try + List.assoc i !sz_static_raises + with + | Not_found -> + Misc.fatal_error + ("exit("^string_of_int i^") outside appropriated catch") + +(* Will the translation of l lead to a jump to label ? *) +let code_as_jump l sz = match l with +| Lstaticfail -> + if sz = !sz_staticfail then + match !lbl_staticfail with + | Some label -> Some label + | None -> Misc.fatal_error "exit outside appropriated catch" + else + None +| Lstaticraise (i,[]) -> + let label,size = find_raise_label i in + if sz = size then + Some label + else + None +| _ -> None (* Function bodies that remain to be compiled *) @@ -290,6 +339,7 @@ let comp_primitive p args = | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3) | Parraysetu _ -> Ksetvectitem | Pisint -> Kisint + | Pisout -> Kisout | Pbittest -> Kccall("bitvect_test", 2) | Pbintofint bi -> comp_bint_primitive bi "of_int" args | Pintofbint bi -> comp_bint_primitive bi "to_int" args @@ -321,6 +371,14 @@ let comp_primitive p args = | Pbigarrayset(n, _, _) -> Kccall("bigarray_set_" ^ string_of_int n, n + 2) | _ -> fatal_error "Bytegen.comp_primitive" +let is_immed n = immed_min <= n && n <= immed_max + +let explode_isout arg l h = + Lprim + (Psequor, + [Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ; + Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])]) + (* Compile an expression. The value of the expression is left in the accumulator. env = compilation environment @@ -478,10 +536,18 @@ let rec comp_expr env exp sz cont = end | Lprim(Praise, [arg]) -> comp_expr env arg sz (Kraise :: discard_dead_code cont) - | Lprim((Paddint | Psubint as prim), [arg; Lconst(Const_base(Const_int n))]) - when n >= immed_min & n <= immed_max -> - let ofs = if prim == Paddint then n else -n in - comp_expr env arg sz (Koffsetint ofs :: cont) + | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) + when is_immed n -> + comp_expr env arg sz (Koffsetint n :: cont) + | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))]) + when is_immed (-n) -> + comp_expr env arg sz (Koffsetint (-n) :: cont) + | Lprim (Poffsetint n, [arg]) + when not (is_immed n) -> + comp_expr env arg sz + (Kpush:: + Kconst (Const_base (Const_int n)):: + Kaddint::cont) | Lprim(Pmakearray kind, args) -> begin match kind with Pintarray | Paddrarray -> @@ -495,6 +561,11 @@ let rec comp_expr env exp sz cont = (Kmakeblock(List.length args, 0) :: Kccall("make_array", 1) :: cont) end +(* Integer first for enabling futher optimization (cf. emitcode.ml) *) + | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) -> + let p = Pintcomp (commute_comparison c) + and args = [k ; arg] in + comp_args env args sz (comp_primitive p args :: cont) | Lprim(p, args) -> comp_args env args sz (comp_primitive p args :: cont) | Lcatch(body, Lstaticfail) -> @@ -511,24 +582,24 @@ let rec comp_expr env exp sz cont = sz_staticfail := saved_sz_staticfail; cont3 | Lstaticfail -> comp_static_fail sz cont - | Lstaticcatch (body, i, handler) -> - let branch1, cont1 = make_branch cont in + | Lstaticcatch (body, (i, vars) , handler) -> + let branch1, cont1 = make_branch cont + and nvars = List.length vars in let lbl_handler, cont2 = - label_code (comp_expr env handler sz cont1) in - sz_static_raises := (i, (lbl_handler, sz)) :: !sz_static_raises ; + label_code + (comp_expr + (add_vars vars (sz+1) env) + handler (sz+nvars) (add_pop nvars cont1)) in + sz_static_raises := (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; let cont3 = comp_expr env body sz (branch1 :: cont2) in sz_static_raises := List.tl !sz_static_raises ; cont3 - | Lstaticraise i -> + | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label, size = - try - List.assoc i !sz_static_raises - with - | Not_found -> - Misc.fatal_error - ("exit("^string_of_int i^") outside appropriated catch") in - add_pop (sz-size) (Kbranch label :: cont) + let label,size = find_raise_label i in + comp_expr_list env args sz + (add_squeeze (List.length args) (sz+List.length args-size) + (branch_to label cont)) | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in @@ -656,7 +727,7 @@ and comp_static_fail sz cont = | None -> Misc.fatal_error "exit outside appropriated catch" | Some label -> - add_pop (sz - !sz_staticfail) (Kbranch label :: cont) + add_pop (sz - !sz_staticfail) (branch_to label cont) end (* Compile a list of arguments [e1; ...; eN] to a primitive operation. @@ -681,24 +752,21 @@ and comp_binary_test env cond ifso ifnot sz cont = let (lbl_end, cont1) = label_code cont in Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1 end else - if ifso = Lstaticfail && sz = !sz_staticfail - then + match code_as_jump ifso sz with + | Some label -> let cont = comp_expr env ifnot sz cont in - match !lbl_staticfail with - | None -> Misc.fatal_error "exit outside appropriated catch" - | Some label -> Kbranchif label :: cont - else - if ifnot = Lstaticfail && sz = !sz_staticfail - then - let cont = comp_expr env ifso sz cont in - match !lbl_staticfail with - | None -> Misc.fatal_error "exit outside appropriated catch" - | Some label -> Kbranchifnot label :: cont - else begin - let (branch_end, cont1) = make_branch cont in - let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in - Kbranchifnot lbl_not :: comp_expr env ifso sz (branch_end :: cont2) - end in + Kbranchif label :: cont + | _ -> + match code_as_jump ifnot sz with + | Some label -> + let cont = comp_expr env ifso sz cont in + Kbranchifnot label :: cont + | _ -> + let (branch_end, cont1) = make_branch cont in + let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in + Kbranchifnot lbl_not :: + comp_expr env ifso sz (branch_end :: cont2) in + comp_expr env cond sz cont_cond (**** Compilation of functions ****) @@ -737,6 +805,7 @@ let compile_implementation modulename expr = label_counter := 0; lbl_staticfail := None; sz_staticfail := 0; + sz_static_raises := [] ; compunit_name := modulename; let init_code = comp_expr empty_env expr 0 [] in if Stack.length functions_to_compile > 0 then begin diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 83e51dc2f..c09885c8d 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -73,9 +73,33 @@ let out_word b1 b2 b3 b4 = let out opcode = out_word opcode 0 0 0 + +exception AsInt + +let const_as_int = function + | Const_base(Const_int i) -> i + | Const_base(Const_char c) -> Char.code c + | Const_pointer i -> i + | _ -> raise AsInt + +let is_immed i = immed_min <= i && i <= immed_max +let is_immed_const k = + try + is_immed (const_as_int k) + with + | AsInt -> false + + let out_int n = out_word n (n asr 8) (n asr 16) (n asr 24) +let out_const c = + try + out_int (const_as_int c) + with + | AsInt -> Misc.fatal_error "Emitcode.const_as_int" + + (* Handling of local labels and backpatching *) type label_definition = @@ -157,6 +181,16 @@ let init () = (* Emission of one instruction *) +let emit_comp = function +| Ceq -> out opEQ | Cneq -> out opNEQ +| Clt -> out opLTINT | Cle -> out opLEINT +| Cgt -> out opGTINT | Cge -> out opGEINT + +and emit_branch_comp = function +| Ceq -> out opBEQ | Cneq -> out opBNEQ +| Clt -> out opBLTINT | Cle -> out opBLEINT +| Cgt -> out opBGTINT | Cge -> out opBGEINT + let emit_instr = function Klabel lbl -> define_label lbl | Kacc n -> @@ -193,7 +227,7 @@ let emit_instr = function | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q | Kconst sc -> begin match sc with - Const_base(Const_int i) when i >= immed_min & i <= immed_max -> + Const_base(Const_int i) when is_immed i -> if i >= 0 & i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) @@ -252,12 +286,11 @@ let emit_instr = function | Kandint -> out opANDINT | Korint -> out opORINT | Kxorint -> out opXORINT | Klslint -> out opLSLINT | Klsrint -> out opLSRINT | Kasrint -> out opASRINT - | Kintcomp Ceq -> out opEQ | Kintcomp Cneq -> out opNEQ - | Kintcomp Clt -> out opLTINT | Kintcomp Cle -> out opLEINT - | Kintcomp Cgt -> out opGTINT | Kintcomp Cge -> out opGEINT + | Kintcomp c -> emit_comp c | Koffsetint n -> out opOFFSETINT; out_int n | Koffsetref n -> out opOFFSETREF; out_int n | Kisint -> out opISINT + | Kisout -> out opULTINT | Kgetmethod -> out opGETMETHOD | Kevent ev -> record_event ev | Kstop -> out opSTOP @@ -267,6 +300,33 @@ let emit_instr = function let rec emit = function [] -> () (* Peephole optimizations *) +(* optimization of integer tests *) + | Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem + when is_immed_const k -> + emit_branch_comp c ; + out_const k ; + out_label lbl ; + emit rem + | Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem + when is_immed_const k -> + emit_branch_comp (negate_comparison c) ; + out_const k ; + out_label lbl ; + emit rem +(* same for range tests *) + | Kpush::Kconst k::Kisout::Kbranchif lbl::rem + when is_immed_const k -> + out opBULTINT ; + out_const k ; + out_label lbl ; + emit rem + | Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem + when is_immed_const k -> + out opBUGEINT ; + out_const k ; + out_label lbl ; + emit rem + | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c @@ -286,7 +346,7 @@ let rec emit = function out opPUSHGETGLOBAL; slot_for_getglobal id; emit c | Kpush :: Kconst sc :: c -> begin match sc with - Const_base(Const_int i) when i >= immed_min & i <= immed_max -> + Const_base(Const_int i) when is_immed i -> if i >= 0 & i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i) diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index ec645fa91..7aed995ad 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -95,6 +95,7 @@ type instruction = | Koffsetint of int | Koffsetref of int | Kisint + | Kisout | Kgetmethod | Kevent of debug_event | Kstop diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 561ce5339..6fb979f4d 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -114,6 +114,7 @@ type instruction = | Koffsetint of int | Koffsetref of int | Kisint + | Kisout | Kgetmethod | Kevent of debug_event | Kstop diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index e54ec3d0b..7153dbe72 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -57,6 +57,8 @@ type primitive = | Parraysets of array_kind (* Test if the argument is a block or an immediate integer *) | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout (* Bitvect operations *) | Pbittest (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) @@ -125,8 +127,8 @@ type lambda = | Lswitch of lambda * lambda_switch | Lstaticfail | Lcatch of lambda * lambda - | Lstaticraise of int - | Lstaticcatch of lambda * int * lambda + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda | Lifthenelse of lambda * lambda * lambda | Lsequence of lambda * lambda @@ -207,9 +209,11 @@ let free_variables l = | Lstaticfail -> () | Lcatch(e1, e2) -> freevars e1; freevars e2 - | Lstaticraise _ -> () - | Lstaticcatch(e1, _, e2) -> - freevars e1; freevars e2 + | Lstaticraise (_,args) -> + List.iter freevars args + | Lstaticcatch(e1, (_,vars), e2) -> + freevars e1; freevars e2 ; + List.iter (fun id -> fv := IdentSet.remove id !fv) vars | Ltrywith(e1, exn, e2) -> freevars e1; freevars e2; fv := IdentSet.remove exn !fv | Lifthenelse(e1, e2, e3) -> @@ -278,7 +282,7 @@ let subst_lambda s lam = sw_blocks = List.map subst_case sw.sw_blocks}) | Lstaticfail as l -> l | Lcatch(e1, e2) -> Lcatch(subst e1, subst e2) - | Lstaticraise i as l -> l + | Lstaticraise _ as l -> l | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3) @@ -292,3 +296,27 @@ let subst_lambda s lam = and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) in subst lam + + +(* To let-bind expressions to variables *) + +let bind str var exp body = + match exp with + Lvar var' when Ident.same var var' -> body + | _ -> Llet(str, var, exp, body) + +and commute_comparison = function +| Ceq -> Ceq| Cneq -> Cneq +| Clt -> Cgt | Cle -> Cge +| Cgt -> Clt | Cge -> Cle + +and negate_comparison = function +| Ceq -> Cneq| Cneq -> Ceq +| Clt -> Cge | Cle -> Cgt +| Cgt -> Cle | Cge -> Clt + +let raise_count = ref 0 + +let next_raise_count () = + incr raise_count ; (* Done before, since 0 is for partial matches *) + !raise_count diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index e4eac31b6..18cebad34 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -57,6 +57,8 @@ type primitive = | Parraysets of array_kind (* Test if the argument is a block or an immediate integer *) | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout (* Bitvect operations *) | Pbittest (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) @@ -134,8 +136,8 @@ type lambda = | Lswitch of lambda * lambda_switch | Lstaticfail | Lcatch of lambda * lambda - | Lstaticraise of int - | Lstaticcatch of lambda * int * lambda + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda | Lifthenelse of lambda * lambda * lambda | Lsequence of lambda * lambda @@ -177,3 +179,9 @@ val transl_path: Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda val subst_lambda: lambda Ident.tbl -> lambda -> lambda +val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda + +val commute_comparison : comparison -> comparison +val negate_comparison : comparison -> comparison + +val next_raise_count : unit -> int diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 0ca62055f..09af931b1 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -56,12 +56,6 @@ let rec name_pattern default = function end | _ -> Ident.create default -(* To let-bind expressions to variables *) - -let bind str var exp body = - match exp with - Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, var, exp, body) (* To remove aliases and bind named components *) @@ -69,46 +63,58 @@ let any_pat = { pat_desc = Tpat_any; pat_loc = Location.none; pat_type = Ctype.none; pat_env = Env.empty } -exception Var -;; +exception Var of pattern + let simplify_or p = let rec simpl_rec = function - | {pat_desc = Tpat_any} -> raise Var + | {pat_desc = Tpat_any|Tpat_var _} as p -> raise (Var p) + | {pat_desc = Tpat_alias (q,id)} as p -> + begin try + simpl_rec q + with + | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)}) + end | {pat_desc = Tpat_or (p1,p2)} -> simpl_rec p1 ; simpl_rec p2 | _ -> () in try simpl_rec p ; p with - | Var -> any_pat + | Var p -> p + let simplify_matching m = match m.args with | [] -> m -| (arg, mut) :: argl -> +| (arg, _) :: _ -> let rec simplify = function (pat :: patl, action as patl_action) :: rem -> begin match pat.pat_desc with | Tpat_var id -> - (any_pat :: patl, bind Alias id arg action) :: - simplify rem + (any_pat :: patl, bind Alias id arg action) :: simplify rem | Tpat_alias(p, id) -> simplify ((p :: patl, bind Alias id arg action) :: rem) | Tpat_record [] -> (any_pat :: patl, action) :: simplify rem | Tpat_or (_,_) -> - (simplify_or pat :: patl, action) :: - simplify rem + let pat_simple = simplify_or pat in + begin match pat_simple.pat_desc with + | Tpat_or (_,_) -> + (pat_simple :: patl, action) :: + simplify rem + | _ -> + simplify ((pat_simple::patl,action) :: rem) + end | _ -> patl_action :: simplify rem end | cases -> cases in - { args = m.args; cases = simplify m.cases } + {m with cases = simplify m.cases } let rec what_is_or = function - | {pat_desc = Tpat_or (p1,_)} -> what_is_or p1 - | {pat_desc = (Tpat_alias (_,_)|Tpat_var _|Tpat_any)} -> - Misc.fatal_error "Mathing.what_is_or" + | {pat_desc = Tpat_or (p,_)} -> what_is_or p + | {pat_desc = (Tpat_alias (p,_))} -> what_is_or p + | {pat_desc=(Tpat_var _|Tpat_any)} -> fatal_error "Matching.what_is_or" | p -> p let rec upper_left_pattern pm = match pm.cases with @@ -118,27 +124,60 @@ let rec upper_left_pattern pm = match pm.cases with (* Optimize breaks *) -let raise_count = ref 0 - -let next_raise_count () = - incr raise_count ; (* Done before, since 0 is for partial matches *) - !raise_count let rec group_or group = function | {pat_desc = Tpat_or (p1, p2)} -> group_or group p1 && group_or group p2 + | {pat_desc = Tpat_alias (p,_)} -> group_or group p | p -> group p -let rec explode_or_pat patl action rem = function + +let rec extract_vars r p = match p.pat_desc with +| Tpat_var id -> IdentSet.add id r +| Tpat_alias (p, id) -> + extract_vars (IdentSet.add id r) p +| Tpat_tuple pats -> + List.fold_left extract_vars r pats +| Tpat_record lpats -> + List.fold_left + (fun r (_,p) -> extract_vars r p) + r lpats +| Tpat_construct (_,pats) -> + List.fold_left extract_vars r pats +| Tpat_array pats -> + List.fold_left extract_vars r pats +| Tpat_variant (_,Some p, _) -> extract_vars r p +| Tpat_or (p,_) -> extract_vars r p +| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r + +exception Cannot_flatten + +let mk_alpha_env arg aliases ids = + List.map + (fun id -> id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else + Ident.create (Ident.name id)) + ids + + +let rec explode_or_pat arg patl mk_action rem vars aliases = function | {pat_desc = Tpat_or (p1,p2)} -> explode_or_pat - patl action - (explode_or_pat patl action rem p1) - p2 - | p -> (p::patl,action)::rem + arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p1) + vars aliases p2 + | {pat_desc = Tpat_alias (p,id)} -> + explode_or_pat arg patl mk_action rem vars (id::aliases) p + | p -> + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p::patl,mk_action (List.map snd env))::rem + let more group ({cases=cl ; args = al} as m) = match al with -| [] -> assert false -| _ -> +| (Lvar arg,_)::_ -> let rec more_rec yes no = function | (pat::_ as patl, action) as full :: rem -> if @@ -159,25 +198,47 @@ let more group ({cases=cl ; args = al} as m) = match al with | ({pat_desc=Tpat_or (_,_)} as p::patl, action)::rem when group_or group p && not (List.exists (fun q -> Parmatch.compat q p) prev) -> + let vars = + IdentSet.elements + (IdentSet.inter + (extract_vars IdentSet.empty p) + (free_variables action)) in begin match action with - | Lstaticraise _ | Lstaticfail - when List.for_all + | Lstaticraise (_,[]) | Lstaticfail + when + vars = [] && + List.for_all (function {pat_desc=Tpat_any} -> true | _ -> false) - patl -> - let new_yes,new_to_catch,new_others = - add_or (p::prev) rem in - explode_or_pat patl action new_yes p, - new_to_catch, - new_others + patl -> + let new_yes,new_to_catch,new_others = + add_or (p::prev) rem in + explode_or_pat + (Some arg) patl (fun _ -> action) new_yes vars [] p, + new_to_catch, + new_others | _ -> let raise_num = next_raise_count () in - let new_patl = Parmatch.omega_list patl - and new_action = Lstaticraise raise_num in + let new_patl = Parmatch.omega_list patl in + +(* Compilation assigne, pas bo + let mk_new_action vs = + List.fold_right2 + (fun dest src lambda -> + Lsequence (Lassign (dest, Lvar src),lambda)) + vars vs + (Lstaticraise (raise_num,[])) in +*) + let mk_new_action vs = + Lstaticraise + (raise_num, List.map (fun v -> Lvar v) vs) in + let new_yes,new_to_catch,new_others = add_or (p::prev) rem in - explode_or_pat new_patl new_action new_yes p, - ((raise_num, {cases=[patl, action] ; args = List.tl al}):: + explode_or_pat + (Some arg) new_patl mk_new_action new_yes vars [] p, + ((raise_num, vars , + {cases=[patl, action] ; args = List.tl al}):: new_to_catch), new_others end @@ -187,7 +248,7 @@ let more group ({cases=cl ; args = al} as m) = match al with {cases=rem ; args = al} in let yes,to_catch,others = add_or [] no in List.rev yes, to_catch, others - +| _ -> assert false (* General divide functions *) let divide group make get_key get_args ({args=al} as pm) = @@ -399,21 +460,6 @@ let divide_record all_labels pm = (get_args_record (Array.length all_labels)) pm -(* Matching against an or pattern. *) - -let rec flatten_orpat_match pat = - match pat.pat_desc with - Tpat_or(p1, p2) -> flatten_orpat_match p1 @ flatten_orpat_match p2 - | _ -> [[pat], lambda_unit] - -let divide_orpat = function - {cases = (orpat :: patl, act) :: casel; args = arg1 :: argl as args} -> - ({cases = flatten_orpat_match orpat; args = [arg1]}, - {cases = [patl, act]; args = argl}, - {cases = casel; args = args}) - | _ -> - fatal_error "Matching.divide_orpat" - (* Matching against an array pattern *) let group_array = function | {pat_desc=Tpat_array _} -> true @@ -445,26 +491,55 @@ let divide_array kind pm = (* To combine sub-matchings together *) -let rec raw_action = function - | Llet(Alias,_,_, body) -> raw_action body - | l -> l +exception Not_simple + +let rec raw_rec env = function + | Llet(Alias,x,ex, body) -> raw_rec ((x,ex)::env) body + | Lstaticfail as l -> l + | Lvar id as l -> + begin try List.assoc id env with + | Not_found -> l + end + | Lprim (Pfield i,args) -> + Lprim (Pfield i, List.map (raw_rec env) args) + | Lconst _ as l -> l + | Lstaticraise (i,args) -> + Lstaticraise (i, List.map (raw_rec env) args) + | _ -> raise Not_simple + +let raw_action l = try raw_rec [] l with Not_simple -> l let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> - let raw_act0 = raw_action act0 in - match raw_act0 with - | Lstaticfail | Lstaticraise _ -> - let rec s_rec = function - | [] -> Some raw_act0 - | (_,act)::rem -> - if raw_act0 = raw_action act then - s_rec rem - else - None in - s_rec rem - | _ -> None + try + let raw_act0 = raw_rec [] act0 in + let rec s_rec = function + | [] -> Some act0 + | (_,act)::rem -> + if raw_act0 = raw_rec [] act then + s_rec rem + else + None in + s_rec rem + with + | Not_simple -> None + +let equal_action act1 act2 = + try + let raw1 = raw_rec [] act1 + and raw2 = raw_rec [] act2 in + raw1 = raw2 + with + | Not_simple -> false + + +let sort_lambda_list l = + List.sort + (fun (x,_) (y,_) -> x - y) + l + let add_catch (lambda1,total1) (c_catch,(lambda_default,total_default)) = let rec do_rec r total_r = function @@ -475,19 +550,31 @@ let add_catch (lambda1,total1) (c_catch,(lambda_default,total_default)) = | Lstaticfail -> r,total_r | _ -> Lcatch (r,lambda_default),total_default end - | (i,(handler_i,total_i))::rem -> + | (i,vars,(handler_i,total_i))::rem -> +(* Compilation assign, pas bo do_rec - (match raw_action r with - | Lstaticraise j when i=j -> handler_i - | _ -> Lstaticcatch(r,i,handler_i)) + (List.fold_right + (fun v lambda -> + bind StrictOpt v (Lconst const_unit) lambda) + vars (Lstaticcatch (r,(i,[]), handler_i))) (total_i && total_r) rem in - - do_rec lambda1 total1 c_catch +*) + match raw_action r with + | Lstaticraise (j,args) -> + if j <> i then + do_rec r total_r rem + else if args=[] then + do_rec handler_i total_i rem + else + do_rec + (Lstaticcatch (r,(i,vars), handler_i)) + (total_i && total_r) rem + | _ -> + do_rec + (Lstaticcatch (r,(i,vars), handler_i)) + (total_i && total_r) rem in -let combine_var (lambda1, total1) (lambda2, total2) = - if total1 then (lambda1, true) - else if lambda2 = Lstaticfail then (lambda1, total1) - else (Lcatch(lambda1, lambda2), total2) + do_rec lambda1 total1 c_catch let combine_line (lambda1, total1) c_catch = add_catch (lambda1, total1) c_catch @@ -506,7 +593,7 @@ let make_test_sequence nofail check tst lt_tst arg const_lambda_list = List.fold_right (fun (c, act) rem -> if rem = Lstaticfail && (not check || nofail) then act else - Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem)) + Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), rem, act)) const_lambda_list Lstaticfail and split_sequence const_lambda_list = @@ -518,6 +605,19 @@ let make_test_sequence nofail check tst lt_tst arg const_lambda_list = (Sort.list (fun (c1,_) (c2,_) -> c1 < c2) const_lambda_list) +let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) + +let make_switch_offset nofail check arg min_key max_key int_lambda_list = + let numcases = max_key - min_key + 1 in + let cases = + List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in + let offsetarg = make_offset (-min_key) arg in + Lswitch(offsetarg, + {sw_numconsts = numcases; sw_consts = cases; + sw_numblocks = 0; sw_blocks = []; sw_checked = check ; + sw_nofail = nofail}) + + let make_switch_or_test_sequence nofail check arg const_lambda_list int_lambda_list = if const_lambda_list = [] then @@ -531,30 +631,22 @@ let make_switch_or_test_sequence overflow in the following comparison *) if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then (* Sparse matching -- use a sequence of tests *) - make_test_sequence nofail check (Pintcomp Ceq) (Pintcomp Clt) + make_test_sequence nofail check (Pintcomp Cneq) (Pintcomp Clt) arg const_lambda_list else begin (* Dense matching -- use a jump table (2 bytecode instructions + 1 word per entry in the table) *) - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = - if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; sw_checked = check ; - sw_nofail = nofail}) + make_switch_offset nofail check arg min_key max_key int_lambda_list end let make_test_sequence_variant_constant check arg int_lambda_list = - make_test_sequence false check (Pintcomp Ceq) (Pintcomp Clt) arg + make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) arg (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list) let make_test_sequence_variant_constr check arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), - make_test_sequence false check (Pintcomp Ceq) (Pintcomp Clt) (Lvar v) + make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) (Lvar v) (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)) let make_bitvect_check arg int_lambda_list lambda = @@ -566,55 +658,292 @@ let make_bitvect_check arg int_lambda_list lambda = Lifthenelse(Lprim(Pbittest, [Lconst(Const_base(Const_string bv)); arg]), lambda, Lstaticfail) -let prim_string_equal = - Pccall{prim_name = "string_equal"; +let prim_string_notequal = + Pccall{prim_name = "string_notequal"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false} +let is_default act = match raw_action act with +| Lstaticfail -> true +| _ -> 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) + else + k + +let as_int_list cases acts = + let min_key,_,_ = cases.(0) + and _,max_key,_ = cases.(Array.length cases-1) in + let offset = max_key-min_key in + let rec do_rec i k = + if i >= 0 then + let low, high, act = cases.(i) in + if is_default acts.(act) then + do_rec (i-1) k + else + do_rec (i-1) (explode_inter min_key low high acts.(act) k) + else + k in + min_key, max_key,do_rec (Array.length cases-1) [] + + +let make_switch_switcher arg cases acts = + let min_key, max_key, clauses = as_int_list cases acts in + make_switch_offset false false arg 0 (max_key-min_key) clauses + +module SArg = struct + type primitive = Lambda.primitive + + let eqint = Pintcomp Ceq + let neint = Pintcomp Cneq + let leint = Pintcomp Cle + let ltint = Pintcomp Clt + let geint = Pintcomp Cge + let gtint = Pintcomp Cgt + + type act = Lambda.lambda + + let default = Lstaticfail +(* let equal_action = equal_action *) + let make_prim p args = Lprim (p,args) + let make_offset arg n = match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = + let newvar,newarg = match arg with + | Lvar v -> v,arg + | _ -> + let newvar = Ident.create "switcher" in + newvar,Lvar newvar in + bind Alias newvar arg (body newarg) + + let make_isout h arg = Lprim (Pisout, [h ; arg]) + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + let make_switch = make_switch_switcher +end + +module Switcher = Switch.Make(SArg) +open Switch + +let lambda_of_int i = Lconst (Const_base (Const_int i)) + +(* Store for actions in object style *) +exception Found of int +type t_store = + {get : unit -> lambda array ; store : lambda -> int} + +let mk_store () = + let r_acts = ref [] in + let store act = + let rec store_rec i = function + | [] -> i,[act] + | act0::rem -> + if equal_action act act0 then raise (Found i) + else + let i,rem = store_rec (i+1) rem in + i,act0::rem in + try + let i,acts = store_rec 0 !r_acts in + r_acts := acts ; + i + with + | Found i -> i + + and get () = Array.of_list !r_acts in + {store=store ; get=get} + + +let as_interval_canfail low high l = + let store = mk_store () in + let rec nofail_rec cur_low cur_high cur_act = function + | [] -> begin match high with + | TooMuch -> [cur_low,cur_high,cur_act] + | Int h -> + if cur_high = h then + [cur_low,cur_high,cur_act] + else + [(cur_low,cur_high,cur_act) ; (cur_high+1,h, 0)] + end + | ((i,act_i)::rem) as all -> + let act_index = store.store act_i in + if cur_high+1= i then + if act_index=cur_act then + nofail_rec cur_low i cur_act rem + else if is_default act_i then + (cur_low,i-1, cur_act)::fail_rec i i rem + else + (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else + (cur_low, cur_high, cur_act):: + fail_rec ((cur_high+1)) (cur_high+1) all + + and fail_rec cur_low cur_high = function + | [] -> [(cur_low, cur_high, 0)] + | (i,act_i)::rem -> + if is_default act_i then fail_rec cur_low i rem + else + (cur_low,i-1,0):: + nofail_rec i i (store.store act_i) rem in + + let rec init_rec = function + | [] -> [] + | (i,act_i)::rem as all -> + if is_default act_i then + match low with + | TooMuch -> init_rec rem + | Int low -> fail_rec low i rem + else begin match low with + | TooMuch -> nofail_rec i i (store.store act_i) rem + | Int low -> + if low < i then + (low,i-1,0)::nofail_rec i i (store.store act_i) rem + else + nofail_rec i i (store.store act_i) rem + end in + + ignore (store.store Lstaticfail) ; (* Lstaticfail has action index 0 *) + let r = init_rec (sort_lambda_list l) in + low, high, Array.of_list r, store.get () + +let as_interval_nofail l = + let store = mk_store () + and high = ref (-1) + and low = ref (-1) in + + let rec i_rec cur_low cur_high cur_act = function + | [] -> + high := cur_high ; + [cur_low, cur_high, cur_act] + | (i,act)::rem -> + let act_index = store.store act in + if act_index = cur_act then + i_rec cur_low i cur_act rem + else + (cur_low, cur_high, cur_act):: + i_rec i i act_index rem in + let inters = match sort_lambda_list l with + | (i,act)::rem -> + low := i ; + let act_index = store.store act in + i_rec i i act_index rem + | _ -> assert false in + Int !low, Int !high, Array.of_list inters, store.get () + +let as_interval nofail low high l = + if nofail then + as_interval_nofail l + else + as_interval_canfail low high l + +let call_switcher konst nofail arg low high int_lambda_list = + let real_low, real_high, cases, actions = + as_interval nofail low high int_lambda_list in + Switcher.zyva + konst arg real_low real_high cases actions + + let combine_constant arg cst partial (const_lambda_list, total1) c_catch = - let nofail = partial=Total - and one_action = same_actions const_lambda_list in - match nofail,one_action with - | true, Some act -> act,total1 - | _, _ -> - let lambda1 = - match cst with - Const_int _ -> - let int_lambda_list = - List.map (function Const_int n, l -> n,l | _ -> assert false) - const_lambda_list in - make_switch_or_test_sequence - nofail true arg const_lambda_list int_lambda_list + let nofail = partial=Total in + let lambda1 = + match cst with + | Const_int _ -> + let int_lambda_list = + List.map (function Const_int n, l -> n,l | _ -> assert false) + const_lambda_list in + call_switcher + lambda_of_int nofail arg + Switch.TooMuch Switch.TooMuch + int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) - | _ -> assert false) - const_lambda_list in - begin match one_action with - | Some lambda when List.length int_lambda_list > 8 -> - make_bitvect_check arg int_lambda_list lambda - | _ -> - make_switch_or_test_sequence nofail true arg - const_lambda_list int_lambda_list - end + | _ -> assert false) + const_lambda_list in + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + nofail arg + (Switch.Int 0) (Switch.Int 255) + int_lambda_list +(* + begin match one_action with + | Some lambda when List.length int_lambda_list > 8 -> + make_bitvect_check arg int_lambda_list lambda + | _ -> + make_switch_or_test_sequence nofail true arg + const_lambda_list int_lambda_list + end + *) | Const_string _ -> make_test_sequence - nofail true prim_string_equal Praise arg const_lambda_list + nofail true prim_string_notequal Praise arg const_lambda_list | Const_float _ -> make_test_sequence nofail - true (Pfloatcomp Ceq) (Pfloatcomp Clt) + true (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list in add_catch (lambda1, nofail) c_catch -let rec split_cases = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_cases rem in - match cstr with - Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | _ -> assert false + +let split_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | _ -> assert false in + let const, nonconst = split_rec tag_lambda_list in + sort_lambda_list const, + sort_lambda_list nonconst + + +let prerr_c l = + List.iter (fun (i,_) -> Printf.fprintf stderr "%d " i) l +let prerr_i l = + List.iter (fun i -> Printf.fprintf stderr "%d " i) l + +let rec interval min max k = + if min >= max then k + else min::interval (min+1) max k + +let find_missing n l = + let rec find_rec = function + | [] -> [] + | [n1,_] -> interval (n1+1) n [] + | (n1,_)::((n2,_)::_ as rem) -> + interval (n1+1) n2 (find_rec rem) in + + let r = match l with + | [] -> interval 0 n [] + | (n1,_)::_ -> + interval 0 n1 (find_rec l) in +(* + Printf.fprintf stderr "Find missing %d " n; + prerr_c l ; + prerr_string " -> " ; + prerr_i r ; + prerr_endline "" ; +*) + r + + +let test_fail arg cstr const nonconst = + let miss_const = + find_missing cstr.cstr_consts const + and miss_nonconst = + find_missing cstr.cstr_nonconsts nonconst + in + match const, miss_const, nonconst, miss_nonconst with + | _,[n],_,[] -> + Some (Lprim (Pintcomp Ceq, [arg ; Lconst (Const_base (Const_int n))])) + | [n,_],_,[],_ -> + Some (Lprim (Pintcomp Cneq, [arg ; Lconst (Const_base (Const_int n))])) + | _,[],[],_::_ -> Some (Lprim (Pnot, [Lprim (Pisint, [arg])])) + | [],_::_,_,[] -> Some (Lprim (Pisint, [arg])) + | _, _, _, _ -> None let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch = let nofail = partial=Total in @@ -640,29 +969,21 @@ let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch = in add_catch (lambda1, nofail) c_catch end else begin (* Regular concrete type *) - let sig_complete = - List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts + let ncases = List.length tag_lambda_list + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + let sig_complete = ncases = nconstrs and one_action = same_actions tag_lambda_list in let total_loc = sig_complete || nofail in + let (consts, nonconsts) = split_cases tag_lambda_list in let lambda1 = - match total_loc, one_action with - | true, Some act -> act - | _,_ -> - let (consts, nonconsts) = split_cases tag_lambda_list in + match total_loc, one_action, test_fail arg cstr consts nonconsts with + | true, Some act, _ -> act + | false, Some act, Some (Lprim (Pnot,[test])) -> + Lifthenelse (test, act, Lstaticfail) + | false, Some act, Some test -> + Lifthenelse (test, Lstaticfail, act) + | _,_, _ -> match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with - (1, 0, [0, act], []) -> act - | (0, 1, [], [0, act]) -> act - | (2, 0, [(n1, act1) ; (n2, act2)], []) -> - let act_true, act_false = - if n1=0 then act2, act1 else act1, act2 in - Lifthenelse (arg, act_true, act_false) - | (2, 0, [(n, act) ], []) -> - if total_loc then - act - else - let act_true, act_false = - if n=0 then Lstaticfail , act else act, Lstaticfail in - Lifthenelse (arg, act_true, act_false) | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (1, 1, [0, act1], []) -> @@ -675,6 +996,23 @@ let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch = act2 else Lifthenelse(arg, act2, Lstaticfail) + | n,m,l,[] -> + if total_loc || m=0 then + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + nofail arg + (Switch.Int 0) (Switch.Int (n-1)) + l + else + Lifthenelse + (Lprim (Pisint,[arg]), + call_switcher + (fun i -> Lconst (Const_base (Const_int i))) + nofail arg + (Switch.Int 0) (Switch.Int (n-1)) + l, + Lstaticfail) + | (_, _, _, _) -> Lswitch(arg, {sw_numconsts = cstr.cstr_consts; sw_consts = consts; @@ -732,20 +1070,15 @@ let combine_variant row arg partial (tag_lambda_list, total1) let combine_array arg kind _ (len_lambda_list, total1) c_catch = let lambda1 = - match len_lambda_list with - [] -> Lstaticfail (* does not happen? *) - | [n, act] -> - Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Parraylength kind, [arg]); - Lconst(Const_base(Const_int n))]), - act, Lstaticfail) - | _ -> - let max_len = - List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in - Lswitch(Lprim(Parraylength kind, [arg]), - {sw_numblocks = 0; sw_blocks = []; sw_checked = true; - sw_numconsts = max_len + 1; sw_consts = len_lambda_list; - sw_nofail=false}) in + let newvar = Ident.create "len" in + let switch = + call_switcher + lambda_of_int + false (Lvar newvar) + (Switch.Int 0) Switch.TooMuch + len_lambda_list in + bind + Alias newvar (Lprim(Parraylength kind, [arg])) switch in add_catch (lambda1,false) c_catch (* Insertion of debugging events *) @@ -791,9 +1124,9 @@ let compile_catch compile_fun repr partial to_catch others = if others.cases = [] then partial else Partial in let rec c_rec = function | [] -> [],compile_fun repr partial others - | (i,m)::rem -> + | (i,vars,m)::rem -> let c_catch, c_others = c_rec rem in - (i, compile_fun repr partial_catch m)::c_catch, + (i, vars, compile_fun repr partial_catch m)::c_catch, c_others in c_rec to_catch @@ -805,6 +1138,56 @@ let compile_test compile_match repr partial divide combine pm = (compile_list (compile_match repr partial') this_match) (compile_catch compile_match repr partial to_catch others) +(* Attempt to avoid some useless bindinds by lowering them *) + +(* Approximation of v present in lam *) +let rec approx_present v = function + | Lconst _ -> false + | Lstaticfail -> false + | Lstaticraise (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Lprim (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _, l1, l2) -> + approx_present v l1 || approx_present v l2 + | Lvar vv -> Ident.same v vv + | _ -> true + +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + +let rec lower_bind v arg lam = match lam with +| Lifthenelse (cond, ifso, ifnot) -> + let pcond = approx_present v cond + and pso = approx_present v ifso + and pnot = approx_present v ifnot in + begin match pcond, pso, pnot with + | false, false, false -> lam + | false, true, false -> + Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> + Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _,_,_ -> 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 (Alias, vv, lv, l) -> + if approx_present v lv then + bind Alias v arg lam + else + Llet (Alias, vv, lv, lower_bind v arg l) +| _ -> + bind Alias v arg lam + +let bind_check str v arg lam = match str,arg with +| _, Lvar _ ->bind str v arg lam +| Alias,_ -> lower_bind v arg lam +| _,_ -> bind str v arg lam let rec compile_match repr partial m = match m with { cases = [] } -> @@ -820,8 +1203,12 @@ let rec compile_match repr partial m = match m with end else (event_branch repr action, true) | { args = (arg, str)::argl ; cases = (pat::_, _)::_ } -> - let v = name_pattern "match" m.cases in - let newarg = Lvar v in + let v,newarg = + match arg with + | Lvar v -> v,arg + | _ -> + let v = name_pattern "match" m.cases in + v,Lvar v in let pm = simplify_matching { cases = m.cases; args = (newarg, Alias) :: argl } in @@ -830,7 +1217,7 @@ let rec compile_match repr partial m = match m with repr partial newarg (upper_left_pattern pm) pm in - bind str v arg lam, total + bind_check str v arg lam, total | _ -> assert false and do_compile_matching repr partial newarg pat pm = match pat.pat_desc with @@ -862,7 +1249,6 @@ and do_compile_matching repr partial newarg pat pm = match pat.pat_desc with (combine_variant row newarg) pm | _ -> - Location.prerr_warning pat.pat_loc (Warnings.Other "ICI") ; fatal_error "Matching.do_compile_matching" and compile_no_test divide repr partial pm = @@ -876,11 +1262,9 @@ and compile_no_test divide repr partial pm = (* The entry points *) -(* - Use the match-compiler infered exhaustiveness information, -*) +(* had toplevel handler when appropriate *) -let check_total loc partial total lambda handler_fun = +let check_total loc total lambda handler_fun = if total then lambda else @@ -891,7 +1275,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial = { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; args = [arg, Strict] } in let (lambda, total) = compile_match repr partial pm in - check_total loc partial total lambda handler_fun + check_total loc total lambda handler_fun let partial_function loc () = Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), @@ -914,25 +1298,44 @@ let for_let loc param pat body = (* Handling of tupled functions and matches *) -exception Cannot_flatten let flatten_pattern size p = match p.pat_desc with Tpat_tuple args -> args - | Tpat_any -> replicate_list any_pat size + | Tpat_any -> replicate_list any_pat size | _ -> raise Cannot_flatten let flatten_cases size cases = - List.map (function (pat :: _, act) -> (flatten_pattern size pat, act) - | _ -> assert false) - cases + let rec flat_rec = function + | [] -> [],[] + | ({pat_desc=Tpat_or (_,_)} as pat :: _, act) :: rem -> + let vars = + IdentSet.elements + (IdentSet.inter + (extract_vars IdentSet.empty pat) + (free_variables act)) in + let raise_num = next_raise_count () in + let mk_new_action vs = + Lstaticraise + (raise_num, List.map (fun v -> Lvar v) vs) in + let new_cases,to_catch = + flat_rec + (explode_or_pat None [] mk_new_action rem vars [] pat) in + new_cases, + (raise_num,vars,(act,true))::to_catch + | (pat :: _, act)::rem -> + let new_cases, to_catch = flat_rec rem in + (flatten_pattern size pat, act)::new_cases, + to_catch + | _ -> assert false in + flat_rec cases let for_tupled_function loc paraml pats_act_list partial = let pm = { cases = pats_act_list; args = List.map (fun id -> (Lvar id, Strict)) paraml } in let (lambda, total) = compile_match None partial pm in - check_total loc partial total lambda (partial_function loc) + check_total loc total lambda (partial_function loc) let for_multiple_match loc paraml pat_act_list partial = let pm1 = @@ -942,13 +1345,18 @@ let for_multiple_match loc paraml pat_act_list partial = simplify_matching pm1 in try let idl = List.map (fun _ -> Ident.create "match") paraml in + let new_cases, to_catch = flatten_cases (List.length paraml) pm2.cases in let pm3 = - { cases = flatten_cases (List.length paraml) pm2.cases; + { cases = new_cases ; args = List.map (fun id -> (Lvar id, Alias)) idl } in - let (lambda, total) = compile_match None partial pm3 in - let lambda2 = check_total loc partial total lambda (partial_function loc) in + let (lambda, total) = + add_catch + (compile_match None partial pm3) + (to_catch,(Lstaticfail,true)) in + let lambda2 = + check_total loc total lambda (partial_function loc) in List.fold_right2 (bind Strict) idl paraml lambda2 with Cannot_flatten -> let (lambda, total) = compile_match None partial pm2 in - check_total loc partial total lambda (partial_function loc) + check_total loc total lambda (partial_function loc) diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 21e13c80c..d175cf185 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -94,6 +94,7 @@ let instruction ppf = function | Koffsetint n -> fprintf ppf "\toffsetint %i" n | Koffsetref n -> fprintf ppf "\toffsetref %i" n | Kisint -> fprintf ppf "\tisint" + | Kisout -> fprintf ppf "\tisout" | Kgetmethod -> fprintf ppf "\tgetmethod" | Kstop -> fprintf ppf "\tstop" | Kevent ev -> fprintf ppf "\tevent %i" ev.ev_char diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 6c62e3778..dd0098b1d 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -144,6 +144,7 @@ let primitive ppf = function | Parrayrefs _ -> fprintf ppf "array.get" | Parraysets _ -> fprintf ppf "array.set" | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" | Pbittest -> fprintf ppf "testbit" | Pbintofint bi -> print_boxed_integer "of_int" ppf bi | Pintofbint bi -> print_boxed_integer "to_int" ppf bi @@ -236,13 +237,23 @@ let rec lam ppf = function lam larg switch sw | Lstaticfail -> fprintf ppf "exit" - | Lstaticraise i -> - fprintf ppf "exit(%d)" i + | Lstaticraise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; | Lcatch(lbody, lhandler) -> fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler - | Lstaticcatch(lbody, i, lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with(%d)@ %a)@]" - lam lbody i lam lhandler + | Lstaticcatch(lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Ident.print x) + vars) + vars + lam lhandler | Ltrywith(lbody, param, lhandler) -> fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print param lam lhandler diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index 6dc12c245..6a27cf7f2 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -83,23 +83,43 @@ let rec eliminate_ref id = function | Lifused(v, e) -> Lifused(v, eliminate_ref id e) + (* Simplification of lets *) let simplify_lambda lam = + (* First pass: count the occurrences of all identifiers *) let occ = Hashtbl.create 83 in let count_var v = try !(Hashtbl.find occ v) with Not_found -> - 0 in + 0 + and incr_var v = + try + incr(Hashtbl.find occ v) + with Not_found -> + Hashtbl.add occ v (ref 1) in + + (* Also count occurrences of (exit n) statements with no arguments *) + let exits = Hashtbl.create 17 in + let count_exit i = + try + !(Hashtbl.find exits i) + with + | Not_found -> 0 + and incr_exit i = + try + incr(Hashtbl.find exits i) + with + | Not_found -> Hashtbl.add exits i (ref 1) in + (* And occurences of Lstaticfail, in every staticcatch scope *) + let count_fail = ref (ref 0) in + let at_catch = ref [] in + + let rec count = function - Lvar v -> - begin try - incr(Hashtbl.find occ v) - with Not_found -> - Hashtbl.add occ v (ref 1) - end + | Lvar v -> incr_var v | Lconst cst -> () | Lapply(l1, ll) -> count l1; List.iter count ll | Lfunction(kind, params, l) -> count l @@ -122,31 +142,60 @@ let simplify_lambda lam = count body | Lprim(p, ll) -> List.iter count ll | Lswitch(l, sw) -> + (* switch may generate Lstaticfail *) + if + (not sw.sw_nofail) && + (sw.sw_numconsts > List.length sw.sw_consts || + sw.sw_numblocks > List.length sw.sw_blocks) + then + !count_fail := !(!count_fail) + 2 ; count l; List.iter (fun (n, l) -> count l) sw.sw_consts; - List.iter (fun (n, l) -> count l) sw.sw_blocks - | Lstaticfail -> () - | Lstaticraise _ -> () - | Lcatch(l1, l2) -> count l1; count l2 - | Lstaticcatch(l1, _, l2) -> count l1; count l2 + List.iter (fun (n, l) -> count l) sw.sw_blocks ; + | Lstaticfail -> incr !count_fail + | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls + | Lcatch(l1, l2) as l -> + let save_count_fail = !count_fail in + count_fail := ref 0 ; + count l1; + let this_count = !(!count_fail) in + at_catch := (l,!(!count_fail)) :: !at_catch ; + count_fail := save_count_fail ; + (* If l1 does not contain staticfail, + l2 will be removed, so don't count its variables *) + if this_count > 0 then + count l2 + | Lstaticcatch(l1, (i,_), l2) -> + count l1; + (* If l1 does not contain (exit i), + l2 will be removed, so don't count its variables *) + if count_exit i > 0 then + count l2 | Ltrywith(l1, v, l2) -> count l1; count l2 | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(v, l1, l2, dir, l3) -> count l1; count l2; count l3 + | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 | Lassign(v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count l | Lsend(m, o, ll) -> List.iter count (m::o::ll) - | Levent(l, ev) -> count l + | Levent(l, _) -> count l | Lifused(v, l) -> if count_var v > 0 then count l in count lam; (* Second pass: remove Lalias bindings of unused variables, and substitute the bindings of variables used exactly once. *) - let subst = Hashtbl.create 83 in + (* Also treat ``catch body with (i) handler'' + - if (exit i) does not occur in body, suppress catch + - if (exit i) occurs exactly once in body, + substitute it with handler *) + let subst = Hashtbl.create 83 + and subst_exit = Hashtbl.create 17 + and subst_fail = ref Lstaticfail in + let rec simplif = function Lvar v as l -> begin try @@ -191,10 +240,52 @@ let simplify_lambda lam = and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks in Lswitch (new_l,{sw with sw_consts = new_consts ; sw_blocks = new_blocks}) - | Lstaticfail as l -> l - | Lstaticraise _ as l -> l - | Lcatch(l1, l2) -> Lcatch(simplif l1, simplif l2) - | Lstaticcatch(l1, i, l2) -> Lstaticcatch(simplif l1, i, simplif l2) + | Lstaticfail as l -> !subst_fail + | Lstaticraise (i,[]) as l -> + begin try + Hashtbl.find subst_exit i + with + | Not_found -> l + end + | Lstaticraise (i,ls) -> + Lstaticraise (i, List.map simplif ls) + | Lcatch(l1, l2) as l -> + let nfail = + try + List.assq l !at_catch + with + | Not_found -> Misc.fatal_error "Simplif: catch" in + begin match nfail with + | 0 -> simplif l1 + | 1 -> + let new_l2 = simplif l2 in + let save_subst_fail = !subst_fail in + subst_fail := new_l2 ; + let r = simplif l1 in + subst_fail := save_subst_fail ; + r + | _ -> + let save_subst_fail = !subst_fail in + subst_fail := Lstaticfail ; + let r = simplif l1 in + subst_fail := save_subst_fail ; + Lcatch (r,simplif l2) + end + | Lstaticcatch (l1,(i,[]),l2) -> + begin match count_exit i with + | 0 -> simplif l1 + | 1 -> + Hashtbl.add subst_exit i (simplif l2) ; + simplif l1 + | _ -> + Lstaticcatch (simplif l1, (i,[]), simplif l2) + end + | Lstaticcatch(l1, (i,args), l2) -> + begin match count_exit i with + | 0 -> simplif l1 + | _ -> + Lstaticcatch (simplif l1, (i,args), simplif l2) + end | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) | Lsequence(Lifused(v, l1), l2) -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml new file mode 100644 index 000000000..707ff4f33 --- /dev/null +++ b/bytecomp/switch.ml @@ -0,0 +1,750 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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. *) +(* *) +(***********************************************************************) + +type iext = TooMuch | Int of int + +module type S = + sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val default : act + val bind : act -> (act -> act) -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : + act -> (int * int * int) array -> act array -> act + end + +module Make (Arg : S) = + struct + type l_status = Linter | Lsimple + type t_status = + Linear of l_status | Switch | ToCluster | Empty + + let string_of_status = function + | Linear Linter -> "Linter" + | Linear Lsimple -> "L" + | Empty -> "E" + | Switch -> "S" + | ToCluster -> "?" + + + type 'a inter = + {low : iext ; high : iext ; + icases : (int * int * int) array ; + iacts : 'a array ; + status : t_status} + + let prerr_icases t = + prerr_string "{ " ; + for i = 0 to Array.length t-1 do + let l,h,act = t.(i) in + Printf.fprintf stderr "(%d,%d,%d) " l h act + done ; + prerr_string "}" + + + let string_of_iext = function + | TooMuch -> "oo" + | Int i -> string_of_int i + + let prerr_inter i = + Printf.fprintf stderr + "status=%s, low=%s, high=%s, cases=" + (string_of_status i.status) + (string_of_iext i.low) (string_of_iext i.high) ; + prerr_icases i.icases + + let inter_default _ = function + | 0 -> true + | _ -> false + + let is_closed i = match i.low, i.high with + | Int _, Int _ -> true + | _,_ -> false + + type 'a t_ctx = + {ctx_low : iext ; ctx_high : iext ; off : int ; + arg : 'a} + +let find_staticfail _ = 0 + +(* +let as_checked i = match i.low, i.high with +| Int _, Int _ -> + let cases = i.icases in + let len = Array.length cases in + let l0,h0,a0 = cases.(0) + and ln,hn,an = cases.(len-1) in + if inter_default i a0 && inter_default i an then + {i with low=TooMuch ; high=TooMuch ; + icases=Array.sub cases 1 (len-2)} + else + i +| TooMuch,Int _ -> + let cases = i.icases in + let len = Array.length cases in + let ln,hn,an = cases.(len-1) in + if inter_default i an then + {i with high=TooMuch ; icases = Array.sub cases 0 (len-1)} + else + i +| Int _,TooMuch -> + let cases = i.icases in + let len = Array.length cases in + let l0,h0,a0 = cases.(0) in + if inter_default i a0 then + {i with low=TooMuch ; icases = Array.sub cases 1 (len-1)} + else + i +| _,_ -> i +*) + + + + +let ninters {low=low ; high=high ; icases = cases} = + Array.length cases + + (match low,high with + | Int _, Int _ -> 0 + | _,_ -> 1) + +let min_key i = match i.low with +| TooMuch -> + let low,_,_ = i.icases.(0) in + low +| Int low -> low + +and max_key i = match i.high with +| TooMuch -> + let _,high,_ = i.icases.(Array.length i.icases-1) in + high +| Int high -> high + +let nlabels i = max_key i/4 - min_key i/4 + +let count_bornes i = if is_closed i then 0 else 1 + +exception NoSuch + +let single_values i = + let singles = ref [] + and def = ref None + and cases = i.icases in + for i = 0 to Array.length cases-1 do + let low,high,act = cases.(i) in + if low=high then begin + match !def with + | Some def when def=act -> () + | _ -> + singles := (low,act) :: !singles + end else match !def with + | None -> + def := Some act ; + singles := + List.filter (fun (_,act0) -> act0 <> act) !singles + | Some def -> + if def <> act then raise NoSuch + done ; + match i.low,i.high,!def,!singles with + | Int _, Int _, None,(_,x)::r -> r,x + | Int _, Int _, Some x,r -> r,x + | _,_,Some x,r when inter_default i x -> r,x + | _,_,None,r -> r,find_staticfail i + | _,_,_,_ -> raise NoSuch + +let count_by_action i = + let low = i.low and high = i.high in + let t = Array.create (Array.length i.iacts) (0,0,0) in + let add l h act = + let old_n,old_itests,old_ztests = t.(act) in + t.(act) <- + (old_n+1, + old_itests + + (if l=h then 0 + else if Int l = low then 0 + else if Int h = high then 0 + else 1), + old_ztests + + (if l=h && Int l = low then 1 else 0)) in + Array.iter (fun (l,h,act) -> add l h act) i.icases ; + t + +and group_by_action i = + let t = Array.create (Array.length i.iacts) [] in + let add l h act = t.(act) <- (l,h)::t.(act) in + Array.iter (fun (l,h,act) -> add l h act) i.icases ; + t + +and low_action i = + let _,_,act = i.icases.(0) in + act + +and high_action i = + let cases = i.icases in + let _,_,act = cases.(Array.length cases-1) in + act + +let array_iteri_rev f t = + for i = Array.length t-1 downto 0 do + f i t.(i) + done + +exception Found of int + +let inter_values i = + if is_closed i then begin + + let find_max t = + let max = ref (-1) and max_itests = ref (-1) and max_ztests = ref (-1) + and max_act = ref (-1) in + array_iteri_rev + (fun act (n,itests,ztests) -> + if + n > !max ||(* choose action with maximum number of intervals *) + (* then with maximal number of actual interval tests *) + (n = !max && itests > !max_itests) || + (* then with minimal number of tests against zero *) + (n = !max && itests = !max_itests && ztests < !max_ztests) + then begin + max := n ; + max_itests := itests ; + max_ztests := ztests ; + max_act := act + end) t ; + !max_act in + + let max_act = find_max (count_by_action i) in + List.filter + (fun (l,h,act) -> act <> max_act) + (Array.to_list i.icases), + max_act + + end else + List.filter + (fun (l,h,act) -> not (inter_default i act)) + (Array.to_list i.icases), + find_staticfail i + + +let count_tests i = match i.icases with +| [| _ |] -> count_bornes i, Lsimple +| _ -> + let count_inter = + try + let l,_ = inter_values i in + List.length l + with + | NoSuch -> 1000 + + and count_simple = + let cases,low,high = i.icases, i.low, i.high in + let n = Array.length cases-1 in + n + count_bornes i in + + if count_inter <= count_simple then + count_inter, Linter + else + count_simple, Lsimple + + +let make_if_test konst test arg i ifso ifnot = + Arg.make_if + (Arg.make_prim test [arg.arg ; konst (i+arg.off)]) + ifso ifnot + +let inter_ctx off l h arg = + {off=off ; ctx_low = Int l ; ctx_high = Int h ; arg = arg} + +let make_if_inter konst arg l h mk_ifin ifout = + if l=h then + make_if_test konst Arg.neint arg l ifout + (mk_ifin (inter_ctx arg.off l h arg.arg)) + else + let new_off = arg.off-l in + Arg.bind + (Arg.make_offset arg.arg (-l)) + (fun arg -> + Arg.make_if + (Arg.make_isout (konst (h-l)) arg) + ifout (mk_ifin (inter_ctx new_off l h arg))) + +and make_if_inter_last konst arg l h mk_ifin ifout = + if l=h then + make_if_test konst Arg.eqint arg l + (mk_ifin (inter_ctx arg.off l h arg.arg)) + ifout + else + let new_off = arg.off-l in + Arg.bind + (Arg.make_offset arg.arg (-l)) + (fun arg -> + Arg.make_if + (Arg.make_isout (konst (h-l)) arg) + ifout (mk_ifin (inter_ctx new_off l h arg))) + +let make_inters_ifs konst arg ({iacts = acts} as i) = + try + let l,def = inter_values i in + let rec if_rec arg = function + | [] -> acts.(def) arg + | (l1,h1,act1)::rem -> + if Int l1 = arg.ctx_low then + make_if_test konst (if l1=h1 then Arg.neint else Arg.gtint) arg h1 + (if_rec {arg with ctx_low=Int (h1+1)} rem) + (acts.(act1) arg) + else if Int h1 = arg.ctx_high then + make_if_test konst (if l1=h1 then Arg.neint else Arg.ltint) arg l1 + (if_rec {arg with ctx_high = Int (l1-1)} rem) + (acts.(act1) arg) + else + make_if_inter konst arg l1 h1 acts.(act1) (if_rec arg rem) in + if_rec arg l + with + | NoSuch -> assert false + + + let make_linear_ifs l_status konst arg ({iacts = acts} as i) = + match l_status with + | Linter -> make_inters_ifs konst arg i + | Lsimple -> + let cases,low,high = i.icases,arg.ctx_low,arg.ctx_high in + let n = Array.length cases-1 in + let rec do_rec arg i = + if i=n then + let _,_,act = cases.(i) in + acts.(act) arg + else + let _,high,act = cases.(i) in + make_if_test konst + Arg.leint arg high (acts.(act) arg) + (do_rec arg (i+1)) in + match low,high with + | TooMuch, TooMuch -> + let l = min_key i + and h = max_key i in + make_if_inter konst arg l h (fun arg -> do_rec arg 0) Arg.default + | TooMuch,_ -> + let l = min_key i in + make_if_test konst Arg.ltint arg l Arg.default (do_rec arg 0) + | _, TooMuch -> + let h = max_key i in + make_if_test konst Arg.gtint arg h Arg.default (do_rec arg 0) + | _,_ -> do_rec arg 0 + +let special_case i = match i.low, i.high with +| Int 0, Int 2 -> begin match i.icases with + | [| (0,0,act1) ; (1,1,act2) ; (2,2,act3) |] -> act1 <> act3 + | _ -> false +end +| _ -> false + + + +exception Ends +exception NoCut of t_status +(* +let debug = ref false +*) + +let cut_here i = + let c_if, l_status = count_tests i in +(* + if !debug then + Printf.fprintf stderr "Attempt: %d as %s\n" c_if + (string_of_status (Linear l_status)) ; +*) + if c_if=0 then raise (NoCut Empty) ; + if special_case i then raise (NoCut Switch) ; + if c_if - count_bornes i <= !Clflags.limit_switch then + raise (NoCut (Linear l_status)) ; + let icases = i.icases in + let len = Array.length icases + and c_switch = nlabels i + 1 in + if c_switch <= c_if then raise (NoCut Switch) ; + + let r = ref (-1) and max = ref (-1) in + for j = 0 to len-1 do + let low,high,_ = icases.(j) in + if high-low+1 > !max then begin + max := high-low ; + r := j + end + done ; + if len > 2 then begin + let l0,h0,act0 = icases.(0) + and ln,hn,actn = icases.(len-1) in + if + act0 = actn && + (h0-l0+hn-ln+2 > !max) + then + raise Ends + end ; + !r + +let sub_cases from_here len cases = + if len <= 0 then [||] + else + Array.sub cases from_here len + +let present act i len cases = + let rec do_rec i = + if i < len then + let _,_,act0 = cases.(i) in + act0=act || do_rec (i+1) + else + false in + do_rec i + + + +let explode_linear i k = + let acts = i.iacts + and cases = i.icases in + let last = Array.length cases-1 in + + let rec explode_rec j = match last-j with + | 0 -> + let (l,_,_) as x = cases.(j) in + {i with low = Int l ; icases = [| x |] ; status = Empty}::k + | _ -> + let (l,h,_) as x = cases.(j) in + {i with low = Int l ; high = Int h ; + icases = [| x |] ; status = Empty}:: + explode_rec (j+1) in + + + match cases with + | [| |] | [| _ |] -> {i with status=Empty}::k + | _ -> + let (_,h0,_) as x = cases.(0) in + {i with high = Int h0 ; icases = [| x |] ; status = Empty}:: + explode_rec 1 + +let rec do_cluster i k = +(* + if !debug then begin + prerr_string "++++++++++++++++\nCluster " ; prerr_inter i ; + prerr_endline "" + end ; +*) + let cases = i.icases in + if i.high = TooMuch && inter_default i (low_action i) then + let l0,h0,act0 = cases.(0) in + let rest = sub_cases 1 (Array.length cases-1) cases in + {i with high=Int h0 ; icases = [| cases.(0) |] ; status=Empty}:: + do_cluster + {i with low=Int (h0+1) ; icases = rest} + k + else + try + match cases with + | [| _,_,act |] -> + if is_closed i || inter_default i act then + {i with status=Empty}::k + else + let _,status = count_tests i in + raise (NoCut (Linear status)) + | _ -> + let j = cut_here i in + + let c_low,c_high,c_act = cases.(j) in + if false (* c_low=c_high *) then begin + let left,right = + if j=0 || present c_act 0 j cases then + sub_cases 0 (j+1) cases, + sub_cases (j+1) (Array.length cases-j-1) cases + else + sub_cases 0 j cases, + sub_cases j (Array.length cases-j) cases in +(* + if !debug then begin + prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ; + prerr_string "Right = " ; prerr_icases right ; prerr_endline "" + end ; +*) + do_cluster + {i with high = Int (c_low-1) ; icases=left} + (do_cluster + {i with low = Int c_low ; icases=right} k) + end else begin + let left = sub_cases 0 j cases + and center = [| cases.(j) |] + and right = sub_cases (j+1) (Array.length cases-j-1) cases in +(* + if !debug then begin + prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ; + prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ; + prerr_string "Right = " ; prerr_icases right ; prerr_endline "" + end ; +*) + if j=0 then + {i with low=i.low ; high = Int c_high ; + icases = center ; status=Empty}:: + do_cluster + {i with low = Int (c_high+1) ; high=i.high ; icases = right} k + else if j = Array.length cases-1 then + do_cluster + {i with low = i.low ; high= Int (c_low-1) ; icases = left} + ({i with low = Int c_low ; high = i.high ; + icases=center ; status=Empty}::k) + else + do_cluster + {i with low = i.low ; high= Int (c_low-1) ; icases = left} + ({i with low = Int c_low ; high = Int c_high ; + icases=center ; status=Empty}:: + do_cluster + {i with low = Int (c_high+1) ; high=i.high ; icases = right} + k) + end +with +| NoCut status -> +(* + if !debug then + Printf.fprintf stderr "%s\n" (string_of_status status) ; +*) + begin match status with + | Linear _ -> explode_linear i k + | _ -> {i with status=status}::k + end +| Ends -> + let cases = i.icases in + let len = Array.length cases in + let _,h0,act0 = cases.(0) + and center = sub_cases 1 (len-2) cases + and ln,_,actn = cases.(len-1) in + +(* + if !debug then begin + prerr_string "Left = " ; prerr_icases [| cases.(0) |] ; + prerr_endline "" ; + prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ; + prerr_string "Right = " ; prerr_icases [| cases.(len-1) |] ; + prerr_endline "" + end ; +*) + + {i with high = Int h0 ; status = Empty ; icases = [| cases.(0) |]}:: + do_cluster + {i with low = Int (h0+1) ; high = Int (ln-1) ; icases = center} + ({i with low = Int ln ; status = Empty ; icases = [| cases.(len-1) |]}::k) + + +let do_merge_clusters i1 i2 = + {low=i1.low ; high = i2.high ; + icases = Array.append i1.icases i2.icases ; + iacts= i1.iacts ; + status = ToCluster} + + +exception NoMerge + +let merge_clusters i1 i2 = match i1.status, i2.status with +| Linear _, Linear _ -> do_merge_clusters i1 i2 +| _,_ -> raise NoMerge + +let simpl_clusters l = + match l with + | [] -> l + | [_] -> l + | _ -> +(* + if !debug then begin + prerr_endline "------------------- Clusters --------------" ; + List.iter + (fun i -> prerr_inter i ; prerr_endline "") l + end ; +*) + l + +let cluster i = + + simpl_clusters (do_cluster i []) + + + +let fail_out inter = + let t = inter.icases in + let j = ref 1 + and len = Array.length t in + let new_low = + let _,high,act0 as all0 = t.(0) in + if inter_default inter act0 then begin + t.(0) <- t.(1) ; + Int (high+1) + end else begin + inter.low + end in + + for i = 1 to Array.length t-1 do + let (_,high,act as all) = t.(i) + and low0,_,act0 = t.(!j-1) in + if inter_default inter act || act0=act then + t.(!j-1) <- low0, high, act0 + else begin + t.(!j) <- all ; + incr j + end + done ; + let new_t = + if !j <> len then + Array.sub t 0 !j + else + t in + let _,new_high,_ = new_t.(!j-1) in + {inter with low = new_low ; high = Int new_high ; icases = new_t} + + +let as_int_int_acts i = + let acts = i.iacts in + Array.map + (fun (l,h,act) -> (l,h,acts.(act))) + i.icases + +let comp_leaf konst arg i = match i.status with + | Linear l_status -> make_linear_ifs l_status konst arg i + | Empty -> + let _,_,act = i.icases.(0) in + i.iacts.(act) arg + | Switch -> + let min_key = min_key i in + let mk_switch arg = + let acts = Array.map (fun act -> act arg) i.iacts in + Arg.make_switch arg.arg i.icases acts in + mk_switch {arg with arg = Arg.make_offset arg.arg (-arg.off-min_key)} + + | ToCluster -> Misc.fatal_error "Matching.comp_leaf" + + +type 'a action = | Unique of 'a | Shared of int * 'a + + +let same_cluster_action c1 c2 = match c1.status, c2 with +| Empty, Shared (i2,_) -> low_action c1=i2 +| _,_ -> false + +let cluster_clusters konst arg cls = + let actions = ref [Shared (0, cls.(0).iacts.(0))] + and n_actions = ref 1 in + let rec store_rec act i = function + | [] -> begin match act.status with + | Empty -> + let index = low_action act in + [Shared (index, act.iacts.(index))] + | _ -> [Unique (fun arg -> comp_leaf konst arg act)] + end + | act0::rem -> + if same_cluster_action act act0 then + raise (Found i) + else + act0::store_rec act (i+1) rem in + let store act = + try + actions := store_rec act 0 !actions ; + let r = !n_actions in + incr n_actions ; + r + with + | Found i -> i in + let cases = + Array.map + (fun c -> min_key c, max_key c,store c) cls in + let low = cls.(0).low + and high = cls.(Array.length cls-1).high in + {high = high ; low = low ; + icases = cases ; + iacts = Array.map + (function + | Unique act -> act + | Shared (_,act) -> act) + (Array.of_list !actions) ; + status = ToCluster} + + +let final_tests konst arg cl = + + let rec comp_tree cl = + let n,status = count_tests cl in + +(* + if !debug then begin + prerr_inter cl ; + Printf.fprintf stderr "\nFinally : %d tests as %s\n" n + (string_of_status (Linear status)) ; + flush stderr + end ; +*) + + if n <= !Clflags.limit_tree then + comp_leaf konst + {arg with ctx_low = cl.low ; ctx_high = cl.high} + {cl with status = Linear status} + else + let cases = cl.icases in + let len = Array.length cases in + let half = match cl.low, cl.high with + | TooMuch,Int _ -> (len-1)/2 + | Int _, TooMuch -> (len+1)/2 + | _,_ -> len/2 in + let left = sub_cases 0 half cases + and right = sub_cases half (len-half) cases in + let _,key,_ = left.(half-1) in + make_if_test konst + Arg.leint arg key + (comp_tree {cl with high=Int key ; icases = left}) + (comp_tree {cl with low=Int (key+1) ; icases=right}) in + + comp_tree cl + + + +let comp_clusters konst arg l = + let cls = Array.of_list l in + let cl = cluster_clusters konst arg cls in + final_tests konst arg cl + +let comp_inter konst arg i = comp_clusters konst arg (cluster i) + + +let zyva konst arg low high cases acts = + let cl = + {low = low ; high = high ; + icases = cases ; + iacts=Array.map (fun act -> (fun _ -> act)) acts ; + status = ToCluster} in +(* + let old_debug = !debug in + if fst (count_tests cl) > 2 then debug := true ; + if !debug then begin + prerr_endline "******** zyva **********" ; + prerr_inter cl ; + prerr_endline "" + end ; +*) + let r = comp_inter konst + {ctx_low=low ; ctx_high=high ; off=0 ; arg=arg} cl in +(* + if !debug then prerr_endline "************************" ; + debug := old_debug ; +*) + r + + end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli new file mode 100644 index 000000000..f39138563 --- /dev/null +++ b/bytecomp/switch.mli @@ -0,0 +1,76 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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. *) +(* *) +(***********************************************************************) + +(* + This module transforms generic switches in combinations + of if tests and switches. +*) + + +(* integer plus infinity, for interval limits *) + +type iext = TooMuch | Int of int + +(* Arguments to the Make functor *) +module type S = + sig + (* type of basic tests *) + type primitive + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + (* type of actions *) + type act + (* default action *) + val default : act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_if : act -> act -> act -> act + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the interval form *) + val make_switch : + act -> (int * int * int) array -> act array -> act + end + + +(* + Make.zyva mk_const arg low high cases actions where + - mk_const takes an integer sends a constant action. + - arg is the argument of the switch. + - low, high are the interval limits. + - cases is a list of sub-interval and action indices + - action is an array of actions. + + All these arguments specify a switch construct and zyva + returns an action that performs the switch, +*) +module Make : + functor (Arg : S) -> + sig + val zyva : + (int -> Arg.act) -> + Arg.act -> + iext -> iext -> + (int * int * int) array -> + Arg.act array -> + Arg.act + end diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 361df9259..7eca06aa4 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -276,6 +276,7 @@ let transl_prim prim args = with Not_found -> Pccall prim + (* Eta-expand a primitive without knowing the types of its arguments *) let transl_primitive p = diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 6496ee4db..5da63c62a 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -108,8 +108,9 @@ void thread_code (code_t code, asize_t len) /* Instructions with two operands */ l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = - l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = 2; - + l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = + l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = + l[BULTINT] = l[BUGEINT] = 2; len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; @@ -117,6 +118,7 @@ void thread_code (code_t code, asize_t len) fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); } + *p++ = (opcode_t)(instr_table[instr] - instr_base); if (instr == SWITCH) { uint32 sizes = *p++; diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 3eae0cdb8..160225fb5 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -54,6 +54,8 @@ void disasm_instr(pc) /* Instructions with two operands */ case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: case GETGLOBALFIELD: case MAKEBLOCK: + case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: + case BULTINT: case BUGEINT: printf(" %d, %d\n", pc[0], pc[1]); break; /* Instructions with a C primitive as operand */ case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5: diff --git a/byterun/instruct.h b/byterun/instruct.h index 5ad1e6c41..80d9ed1ea 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -44,7 +44,10 @@ enum instructions { NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, EQ, NEQ, LTINT, LEINT, GTINT, GEINT, - OFFSETINT, OFFSETREF, ISINT, + OFFSETINT, OFFSETREF, ISINT, GETMETHOD, - STOP, EVENT, BREAK + BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, + ULTINT, UGEINT, + BULTINT, BUGEINT, STOP, + EVENT, BREAK, }; diff --git a/byterun/interp.c b/byterun/interp.c index f9eae04e0..fcd92cfa4 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -13,7 +13,7 @@ /* $Id$ */ /* The bytecode interpreter */ - +#include<stdio.h> #include "alloc.h" #include "callback.h" #include "debugger.h" @@ -928,16 +928,35 @@ value interprete(code_t prog, asize_t prog_size) Instruct(ASRINT): accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next; -#define Integer_comparison(opname,tst) \ +#define Integer_comparison(sign,opname,tst) \ Instruct(opname): \ - accu = Val_int((long) accu tst (long) *sp++); Next; - - Integer_comparison(EQ, ==) - Integer_comparison(NEQ, !=) - Integer_comparison(LTINT, <) - Integer_comparison(LEINT, <=) - Integer_comparison(GTINT, >) - Integer_comparison(GEINT, >=) + accu = Val_int((sign long) accu tst (sign long) *sp++); Next; + + Integer_comparison(signed,EQ, ==) + Integer_comparison(signed,NEQ, !=) + Integer_comparison(signed,LTINT, <) + Integer_comparison(signed,LEINT, <=) + Integer_comparison(signed,GTINT, >) + Integer_comparison(signed,GEINT, >=) + Integer_comparison(unsigned,ULTINT, <) + Integer_comparison(unsigned,UGEINT, >=) + +#define Integer_branch_comparison(sign,opname,tst,debug) \ + Instruct(opname): \ + if ( *pc++ tst ((sign long)Long_val(accu))) { \ + pc += *pc ; \ + } else { \ + pc++ ; \ + } ; Next; + + Integer_branch_comparison(signed,BEQ, ==, "==") + Integer_branch_comparison(signed,BNEQ, !=, "!=") + Integer_branch_comparison(signed,BLTINT, <, "<") + Integer_branch_comparison(signed,BLEINT, <=, "<=") + Integer_branch_comparison(signed,BGTINT, >, ">") + Integer_branch_comparison(signed,BGEINT, >=, ">=") + Integer_branch_comparison(unsigned,BULTINT, <, "<") + Integer_branch_comparison(unsigned,BUGEINT, >=, ">=") Instruct(OFFSETINT): accu += *pc << 1; @@ -951,7 +970,7 @@ value interprete(code_t prog, asize_t prog_size) Instruct(ISINT): accu = Val_long(accu & 1); Next; - + /* Object-oriented operations */ #define Lookup(obj, lab) \ diff --git a/driver/optmain.ml b/driver/optmain.ml index d3a6fff34..231aa1726 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -146,6 +146,9 @@ let main () = "-dlinear", Arg.Set dump_linear, " (undocumented)"; "-dstartup", Arg.Set keep_startup_file, " (undocumented)"; + "-switch", Arg.Int (fun i -> limit_switch := i), " (undocumented)"; + "-tree", Arg.Int (fun i -> limit_tree := i), " (undocumented)"; + "-", Arg.String (process_file ppf), "<file> Treat <file> as a file name (even if it starts with `-')" ] (process_file ppf) usage; diff --git a/tools/Makefile b/tools/Makefile index b94721cb0..7225eb401 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -26,13 +26,13 @@ all: ocamldep ocamlprof ocamlcp ocamlmktop # The dependency generator -CAMLDEP=ocamldep.cmo +CAMLDEP_OBJ=ocamldep.cmo CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo -ocamldep: $(CAMLDEP) - $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP) +ocamldep: $(CAMLDEP_OBJ) + $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) clean:: rm -f ocamldep diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll index 3aefa3ebd..3e28ae972 100644 --- a/tools/cvt_emit.mll +++ b/tools/cvt_emit.mll @@ -79,4 +79,6 @@ and command = parse { let _ = main(Lexing.from_channel stdin) + +let _ = exit (0) } diff --git a/typing/parmatch.ml b/typing/parmatch.ml index edde3bbf5..e2f58709a 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -710,35 +710,6 @@ let get_mins ps = else select_rec (p::r) ps in select_rec [] (select_rec [] ps) -let rec compat p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_),_ -> compat p q -| _,Tpat_alias (q,_) -> compat p q -| (Tpat_any|Tpat_var _),_ -> true -| _,(Tpat_any|Tpat_var _) -> true -| Tpat_or (p1,p2),_ -> compat p1 q || compat p2 q -| _,Tpat_or (q1,q2) -> compat p q1 || compat p q2 -| Tpat_constant c1, Tpat_constant c2 -> c1=c2 -| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs -| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> - c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 -| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> - l1=l2 && compat p1 p2 -| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2 -| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false -| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false -| Tpat_record l1,Tpat_record l2 -> - let ps,qs = records_args l1 l2 in - compats ps qs -| Tpat_array ps, Tpat_array qs -> - List.length ps = List.length qs && - compats ps qs -| _,_ -> assert false - -and compats ps qs = match ps,qs with -| [], [] -> true -| p::ps, q::qs -> compat p q && compats ps qs -| _,_ -> assert false - (*************************************) (* Values as patterns pretty printer *) (*************************************) @@ -841,6 +812,41 @@ let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v +let rec compat p q = match p.pat_desc,q.pat_desc with +| Tpat_alias (p,_),_ -> compat p q +| _,Tpat_alias (q,_) -> compat p q +| (Tpat_any|Tpat_var _),_ -> true +| _,(Tpat_any|Tpat_var _) -> true +| Tpat_or (p1,p2),_ -> compat p1 q || compat p2 q +| _,Tpat_or (q1,q2) -> compat p q1 || compat p q2 +| Tpat_constant c1, Tpat_constant c2 -> c1=c2 +| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs +| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> + c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 +| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> + l1=l2 && compat p1 p2 +| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2 +| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false +| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false +| Tpat_record l1,Tpat_record l2 -> + let ps,qs = records_args l1 l2 in + compats ps qs +| Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && + compats ps qs +| _,_ -> + top_pretty Format.str_formatter p ; + prerr_endline (Format.flush_str_formatter ()) ; + top_pretty Format.str_formatter q ; + prerr_endline (Format.flush_str_formatter ()) ; + assert false + +and compats ps qs = match ps,qs with +| [], [] -> true +| p::ps, q::qs -> compat p q && compats ps qs +| _,_ -> assert false + + (******************************) (* Entry points *) (* - Partial match *) diff --git a/typing/typecore.ml b/typing/typecore.ml index 0a6829ba5..3bd964ede 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -31,7 +31,7 @@ type error = | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable - | Orpat_not_closed + | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr @@ -110,12 +110,47 @@ let unify_pat' env pat expected_ty = let pattern_variables = ref ([]: (Ident.t * type_expr) list) let enter_variable loc name ty = - if List.exists (fun (id, ty) -> Ident.name id = name) !pattern_variables + if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables then raise(Error(loc, Multiply_bound_variable)); let id = Ident.create name in pattern_variables := (id, ty) :: !pattern_variables; id +let sort_pattern_variables vs = + List.sort + (fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y)) + vs + +let enter_orpat_variables loc env p1_vs p2_vs = + (* unify_vars operate on sorted lists *) + + let p1_vs = sort_pattern_variables p1_vs + and p2_vs = sort_pattern_variables p2_vs in + + let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with + | (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 -> + if x1==x2 then + unify_vars rem1 rem2 + else begin + begin try + unify_strict env t1 t2 + with + | Unify trace -> + raise(Error(loc, Pattern_type_clash(trace))) + end ; + (x2,x1)::unify_vars rem1 rem2 + end + | [],[] -> [] + | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x)) + | [],(x,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (x,_)::_, (y,_)::_ -> + let min_var = + if Ident.name x < Ident.name y then x + else y in + raise (Error (loc, Orpat_vars min_var)) in + unify_vars p1_vs p2_vs + + let rec build_as_type env p = match p.pat_desc with Tpat_alias(p1, _) -> build_as_type env p1 @@ -216,16 +251,16 @@ let rec type_pat env sp = pat_loc = sp.ppat_loc; pat_type = ty; pat_env = env } - | Ppat_alias(sp, name) -> - let p = type_pat env sp in + | Ppat_alias(sq, name) -> + let q = type_pat env sq in begin_def (); - let ty_var = build_as_type env p in + let ty_var = build_as_type env q in end_def (); generalize ty_var; let id = enter_variable sp.ppat_loc name ty_var in - { pat_desc = Tpat_alias(p, id); + { pat_desc = Tpat_alias(q, id); pat_loc = sp.ppat_loc; - pat_type = p.pat_type; + pat_type = q.pat_type; pat_env = env } | Ppat_constant cst -> { pat_desc = Tpat_constant cst; @@ -314,11 +349,15 @@ let rec type_pat env sp = | Ppat_or(sp1, sp2) -> let initial_pattern_variables = !pattern_variables in let p1 = type_pat env sp1 in + let p1_variables = !pattern_variables in + pattern_variables := initial_pattern_variables ; let p2 = type_pat env sp2 in - if !pattern_variables != initial_pattern_variables then - raise(Error(sp.ppat_loc, Orpat_not_closed)); + let p2_variables = !pattern_variables in unify_pat env p2 p1.pat_type; - { pat_desc = Tpat_or(p1, p2); + let alpha_env = + enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in + pattern_variables := p1_variables ; + { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2); pat_loc = sp.ppat_loc; pat_type = p1.pat_type; pat_env = env } @@ -1361,8 +1400,9 @@ let report_error ppf = function fprintf ppf "but is here used to match values of type") | Multiply_bound_variable -> fprintf ppf "This variable is bound several times in this matching" - | Orpat_not_closed -> - fprintf ppf "A pattern with | must not bind variables" + | Orpat_vars id -> + fprintf ppf "Variable %s must occur on both sides of this | pattern" + (Ident.name id) | Expr_type_clash trace -> report_unification_error ppf trace (function ppf -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 14c581fec..788ec75f2 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -61,7 +61,7 @@ type error = | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable - | Orpat_not_closed + | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 1d06dc544..55d0bba1f 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -161,7 +161,9 @@ let rec bound_idents pat = | Tpat_record lbl_pat_list -> List.iter (fun (lbl, pat) -> bound_idents pat) lbl_pat_list | Tpat_array patl -> List.iter bound_idents patl - | Tpat_or(p1, p2) -> bound_idents p1; bound_idents p2 + | Tpat_or(p1, _) -> + (* Invariant : both arguments binds the same variables *) + bound_idents p1 let pat_bound_idents pat = idents := []; bound_idents pat; let res = !idents in idents := []; res @@ -173,3 +175,38 @@ let rev_let_bound_idents pat_expr_list = let let_bound_idents pat_expr_list = List.rev(rev_let_bound_idents pat_expr_list) + +let alpha_var env id = List.assoc id env + +let rec alpha_pat env p = match p.pat_desc with +| Tpat_var id -> (* note the ``Not_found'' case *) + {p with pat_desc = + try Tpat_var (alpha_var env id) with + | Not_found -> Tpat_any} +| Tpat_alias (p, id) -> + let new_p = alpha_pat env p in + begin try + {p with pat_desc = Tpat_alias (new_p, alpha_var env id)} + with + | Not_found -> new_p + end +| Tpat_tuple pats -> + {p with pat_desc = + Tpat_tuple (List.map (alpha_pat env) pats)} +| Tpat_record lpats -> + {p with pat_desc = + Tpat_record (List.map (fun (l,p) -> l,alpha_pat env p) lpats)} +| Tpat_construct (c,pats) -> + {p with pat_desc = + Tpat_construct (c,List.map (alpha_pat env) pats)} +| Tpat_array pats -> + {p with pat_desc = + Tpat_array (List.map (alpha_pat env) pats)} +| Tpat_variant (x1, Some p, x2) -> + {p with pat_desc = + Tpat_variant (x1, Some (alpha_pat env p), x2)} +| Tpat_or (p1,p2) -> + {p with pat_desc = + Tpat_or (alpha_pat env p1, alpha_pat env p2)} +| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> p + diff --git a/typing/typedtree.mli b/typing/typedtree.mli index bf40a0cf7..72db5237a 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -146,6 +146,9 @@ and module_coercion = (* Auxiliary functions over the a.s.t. *) -val pat_bound_idents: pattern -> Ident.t list val let_bound_idents: (pattern * expression) list -> Ident.t list val rev_let_bound_idents: (pattern * expression) list -> Ident.t list + +(* Alpha conversion of patterns *) +val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern + diff --git a/utils/clflags.ml b/utils/clflags.ml index 0791c904a..71c7aba5b 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -70,3 +70,6 @@ let dump_combine = ref false (* -dcombine *) let native_code = ref false (* set to true under ocamlopt *) let inline_threshold = ref 10 + +let limit_tree = ref 3 +and limit_switch = ref 2 diff --git a/utils/config.mlp b/utils/config.mlp index 80e7af7fa..e30c63b6d 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,7 +12,7 @@ (* $Id$ *) -let version = "3.00+14 (2000-09-06)" +let version = "3.00+15 (2000-10-02)" let standard_library = try |