[Git][ghc/ghc][wip/T17676] Assume that precise exceptions can only be thrown from IO
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Mar 25 10:52:38 UTC 2020
Sebastian Graf pushed to branch wip/T17676 at Glasgow Haskell Compiler / GHC
Commits:
bb59fada by Sebastian Graf at 2020-03-25T11:51:53+01:00
Assume that precise exceptions can only be thrown from IO
- - - - -
2 changed files:
- compiler/basicTypes/Demand.hs
- compiler/stranal/DmdAnal.hs
Changes:
=====================================
compiler/basicTypes/Demand.hs
=====================================
@@ -28,7 +28,8 @@ module Demand (
DmdEnv, emptyDmdEnv,
peelFV, findIdDemand,
- Divergence(..), lubDivergence, isDeadEndDiv, topDiv, botDiv, exnDiv, conDiv,
+ Divergence(..), lubDivergence, isDeadEndDiv, removeExn,
+ topDiv, botDiv, exnDiv, conDiv,
appIsBottom, isDeadEndSig, pprIfaceStrictSig,
StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
emptySig, botSig, cprProdSig,
@@ -39,8 +40,7 @@ module Demand (
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
- splitDmdTy, splitFVs,
- mayThrowPreciseException, deferAfterPreciseException,
+ splitDmdTy, splitFVs, deferAfterPreciseException,
postProcessUnsat, postProcessDmdType,
splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
@@ -1075,6 +1075,11 @@ isDeadEndDiv ExnOrDiv = True
isDeadEndDiv ConOrDiv = False
isDeadEndDiv Dunno = False
+removeExn :: Divergence -> Divergence
+removeExn ExnOrDiv = Diverges
+removeExn Dunno = ConOrDiv
+removeExn div = div
+
-- See Notes [Default demand on free variables and arguments]
-- and [defaultFvDmd vs. defaultArgDmd]
-- and Scenario 2 in [Precise exceptions and strictness analysis]
@@ -1346,11 +1351,6 @@ splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty)
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException d = lubDmdType d (emptyDmdType conDiv)
-mayThrowPreciseException :: DmdType -> Bool
-mayThrowPreciseException (DmdType _ _ Dunno) = True
-mayThrowPreciseException (DmdType _ _ ExnOrDiv) = True
-mayThrowPreciseException (DmdType _ _ _) = False
-
strictenDmd :: Demand -> CleanDemand
strictenDmd (JD { sd = s, ud = u})
= JD { sd = poke_s s, ud = poke_u u }
@@ -1804,15 +1804,17 @@ dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
-- which has a special kind of demand transformer.
-- If the constructor is saturated, we feed the demand on
-- the result into the constructor arguments.
-dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
- (JD { sd = str, ud = abs })
+-- NB: Its idStrictness will just be the special case of this transformer
+-- for a head-strict demand.
+dmdTransformDataConSig arity str_sig cd@(JD { sd = str, ud = abs })
+ -- TODO: I think this should be more like dmdTransformSig, using a
+ -- combination of postProcessUnsat, peelManyCalls and splitProdDmd_maybe.
| Just str_dmds <- go_str arity str
, Just abs_dmds <- go_abs arity abs
- = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res
- -- Must remember whether it's a product, hence con_res, not TopRes
-
- | otherwise -- Not saturated
- = emptyDmdType conDiv
+ = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) conDiv
+ -- Not saturated. Fall back to transforming the StrictSig (see MkId)
+ | otherwise
+ = dmdTransformSig str_sig cd
where
go_str 0 dmd = splitStrProdDmd arity dmd
go_str n (SCall s') = go_str (n-1) s'
=====================================
compiler/stranal/DmdAnal.hs
=====================================
@@ -16,7 +16,7 @@ module DmdAnal ( dmdAnalProgram ) where
import GhcPrelude
import GHC.Driver.Session
-import WwLib ( findTypeShape )
+import WwLib ( findTypeShape, deepSplitProductType_maybe )
import Demand -- All of it
import GHC.Core
import GHC.Core.Seq ( seqBinds )
@@ -34,6 +34,7 @@ import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
import Util
import Maybes ( isJust )
+import TysPrim ( realWorldStatePrimTy )
import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) )
import UniqSet
@@ -220,9 +221,13 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
(alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs
(alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
id_dmds = addCaseBndrDmd case_bndr_dmd dmds
+ fam_envs = ae_fam_envs env
-- See Note [Precise exceptions and strictness analysis] in Demand
- alt_ty3 | mayThrowPreciseException scrut_ty = deferAfterPreciseException alt_ty2
- | otherwise = alt_ty2
+ alt_ty3
+ | mayThrowPreciseException fam_envs (idType case_bndr) scrut_ty
+ = deferAfterPreciseException alt_ty2
+ | otherwise
+ = alt_ty2
-- Compute demand on the scrutinee
-- See Note [Demand on scrutinee of a product case]
@@ -326,6 +331,49 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
id_dmds = addCaseBndrDmd case_bndr_dmd dmds
= (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
+mayThrowPreciseException :: FamInstEnvs -> Type -> DmdType -> Bool
+mayThrowPreciseException _ _ (DmdType _ _ ConOrDiv) = False
+mayThrowPreciseException _ _ (DmdType _ _ Diverges) = False
+-- Anything that throws a precise exception must force the RealWorld#,
+-- disregarding black magic like unsafePerformIO (for which we give no
+-- guarantees to preserve precise exceptions).
+mayThrowPreciseException fam_envs ty _ = forcesRealWorld fam_envs ty
+
+-- | Whether a 'seqDmd' on an expression of the given type may force the
+-- 'RealWorld#', incurring a side-effect (ignoring unsafe shenigans like
+-- 'unsafePerformIO'). Looks through
+forcesRealWorld :: FamInstEnvs -> Type -> Bool
+forcesRealWorld fam_envs = go initRecTc
+ where
+ go :: RecTcChecker -> Type -> Bool
+ go rec_tc ty
+ -- Found it!
+ | ty `eqType` realWorldStatePrimTy
+ = True
+ -- search depth-first
+ | Just (dc, _, field_tys, _) <- deepSplitProductType_maybe fam_envs ty
+ -- don't check the same TyCon twice
+ , Just rec_tc' <- checkRecTc rec_tc (dataConTyCon dc)
+ = any (strict_field_forces rec_tc') field_tys
+ | otherwise
+ = False
+
+ strict_field_forces rec_tc (field_ty, str_mark) =
+ (isMarkedStrict str_mark || isLiftedType_maybe field_ty == Just False)
+ && go rec_tc field_ty
+
+-- | Tries to reset the precise exception flag from the 'StrictSig's
+-- 'Divergence' if really it not 'mayThrowPreciseException'. Resetting the flag
+-- means that the (very conservative) precise exception "taint" won't spread
+-- unhindered. TODO explain
+tryClearPreciseException :: FamInstEnvs -> Type -> StrictSig -> StrictSig
+tryClearPreciseException fam_envs ty sig@(StrictSig dmd_ty@(DmdType fvs args div))
+ | (arg_tys, res_ty) <- splitPiTys ty
+ , args `equalLength` filter (not . isNamedBinder) arg_tys
+ , mayThrowPreciseException fam_envs res_ty dmd_ty
+ = sig
+ | otherwise
+ = StrictSig (DmdType fvs args (removeExn div))
{- Note [Demand on the scrutinee of a product case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -488,7 +536,8 @@ dmdFix top_lvl env let_dmd orig_pairs
zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
- zapIdStrictness pairs = [(setIdStrictness id (emptySig topDiv), rhs) | (id, rhs) <- pairs ]
+ zapIdStrictness pairs
+ = [(setIdStrictnessResetExc env id (emptySig topDiv), rhs) | (id, rhs) <- pairs ]
{-
Note [Safe abortion in the fixed-point iteration]
@@ -544,7 +593,8 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
(DmdType rhs_fv rhs_dmds rhs_div, rhs')
= dmdAnal env rhs_dmd rhs
sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
- id' = set_idStrictness env id sig
+ id' = -- pprTraceWith "dmdAnalRhsLetDown" (\sig'-> ppr id <+> ppr sig <+> ppr sig') $
+ setIdStrictnessResetExc env id sig
-- See Note [NOINLINE and strictness]
@@ -1132,9 +1182,9 @@ findBndrDmd env arg_of_dfun dmd_ty id
fam_envs = ae_fam_envs env
-set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
-set_idStrictness env id sig
- = setIdStrictness id (killUsageSig (ae_dflags env) sig)
+setIdStrictnessResetExc :: AnalEnv -> Id -> StrictSig -> Id
+setIdStrictnessResetExc env id sig
+ = setIdStrictness id (tryClearPreciseException (ae_fam_envs env) (idType id) sig)
{- Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb59fadad7cc98f69f9cde2ac4fd0e624691983c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb59fadad7cc98f69f9cde2ac4fd0e624691983c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200325/bb171785/attachment-0001.html>
More information about the ghc-commits
mailing list