diff options
| -rw-r--r-- | .depend | 60 | ||||
| -rw-r--r-- | Makefile | 8 | ||||
| -rw-r--r-- | asmcomp/alpha/emit.mlp | 19 | ||||
| -rw-r--r-- | asmcomp/clambda.ml | 4 | ||||
| -rw-r--r-- | asmcomp/clambda.mli | 4 | ||||
| -rw-r--r-- | asmcomp/closure.ml | 50 | ||||
| -rw-r--r-- | asmcomp/cmm.ml | 4 | ||||
| -rw-r--r-- | asmcomp/cmm.mli | 4 | ||||
| -rw-r--r-- | asmcomp/cmmgen.ml | 407 | ||||
| -rw-r--r-- | asmcomp/i386/emit.mlp | 26 | ||||
| -rw-r--r-- | asmcomp/linearize.ml | 56 | ||||
| -rw-r--r-- | asmcomp/linearize.mli | 1 | ||||
| -rw-r--r-- | asmcomp/printcmm.ml | 17 | ||||
| -rw-r--r-- | asmcomp/selectgen.ml | 58 | ||||
| -rw-r--r-- | asmcomp/spill.ml | 15 |
15 files changed, 535 insertions, 198 deletions
@@ -307,13 +307,15 @@ bytecomp/lambda.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ bytecomp/matching.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ctype.cmi \ typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi parsing/location.cmi \ utils/misc.cmi typing/parmatch.cmi typing/predef.cmi typing/primitive.cmi \ - bytecomp/printlambda.cmi typing/typedtree.cmi bytecomp/typeopt.cmi \ - typing/types.cmi utils/warnings.cmi bytecomp/matching.cmi + bytecomp/printlambda.cmi bytecomp/switch.cmi typing/typedtree.cmi \ + bytecomp/typeopt.cmi typing/types.cmi utils/warnings.cmi \ + bytecomp/matching.cmi bytecomp/matching.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ctype.cmx \ typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx parsing/location.cmx \ utils/misc.cmx typing/parmatch.cmx typing/predef.cmx typing/primitive.cmx \ - bytecomp/printlambda.cmx typing/typedtree.cmx bytecomp/typeopt.cmx \ - typing/types.cmx utils/warnings.cmx bytecomp/matching.cmi + bytecomp/printlambda.cmx bytecomp/switch.cmx typing/typedtree.cmx \ + bytecomp/typeopt.cmx typing/types.cmx utils/warnings.cmx \ + bytecomp/matching.cmi bytecomp/meta.cmo: bytecomp/meta.cmi bytecomp/meta.cmx: bytecomp/meta.cmi bytecomp/printinstr.cmo: typing/ident.cmi bytecomp/instruct.cmi \ @@ -329,9 +331,11 @@ bytecomp/printlambda.cmx: parsing/asttypes.cmi typing/ident.cmx \ bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi bytecomp/simplif.cmo: parsing/asttypes.cmi utils/clflags.cmo typing/ident.cmi \ - bytecomp/lambda.cmi bytecomp/simplif.cmi + bytecomp/lambda.cmi utils/misc.cmi bytecomp/simplif.cmi bytecomp/simplif.cmx: parsing/asttypes.cmi utils/clflags.cmx typing/ident.cmx \ - bytecomp/lambda.cmx bytecomp/simplif.cmi + bytecomp/lambda.cmx utils/misc.cmx bytecomp/simplif.cmi +bytecomp/switch.cmo: utils/clflags.cmo utils/misc.cmi bytecomp/switch.cmi +bytecomp/switch.cmx: utils/clflags.cmx utils/misc.cmx bytecomp/switch.cmi bytecomp/symtable.cmo: parsing/asttypes.cmi bytecomp/bytesections.cmi \ utils/clflags.cmo bytecomp/emitcode.cmi typing/ident.cmi \ bytecomp/lambda.cmi bytecomp/meta.cmi utils/misc.cmi typing/predef.cmi \ @@ -412,8 +416,6 @@ asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \ asmcomp/selection.cmi: asmcomp/cmm.cmi asmcomp/mach.cmi asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: utils/config.cmi -asmcomp/arch.cmx: utils/config.cmx asmcomp/asmgen.cmo: utils/clflags.cmo asmcomp/closure.cmi asmcomp/cmm.cmi \ asmcomp/cmmgen.cmi asmcomp/coloring.cmi asmcomp/comballoc.cmi \ utils/config.cmi asmcomp/emit.cmi asmcomp/emitaux.cmi asmcomp/interf.cmi \ @@ -461,11 +463,11 @@ asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi asmcomp/cmmgen.cmo: asmcomp/arch.cmo parsing/asttypes.cmi asmcomp/clambda.cmi \ utils/clflags.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi typing/ident.cmi \ bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi asmcomp/proc.cmi \ - typing/types.cmi asmcomp/cmmgen.cmi + bytecomp/switch.cmi typing/types.cmi asmcomp/cmmgen.cmi asmcomp/cmmgen.cmx: asmcomp/arch.cmx parsing/asttypes.cmi asmcomp/clambda.cmx \ utils/clflags.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx typing/ident.cmx \ bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx asmcomp/proc.cmx \ - typing/types.cmx asmcomp/cmmgen.cmi + bytecomp/switch.cmx typing/types.cmx asmcomp/cmmgen.cmi asmcomp/codegen.cmo: asmcomp/cmm.cmi asmcomp/coloring.cmi asmcomp/emit.cmi \ asmcomp/interf.cmi asmcomp/linearize.cmi asmcomp/liveness.cmi \ asmcomp/printcmm.cmi asmcomp/printlinear.cmi asmcomp/printmach.cmi \ @@ -486,13 +488,13 @@ asmcomp/compilenv.cmo: asmcomp/clambda.cmi utils/config.cmi typing/env.cmi \ typing/ident.cmi utils/misc.cmi asmcomp/compilenv.cmi asmcomp/compilenv.cmx: asmcomp/clambda.cmx utils/config.cmx typing/env.cmx \ typing/ident.cmx utils/misc.cmx asmcomp/compilenv.cmi -asmcomp/emit.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi \ - utils/config.cmi asmcomp/emitaux.cmi asmcomp/linearize.cmi \ - parsing/location.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ +asmcomp/emit.cmo: asmcomp/arch.cmo utils/clflags.cmo asmcomp/cmm.cmi \ + asmcomp/compilenv.cmi utils/config.cmi asmcomp/emitaux.cmi \ + asmcomp/linearize.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ asmcomp/reg.cmi asmcomp/emit.cmi -asmcomp/emit.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx \ - utils/config.cmx asmcomp/emitaux.cmx asmcomp/linearize.cmx \ - parsing/location.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ +asmcomp/emit.cmx: asmcomp/arch.cmx utils/clflags.cmx asmcomp/cmm.cmx \ + asmcomp/compilenv.cmx utils/config.cmx asmcomp/emitaux.cmx \ + asmcomp/linearize.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \ asmcomp/reg.cmx asmcomp/emit.cmi asmcomp/emitaux.cmo: asmcomp/emitaux.cmi asmcomp/emitaux.cmx: asmcomp/emitaux.cmi @@ -524,16 +526,16 @@ asmcomp/printmach.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ asmcomp/printmach.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ asmcomp/printcmm.cmx asmcomp/proc.cmx asmcomp/reg.cmx \ asmcomp/printmach.cmi -asmcomp/proc.cmo: asmcomp/arch.cmo utils/ccomp.cmi utils/clflags.cmo \ - asmcomp/cmm.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \ - asmcomp/proc.cmi -asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx utils/clflags.cmx \ - asmcomp/cmm.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \ - asmcomp/proc.cmi +asmcomp/proc.cmo: asmcomp/arch.cmo utils/ccomp.cmi asmcomp/cmm.cmi \ + asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/proc.cmi +asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx asmcomp/cmm.cmx \ + asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.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/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi +asmcomp/reload.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ + asmcomp/reg.cmi asmcomp/reloadgen.cmi asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ + asmcomp/reg.cmx asmcomp/reloadgen.cmx asmcomp/reload.cmi asmcomp/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \ @@ -542,10 +544,8 @@ asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \ asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \ asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/arch.cmo asmcomp/mach.cmi \ - asmcomp/schedgen.cmi asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/arch.cmx asmcomp/mach.cmx \ - asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/selectgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \ asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi \ utils/tbl.cmi asmcomp/selectgen.cmi @@ -553,10 +553,10 @@ asmcomp/selectgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \ asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx \ utils/tbl.cmx asmcomp/selectgen.cmi asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \ - utils/misc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \ + utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \ asmcomp/selection.cmi asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \ - utils/misc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \ + utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \ asmcomp/selection.cmi asmcomp/spill.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \ asmcomp/reg.cmi asmcomp/spill.cmi @@ -54,7 +54,7 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/typemod.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ - bytecomp/typeopt.cmo bytecomp/matching.cmo \ + bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo @@ -420,7 +420,7 @@ beforedepend:: asmcomp/scheduling.ml # Preprocess the code emitters asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit - boot/ocamlrun tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ + $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ || { rm -f asmcomp/emit.ml; exit 2; } partialclean:: @@ -429,7 +429,7 @@ partialclean:: beforedepend:: asmcomp/emit.ml tools/cvt_emit: tools/cvt_emit.mll - cd tools; $(MAKE) cvt_emit + cd tools; $(MAKE) CAMLC="../$(CAMLRUN) ../ocamlc -I ../stdlib" cvt_emit # The "expunge" utility @@ -504,7 +504,7 @@ alldepend:: # The extra libraries otherlibraries: - set -e; for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) all); done + set -e; for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all); done otherlibrariesopt: set -e; for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) allopt); done partialclean:: diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp index 56bd8fda5..b882adecc 100644 --- a/asmcomp/alpha/emit.mlp +++ b/asmcomp/alpha/emit.mlp @@ -127,6 +127,12 @@ let fastcode_flag = ref true let emit_label lbl = emit_string "$"; emit_int lbl +let emit_Llabel failthrough lbl = + if (not failthrough) then begin + emit_string " .align 4\n" + end ; + emit_label lbl + (* Output a symbol *) let emit_symbol s = @@ -346,7 +352,7 @@ let range_check_trap = ref 0 let float_constants = ref ([] : (label * string) list) let bigint_constants = ref ([] : (label * nativeint) list) -let emit_instr i = +let emit_instr failthrough i = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -589,7 +595,7 @@ let emit_instr i = liveregs i live_26; ` ret ($26)\n` | Llabel lbl -> - `{emit_label lbl}:\n` + `{emit_Llabel failthrough lbl}:\n` | Lbranch lbl -> ` br {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> @@ -685,8 +691,11 @@ let emit_instr i = liveregs i live_26; ` jmp $25, ($26)\n` (* Keep retaddr in $25 for debugging *) -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next +let rec emit_all failthrough i = match i.desc with +| Lend -> () +| _ -> + emit_instr failthrough i; + emit_all (has_failthrough i.desc) i.next (* Emission of a function declaration *) @@ -720,7 +729,7 @@ let emit_fundecl (fundecl, needs_gp) = ` .prologue {emit_int(if needs_gp then 1 else 0)}\n`; tailrec_entry_point := new_label(); `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; + emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; if !range_check_trap > 0 then begin `{emit_label !range_check_trap}:\n`; diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index a2e8f67ff..5ff0c70aa 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -32,8 +32,8 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list | Uswitch of ulambda * ulambda_switch - | Ustaticfail of int - | Ucatch of int * ulambda * ulambda + | Ustaticfail of int * ulambda list + | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 618ad17a8..3b707dded 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -32,8 +32,8 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list | Uswitch of ulambda * ulambda_switch - | Ustaticfail of int - | Ucatch of int * ulambda * ulambda + | Ustaticfail of int * ulambda list + | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index cca66460e..d887ac1af 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -52,8 +52,8 @@ let occurs_var var u = | Uswitch(arg, s) -> occurs arg or occurs_array s.us_cases_consts or occurs_array s.us_cases_blocks - | Ustaticfail _ -> false - | Ucatch(_, body, hdlr) -> occurs body or occurs hdlr + | Ustaticfail (_, args) -> List.exists occurs args + | Ucatch(_, _, body, hdlr) -> occurs body or occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body or occurs hdlr | Uifthenelse(cond, ifso, ifnot) -> occurs cond or occurs ifso or occurs ifnot @@ -131,8 +131,8 @@ let lambda_smaller lam threshold = lambda_size lam; lambda_array_size cases.us_cases_consts; lambda_array_size cases.us_cases_blocks - | Ustaticfail _ -> () - | Ucatch(_, body, handler) -> + | Ustaticfail (_,args) -> lambda_list_size args + | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler | Utrywith(body, id, handler) -> size := !size + 8; lambda_size body; lambda_size handler @@ -272,8 +272,8 @@ let rec substitute sb ulam = us_cases_consts = Array.map (substitute sb) sw.us_cases_consts; us_cases_blocks = Array.map (substitute sb) sw.us_cases_blocks; }) - | Ustaticfail _ -> ulam - | Ucatch(nfail, u1, u2) -> Ucatch(nfail, substitute sb u1, substitute sb u2) + | Ustaticfail (nfail, args) -> Ustaticfail (nfail, List.map (substitute sb) args) + | Ucatch(nfail, ids, u1, u2) -> Ucatch(nfail, ids, substitute sb u1, substitute sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) @@ -410,6 +410,8 @@ let close_approx_var fenv cenv id = let close_var fenv cenv id = let (ulam, app) = close_approx_var fenv cenv id in ulam +exception Found of int + let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id @@ -529,17 +531,17 @@ let rec close fenv cenv = function us_checked = sw.sw_checked && not sw.sw_nofail}), Value_unknown) | Lstaticfail -> - (Ustaticfail 0, Value_unknown) - | Lstaticraise i -> - (Ustaticfail i, Value_unknown) + (Ustaticfail (0, []), Value_unknown) + | Lstaticraise (i, args) -> + (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lcatch(body, handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in - (Ucatch(0, ubody, uhandler), Value_unknown) - | Lstaticcatch(body, i, handler) -> + (Ucatch(0, [], ubody, uhandler), Value_unknown) + | Lstaticcatch(body, (i, vars), handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in - (Ucatch(i, ubody, uhandler), Value_unknown) + (Ucatch(i, vars, ubody, uhandler), Value_unknown) | Ltrywith(body, id, handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in @@ -702,16 +704,30 @@ and close_switch fenv cenv nofail num_keys cases = (* if nofail holds, then static fail is replaced by a random branch *) if List.length cases < num_keys && not nofail then begin num_cases := 1; - ucases := [Ustaticfail 0] + ucases := [Ustaticfail (0,[])] end ; + let store act = + let rec store_rec i = function + | [] -> [act] + | act0::rem -> + if act0 = act then raise (Found i) + else + act0 :: store_rec (i+1) rem in + try + ucases := store_rec 0 !ucases ; + let r = !num_cases in + incr num_cases ; + r + with + | Found i -> i in + List.iter (function (key, lam) -> let (ulam, _) = close fenv cenv lam in - ucases := ulam :: !ucases; - index.(key) <- !num_cases; - incr num_cases) + index.(key) <- store ulam) cases; - (index, Array.of_list(List.rev !ucases)) + + (index, Array.of_list !ucases) (* The entry point *) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index c85c047a7..6fa7203b6 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -100,8 +100,8 @@ type expression = | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array | Cloop of expression - | Ccatch of int * expression * expression - | Cexit of int + | Ccatch of int * Ident.t list * expression * expression + | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression type fundecl = diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 6c052a4a1..fd2892899 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -86,8 +86,8 @@ type expression = | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array | Cloop of expression - | Ccatch of int * expression * expression - | Cexit of int + | Ccatch of int * Ident.t list * expression * expression + | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression type fundecl = diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index c2c5bd36b..326792a82 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -206,7 +206,8 @@ let subst_boxed_float boxed_id unboxed_id exp = | Cswitch(arg, index, cases) -> Cswitch(subst arg, index, Array.map subst cases) | Cloop e -> Cloop(subst e) - | Ccatch(io, e1, e2) -> Ccatch(io, subst e1, subst e2) + | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) + | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) | e -> e in let res = subst exp in @@ -225,8 +226,8 @@ let rec remove_unit = function Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) | Cswitch(sel, index, cases) -> Cswitch(sel, index, Array.map remove_unit cases) - | Ccatch(io, body, handler) -> - Ccatch(io, remove_unit body, remove_unit handler) + | Ccatch(io, ids, body, handler) -> + Ccatch(io, ids, remove_unit body, remove_unit handler) | Ctrywith(body, exn, handler) -> Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> @@ -235,7 +236,7 @@ let rec remove_unit = function Cop(Capply typ_void, args) | Cop(Cextcall(proc, mty, alloc), args) -> Cop(Cextcall(proc, typ_void, alloc), args) - | Cexit _ as c -> c + | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) @@ -406,7 +407,7 @@ let transl_constant = function int_const n | Const_base(Const_char c) -> Cconst_int(((Char.code c) lsl 1) + 1) - | Const_pointer n -> + | Const_pointer n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer(Nativeint.add @@ -604,6 +605,104 @@ let simplif_primitive p = | p -> if size_int = 8 then p else simplif_primitive_32bits p +(* Build switchers both for constants and blocks *) + +(* constants first *) + +let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) + +exception Found of int + +let make_switch_gen arg cases acts = + let min_key,_,_ = cases.(0) + and _,max_key,_ = cases.(Array.length cases-1) in + let new_cases = Array.create (max_key-min_key+1) 0 + and actions = ref [] + and n_acts = ref 0 in + + let store act = + let rec store_rec i = function + | [] -> [act] + | act0::rem -> + if act0 = act then + raise (Found i) + else + act0::(store_rec (i+1) rem) in + try + actions := store_rec 0 !actions ; + let r = !n_acts in + incr n_acts ; + r + with + | Found i -> i in + + for i = 0 to Array.length cases-1 do + let l,h,act = cases.(i) in + let new_act = store act in + for j = l to h do + new_cases.(j-min_key) <- new_act + done + done ; + Cswitch + (arg, new_cases, + Array.map + (fun n -> acts.(n)) + (Array.of_list !actions)) + +(* +module SArgConst = +struct + type primitive = operation + + let eqint = Ccmpi Ceq + let leint = Ccmpi Cle + let ltint = Ccmpi Clt + let geint = Ccmpi Cge + let gtint = Ccmpi Cgt + + type act = expression + + let default = Cexit (0,[]) + let make_prim p args = Cop (p,args) + let make_isout = transl_isout + let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) + let make_switch (nofail : bool) arg cases actions = + make_switch_gen + (fun n arg -> untag_int (add_const arg (n lsl 1))) + arg cases actions +end + +module SwitcherConsts = Switch.Make(SArgConst) +*) + +(* Then for blocks *) + +module SArgBlocks = +struct + type primitive = operation + + let eqint = Ccmpi Ceq + let neint = Ccmpi Cne + let leint = Ccmpi Cle + let ltint = Ccmpi Clt + let geint = Ccmpi Cge + let gtint = Ccmpi Cgt + + type act = expression + + let default = Cexit (0,[]) + let make_prim p args = Cop (p,args) + let make_offset arg n = add_const arg n + let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) + let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) + let make_switch arg cases actions = + make_switch_gen arg cases actions + let bind arg body = bind "switcher" arg body + +end + +module SwitcherBlocks = Switch.Make(SArgBlocks) + (* Translate an expression *) let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) @@ -618,32 +717,32 @@ let rec transl = function constant_closures := (lbl, fundecls) :: !constant_closures; List.iter (fun (label, arity, params, body) -> - Queue.add (label, params, body) functions) + Queue.add (label, params, body) functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> let block_size = fundecls_size fundecls + List.length clos_vars in let rec transl_fundecls pos = function - [] -> - List.map transl clos_vars - | (label, arity, params, body) :: rem -> - Queue.add (label, params, body) functions; - let header = - if pos = 0 - then alloc_closure_header block_size - else alloc_infix_header pos in - if arity = 1 then - header :: - Cconst_symbol label :: - int_const 1 :: - transl_fundecls (pos + 3) rem - else - header :: - Cconst_symbol(curry_function arity) :: - int_const arity :: - Cconst_symbol label :: - transl_fundecls (pos + 4) rem in + [] -> + List.map transl clos_vars + | (label, arity, params, body) :: rem -> + Queue.add (label, params, body) functions; + let header = + if pos = 0 + then alloc_closure_header block_size + else alloc_infix_header pos in + if arity = 1 then + header :: + Cconst_symbol label :: + int_const 1 :: + transl_fundecls (pos + 3) rem + else + header :: + Cconst_symbol(curry_function arity) :: + int_const arity :: + Cconst_symbol label :: + transl_fundecls (pos + 4) rem in Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> field_address (transl arg) offset @@ -655,19 +754,19 @@ let rec transl = function | Ugeneric_apply(clos, args) -> let arity = List.length args in let cargs = Cconst_symbol(apply_function arity) :: - List.map transl (args @ [clos]) in + List.map transl (args @ [clos]) in Cop(Capply typ_addr, cargs) | Usend(met, obj, []) -> bind "obj" (transl obj) (fun obj -> - bind "met" (lookup_label obj (transl met)) (fun clos -> - Cop(Capply typ_addr, [get_field clos 0; obj; clos]))) + bind "met" (lookup_label obj (transl met)) (fun clos -> + Cop(Capply typ_addr, [get_field clos 0; obj; clos]))) | Usend(met, obj, args) -> let arity = List.length args + 1 in bind "obj" (transl obj) (fun obj -> - bind "met" (lookup_label obj (transl met)) (fun clos -> - let cargs = Cconst_symbol(apply_function arity) :: - obj :: (List.map transl args) @ [clos] in - Cop(Capply typ_addr, cargs))) + bind "met" (lookup_label obj (transl met)) (fun clos -> + let cargs = Cconst_symbol(apply_function arity) :: + obj :: (List.map transl args) @ [clos] in + Cop(Capply typ_addr, cargs))) | Ulet(id, exp, body) -> if is_unboxed_float exp then begin let unboxed_id = Ident.create (Ident.name id) in @@ -694,7 +793,7 @@ let rec transl = function transl_constant(Const_block(tag, [])) | (Pmakeblock(tag, mut), args) -> Cop(Calloc, alloc_block_header tag (List.length args) :: - List.map transl args) + List.map transl args) | (Pccall prim, args) -> if prim.prim_native_float then box_float @@ -715,18 +814,18 @@ let rec transl = function Pgenarray -> Cop(Cextcall("make_array", typ_addr, true), [Cop(Calloc, alloc_block_header 0 (List.length args) :: - List.map transl args)]) + List.map transl args)]) | Paddrarray | Pintarray -> Cop(Calloc, alloc_block_header 0 (List.length args) :: - List.map transl args) + List.map transl args) | Pfloatarray -> Cop(Calloc, alloc_floatarray_header (List.length args) :: - List.map transl_unbox_float args) + List.map transl_unbox_float args) end | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get elt_kind layout - (transl arg1) (List.map transl argl) in + (transl arg1) (List.map transl argl) in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt | Pbigarray_int32 -> box_int Pint32 elt @@ -740,12 +839,12 @@ let rec transl = function (transl arg1) (List.map transl argidx) (match elt_kind with - Pbigarray_float32 | Pbigarray_float64 -> - transl_unbox_float argnewval - | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval - | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval - | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval - | _ -> untag_int (transl argnewval)) + Pbigarray_float32 | Pbigarray_float64 -> + transl_unbox_float argnewval + | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval + | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval + | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval + | _ -> untag_int (transl argnewval)) | (p, [arg]) -> transl_prim_1 p arg | (p, [arg1; arg2]) -> @@ -763,63 +862,98 @@ let rec transl = function if Array.length s.us_index_blocks = 0 then if s.us_checked then bind "switch" (untag_int (transl arg)) (fun idx -> - Cifthenelse( - Cop(Ccmpa Cge, - [idx; Cconst_pointer(Array.length s.us_index_consts)]), - Cexit 0, - transl_switch idx s.us_index_consts s.us_cases_consts)) + Cifthenelse + (Cop(Ccmpa Cge, + [idx; Cconst_pointer(Array.length s.us_index_consts)]), + Cexit (0,[]), + Cswitch + (idx,s.us_index_consts, + Array.map transl s.us_cases_consts))) else - transl_switch (untag_int (transl arg)) - s.us_index_consts s.us_cases_consts + Cswitch + (untag_int (transl arg), + s.us_index_consts, + Array.map transl s.us_cases_consts) else if Array.length s.us_index_consts = 0 then transl_switch (get_tag (transl arg)) - s.us_index_blocks s.us_cases_blocks + s.us_index_blocks s.us_cases_blocks else bind "switch" (transl arg) (fun arg -> Cifthenelse( - Cop(Cand, [arg; Cconst_int 1]), - transl_switch (untag_int arg) s.us_index_consts s.us_cases_consts, - transl_switch (get_tag arg) s.us_index_blocks s.us_cases_blocks)) - | Ustaticfail nfail -> Cexit nfail - | Ucatch(nfail, body, handler) -> - Ccatch(nfail, transl body, transl handler) + Cop(Cand, [arg; Cconst_int 1]), + transl_switch (untag_int arg) s.us_index_consts s.us_cases_consts, + transl_switch (get_tag arg) + s.us_index_blocks s.us_cases_blocks)) + | Ustaticfail (nfail, args) -> + Cexit (nfail, List.map transl args) + | Ucatch(nfail, [], body, handler) -> + make_catch nfail (transl body) (transl handler) + | Ucatch(nfail, ids, body, handler) -> + Ccatch(nfail, ids, transl body, transl handler) | Utrywith(body, exn, handler) -> Ctrywith(transl body, exn, transl handler) | Uifthenelse(Uprim(Pnot, [arg]), ifso, ifnot) -> transl (Uifthenelse(arg, ifnot, ifso)) - | Uifthenelse(cond, ifso, Ustaticfail io) -> - exit_if_false cond (transl ifso) io - | Uifthenelse(cond, Ustaticfail io, ifnot) -> - exit_if_true cond io (transl ifnot) + | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> + exit_if_false cond (transl ifso) nfail + | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> + exit_if_true cond nfail (transl ifnot) | Uifthenelse(Uprim(Psequand, _) as cond, ifso, ifnot) -> - Ccatch(0, exit_if_false cond (transl ifso) 0, transl ifnot) + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_false cond (transl ifso) raise_num) + (transl ifnot) | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) -> - Ccatch(0, exit_if_true cond 0 (transl ifnot), transl ifso) + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_true cond raise_num (transl ifnot)) + (transl ifso) + | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) -> + let num_true = next_raise_count () in + make_catch + num_true + (make_catch2 + (fun shared_false -> + Cifthenelse + (test_bool (transl cond), + exit_if_true condso num_true shared_false, + exit_if_true condnot num_true shared_false)) + (transl ifnot)) + (transl ifso) | Uifthenelse(cond, ifso, ifnot) -> Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot) | Usequence(exp1, exp2) -> Csequence(remove_unit(transl exp1), transl exp2) | Uwhile(cond, body) -> + let raise_num = next_raise_count () in return_unit (Ccatch - (0, - Cloop(exit_if_false cond (remove_unit(transl body)) 0), + (raise_num, [], + Cloop(exit_if_false cond (remove_unit(transl body)) raise_num), Ctuple [])) | Ufor(id, low, high, dir, body) -> let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in + let raise_num = next_raise_count () in return_unit - (Clet(id, transl low, - bind_nonvar "bound" (transl high) (fun high -> - Ccatch - (0, - Cifthenelse(Cop(Ccmpi tst, [Cvar id; high]), Cexit 0, - Cloop( - Csequence(remove_unit(transl body), - Csequence(Cassign(id, Cop(inc, [Cvar id; Cconst_int 2])), - Cifthenelse(Cop(Ccmpi tst, [Cvar id; high]), - Cexit 0, Ctuple []))))), - Ctuple [])))) + (Clet + (id, transl low, + bind_nonvar "bound" (transl high) (fun high -> + Ccatch + (raise_num, [], + Cifthenelse + (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []), + Cloop + (Csequence + (remove_unit(transl body), + Csequence + (Cassign(id, Cop(inc, [Cvar id; Cconst_int 2])), + Cifthenelse + (Cop(Ccmpi tst, [Cvar id; high]), + Cexit (raise_num,[]), Ctuple []))))), + Ctuple [])))) | Uassign(id, exp) -> return_unit(Cassign(id, transl exp)) @@ -952,7 +1086,8 @@ and transl_prim_2 p arg1 arg2 = Cconst_int 1]) | Pintcomp cmp -> tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) - + | Pisout -> + transl_isout (transl arg1) (transl arg2) (* Float operations *) | Paddfloat -> box_float(Cop(Caddf, @@ -1146,35 +1281,111 @@ and transl_unbox_int bi = function Cconst_int i | exp -> unbox_int bi (transl exp) +and make_catch ncatch body handler = match body with +| Cexit (nexit,[]) when nexit=ncatch -> handler +| _ -> Ccatch (ncatch, [], body, handler) + +and make_catch2 mk_body handler = match handler with +| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ -> + mk_body handler +| _ -> + let nfail = next_raise_count () in + make_catch + nfail + (mk_body (Cexit (nfail,[]))) + handler + and exit_if_true cond nfail otherwise = match cond with - Uprim(Psequor, [arg1; arg2]) -> + | Uconst (Const_pointer 0) -> otherwise + | Uconst (Const_pointer 1) -> Cexit (nfail,[]) + | Uprim(Psequor, [arg1; arg2]) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) - | Uprim(Psequand, [arg1; arg2]) -> - Csequence(Ccatch(nfail, exit_if_true arg1 nfail (Ctuple []), - exit_if_true arg2 nfail (Ctuple [])), - otherwise) + | Uprim(Psequand, _) -> + begin match otherwise with + | Cexit (raise_num,[]) -> + exit_if_false cond (Cexit (nfail,[])) raise_num + | _ -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_false cond (Cexit (nfail,[])) raise_num) + otherwise + end | Uprim(Pnot, [arg]) -> exit_if_false arg otherwise nfail + | Uifthenelse (cond, ifso, ifnot) -> + make_catch2 + (fun shared -> + Cifthenelse + (test_bool (transl cond), + exit_if_true ifso nfail shared, + exit_if_true ifnot nfail shared)) + otherwise | _ -> - Cifthenelse(test_bool(transl cond), Cexit nfail, otherwise) + Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise) and exit_if_false cond otherwise nfail = match cond with - Uprim(Psequand, [arg1; arg2]) -> + | Uconst (Const_pointer 0) -> Cexit (nfail,[]) + | Uconst (Const_pointer 1) -> otherwise + | Uprim(Psequand, [arg1; arg2]) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail - | Uprim(Psequor, [arg1; arg2]) -> - Csequence(Ccatch(0, exit_if_false arg1 (Ctuple []) 0, - exit_if_false arg2 (Ctuple []) 0), - otherwise) + | Uprim(Psequor, _ ) -> + begin match otherwise with + | Cexit (raise_num,[]) -> + exit_if_true cond raise_num (Cexit (nfail,[])) + | _ -> + let raise_num = next_raise_count () in + make_catch + raise_num + (exit_if_true cond raise_num (Cexit (nfail,[]))) + otherwise + end | Uprim(Pnot, [arg]) -> exit_if_true arg nfail otherwise + | Uifthenelse (cond, ifso, ifnot) -> + make_catch2 + (fun shared -> + Cifthenelse + (test_bool (transl cond), + exit_if_false ifso shared nfail, + exit_if_false ifnot shared nfail)) + otherwise | _ -> - Cifthenelse(test_bool(transl cond), otherwise, Cexit nfail) - -and transl_switch arg index cases = - match Array.length index with - 1 -> transl cases.(0) + Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, [])) + +and transl_switch arg index cases = match Array.length cases with +| 1 -> transl cases.(0) +| _ -> + let n_index = Array.length index in + let actions = Array.map transl cases in + + let inters = ref [] + and this_high = ref (n_index-1) + and this_low = ref (n_index-1) + and this_act = ref index.(n_index-1) in + for i = n_index-2 downto 0 do + let act = index.(i) in + if act = !this_act then + decr this_low + else begin + inters := (!this_low, !this_high, !this_act) :: !inters ; + this_high := i ; + this_low := i ; + this_act := act + end + done ; + inters := (0, !this_high, !this_act) :: !inters ; + + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (fun i -> Cconst_int i) + a (Switch.Int 0) (Switch.Int (n_index-1)) + (Array.of_list !inters) actions) + +(* OLD CODE | 2 -> Cifthenelse(arg, transl cases.(index.(1)), transl cases.(index.(0))) | _ -> (* Determine whether all actions minus one or two are equal to @@ -1183,20 +1394,22 @@ and transl_switch arg index cases = let key1 = ref (-1) in let key2 = ref (-1) in for i = 0 to Array.length index - 1 do - if cases.(index.(i)) = Ustaticfail 0 then incr num_fail + if cases.(index.(i)) = Ustaticfail (0, []) then incr num_fail else if !key1 < 0 then key1 := i else if !key2 < 0 then key2 := i done; match Array.length index - !num_fail with - 0 -> Csequence(arg, Cexit 0) + 0 -> Csequence(arg, Cexit (0, [])) | 1 -> Cifthenelse(Cop(Ccmpi Ceq, [arg; Cconst_int !key1]), - transl cases.(index.(!key1)), Cexit 0) + transl cases.(index.(!key1)), Cexit (0, [])) | 2 -> bind "test" arg (fun a -> Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key1]), transl cases.(index.(!key1)), Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key2]), - transl cases.(index.(!key2)), Cexit 0))) + transl cases.(index.(!key2)), + Cexit (0, [])))) | _ -> Cswitch(arg, index, Array.map transl cases) +OLD CODE *) and transl_letrec bindings cont = let rec init_blocks = function diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index c7dd6ea0e..c1beb3359 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -69,6 +69,7 @@ let label_prefix = let emit_label lbl = emit_string label_prefix; emit_int lbl + (* Some data directives have different names under Solaris *) let word_dir = @@ -95,6 +96,11 @@ let emit_align = | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) +let emit_Llabel failthrough lbl = + if not failthrough && !fastcode_flag then + emit_align 16 ; + emit_label lbl + (* Output a pseudo-register *) let emit_reg = function @@ -278,7 +284,8 @@ let float_constants = ref ([] : (int * string) list) let tos = phys_reg 100 -let emit_instr i = + +let emit_instr failthrough i = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -559,7 +566,7 @@ let emit_instr i = output_epilogue(); ` ret\n` | Llabel lbl -> - `{emit_label lbl}:\n` + `{emit_Llabel failthrough lbl}:\n` | Lbranch lbl -> ` jmp {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> @@ -692,8 +699,15 @@ let emit_instr i = ` popl {emit_symbol "caml_exception_pointer"}\n`; ` ret\n` -let rec emit_all i = - match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next +let rec emit_all failthrough i = + + match i.desc with + | Lend -> () + | _ -> + emit_instr failthrough i; + emit_all + (Linearize.has_failthrough i.desc) + i.next (* Emission of the floating-point constants *) @@ -736,7 +750,7 @@ let fundecl fundecl = call_gc_sites := []; range_check_trap := 0; ` .text\n`; - emit_align 4; + emit_align 16; ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; if !Clflags.gprofile then emit_profile(); @@ -744,7 +758,7 @@ let fundecl fundecl = if n > 0 then ` subl ${emit_int n}, %esp\n`; `{emit_label !tailrec_entry_point}:\n`; - emit_all fundecl.fun_body; + emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; if !range_check_trap > 0 then `{emit_label !range_check_trap}: call {emit_symbol "caml_array_bound_error"}\n`; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index b98cb5ef2..d23657ad8 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -45,6 +45,11 @@ and instruction_desc = | Lpoptrap | Lraise +let has_failthrough = function + | Lreturn | Lbranch _ | Lswitch _ | Lraise + | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | _ -> true + type fundecl = { fun_name: string; fun_body: instruction; @@ -91,15 +96,24 @@ let copy_instr d i n = { desc = d; next = n; arg = i.Mach.arg; res = i.Mach.res; live = i.Mach.live } -(* Label the beginning of the given instruction sequence. - If the sequence starts with a branch, jump over it. *) +(* + Label the beginning of the given instruction sequence. + - If the sequence starts with a branch, jump over it. + - If the sequence is the end, (tail call position), just do nothing +*) -let get_label n = - match n.desc with +let get_label n = match n.desc with Lbranch lbl -> (lbl, n) | Llabel lbl -> (lbl, n) + | Lend -> (-1, n) | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) +(* Check the failthrough label *) +let check_label n = match n.desc with + | Lbranch lbl -> lbl + | Llabel lbl -> lbl + | _ -> -1 + (* Discard all instructions up to the next label. This function is to be called before adding a non-terminating instruction. *) @@ -114,15 +128,21 @@ let rec discard_dead_code n = | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next -(* Add a branch in front of a continuation. +(* + Add a branch in front of a continuation. Discard dead code in the continuation. - Does not insert anything if we're just falling through. *) + Does not insert anything if we're just falling through + or if we jump to dead code after the end of function (lbl=-1) +*) let add_branch lbl n = - let n1 = discard_dead_code n in - match n1.desc with - Llabel lbl1 when lbl1 = lbl -> n1 - | _ -> cons_instr (Lbranch lbl) n1 + if lbl >= 0 then + let n1 = discard_dead_code n in + match n1.desc with + | Llabel lbl1 when lbl1 = lbl -> n1 + | _ -> cons_instr (Lbranch lbl) n1 + else + discard_dead_code n (* Current labels for exit handler *) @@ -134,6 +154,10 @@ let find_exit_label k = with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" +let is_next_catch n = match !exit_label with +| (n0,_)::_ when n0=n -> true +| _ -> false + (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = @@ -158,9 +182,14 @@ let rec linear i n = copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) + | Iexit nfail1, Iexit nfail2, _ + when is_next_catch nfail1 -> + let lbl2 = find_exit_label nfail2 in + copy_instr + (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) | Iexit nfail, _, _ -> - let n2 = linear ifnot n1 in - let lbl = find_exit_label nfail in + let n2 = linear ifnot n1 + and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 | _, Iexit nfail, _ -> let n2 = linear ifso n1 in @@ -193,8 +222,7 @@ let rec linear i n = (* Switches with 1 and 2 branches have been eliminated earlier. Here, we do something for switches with 3 branches. *) if Array.length index = 3 then begin - let fallthrough_lbl = - match !n2.desc with Llabel lbl -> lbl | _ -> -1 in + let fallthrough_lbl = check_label !n2 in let find_label n = let lbl = lbl_cases.(index.(n)) in if lbl = fallthrough_lbl then None else Some lbl in diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index b2666b7d4..989ca754a 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -39,6 +39,7 @@ and instruction_desc = | Lpoptrap | Lraise +val has_failthrough : instruction_desc -> bool val end_instr: instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 1367b4b36..f887ed6de 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -144,12 +144,19 @@ let rec expr ppf = function fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases | Cloop e -> fprintf ppf "@[<2>(loop@ %a)@]" sequence e - | Ccatch(i, e1, e2) -> + | Ccatch(i, ids, e1, e2) -> fprintf ppf - "@[<2>(catch@ %a@;<1 -2>with(%d)@ %a)@]" - sequence e1 i sequence e2 - | Cexit i -> - fprintf ppf "exit(%d)" i + "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]" + sequence e1 i + (fun ppf ids -> + List.iter + (fun id -> fprintf ppf " %a" Ident.print id) + ids) ids + sequence e2 + | Cexit (i, el) -> + fprintf ppf "@[<2>(exit %d" i ; + List.iter (fun e -> fprintf ppf "@ %a" expr e) el; + fprintf ppf ")@]" | Ctrywith(e1, id, e2) -> fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" sequence e1 Ident.print id sequence e2 diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 88793aad1..be1aa6c85 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -174,6 +174,9 @@ let join_array rs = res end +(* Registers for catch contructs *) +let catch_regs = ref [] + (* The default instruction selection class *) class virtual selector_generic = object (self) @@ -301,8 +304,12 @@ method select_condition = function (Iinttest(Isigned cmp), Ctuple args) | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) + | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned cmp, n), arg1) | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) + | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n -> + (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) | Cop(Ccmpa cmp, args) -> (Iinttest(Iunsigned cmp), Ctuple args) | Cop(Ccmpf cmp, args) -> @@ -477,13 +484,34 @@ method emit_expr env exp = let (rarg, sbody) = self#emit_sequence env ebody in self#insert (Iloop(sbody#extract)) [||] [||]; [||] - | Ccatch(nfail, e1, e2) -> + | Ccatch(nfail, ids, e1, e2) -> + let rs = + List.map + (fun id -> + let r = Reg.createv typ_addr in + name_regs id r ; + r) + ids in + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; let (r1, s1) = self#emit_sequence env e1 in - let (r2, s2) = self#emit_sequence env e2 in + catch_regs := List.tl !catch_regs ; + let new_env = + List.fold_left + (fun env (id,r) -> Tbl.add id r env) + env (List.combine ids rs) in + let (r2, s2) = self#emit_sequence new_env e2 in let r = join r1 s1 r2 s2 in self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||]; r - | Cexit nfail -> + | Cexit (nfail,args) -> + let (simple_list, ext_env) = self#emit_parts_list env args in + let src = self#emit_tuple ext_env simple_list in + let dest = + try List.assoc nfail !catch_regs with + | Not_found -> + Misc.fatal_error + ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in + self#insert_moves src dest ; self#insert (Iexit nfail) [||] [||]; [||] | Ctrywith(e1, v, e2) -> @@ -648,6 +676,7 @@ method emit_tail env exp = let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; self#insert Iraise rd [||] + | Cexit (_,_) -> ignore (self#emit_expr env exp) | Csequence(e1, e2) -> let _ = self#emit_expr env e1 in self#emit_tail env e2 @@ -662,12 +691,23 @@ method emit_tail env exp = self#insert (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases)) rsel [||] - | Ccatch(io, e1, e2) -> - self#insert (Icatch(io, self#emit_tail_sequence env e1, - self#emit_tail_sequence env e2)) - [||] [||] - | Cexit io -> - self#insert (Iexit io) [||] [||] + | Ccatch(nfail, ids, e1, e2) -> + let rs = + List.map + (fun id -> + let r = Reg.createv typ_addr in + name_regs id r ; + r) + ids in + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; + let s1 = self#emit_tail_sequence env e1 in + catch_regs := List.tl !catch_regs ; + let new_env = + List.fold_left + (fun env (id,r) -> Tbl.add id r env) + env (List.combine ids rs) in + let s2 = self#emit_tail_sequence new_env e2 in + self#insert (Icatch(nfail, s1, s2)) [||] [||] | Ctrywith(e1, v, e2) -> Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 24d957b9c..a459e5764 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -250,8 +250,13 @@ let rec reload i before = (* As an optimization, if a register needs to be spilled in one branch of a conditional but not in the other, then we spill it late on entrance in the branch that needs it spilled. - This strategy is turned off in loops, as it may prevent a spill from - being lifted up all the way out of the loop. *) + NB: This strategy is turned off in loops, as it may prevent a spill from + being lifted up all the way out of the loop. + NB again: This strategy is also turned off when one of the branch is + Iexit, as it generates many useless spills inside switch arms + NB ter: I am sure that, as implemented, this strategy generates useless + spills inside switches arms *) + let spill_at_exit = ref [] let find_spill_at_exit k = @@ -296,7 +301,11 @@ let rec spill i finally = let (new_next, at_join) = spill i.next finally in let (new_ifso, before_ifso) = spill ifso at_join in let (new_ifnot, before_ifnot) = spill ifnot at_join in - if !inside_loop then + if + !inside_loop || + (match new_ifso.desc with Iexit _ -> true | _ -> false) || + (match new_ifnot.desc with Iexit _ -> true | _ -> false) + then (instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) i.arg i.res new_next, Reg.Set.union before_ifso before_ifnot) |