diff options
| -rw-r--r-- | asmcomp/closure.ml | 54 | ||||
| -rw-r--r-- | bytecomp/semantics_of_primitives.ml | 140 | ||||
| -rw-r--r-- | bytecomp/semantics_of_primitives.mli | 2 |
3 files changed, 15 insertions, 181 deletions
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 562a60c96e..6d3eb15767 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -210,12 +210,6 @@ let lambda_smaller lam threshold = with Exit -> false -let is_pure_prim p = - let open Semantics_of_primitives in - match Semantics_of_primitives.for_primitive p with - | (No_effects | Only_generative_effects), _ -> true - | Arbitrary_effects, _ -> false - let is_pure_clambda_prim p = let open Semantics_of_primitives in match Semantics_of_primitives.for_clambda_primitive p with @@ -745,23 +739,6 @@ let bind_params loc fpc params args body = (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) -let rec is_pure = function - Lvar _ -> true - | Lconst _ -> true - | Lprim(p, args,_) -> is_pure_prim p && List.for_all is_pure args - | Levent(lam, _ev) -> is_pure lam - | _ -> false - -let is_pure lam ulam = - let lam_pure = is_pure lam in - let ulam_pure = is_pure_clambda ulam in - if lam_pure && not ulam_pure then - Misc.fatal_errorf "mismatching purity:@.lam: %b@.%a@.clam: %b@.%a@.@." - lam_pure Printlambda.lambda lam - ulam_pure Printclambda.clambda ulam - else - lam_pure - let warning_if_forced_inline ~loc ~attribute warning = if attribute = Always_inline then Location.prerr_warning loc @@ -769,7 +746,7 @@ let warning_if_forced_inline ~loc ~attribute warning = (* Generate a direct application *) -let direct_apply fundesc funct ufunct uargs ~loc ~attribute = +let direct_apply fundesc ufunct uargs ~loc ~attribute = let app_args = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = @@ -787,7 +764,7 @@ let direct_apply fundesc funct ufunct uargs ~loc ~attribute = If the function is not closed, we evaluate ufunct as part of the arguments. If the function is closed, we force the evaluation of ufunct first. *) - if not fundesc.fun_closed || is_pure funct ufunct + if not fundesc.fun_closed || is_pure_clambda ufunct then app else Usequence(ufunct, app) @@ -803,10 +780,10 @@ let strengthen_approx appl approx = (* If a term has approximation Value_integer or Value_constptr and is pure, replace it by an integer constant *) -let check_constant_result lam ulam approx = +let check_constant_result ulam approx = match approx with - Value_const c when is_pure lam ulam -> make_const c - | Value_global_field (id, i) when is_pure lam ulam -> + Value_const c when is_pure_clambda ulam -> make_const c + | Value_global_field (id, i) when is_pure_clambda ulam -> begin match ulam with | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx) | _ -> @@ -820,8 +797,8 @@ let check_constant_result lam ulam approx = (* Evaluate an expression with known value for its side effects only, or discard it if it's pure *) -let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) = - if is_pure lam ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) +let sequence_constant_expr ulam1 (ulam2, approx2 as res2) = + if is_pure_clambda ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) (* Maintain the approximation of the global structure being defined *) @@ -900,12 +877,12 @@ let rec close fenv cenv = function [Uprim(P.Pmakeblock _, uargs, _)]) when List.length uargs = - fundesc.fun_arity -> let app = - direct_apply ~loc ~attribute fundesc funct ufunct uargs in + direct_apply ~loc ~attribute fundesc ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs = fundesc.fun_arity -> let app = - direct_apply ~loc ~attribute fundesc funct ufunct uargs in + direct_apply ~loc ~attribute fundesc ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) @@ -959,7 +936,7 @@ let rec close fenv cenv = function warning_if_forced_inline ~loc ~attribute "Over-application"; let body = Ugeneric_apply(direct_apply ~loc ~attribute - fundesc funct ufunct first_args, + fundesc ufunct first_args, rem_args, dbg) in let result = @@ -987,7 +964,7 @@ let rec close fenv cenv = function let (ubody, abody) = close fenv cenv body in (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) | (_, Value_const _) - when str = Alias || is_pure lam ulam -> + when str = Alias || is_pure_clambda ulam -> close (V.Map.add id alam fenv) cenv body | (_, _) -> let (ubody, abody) = close (V.Map.add id alam fenv) cenv body in @@ -1056,15 +1033,14 @@ let rec close fenv cenv = function ap_args=[arg]; ap_inlined=Default_inline; ap_specialised=Default_specialise}) - | Lprim(Pgetglobal id, [], loc) as lam -> + | Lprim(Pgetglobal id, [], loc) -> let dbg = Debuginfo.from_location loc in - check_constant_result lam - (getglobal dbg id) + check_constant_result (getglobal dbg id) (Compilenv.global_approx id) | Lprim(Pfield n, [lam], loc) -> let (ulam, approx) = close fenv cenv lam in let dbg = Debuginfo.from_location loc in - check_constant_result lam (Uprim(P.Pfield n, [ulam], dbg)) + check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) (field_approx n approx) | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> let (ulam, approx) = close fenv cenv lam in @@ -1143,7 +1119,7 @@ let rec close fenv cenv = function | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with (uarg, Value_const (Uconst_ptr n)) -> - sequence_constant_expr arg uarg + sequence_constant_expr uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> let (uifso, _) = close fenv cenv ifso in diff --git a/bytecomp/semantics_of_primitives.ml b/bytecomp/semantics_of_primitives.ml index 91a9dcf093..95084ea218 100644 --- a/bytecomp/semantics_of_primitives.ml +++ b/bytecomp/semantics_of_primitives.ml @@ -19,146 +19,6 @@ type effects = No_effects | Only_generative_effects | Arbitrary_effects type coeffects = No_coeffects | Has_coeffects -let for_primitive (prim : Lambda.primitive) = - match prim with - | Pignore | Pidentity -> - No_effects, No_coeffects - | Pbytes_to_string | Pbytes_of_string -> - No_effects, No_coeffects - | Pmakeblock _ - | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects - | Pmakearray (_, Immutable) -> No_effects, No_coeffects - | Pduparray (_, Immutable) -> - No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on - immutable arrays. *) - | Pduparray (_, Mutable) | Pduprecord _ -> - Only_generative_effects, Has_coeffects - | Pccall { prim_name = - ( "caml_format_float" | "caml_format_int" | "caml_int32_format" - | "caml_nativeint_format" | "caml_int64_format" ) } -> - No_effects, No_coeffects - | Pccall _ -> Arbitrary_effects, Has_coeffects - | Praise _ -> Arbitrary_effects, No_coeffects - | Pnot - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Pintcomp _ -> No_effects, No_coeffects - | Pdivbint { is_safe = Unsafe } - | Pmodbint { is_safe = Unsafe } - | Pdivint Unsafe - | Pmodint Unsafe -> - No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) - | Pdivbint { is_safe = Safe } - | Pmodbint { is_safe = Safe } - | Pdivint Safe - | Pmodint Safe -> - Arbitrary_effects, No_coeffects - | Poffsetint _ -> No_effects, No_coeffects - | Poffsetref _ -> Arbitrary_effects, Has_coeffects - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Pabsfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pfloatcomp _ -> No_effects, No_coeffects - | Pstringlength | Pbyteslength - | Parraylength _ -> - No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) - | Pisint - | Pisout - | Pbintofint _ - | Pintofbint _ - | Pcvtbint _ - | Pnegbint _ - | Paddbint _ - | Psubbint _ - | Pmulbint _ - | Pandbint _ - | Porbint _ - | Pxorbint _ - | Plslbint _ - | Plsrbint _ - | Pasrbint _ - | Pbintcomp _ -> No_effects, No_coeffects - | Pbigarraydim _ -> - No_effects, Has_coeffects (* Some people resize bigarrays in place. *) - | Pfield _ - | Pfield_computed - | Pfloatfield _ - | Pgetglobal _ - | Parrayrefu _ - | Pstringrefu - | Pbytesrefu - | Pstring_load_16 true - | Pstring_load_32 true - | Pstring_load_64 true - | Pbytes_load_16 true - | Pbytes_load_32 true - | Pbytes_load_64 true - | Pbigarrayref (true, _, _, _) - | Pbigstring_load_16 true - | Pbigstring_load_32 true - | Pbigstring_load_64 true -> - No_effects, Has_coeffects - | Parrayrefs _ - | Pstringrefs - | Pbytesrefs - | Pstring_load_16 false - | Pstring_load_32 false - | Pstring_load_64 false - | Pbytes_load_16 false - | Pbytes_load_32 false - | Pbytes_load_64 false - | Pbigarrayref (false, _, _, _) - | Pbigstring_load_16 false - | Pbigstring_load_32 false - | Pbigstring_load_64 false -> - (* May trigger a bounds check exception. *) - Arbitrary_effects, Has_coeffects - | Psetfield _ - | Psetfield_computed _ - | Psetfloatfield _ - | Psetglobal _ - | Parraysetu _ - | Parraysets _ - | Pbytessetu - | Pbytessets - | Pbytes_set_16 _ - | Pbytes_set_32 _ - | Pbytes_set_64 _ - | Pbigarrayset _ - | Pbigstring_set_16 _ - | Pbigstring_set_32 _ - | Pbigstring_set_64 _ -> - (* Whether or not some of these are "unsafe" is irrelevant; they always - have an effect. *) - Arbitrary_effects, No_coeffects - | Pctconst _ -> No_effects, No_coeffects - | Pbswap16 - | Pbbswap _ -> No_effects, No_coeffects - | Pint_as_pointer -> No_effects, No_coeffects - | Popaque -> Arbitrary_effects, Has_coeffects - | Prevapply - | Pdirapply -> - (* Removed by [Simplif], but there is no reason to prevent using - the current analysis function before/during Simplif. *) - Arbitrary_effects, Has_coeffects - | Psequand - | Psequor -> - (* Removed by [Closure_conversion] in the flambda pipeline. *) - No_effects, No_coeffects - let for_clambda_primitive (prim : Clambda_primitives.primitive) = match prim with | Pmakeblock _ diff --git a/bytecomp/semantics_of_primitives.mli b/bytecomp/semantics_of_primitives.mli index 91ee805579..e9bb236130 100644 --- a/bytecomp/semantics_of_primitives.mli +++ b/bytecomp/semantics_of_primitives.mli @@ -60,8 +60,6 @@ type coeffects = No_coeffects | Has_coeffects the (non-)(co)effectfulness of the arguments in a primitive application. To determine whether such an application is (co)effectful, the arguments must also be analysed. *) -val for_primitive: Lambda.primitive -> effects * coeffects - val for_clambda_primitive: Clambda_primitives.primitive -> effects * coeffects type return_type = |