Commit 74ad75e8 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Re-implement unsafe coercions in terms of unsafe equality proofs

(Commit message written by Omer, most of the code is written by Simon
and Richard)

See Note [Implementing unsafeCoerce] for how unsafe equality proofs and
the new unsafeCoerce# are implemented.

New notes added:

- [Checking for levity polymorphism] in CoreLint.hs
- [Implementing unsafeCoerce] in base/Unsafe/Coerce.hs
- [Patching magic definitions] in Desugar.hs
- [Wiring in unsafeCoerce#] in Desugar.hs

Only breaking change in this patch is unsafeCoerce# is not exported from
GHC.Exts, instead of GHC.Prim.

Fixes #17443
Fixes #16893

NoFib
-----

--------------------------------------------------------------------------------
        Program           Size    Allocs    Instrs     Reads    Writes
--------------------------------------------------------------------------------
             CS          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            CSD          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
             FS          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
              S          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
             VS          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            VSD          -0.1%      0.0%     -0.0%     -0.0%     -0.1%
            VSM          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           anna          -0.0%      0.0%     -0.0%     -0.0%     -0.0%
           ansi          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           atom          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         awards          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         banner          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
     bernouilli          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   binary-trees          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          boyer          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         boyer2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           bspt          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      cacheprof          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       calendar          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       cichelli          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        circsim          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       clausify          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
  comp_lab_zift          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       compress          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      compress2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
    constraints          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   cryptarithm1          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   cryptarithm2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            cse          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   digits-of-e1          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   digits-of-e2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         dom-lt          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          eliza          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          event          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
    exact-reals          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         exp3_8          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         expert          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
 fannkuch-redux          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          fasta          -0.1%      0.0%     -0.5%     -0.3%     -0.4%
            fem          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            fft          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           fft2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       fibheaps          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           fish          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          fluid          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         fulsom          -0.1%      0.0%     +0.0%     +0.0%     +0.0%
         gamteb          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            gcd          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
    gen_regexps          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         genfft          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
             gg          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           grep          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         hidden          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            hpg          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            ida          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          infer          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        integer          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      integrate          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   k-nucleotide          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          kahan          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        knights          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         lambda          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
     last-piece          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           lcss          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           life          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           lift          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         linear          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      listcompr          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       listcopy          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       maillist          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         mandel          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        mandel2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           mate          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        minimax          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        mkhprog          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
     multiplier          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         n-body          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       nucleic2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           para          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      paraffins          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         parser          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        parstof          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            pic          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       pidigits          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          power          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         pretty          -0.1%      0.0%     -0.1%     -0.1%     -0.1%
         primes          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      primetest          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         prolog          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         puzzle          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         queens          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        reptile          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
reverse-complem          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        rewrite          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           rfib          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            rsa          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            scc          -0.1%      0.0%     -0.1%     -0.1%     -0.1%
          sched          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            scs          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         simple          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
          solid          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        sorting          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
  spectral-norm          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         sphere          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
         symalg          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
            tak          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      transform          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
       treejoin          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      typecheck          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
        veritas          -0.0%      0.0%     -0.0%     -0.0%     -0.0%
           wang          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
      wave4main          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   wheel-sieve1          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
   wheel-sieve2          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
           x2n1          -0.1%      0.0%     -0.0%     -0.0%     -0.0%
--------------------------------------------------------------------------------
            Min          -0.1%      0.0%     -0.5%     -0.3%     -0.4%
            Max          -0.0%      0.0%     +0.0%     +0.0%     +0.0%
 Geometric Mean          -0.1%     -0.0%     -0.0%     -0.0%     -0.0%

Test changes
------------

- break006 is marked as broken, see #17833
- The compiler allocates less when building T14683 (an unsafeCoerce#-
  heavy happy-generated code) on 64-platforms. Allocates more on 32-bit
  platforms.
- Rest of the increases are tiny amounts (still enough to pass the
  threshold) in micro-benchmarks. I briefly looked at each one in a
  profiling build: most of the increased allocations seem to be because
  of random changes in the generated code.

Metric Decrease:
    T14683

Metric Increase:
    T12150
    T12234
    T12425
    T13035
    T14683
    T5837
    T6048
Co-Authored-By: Richard Eisenberg's avatarRichard Eisenberg <rae@cs.brynmawr.edu>
Co-Authored-By: Ömer Sinan Ağacan's avatarÖmer Sinan Ağacan <omeragacan@gmail.com>
parent 19680ee5
......@@ -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)
......
......@@ -301,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
......
......@@ -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.
This diff is collapsed.
......@@ -360,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
......@@ -1618,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
......
......@@ -454,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1195,8 +1202,11 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
--------- 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
......@@ -1559,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
......@@ -1607,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)
......@@ -1620,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
......@@ -1951,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,12 +1464,23 @@ 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
case info of
NoInfo -> return init_info
HasInfo info -> foldlM tcPrag init_info 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)
......@@ -1493,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
......@@ -1507,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 )}
......@@ -1535,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"
......@@ -1555,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
......
......@@ -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"
{-
************************************************************************
......
......@@ -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
......@@ -1381,6 +1379,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)
......@@ -1464,38 +1466,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
......@@ -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
......@@ -151,7 +153,6 @@ ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)]
ghcPrimIds
= [ realWorldPrimId
, voidPrimId
, unsafeCoerceId
, nullAddrId
, seqId
, magicDictId
......@@ -601,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1322,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
......@@ -1365,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#
......@@ -1487,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
......
......@@ -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
......
......@@ -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
......@@ -494,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
......@@ -683,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
......@@ -699,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