...
 
Commits (8)
......@@ -31,7 +31,6 @@ import GHC.Runtime.Heap.Layout
import UniqSupply
import CostCentre
import GHC.StgToCmm.Heap
import ErrUtils
import Control.Monad
import Data.Map.Strict (Map)
......@@ -802,9 +801,6 @@ doSRTs dflags moduleSRTInfo procs data_ = do
(srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
srt_decls = concat srt_declss
unless (null srt_decls) $
dumpIfSet_dyn dflags Opt_D_dump_srts "SRTs" FormatCMM (ppr srt_decls)
-- Next, update the info tables with the SRTs
let
srtFieldMap = mapFromList (concat pairs)
......
......@@ -56,6 +56,7 @@ import GHC.Data.Bitmap
import OrdList
import Maybes
import VarEnv
import PrelNames ( unsafeEqualityProofName )
import Data.List
import Foreign
......@@ -634,11 +635,12 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-- ignore other kinds of tick
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
-- no alts: scrut is guaranteed to diverge
schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- no alts: scrut is guaranteed to diverge
-- handle pairs with one void argument (e.g. state token)
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
| isUnboxedTupleCon dc
-- Convert
-- case .... of x { (# V'd-thing, a #) -> ... }
-- to
......@@ -655,11 +657,13 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
_ -> Nothing
= res
-- handle unit tuples
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
, typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
, typePrimRep (idType bndr) `lengthAtMost` 1
= doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
-- handle nullary tuples
schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
| isUnboxedTupleType (idType bndr)
, Just ty <- case typePrimRep (idType bndr) of
......@@ -983,6 +987,7 @@ doCase
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| typePrimRep (idType bndr) `lengthExceeds` 1
= multiValException
| otherwise
= do
dflags <- getDynFlags
......@@ -1883,6 +1888,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- b) type applications
-- c) casts
-- d) ticks (but not breakpoints)
-- e) case unsafeEqualityProof of UnsafeRefl -> e ==> e
-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnCast (_,e) _) = Just e
......@@ -1890,8 +1896,19 @@ bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView (AnnTick Breakpoint{} _) = Nothing
bcView (AnnTick _other_tick (_,e)) = Just e
bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof
| AnnVar id <- bcViewLoop e
, idName id == unsafeEqualityProofName
, [(_, _, (_, rhs))] <- alts
= Just rhs
bcView _ = Nothing
bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann
bcViewLoop e =
case bcView e of
Nothing -> e
Just e' -> bcViewLoop e'
isVAtom :: AnnExpr' Var ann -> Bool
isVAtom e | Just e' <- bcView e = isVAtom e'
isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
......
......@@ -71,6 +71,7 @@ import VarSet
import TyCoRep
import TyCoTidy ( tidyCo )
import Demand ( isTopSig )
import Cpr ( topCprSig )
import Data.Maybe ( catMaybes )
......@@ -300,7 +301,6 @@ toIfaceCoercionX fr co
fr' = fr `delVarSet` tv
go_prov :: UnivCoProvenance -> IfaceUnivCoProv
go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str
......@@ -442,7 +442,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
inline_hsinfo, unfold_hsinfo, levity_hsinfo] of
[] -> NoInfo
infos -> HasInfo infos
......@@ -466,6 +466,10 @@ toIfaceIdInfo id_info
strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
| otherwise = Nothing
------------ CPR --------------
cpr_info = cprInfo id_info
cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info)
| otherwise = Nothing
------------ Unfolding --------------
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info)
......
......@@ -46,6 +46,7 @@ import ForeignCall
import Demand ( isUsedOnce )
import PrimOp ( PrimCall(..), primOpWrapperId )
import SrcLoc ( mkGeneralSrcSpan )
import PrelNames ( unsafeEqualityProofName )
import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe)
......@@ -404,11 +405,23 @@ coreToStgExpr (Case scrut _ _ [])
-- runtime system error function.
coreToStgExpr (Case scrut bndr _ alts) = do
coreToStgExpr e0@(Case scrut bndr _ alts) = do
alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
scrut2 <- coreToStgExpr scrut
return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2
-- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
case scrut2 of
StgApp id [] | idName id == unsafeEqualityProofName ->
case alts2 of
[(_, [_co], rhs)] ->
return rhs
_ ->
pprPanic "coreToStgExpr" $
text "Unexpected unsafe equality case expression:" $$ ppr e0 $$
text "STG:" $$ ppr stg
_ -> return stg
where
vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
vars_alt (con, binders, rhs)
| DataAlt c <- con, c == unboxedUnitDataCon
= -- This case is a bit smelly.
......
This diff is collapsed.
......@@ -758,11 +758,12 @@ positions in the kind of the tycon.
mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@.
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@
-- See Note [Detecting forced eta expansion] in "DsExpr"
mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e))
mkHsWrap co_fn e = XExpr (HsWrap co_fn e)
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
......
......@@ -49,6 +49,7 @@ import BinFingerprint
import CoreSyn( IsOrphan, isOrphan )
import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) )
import Demand
import Cpr
import Class
import FieldLabel
import NameSet
......@@ -344,6 +345,7 @@ data IfaceIdInfo
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsCpr CprSig
| HsInline InlinePragma
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
......@@ -358,7 +360,9 @@ data IfaceUnfolding
-- Possibly could eliminate the Bool here, the information
-- is also in the InlinePragma.
| IfCompulsory IfaceExpr -- Only used for default methods, in fact
| IfCompulsory IfaceExpr -- default methods and unsafeCoerce#
-- for more about unsafeCoerce#, see
-- Note [Wiring in unsafeCoerce#] in Desugar
| IfInlineRule Arity -- INLINE pragmas
Bool -- OK to inline even if *un*-saturated
......@@ -1394,7 +1398,8 @@ instance Outputable IfaceInfoItem where
<> colon <+> ppr unf
ppr (HsInline prag) = text "Inline:" <+> ppr prag
ppr (HsArity arity) = text "Arity:" <+> int arity
ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr
ppr HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic"
......@@ -1615,7 +1620,6 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
= fnList freeNamesIfCoercion cos
freeNamesIfProv :: IfaceUnivCoProv -> NameSet
freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet
......@@ -2168,6 +2172,7 @@ instance Binary IfaceInfoItem where
put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
put_ bh HsNoCafRefs = putByte bh 4
put_ bh HsLevity = putByte bh 5
put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr
get bh = do
h <- getByte bh
case h of
......@@ -2178,7 +2183,8 @@ instance Binary IfaceInfoItem where
return (HsUnfold lb ad)
3 -> liftM HsInline $ get bh
4 -> return HsNoCafRefs
_ -> return HsLevity
5 -> return HsLevity
_ -> HsCpr <$> get bh
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do
......@@ -2513,6 +2519,7 @@ instance NFData IfaceInfoItem where
HsUnfold b unf -> rnf b `seq` rnf unf
HsNoCafRefs -> ()
HsLevity -> ()
HsCpr cpr -> cpr `seq` ()
instance NFData IfaceUnfolding where
rnf = \case
......
......@@ -40,6 +40,7 @@ import IdInfo
import InstEnv
import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig )
import Cpr ( mkCprSig, botCpr )
import BasicTypes
import Name hiding (varName)
import NameSet
......@@ -453,8 +454,15 @@ trimId :: Id -> Id
trimId id
| not (isImplicitId id)
= id `setIdInfo` vanillaIdInfo
`setIdUnfolding` unfolding
| otherwise
= id
where
unfolding
| isCompulsoryUnfolding (idUnfolding id)
= idUnfolding id
| otherwise
= noUnfolding
{- Note [Drop wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1150,6 +1158,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
-- c.f. CoreTidy.tidyLetBndr
`setArityInfo` arity
`setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness]
-- in CoreTidy
......@@ -1157,6 +1166,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
= vanillaIdInfo
`setArityInfo` arity
`setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setOccInfo` robust_occ_info
`setInlinePragInfo` (inlinePragInfo idinfo)
`setUnfoldingInfo` unfold_info
......@@ -1180,14 +1190,23 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| Just (_, nsig) <- mb_bot_str = nsig
| otherwise = sig
cpr = cprInfo idinfo
final_cpr | Just _ <- mb_bot_str
= mkCprSig arity botCpr
| otherwise
= cpr
_bottom_hidden id_sig = case mb_bot_str of
Nothing -> False
Just (arity, _) -> not (appIsBottom id_sig arity)
--------- Unfolding ------------
unf_info = unfoldingInfo idinfo
unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise = minimal_unfold_info
unfold_info
| isCompulsoryUnfolding unf_info || show_unfold
= tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise
= minimal_unfold_info
minimal_unfold_info = zapUnfolding unf_info
unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
is_bot = isBottomingSig final_sig
......
......@@ -237,6 +237,12 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
-- only: see Note [Equality predicates in IfaceType]
deriving (Eq)
instance Outputable IfaceTyConSort where
ppr IfaceNormalTyCon = text "normal"
ppr (IfaceTupleTyCon n sort) = ppr sort <> colon <> ppr n
ppr (IfaceSumTyCon n) = text "sum:" <> ppr n
ppr IfaceEqualityTyCon = text "equality"
{- Note [Free tyvars in IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
......@@ -350,8 +356,7 @@ data IfaceCoercion
| IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
data IfaceUnivCoProv
= IfaceUnsafeCoerceProv
| IfacePhantomProv IfaceCoercion
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
......@@ -525,7 +530,6 @@ substIfaceType env ty
go_cos = map go_co
go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov (IfacePluginProv str) = IfacePluginProv str
......@@ -1102,10 +1106,7 @@ pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
pprIfaceForAllBndr bndr =
case bndr of
Bndr (IfaceTvBndr tv) Inferred ->
sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False)
else pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False)
Bndr (IfaceTvBndr tv) _ ->
pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv
......@@ -1562,11 +1563,6 @@ ppr_co _ (IfaceFreeCoVar covar) = ppr covar
ppr_co _ (IfaceCoVarCo covar) = ppr covar
ppr_co _ (IfaceHoleCo covar) = braces (ppr covar)
ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
= maybeParen ctxt_prec appPrec $
text "UnsafeCo" <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
ppr_co _ (IfaceUnivCo prov role ty1 ty2)
= text "Univ" <> (parens $
sep [ ppr role <+> pprIfaceUnivCoProv prov
......@@ -1610,8 +1606,6 @@ ppr_role r = underscore <> pp_role
------------------
pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
pprIfaceUnivCoProv IfaceUnsafeCoerceProv
= text "unsafe"
pprIfaceUnivCoProv (IfacePhantomProv co)
= text "phantom" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfaceProofIrrelProv co)
......@@ -1623,6 +1617,11 @@ pprIfaceUnivCoProv (IfacePluginProv s)
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
instance Outputable IfaceTyConInfo where
ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom
, ifaceTyConSort = sort })
= angleBrackets $ ppr prom <> comma <+> ppr sort
pprPromotionQuote :: IfaceTyCon -> SDoc
pprPromotionQuote tc =
pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
......@@ -1954,26 +1953,24 @@ instance Binary IfaceCoercion where
_ -> panic ("get IfaceCoercion " ++ show tag)
instance Binary IfaceUnivCoProv where
put_ bh IfaceUnsafeCoerceProv = putByte bh 1
put_ bh (IfacePhantomProv a) = do
putByte bh 2
putByte bh 1
put_ bh a
put_ bh (IfaceProofIrrelProv a) = do
putByte bh 3
putByte bh 2
put_ bh a
put_ bh (IfacePluginProv a) = do
putByte bh 4
putByte bh 3
put_ bh a
get bh = do
tag <- getByte bh
case tag of
1 -> return $ IfaceUnsafeCoerceProv
2 -> do a <- get bh
1 -> do a <- get bh
return $ IfacePhantomProv a
3 -> do a <- get bh
2 -> do a <- get bh
return $ IfaceProofIrrelProv a
4 -> do a <- get bh
3 -> do a <- get bh
return $ IfacePluginProv a
_ -> panic ("get IfaceUnivCoProv " ++ show tag)
......
......@@ -1249,7 +1249,6 @@ tcIfaceCo = go
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
......@@ -1465,16 +1464,28 @@ tcIdInfo ignore_prags toplvl name ty info = do
-- we start; default assumption is that it has CAFs
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
if ignore_prags
then return init_info
else case info of
NoInfo -> return init_info
HasInfo info -> foldlM tcPrag init_info info
case info of
NoInfo -> return init_info
HasInfo info -> let needed = needed_prags info in
foldlM tcPrag init_info needed
where
needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
needed_prags items
| not ignore_prags = items
| otherwise = filter need_prag items
need_prag :: IfaceInfoItem -> Bool
-- compulsory unfoldings are really compulsory.
-- See wrinkle in Note [Wiring in unsafeCoerce#] in Desugar
need_prag (HsUnfold _ (IfCompulsory {})) = True
need_prag _ = False
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
......@@ -1492,7 +1503,7 @@ tcJoinInfo IfaceNotJoinPoint = Nothing
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
; mb_expr <- tcPragExpr toplvl name if_expr
; mb_expr <- tcPragExpr False toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
......@@ -1506,13 +1517,13 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
= do { mb_expr <- tcPragExpr True toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
= do { mb_expr <- tcPragExpr False toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
......@@ -1534,17 +1545,20 @@ For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
-}
tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr toplvl name expr
tcPragExpr :: Bool -- Is this unfolding compulsory?
-- See Note [Checking for levity polymorphism] in CoreLint
-> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr is_compulsory toplvl name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding
-- See Note [Linting Unfoldings from Interfaces]
when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
when (isTopLevel toplvl) $
whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
dflags <- getDynFlags
case lintUnfolding dflags noSrcLoc in_scope core_expr' of
case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
......@@ -1554,7 +1568,8 @@ tcPragExpr toplvl name expr
, text "Iface expr =" <+> ppr expr ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
doc = ppWhen is_compulsory (text "Compulsory") <+>
text "Unfolding of" <+> ppr name
get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope
......@@ -1685,7 +1700,7 @@ tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of
NotPromoted -> tyThingTyCon thing
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
......
......@@ -105,9 +105,9 @@ import Data.Map (Map)
import qualified Data.Map as Map
import StringBuffer (stringToStringBuffer)
import Control.Monad
import GHC.Exts
import Data.Array
import Exception
import Unsafe.Coerce ( unsafeCoerce )
import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces )
import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) )
......@@ -1225,7 +1225,7 @@ dynCompileExpr expr = do
to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic)
return (unsafeCoerce hval :: Dynamic)
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
......@@ -1254,7 +1254,7 @@ obtainTermFromVal hsc_env bound force ty x
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
| otherwise
= cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
= cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
......
......@@ -54,7 +54,7 @@ import Hooks
import Control.Monad ( when, unless )
import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# )
import Unsafe.Coerce ( unsafeCoerce )
-- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before
......@@ -222,7 +222,7 @@ lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do
debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
(text "...")
output <- evaluate (unsafeCoerce# what)
output <- evaluate (unsafeCoerce what)
debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
return output
......
......@@ -325,6 +325,9 @@ isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True
isPromoted NotPromoted = False
instance Outputable PromotionFlag where
ppr NotPromoted = text "NotPromoted"
ppr IsPromoted = text "IsPromoted"
{-
************************************************************************
......
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-- | Types for the Constructed Product Result lattice. "CprAnal" and "WwLib"
-- are its primary customers via 'idCprInfo'.
module Cpr (
CprResult, topCpr, botCpr, conCpr, asConCpr,
CprType (..), topCprType, botCprType, conCprType,
lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
) where
import GhcPrelude
import BasicTypes
import Outputable
import Binary
--
-- * CprResult
--
-- | The constructed product result lattice.
--
-- @
-- NoCPR
-- |
-- ConCPR ConTag
-- |
-- BotCPR
-- @
data CprResult = NoCPR -- ^ Top of the lattice
| ConCPR !ConTag -- ^ Returns a constructor from a data type
| BotCPR -- ^ Bottom of the lattice
deriving( Eq, Show )
lubCpr :: CprResult -> CprResult -> CprResult
lubCpr (ConCPR t1) (ConCPR t2)
| t1 == t2 = ConCPR t1
lubCpr BotCPR cpr = cpr
lubCpr cpr BotCPR = cpr
lubCpr _ _ = NoCPR
topCpr :: CprResult
topCpr = NoCPR
botCpr :: CprResult
botCpr = BotCPR
conCpr :: ConTag -> CprResult
conCpr = ConCPR
trimCpr :: CprResult -> CprResult
trimCpr ConCPR{} = NoCPR
trimCpr cpr = cpr
asConCpr :: CprResult -> Maybe ConTag
asConCpr (ConCPR t) = Just t
asConCpr NoCPR = Nothing
asConCpr BotCPR = Nothing
--
-- * CprType
--
-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
data CprType
= CprType
{ ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
-- eats before returning the 'ct_cpr'
, ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to
-- 'ct_arty' arguments
}
instance Eq CprType where
a == b = ct_cpr a == ct_cpr b
&& (ct_arty a == ct_arty b || ct_cpr a == topCpr)
topCprType :: CprType
topCprType = CprType 0 topCpr
botCprType :: CprType
botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments
conCprType :: ConTag -> CprType
conCprType con_tag = CprType 0 (conCpr con_tag)
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
-- The arity of bottom CPR types can be extended arbitrarily.
| cpr1 == botCpr && n1 <= n2 = ty2
| cpr2 == botCpr && n2 <= n1 = ty1
-- There might be non-bottom CPR types with mismatching arities.
-- Consider test DmdAnalGADTs. We want to return top in these cases.
| n1 == n2 = CprType n1 (lubCpr cpr1 cpr2)
| otherwise = topCprType
applyCprTy :: CprType -> CprType
applyCprTy (CprType n res)
| n > 0 = CprType (n-1) res
| res == botCpr = botCprType
| otherwise = topCprType
abstractCprTy :: CprType -> CprType
abstractCprTy (CprType n res)
| res == topCpr = topCprType
| otherwise = CprType (n+1) res
ensureCprTyArity :: Arity -> CprType -> CprType
ensureCprTyArity n ty@(CprType m _)
| n == m = ty
| otherwise = topCprType
trimCprTy :: CprType -> CprType
trimCprTy (CprType arty res) = CprType arty (trimCpr res)
-- | The arity of the wrapped 'CprType' is the arity at which it is safe
-- to unleash. See Note [Understanding DmdType and StrictSig] in Demand
newtype CprSig = CprSig { getCprSig :: CprType }
deriving (Eq, Binary)
-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'
-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in
-- Demand
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)
topCprSig :: CprSig
topCprSig = CprSig topCprType
mkCprSig :: Arity -> CprResult -> CprSig
mkCprSig arty cpr = CprSig (CprType arty cpr)
seqCprSig :: CprSig -> ()
seqCprSig sig = sig `seq` ()
instance Outputable CprResult where
ppr NoCPR = empty
ppr (ConCPR n) = char 'm' <> int n
ppr BotCPR = char 'b'
instance Outputable CprType where
ppr (CprType arty res) = ppr arty <> ppr res
-- | Only print the CPR result
instance Outputable CprSig where
ppr (CprSig ty) = ppr (ct_cpr ty)
instance Binary CprResult where
put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n }
put_ bh NoCPR = putByte bh 1
put_ bh BotCPR = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> do { n <- get bh; return (ConCPR n) }
1 -> return NoCPR
_ -> return BotCPR
instance Binary CprType where
put_ bh (CprType arty cpr) = do
put_ bh arty
put_ bh cpr
get bh = CprType <$> get bh <*> get bh
......@@ -24,7 +24,7 @@ module DataCon (
FieldLbl(..), FieldLabel, FieldLabelString,
-- ** Type construction
mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG,
mkDataCon, fIRST_TAG,
-- ** Type deconstruction
dataConRepType, dataConInstSig, dataConFullSig,
......@@ -65,7 +65,6 @@ import GhcPrelude
import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import ForeignCall ( CType )
import Coercion
import Unify
import TyCon
......@@ -75,7 +74,6 @@ import Name
import PrelNames
import Predicate
import Var
import VarSet( emptyVarSet )
import Outputable
import Util
import BasicTypes
......@@ -1380,6 +1378,10 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool
-- scrutinee of type (T tys)
-- where T is the dcRepTyCon for the data con
dataConCannotMatch tys con
-- See (U6) in Note [Implementing unsafeCoerce]
-- in base:Unsafe.Coerce
| dataConName con == unsafeReflDataConName
= False
| null inst_theta = False -- Common
| all isTyVarTy tys = False -- Also common
| otherwise = typesCantMatch (concatMap predEqs inst_theta)
......@@ -1463,38 +1465,3 @@ splitDataProductType_maybe ty
| otherwise
= Nothing
{-
************************************************************************
* *
Building an algebraic data type
* *
************************************************************************
buildAlgTyCon is here because it is called from TysWiredIn, which can
depend on this module, but not on BuildTyCl.
-}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> Bool -- ^ True <=> was declared in GADT syntax
-> AlgTyConFlav
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
gadt_syn parent
= mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
rhs parent gadt_syn
where
binders = mkTyConBindersPreferAnon ktvs emptyVarSet
buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> KnotTied Type -> TyCon
buildSynTyCon name binders res_kind roles rhs
= mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
where
is_tau = isTauTy rhs
is_fam_free = isFamFreeTy rhs
This diff is collapsed.
......@@ -107,9 +107,11 @@ module Id (
setIdDemandInfo,
setIdStrictness,
setIdCprInfo,
idDemandInfo,
idStrictness,
idCprInfo,
) where
......@@ -137,6 +139,7 @@ import GHC.Types.RepType
import TysPrim
import DataCon
import Demand
import Cpr
import Name
import Module
import Class
......@@ -164,6 +167,7 @@ infixl 1 `setIdUnfolding`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdCprInfo`,
`asJoinId`,
`asJoinId_maybe`
......@@ -645,6 +649,12 @@ idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id
idCprInfo :: Id -> CprSig
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprSig -> Id
setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id
......@@ -948,11 +958,13 @@ transferPolyIdInfo old_id abstract_wrt new_id
old_strictness = strictnessInfo old_info
new_strictness = increaseStrictSigArity arity_increase old_strictness
old_cpr = cprInfo old_info
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setOccInfo` new_occ_info
`setStrictnessInfo` new_strictness
`setCprInfo` old_cpr
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
......@@ -42,6 +42,7 @@ module IdInfo (
-- ** Demand and strictness Info
strictnessInfo, setStrictnessInfo,
cprInfo, setCprInfo,
demandInfo, setDemandInfo, pprStrictness,
-- ** Unfolding Info
......@@ -100,6 +101,7 @@ import ForeignCall
import Outputable
import Module
import Demand
import Cpr
import Util
-- infixl so you can say (id `set` a `set` b)
......@@ -111,6 +113,7 @@ infixl 1 `setRuleInfo`,
`setOccInfo`,
`setCafInfo`,
`setStrictnessInfo`,
`setCprInfo`,
`setDemandInfo`,
`setNeverLevPoly`,
`setLevityInfoWithType`
......@@ -258,6 +261,9 @@ data IdInfo
strictnessInfo :: StrictSig,
-- ^ A strictness signature. Digests how a function uses its arguments
-- if applied to at least 'arityInfo' arguments.
cprInfo :: CprSig,
-- ^ Information on whether the function will ultimately return a
-- freshly allocated constructor.
demandInfo :: Demand,
-- ^ ID demand information
callArityInfo :: !ArityInfo,
......@@ -302,6 +308,9 @@ setDemandInfo info dd = dd `seq` info { demandInfo = dd }
setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
setCprInfo :: IdInfo -> CprSig -> IdInfo
setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }
-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo
......@@ -315,6 +324,7 @@ vanillaIdInfo
occInfo = noOccInfo,
demandInfo = topDmd,
strictnessInfo = nopSig,
cprInfo = topCprSig,
callArityInfo = unknownArity,
levityInfo = NoLevityInfo
}
......
......@@ -22,11 +22,12 @@ module MkId (
mkPrimOpId, mkFCallId,
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, magicDictId, coerceId,
......@@ -46,6 +47,7 @@ import TysPrim
import TysWiredIn
import PrelRules
import Type
import TyCoRep
import FamInstEnv
import Coercion
import TcType
......@@ -63,6 +65,7 @@ import DataCon
import Id
import IdInfo
import Demand
import Cpr
import CoreSyn
import Unique
import UniqSupply
......@@ -150,7 +153,6 @@ ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)]
ghcPrimIds
= [ realWorldPrimId
, voidPrimId
, unsafeCoerceId
, nullAddrId
, seqId
, magicDictId
......@@ -411,6 +413,7 @@ mkDictSelId name clas
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setCprInfo` topCprSig
`setLevityInfoWithType` sel_ty
info | new_tycon
......@@ -439,7 +442,7 @@ mkDictSelId name clas
-- It's worth giving one, so that absence info etc is generated
-- even if the selector isn't inlined
strict_sig = mkClosedStrictSig [arg_dmd] topRes
strict_sig = mkClosedStrictSig [arg_dmd] topDiv
arg_dmd | new_tycon = evalDmd
| otherwise = mkManyUsedDmd $
mkProdDmd [ if name == sel_name then evalDmd else absDmd
......@@ -507,6 +510,7 @@ mkDataConWorkId wkr_name data_con
alg_wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setCprInfo` mkCprSig wkr_arity (dataConCPR data_con)
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` wkr_ty
......@@ -514,7 +518,7 @@ mkDataConWorkId wkr_name data_con
-- setNeverLevPoly
wkr_arity = dataConRepArity data_con
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv
-- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker Id is strict
-- even if the data constructor is declared strict
......@@ -552,19 +556,17 @@ mkDataConWorkId wkr_name data_con
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
dataConCPR :: DataCon -> DmdResult
dataConCPR :: DataCon -> CprResult
dataConCPR con
| isDataTyCon tycon -- Real data types only; that is,
-- not unboxed tuples or newtypes
, null (dataConExTyCoVars con) -- No existentials
, wkr_arity > 0
, wkr_arity <= mAX_CPR_SIZE
= if is_prod then vanillaCprProdRes (dataConRepArity con)
else cprSumRes (dataConTag con)
= conCpr (dataConTag con)
| otherwise
= topRes
= topCpr
where
is_prod = isProductTyCon tycon
tycon = dataConTyCon con
wkr_arity = dataConRepArity con
......@@ -600,6 +602,10 @@ newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
-- Bind these src-level vars, returning the
-- rep-level vars to bind in the pattern
vanillaDataConBoxer :: DataConBoxer
-- No transformation on arguments needed
vanillaDataConBoxer = DCB (\_tys args -> return (args, []))
{-
Note [Inline partially-applied constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -651,12 +657,13 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
`setInlinePragInfo` wrap_prag
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` wrap_sig
`setCprInfo` mkCprSig wrap_arity (dataConCPR data_con)
-- We need to get the CAF info right here because GHC.Iface.Tidy
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
`setLevityInfoWithType` wrap_ty
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv
wrap_arg_dmds =
replicate (length theta) topDmd ++ map mk_dmd arg_ibangs
......@@ -664,7 +671,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- the strictness signature (#14290).
mk_dmd str | isBanged str = evalDmd
| otherwise = topDmd
| otherwise = topDmd
wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
activeDuringFinal
......@@ -1218,10 +1225,16 @@ mkPrimOpId prim_op
(AnId id) UserSyntax
id = mkGlobalId (PrimOpId prim_op) name ty info
-- PrimOps don't ever construct a product, but we want to preserve bottoms
cpr
| isBotDiv (snd (splitStrictSig strict_sig)) = botCpr
| otherwise = topCpr
info = noCafIdInfo
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setCprInfo` mkCprSig arity cpr
`setInlinePragInfo` neverInlinePragma
`setLevityInfoWithType` res_ty
-- We give PrimOps a NOINLINE pragma so that we don't
......@@ -1254,11 +1267,12 @@ mkFCallId dflags uniq fcall ty
info = noCafIdInfo
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setCprInfo` topCprSig
`setLevityInfoWithType` ty
(bndrs, _) = tcSplitPiTys ty
arity = count isAnonTyCoBinder bndrs
strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv
-- the call does not claim to be strict in its arguments, since they
-- may be lifted (foreign import prim) and the called code doesn't
-- necessarily force them. See #11076.
......@@ -1313,19 +1327,14 @@ no curried identifier for them. That's what mkCompulsoryUnfolding
does. If we had a way to get a compulsory unfolding from an interface
file, we could do that, but we don't right now.
unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
just gets expanded into a type coercion wherever it occurs. Hence we
add it as a built-in Id with an unfolding here.
The type variables we use here are "open" type variables: this means
they can unify with both unlifted and lifted types. Hence we provide
another gun with which to shoot yourself in the foot.
-}
unsafeCoerceName, nullAddrName, seqName,
nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
magicDictName, coerceName, proxyName :: Name
unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
......@@ -1356,28 +1365,6 @@ proxyHashId
tv_ty = mkTyVarTy tv
ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty
------------------------------------------------
unsafeCoerceId :: Id
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-- (a :: TYPE r1) (b :: TYPE r2).
-- a -> b
bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy]
(\ks -> map tYPE ks)
[_, _, a, b] = mkTyVarTys bndrs
ty = mkSpecForAllTys bndrs (mkVisFunTy a b)
[x] = mkTemplateLocals [a]
rhs = mkLams (bndrs ++ [x]) $
Cast (Var x) (mkUnsafeCo Representational a b)
------------------------------------------------
nullAddrId :: Id
-- nullAddr# :: Addr#
......@@ -1478,22 +1465,6 @@ coerceId = pcMiscPrelId coerceName ty info
[(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]
{-
Note [Unsafe coerce magic]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We define a *primitive*
GHC.Prim.unsafeCoerce#
and then in the base library we define the ordinary function
Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b
unsafeCoerce x = unsafeCoerce# x
Notice that unsafeCoerce has a civilized (albeit still dangerous)
polymorphic type, whose type args have kind *. So you can't use it on
unboxed values (unsafeCoerce 3#).
In contrast unsafeCoerce# is even more dangerous because you *can* use
it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b
Note [seqId magic]
~~~~~~~~~~~~~~~~~~
'GHC.Prim.seq' is special in several ways.
......
......@@ -394,12 +394,6 @@ mkPreludeTyConUnique i = mkUnique '3' (2*i)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
-- evaluates arguments as necessary and calls the worker). The second is
-- used for the worker function (the function that builds the constructor
-- representation).
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
......
......@@ -155,7 +155,7 @@ exprBotStrictness_maybe e
Just ar -> Just (ar, sig ar)
where
env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv
{-
Note [exprArity invariant]
......@@ -758,7 +758,7 @@ arityType _ (Var v)
, not $ isTopSig strict_sig
, (ds, res) <- splitStrictSig strict_sig
, let arity = length ds
= if isBotRes res then ABot arity
= if isBotDiv res then ABot arity
else ATop (take arity one_shots)
| otherwise
= ATop (take (idArity v) one_shots)
......
......@@ -393,7 +393,6 @@ orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
orphNamesOfCo (HoleCo _) = emptyNameSet
orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
......
......@@ -64,7 +64,7 @@ import Util
import InstEnv ( instanceDFunId )
import OptCoercion ( checkAxInstCo )
import CoreArity ( typeArity )
import Demand ( splitStrictSig, isBotRes )
import Demand ( splitStrictSig, isBotDiv )
import HscTypes
import DynFlags
......@@ -84,7 +84,7 @@ Core Lint is the type-checker for Core. Using it, we get the following guarantee
If all of:
1. Core Lint passes,
2. there are no unsafe coercions (i.e. UnsafeCoerceProv),
2. there are no unsafe coercions (i.e. unsafeEqualityProof),
3. all plugin-supplied coercions (i.e. PluginProv) are valid, and
4. all case-matches are complete
then running the compiled program will not seg-fault, assuming no bugs downstream
......@@ -291,7 +291,8 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify
coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal
coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal
coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
......@@ -493,18 +494,23 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
-}
lintUnfolding :: DynFlags
lintUnfolding :: Bool -- True <=> is a compulsory unfolding
-> DynFlags
-> SrcLoc
-> VarSet -- Treat these as in scope
-> CoreExpr
-> Maybe MsgDoc -- Nothing => OK
lintUnfolding dflags locn vars expr
lintUnfolding is_compulsory dflags locn vars expr
| isEmptyBag errs = Nothing
| otherwise = Just (pprMessageBag errs)
where
in_scope = mkInScopeSet vars
(_warns, errs) = initL dflags defaultLintFlags in_scope linter
(_warns, errs) = initL dflags defaultLintFlags in_scope $
if is_compulsory
-- See Note [Checking for levity polymorphism]
then noLPChecks linter
else linter
linter = addLoc (ImportedUnfolding locn) $
lintCoreExpr expr
......@@ -607,7 +613,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
ppr binder)
; case splitStrictSig (idStrictness binder) of
(demands, result_info) | isBotRes result_info ->
(demands, result_info) | isBotDiv result_info ->
checkL (demands `lengthAtLeast` idArity binder)
(text "idArity" <+> ppr (idArity binder) <+>
text "exceeds arity imposed by the strictness signature" <+>
......@@ -682,7 +688,10 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty uf
| isStableUnfolding uf
, Just rhs <- maybeUnfoldingTemplate uf
= do { ty <- lintRhs bndr rhs
= do { ty <- if isCompulsoryUnfolding uf
then noLPChecks $ lintRhs bndr rhs
-- See Note [Checking for levity polymorphism]
else lintRhs bndr rhs
; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
lintIdUnfolding _ _ _
= return () -- Do not Lint unstable unfoldings, because that leads
......@@ -698,6 +707,23 @@ that form a mutually recursive group. Only after a round of
simplification are they unravelled. So we suppress the test for
the desugarer.
Note [Checking for levity polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We ordinarily want to check for bad levity polymorphism. See
Note [Levity polymorphism invariants] in CoreSyn. However, we do *not*
want to do this in a compulsory unfolding. Compulsory unfoldings arise
only internally, for things like newtype wrappers, dictionaries, and
(notably) unsafeCoerce#. These might legitimately be levity-polymorphic;
indeed levity-polyorphic unfoldings are a primary reason for the
very existence of compulsory unfoldings (we can't compile code for
the original, levity-poly, binding).
It is vitally important that we do levity-polymorphism checks *after*
performing the unfolding, but not beforehand. This is all safe because
we will check any unfolding after it has been unfolded; checking the
unfolding beforehand is merely an optimization, and one that actively
hurts us here.
************************************************************************
* *
\subsection[lintCoreExpr]{lintCoreExpr}
......@@ -996,7 +1022,8 @@ lintCoreArg fun_ty (Type arg_ty)
lintCoreArg fun_ty arg
= do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg
-- See Note [Levity polymorphism invariants] in CoreSyn
; lintL (not (isTypeLevPoly arg_ty))