diff options
| -rw-r--r-- | .depend | 89 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | asmcomp/clambda.ml | 5 | ||||
| -rw-r--r-- | asmcomp/clambda.mli | 5 | ||||
| -rw-r--r-- | asmcomp/closure.ml | 103 | ||||
| -rw-r--r-- | asmcomp/cmmgen.ml | 81 | ||||
| -rw-r--r-- | asmcomp/spill.ml | 23 |
7 files changed, 126 insertions, 182 deletions
@@ -69,7 +69,8 @@ typing/includemod.cmi: typing/ctype.cmi typing/env.cmi typing/ident.cmi \ typing/typedtree.cmi typing/types.cmi typing/mtype.cmi: typing/env.cmi typing/ident.cmi typing/path.cmi \ typing/types.cmi -typing/parmatch.cmi: typing/env.cmi parsing/location.cmi typing/typedtree.cmi +typing/parmatch.cmi: typing/env.cmi parsing/location.cmi typing/typedtree.cmi \ + typing/types.cmi typing/path.cmi: typing/ident.cmi typing/predef.cmi: typing/ident.cmi typing/path.cmi typing/types.cmi typing/printtyp.cmi: typing/ident.cmi parsing/longident.cmi typing/path.cmi \ @@ -268,10 +269,12 @@ bytecomp/typeopt.cmi: bytecomp/lambda.cmi typing/path.cmi \ typing/typedtree.cmi bytecomp/bytegen.cmo: parsing/asttypes.cmi typing/ident.cmi \ bytecomp/instruct.cmi bytecomp/lambda.cmi utils/misc.cmi \ - typing/primitive.cmi typing/types.cmi bytecomp/bytegen.cmi + typing/primitive.cmi bytecomp/switch.cmi typing/types.cmi \ + bytecomp/bytegen.cmi bytecomp/bytegen.cmx: parsing/asttypes.cmi typing/ident.cmx \ bytecomp/instruct.cmx bytecomp/lambda.cmx utils/misc.cmx \ - typing/primitive.cmx typing/types.cmx bytecomp/bytegen.cmi + typing/primitive.cmx bytecomp/switch.cmx typing/types.cmx \ + bytecomp/bytegen.cmi bytecomp/bytelibrarian.cmo: utils/clflags.cmo utils/config.cmi \ bytecomp/emitcode.cmi utils/misc.cmi bytecomp/bytelibrarian.cmi bytecomp/bytelibrarian.cmx: utils/clflags.cmx utils/config.cmx \ @@ -306,14 +309,14 @@ bytecomp/lambda.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ bytecomp/lambda.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ utils/misc.cmx typing/path.cmx typing/primitive.cmx typing/types.cmx \ bytecomp/lambda.cmi -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/matching.cmo: parsing/asttypes.cmi typing/btype.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 bytecomp/switch.cmi typing/typedtree.cmi \ bytecomp/typeopt.cmi typing/types.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/matching.cmx: parsing/asttypes.cmi typing/btype.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 bytecomp/switch.cmx typing/typedtree.cmx \ bytecomp/typeopt.cmx typing/types.cmx bytecomp/matching.cmi bytecomp/meta.cmo: bytecomp/meta.cmi @@ -331,11 +334,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 utils/misc.cmi bytecomp/simplif.cmi + bytecomp/lambda.cmi bytecomp/simplif.cmi bytecomp/simplif.cmx: parsing/asttypes.cmi utils/clflags.cmx typing/ident.cmx \ - 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/lambda.cmx bytecomp/simplif.cmi +bytecomp/switch.cmo: utils/misc.cmi bytecomp/switch.cmi +bytecomp/switch.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 \ @@ -416,8 +419,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 \ @@ -454,12 +455,12 @@ asmcomp/clambda.cmx: parsing/asttypes.cmi typing/ident.cmx \ bytecomp/lambda.cmx asmcomp/clambda.cmi asmcomp/closure.cmo: parsing/asttypes.cmi asmcomp/clambda.cmi \ utils/clflags.cmo asmcomp/compilenv.cmi typing/ident.cmi \ - bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi utils/tbl.cmi \ - asmcomp/closure.cmi + bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \ + bytecomp/switch.cmi utils/tbl.cmi asmcomp/closure.cmi asmcomp/closure.cmx: parsing/asttypes.cmi asmcomp/clambda.cmx \ utils/clflags.cmx asmcomp/compilenv.cmx typing/ident.cmx \ - bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx utils/tbl.cmx \ - asmcomp/closure.cmi + bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \ + bytecomp/switch.cmx utils/tbl.cmx asmcomp/closure.cmi asmcomp/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi asmcomp/cmmgen.cmo: asmcomp/arch.cmo parsing/asttypes.cmi asmcomp/clambda.cmi \ @@ -490,13 +491,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 @@ -528,16 +529,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 \ @@ -546,10 +547,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 @@ -557,10 +556,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 @@ -631,13 +630,13 @@ driver/opterrors.cmx: asmcomp/asmgen.cmx asmcomp/asmlibrarian.cmx \ typing/typecore.cmx typing/typedecl.cmx typing/typemod.cmx \ typing/typetexp.cmx driver/opterrors.cmi driver/optmain.cmo: asmcomp/asmlibrarian.cmi asmcomp/asmlink.cmi \ - utils/clflags.cmo utils/config.cmi driver/optcompile.cmi \ - driver/opterrors.cmi asmcomp/printmach.cmi utils/warnings.cmi \ - driver/optmain.cmi + utils/clflags.cmo utils/config.cmi bytecomp/matching.cmi \ + driver/optcompile.cmi driver/opterrors.cmi asmcomp/printmach.cmi \ + bytecomp/switch.cmi utils/warnings.cmi driver/optmain.cmi driver/optmain.cmx: asmcomp/asmlibrarian.cmx asmcomp/asmlink.cmx \ - utils/clflags.cmx utils/config.cmx driver/optcompile.cmx \ - driver/opterrors.cmx asmcomp/printmach.cmx utils/warnings.cmx \ - driver/optmain.cmi + utils/clflags.cmx utils/config.cmx bytecomp/matching.cmx \ + driver/optcompile.cmx driver/opterrors.cmx asmcomp/printmach.cmx \ + bytecomp/switch.cmx utils/warnings.cmx driver/optmain.cmi toplevel/genprintval.cmi: typing/env.cmi typing/path.cmi typing/types.cmi toplevel/topdirs.cmi: parsing/longident.cmi toplevel/toploop.cmi: typing/env.cmi parsing/location.cmi \ @@ -222,7 +222,7 @@ install: FORCE cp toplevel/topmain.cmo $(LIBDIR) cp toplevel/toploop.cmi toplevel/topdirs.cmi $(LIBDIR) cd tools; $(MAKE) install - cd man; $(MAKE) install + -cd man; $(MAKE) install set -e; for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) install); done if test -f ocamlopt; then $(MAKE) installopt; else :; fi if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); else :; fi diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 5ff0c70aa..c854b3ac7 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -44,10 +44,9 @@ type ulambda = and ulambda_switch = { us_index_consts: int array; - us_cases_consts: ulambda array; + us_actions_consts : ulambda array; us_index_blocks: int array; - us_cases_blocks: ulambda array; - us_checked: bool} + us_actions_blocks: ulambda array} (* Description of known functions *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 3b707dded..31ff125ce 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -44,10 +44,9 @@ type ulambda = and ulambda_switch = { us_index_consts: int array; - us_cases_consts: ulambda array; + us_actions_consts: ulambda array; us_index_blocks: int array; - us_cases_blocks: ulambda array; - us_checked: bool } + us_actions_blocks: ulambda array} (* Description of known functions *) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index eb87846fb..77c36095b 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -18,6 +18,7 @@ open Misc open Asttypes open Primitive open Lambda +open Switch open Clambda (* Auxiliaries for compiling functions *) @@ -50,8 +51,8 @@ let occurs_var var u = List.exists (fun (id, u) -> occurs u) decls || occurs body | Uprim(p, args) -> List.exists occurs args | Uswitch(arg, s) -> - occurs arg || occurs_array s.us_cases_consts - || occurs_array s.us_cases_blocks + occurs arg || + occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -101,6 +102,8 @@ let prim_size prim args = | Pbigarrayset(ndims, _, _) -> 4 + ndims * 6 | _ -> 2 (* arithmetic and comparisons *) +(* Very raw approximation of switch cost *) + let lambda_smaller lam threshold = let size = ref 0 in let rec lambda_size lam = @@ -127,12 +130,11 @@ let lambda_smaller lam threshold = size := !size + prim_size prim args; lambda_list_size args | Uswitch(lam, cases) -> - if Array.length cases.us_cases_consts > 0 then size := !size + 5; - if Array.length cases.us_cases_blocks > 0 then size := !size + 5; - if cases.us_checked then size := !size + 2; + if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; + if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; lambda_size lam; - lambda_array_size cases.us_cases_consts; - lambda_array_size cases.us_cases_blocks + lambda_array_size cases.us_actions_consts ; + lambda_array_size cases.us_actions_blocks | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -271,8 +273,10 @@ let rec substitute sb ulam = | Uswitch(arg, sw) -> Uswitch(substitute sb arg, { sw with - us_cases_consts = Array.map (substitute sb) sw.us_cases_consts; - us_cases_blocks = Array.map (substitute sb) sw.us_cases_blocks; + us_actions_consts = + Array.map (substitute sb) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute sb) sw.us_actions_blocks; }) | Ustaticfail (nfail, args) -> Ustaticfail (nfail, List.map (substitute sb) args) @@ -522,27 +526,21 @@ let rec close fenv cenv = function Value_unknown) | Lprim(p, args) -> simplif_prim p (close_list_approx fenv cenv args) - | Lswitch(arg, sw) -> + | Lswitch(arg, sw) as l -> +(* NB: failaction might get copied, thus it should be some Lstaticraise *) let (uarg, _) = close fenv cenv arg in - let (const_index, const_cases) = - close_switch fenv cenv sw.sw_nofail sw.sw_numconsts sw.sw_consts in - let (block_index, block_cases) = - close_switch fenv cenv sw.sw_nofail sw.sw_numblocks sw.sw_blocks in + let const_index, const_actions = + close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction + and block_index, block_actions = + close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in (Uswitch(uarg, {us_index_consts = const_index; - us_cases_consts = const_cases; + us_actions_consts = const_actions; us_index_blocks = block_index; - us_cases_blocks = block_cases; - us_checked = sw.sw_checked && not sw.sw_nofail}), + us_actions_blocks = block_actions}), Value_unknown) - | Lstaticfail -> - (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, vars), handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in @@ -698,41 +696,32 @@ and close_one_function fenv cenv id funct = (* Close a switch *) -and close_switch fenv cenv nofail num_keys cases = - match cases, nofail with - | [], true -> - [| |], [| |] (* no need to switch here *) - | _,_ -> - let index = Array.create num_keys 0 in - let ucases = ref [] - and num_cases = ref 0 in -(* 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,[])] - 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 - +and close_switch fenv cenv cases num_keys default = + let index = Array.create num_keys 0 + and store = mk_store Pervasives.(=) in + + (* First default case *) + begin match default with + | Some def when List.length cases < num_keys -> + ignore (store.act_store def) + | _ -> () + end ; + (* Then all other cases *) List.iter - (function (key, lam) -> - let (ulam, _) = close fenv cenv lam in - index.(key) <- store ulam) - cases; - - (index, Array.of_list !ucases) + (fun (key,lam) -> + index.(key) <- store.act_store lam) + cases ; + (* Compile action *) + let actions = + Array.map + (fun lam -> + let ulam,_ = close fenv cenv lam in + ulam) + (store.act_get ()) in + match actions with + | [| |] -> [| |], [| |] (* May happen when default is None *) + | _ -> index, actions + (* The entry point *) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index acbcce49b..d5b68e584 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -579,29 +579,12 @@ 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 + let new_cases = Array.create (max_key-min_key+1) 0 in + let store = Switch.mk_store (=) in for i = 0 to Array.length cases-1 do let l,h,act = cases.(i) in - let new_act = store act in + let new_act = store.Switch.act_store act in for j = l to h do new_cases.(j-min_key) <- new_act done @@ -610,33 +593,8 @@ let make_switch_gen arg cases acts = (arg, new_cases, Array.map (fun n -> acts.(n)) - (Array.of_list !actions)) + (store.Switch.act_get ())) -(* -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 *) @@ -899,30 +857,21 @@ let rec transl = function (* As in the bytecode interpreter, only matching against constants can be checked *) 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,[]), - Cswitch - (idx,s.us_index_consts, - Array.map transl s.us_cases_consts))) - else - Cswitch - (untag_int (transl arg), - s.us_index_consts, - Array.map transl s.us_cases_consts) + Cswitch + (untag_int (transl arg), + s.us_index_consts, + Array.map transl s.us_actions_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_actions_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)) + transl_switch + (untag_int arg) s.us_index_consts s.us_actions_consts, + transl_switch + (get_tag arg) s.us_index_blocks s.us_actions_blocks)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) | Ucatch(nfail, [], body, handler) -> @@ -1407,6 +1356,7 @@ and exit_if_false cond otherwise nfail = Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, [])) and transl_switch arg index cases = match Array.length cases with +| 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> let n_index = Array.length index in @@ -1498,9 +1448,10 @@ let rec transl_all_functions already_translated cont = let (lbl, params, body) = Queue.take functions in if StringSet.mem lbl already_translated then transl_all_functions already_translated cont - else + else begin transl_all_functions (StringSet.add lbl already_translated) (transl_function lbl params body :: cont) + end with Queue.Empty -> cont diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index a459e5764..38c990b3f 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -247,15 +247,16 @@ let rec reload i before = That is, any register that may be reloaded in the future must be spilled just after its definition. *) -(* As an optimization, if a register needs to be spilled in one branch of +(* + 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. 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 *) + NB again: This strategy is also off in switch arms + as it generates many useless spills inside switch arms + NB ter: is it the same thing for catch bodies ? +*) let spill_at_exit = ref [] @@ -267,6 +268,8 @@ let find_spill_at_exit k = let spill_at_raise = ref Reg.Set.empty let inside_loop = ref false +and inside_arm = ref false +and inside_catch = ref false let add_spills regset i = Reg.Set.fold @@ -302,9 +305,7 @@ let rec spill i finally = let (new_ifso, before_ifso) = spill ifso at_join in let (new_ifnot, before_ifnot) = spill ifnot at_join in if - !inside_loop || - (match new_ifso.desc with Iexit _ -> true | _ -> false) || - (match new_ifnot.desc with Iexit _ -> true | _ -> false) + !inside_loop || !inside_arm then (instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) i.arg i.res new_next, @@ -325,6 +326,8 @@ let rec spill i finally = end | Iswitch(index, cases) -> let (new_next, at_join) = spill i.next finally in + let saved_inside_arm = !inside_arm in + inside_arm := true ; let before = ref Reg.Set.empty in let new_cases = Array.map @@ -333,6 +336,7 @@ let rec spill i finally = before := Reg.Set.union !before before_c; new_c) cases in + inside_arm := saved_inside_arm ; (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next, !before) | Iloop(body) -> @@ -358,9 +362,12 @@ let rec spill i finally = | Icatch(nfail, body, handler) -> let (new_next, at_join) = spill i.next finally in let (new_handler, at_exit) = spill handler at_join in + let saved_inside_catch = !inside_catch in + inside_catch := true ; spill_at_exit := (nfail, at_exit) :: !spill_at_exit ; let (new_body, before) = spill body at_join in spill_at_exit := List.tl !spill_at_exit; + inside_catch := saved_inside_catch ; (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, before) | Iexit nfail -> |