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 ...@@ -56,6 +56,7 @@ import GHC.Data.Bitmap
import OrdList import OrdList
import Maybes import Maybes
import VarEnv import VarEnv
import PrelNames ( unsafeEqualityProofName )
import Data.List import Data.List
import Foreign import Foreign
...@@ -634,11 +635,12 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) ...@@ -634,11 +635,12 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-- ignore other kinds of tick -- ignore other kinds of tick
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs 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 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)]) 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 -- Convert
-- case .... of x { (# V'd-thing, a #) -> ... } -- case .... of x { (# V'd-thing, a #) -> ... }
-- to -- to
...@@ -655,11 +657,13 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) ...@@ -655,11 +657,13 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
_ -> Nothing _ -> Nothing
= res = res
-- handle unit tuples
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc | 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) = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
-- handle nullary tuples
schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
| isUnboxedTupleType (idType bndr) | isUnboxedTupleType (idType bndr)
, Just ty <- case typePrimRep (idType bndr) of , Just ty <- case typePrimRep (idType bndr) of
...@@ -983,6 +987,7 @@ doCase ...@@ -983,6 +987,7 @@ doCase
doCase d s p (_,scrut) bndr alts is_unboxed_tuple doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| typePrimRep (idType bndr) `lengthExceeds` 1 | typePrimRep (idType bndr) `lengthExceeds` 1
= multiValException = multiValException
| otherwise | otherwise
= do = do
dflags <- getDynFlags dflags <- getDynFlags
...@@ -1883,6 +1888,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) ...@@ -1883,6 +1888,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- b) type applications -- b) type applications
-- c) casts -- c) casts
-- d) ticks (but not breakpoints) -- d) ticks (but not breakpoints)
-- e) case unsafeEqualityProof of UnsafeRefl -> e ==> e
-- Type lambdas *can* occur in random expressions, -- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here -- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnCast (_,e) _) = Just e bcView (AnnCast (_,e) _) = Just e
...@@ -1890,8 +1896,19 @@ bcView (AnnLam v (_,e)) | isTyVar v = Just e ...@@ -1890,8 +1896,19 @@ bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView (AnnTick Breakpoint{} _) = Nothing bcView (AnnTick Breakpoint{} _) = Nothing
bcView (AnnTick _other_tick (_,e)) = Just e 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 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 :: AnnExpr' Var ann -> Bool
isVAtom e | Just e' <- bcView e = isVAtom e' isVAtom e | Just e' <- bcView e = isVAtom e'
isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
......
...@@ -301,7 +301,6 @@ toIfaceCoercionX fr co ...@@ -301,7 +301,6 @@ toIfaceCoercionX fr co
fr' = fr `delVarSet` tv fr' = fr `delVarSet` tv
go_prov :: UnivCoProvenance -> IfaceUnivCoProv go_prov :: UnivCoProvenance -> IfaceUnivCoProv
go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str go_prov (PluginProv str) = IfacePluginProv str
......
...@@ -46,6 +46,7 @@ import ForeignCall ...@@ -46,6 +46,7 @@ import ForeignCall
import Demand ( isUsedOnce ) import Demand ( isUsedOnce )
import PrimOp ( PrimCall(..), primOpWrapperId ) import PrimOp ( PrimCall(..), primOpWrapperId )
import SrcLoc ( mkGeneralSrcSpan ) import SrcLoc ( mkGeneralSrcSpan )
import PrelNames ( unsafeEqualityProofName )
import Data.List.NonEmpty (nonEmpty, toList) import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
...@@ -404,11 +405,23 @@ coreToStgExpr (Case scrut _ _ []) ...@@ -404,11 +405,23 @@ coreToStgExpr (Case scrut _ _ [])
-- runtime system error function. -- 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) alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
scrut2 <- coreToStgExpr scrut 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 where
vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
vars_alt (con, binders, rhs) vars_alt (con, binders, rhs)
| DataAlt c <- con, c == unboxedUnitDataCon | DataAlt c <- con, c == unboxedUnitDataCon
= -- This case is a bit smelly. = -- This case is a bit smelly.
......
This diff is collapsed.
This diff is collapsed.
...@@ -360,7 +360,9 @@ data IfaceUnfolding ...@@ -360,7 +360,9 @@ data IfaceUnfolding
-- Possibly could eliminate the Bool here, the information -- Possibly could eliminate the Bool here, the information
-- is also in the InlinePragma. -- 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 | IfInlineRule Arity -- INLINE pragmas
Bool -- OK to inline even if *un*-saturated Bool -- OK to inline even if *un*-saturated
...@@ -1618,7 +1620,6 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) ...@@ -1618,7 +1620,6 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
= fnList freeNamesIfCoercion cos = fnList freeNamesIfCoercion cos
freeNamesIfProv :: IfaceUnivCoProv -> NameSet freeNamesIfProv :: IfaceUnivCoProv -> NameSet
freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet freeNamesIfProv (IfacePluginProv _) = emptyNameSet
......
...@@ -454,8 +454,15 @@ trimId :: Id -> Id ...@@ -454,8 +454,15 @@ trimId :: Id -> Id
trimId id trimId id
| not (isImplicitId id) | not (isImplicitId id)
= id `setIdInfo` vanillaIdInfo = id `setIdInfo` vanillaIdInfo
`setIdUnfolding` unfolding
| otherwise | otherwise
= id = id
where
unfolding
| isCompulsoryUnfolding (idUnfolding id)
= idUnfolding id
| otherwise
= noUnfolding
{- Note [Drop wired-in things] {- Note [Drop wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -1195,8 +1202,11 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold ...@@ -1195,8 +1202,11 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
--------- Unfolding ------------ --------- Unfolding ------------
unf_info = unfoldingInfo idinfo unf_info = unfoldingInfo idinfo
unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs unfold_info
| otherwise = minimal_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 minimal_unfold_info = zapUnfolding unf_info
unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
is_bot = isBottomingSig final_sig is_bot = isBottomingSig final_sig
......
...@@ -237,6 +237,12 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon ...@@ -237,6 +237,12 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
-- only: see Note [Equality predicates in IfaceType] -- only: see Note [Equality predicates in IfaceType]
deriving (Eq) 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] {- Note [Free tyvars in IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
...@@ -350,8 +356,7 @@ data IfaceCoercion ...@@ -350,8 +356,7 @@ data IfaceCoercion
| IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
data IfaceUnivCoProv data IfaceUnivCoProv
= IfaceUnsafeCoerceProv = IfacePhantomProv IfaceCoercion
| IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String | IfacePluginProv String
...@@ -525,7 +530,6 @@ substIfaceType env ty ...@@ -525,7 +530,6 @@ substIfaceType env ty
go_cos = map go_co go_cos = map go_co
go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov (IfacePluginProv str) = IfacePluginProv str go_prov (IfacePluginProv str) = IfacePluginProv str
...@@ -1559,11 +1563,6 @@ ppr_co _ (IfaceFreeCoVar covar) = ppr covar ...@@ -1559,11 +1563,6 @@ ppr_co _ (IfaceFreeCoVar covar) = ppr covar
ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar
ppr_co _ (IfaceHoleCo covar) = braces (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) ppr_co _ (IfaceUnivCo prov role ty1 ty2)
= text "Univ" <> (parens $ = text "Univ" <> (parens $
sep [ ppr role <+> pprIfaceUnivCoProv prov sep [ ppr role <+> pprIfaceUnivCoProv prov
...@@ -1607,8 +1606,6 @@ ppr_role r = underscore <> pp_role ...@@ -1607,8 +1606,6 @@ ppr_role r = underscore <> pp_role
------------------ ------------------
pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
pprIfaceUnivCoProv IfaceUnsafeCoerceProv
= text "unsafe"
pprIfaceUnivCoProv (IfacePhantomProv co) pprIfaceUnivCoProv (IfacePhantomProv co)
= text "phantom" <+> pprParendIfaceCoercion co = text "phantom" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfaceProofIrrelProv co) pprIfaceUnivCoProv (IfaceProofIrrelProv co)
...@@ -1620,6 +1617,11 @@ pprIfaceUnivCoProv (IfacePluginProv s) ...@@ -1620,6 +1617,11 @@ pprIfaceUnivCoProv (IfacePluginProv s)
instance Outputable IfaceTyCon where instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) 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 :: IfaceTyCon -> SDoc
pprPromotionQuote tc = pprPromotionQuote tc =
pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
...@@ -1951,26 +1953,24 @@ instance Binary IfaceCoercion where ...@@ -1951,26 +1953,24 @@ instance Binary IfaceCoercion where
_ -> panic ("get IfaceCoercion " ++ show tag) _ -> panic ("get IfaceCoercion " ++ show tag)
instance Binary IfaceUnivCoProv where instance Binary IfaceUnivCoProv where
put_ bh IfaceUnsafeCoerceProv = putByte bh 1
put_ bh (IfacePhantomProv a) = do put_ bh (IfacePhantomProv a) = do
putByte bh 2 putByte bh 1
put_ bh a put_ bh a
put_ bh (IfaceProofIrrelProv a) = do put_ bh (IfaceProofIrrelProv a) = do
putByte bh 3 putByte bh 2
put_ bh a put_ bh a
put_ bh (IfacePluginProv a) = do put_ bh (IfacePluginProv a) = do
putByte bh 4 putByte bh 3
put_ bh a put_ bh a
get bh = do get bh = do
tag <- getByte bh tag <- getByte bh
case tag of case tag of
1 -> return $ IfaceUnsafeCoerceProv 1 -> do a <- get bh
2 -> do a <- get bh
return $ IfacePhantomProv a return $ IfacePhantomProv a
3 -> do a <- get bh 2 -> do a <- get bh
return $ IfaceProofIrrelProv a return $ IfaceProofIrrelProv a
4 -> do a <- get bh 3 -> do a <- get bh
return $ IfacePluginProv a return $ IfacePluginProv a
_ -> panic ("get IfaceUnivCoProv " ++ show tag) _ -> panic ("get IfaceUnivCoProv " ++ show tag)
......
...@@ -1249,7 +1249,6 @@ tcIfaceCo = go ...@@ -1249,7 +1249,6 @@ tcIfaceCo = go
go_var = tcIfaceLclId go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
...@@ -1465,12 +1464,23 @@ tcIdInfo ignore_prags toplvl name ty info = do ...@@ -1465,12 +1464,23 @@ tcIdInfo ignore_prags toplvl name ty info = do
-- we start; default assumption is that it has CAFs -- we start; default assumption is that it has CAFs
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo | otherwise = vanillaIdInfo
if ignore_prags
then return init_info case info of
else case info of NoInfo -> return init_info
NoInfo -> return init_info HasInfo info -> let needed = needed_prags info in
HasInfo info -> foldlM tcPrag init_info info foldlM tcPrag init_info needed
where 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 :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
...@@ -1493,7 +1503,7 @@ tcJoinInfo IfaceNotJoinPoint = Nothing ...@@ -1493,7 +1503,7 @@ tcJoinInfo IfaceNotJoinPoint = Nothing
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; mb_expr <- tcPragExpr toplvl name if_expr ; mb_expr <- tcPragExpr False toplvl name if_expr
; let unf_src | stable = InlineStable ; let unf_src | stable = InlineStable
| otherwise = InlineRhs | otherwise = InlineRhs
; return $ case mb_expr of ; return $ case mb_expr of
...@@ -1507,13 +1517,13 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) ...@@ -1507,13 +1517,13 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
-- Strictness should occur before unfolding! -- Strictness should occur before unfolding!
strict_sig = strictnessInfo info strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr) 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 ; return (case mb_expr of
Nothing -> NoUnfolding Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) } Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_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 ; return (case mb_expr of
Nothing -> NoUnfolding Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )} 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 ...@@ -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. an unfolding that isn't going to be looked at.
-} -}
tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr) tcPragExpr :: Bool -- Is this unfolding compulsory?
tcPragExpr toplvl name expr -- See Note [Checking for levity polymorphism] in CoreLint
-> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr is_compulsory toplvl name expr
= forkM_maybe doc $ do = forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding -- Check for type consistency in the unfolding
-- See Note [Linting Unfoldings from Interfaces] -- 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 in_scope <- get_in_scope
dflags <- getDynFlags dflags <- getDynFlags
case lintUnfolding dflags noSrcLoc in_scope core_expr' of case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
Nothing -> return () Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure" ; pprPanic "Iface Lint failure"
...@@ -1555,7 +1568,8 @@ tcPragExpr toplvl name expr ...@@ -1555,7 +1568,8 @@ tcPragExpr toplvl name expr
, text "Iface expr =" <+> ppr expr ]) } , text "Iface expr =" <+> ppr expr ]) }
return core_expr' return core_expr'
where 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 :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope get_in_scope
...@@ -1686,7 +1700,7 @@ tcIfaceTyCon (IfaceTyCon name info) ...@@ -1686,7 +1700,7 @@ tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name = do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of ; return $ case ifaceTyConIsPromoted info of
NotPromoted -> tyThingTyCon thing NotPromoted -> tyThingTyCon thing
IsPromoted -> promoteDataCon $ tyThingDataCon thing } IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
......
...@@ -105,9 +105,9 @@ import Data.Map (Map) ...@@ -105,9 +105,9 @@ import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import StringBuffer (stringToStringBuffer) import StringBuffer (stringToStringBuffer)
import Control.Monad import Control.Monad
import GHC.Exts
import Data.Array import Data.Array
import Exception import Exception
import Unsafe.Coerce ( unsafeCoerce )
import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces )
import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) )
...@@ -1225,7 +1225,7 @@ dynCompileExpr expr = do ...@@ -1225,7 +1225,7 @@ dynCompileExpr expr = do
to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)
parsed_expr parsed_expr
hval <- compileParsedExpr to_dyn_expr hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic) return (unsafeCoerce hval :: Dynamic)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- show a module and it's source/object filenames -- show a module and it's source/object filenames
...@@ -1254,7 +1254,7 @@ obtainTermFromVal hsc_env bound force ty x ...@@ -1254,7 +1254,7 @@ obtainTermFromVal hsc_env bound force ty x
= throwIO (InstallationError = throwIO (InstallationError
"this operation requires -fno-external-interpreter") "this operation requires -fno-external-interpreter")
| otherwise | 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 :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do obtainTermFromId hsc_env bound force id = do
......
...@@ -54,7 +54,7 @@ import Hooks ...@@ -54,7 +54,7 @@ import Hooks
import Control.Monad ( when, unless ) import Control.Monad ( when, unless )
import Data.Maybe ( mapMaybe ) import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# ) import Unsafe.Coerce ( unsafeCoerce )
-- | Loads the plugins specified in the pluginModNames field of the dynamic -- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before -- flags. Should be called after command line arguments are parsed, but before
...@@ -222,7 +222,7 @@ lessUnsafeCoerce :: DynFlags -> String -> a -> IO b ...@@ -222,7 +222,7 @@ lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do lessUnsafeCoerce dflags context what = do
debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
(text "...") (text "...")
output <- evaluate (unsafeCoerce# what) output <- evaluate (unsafeCoerce what)
debugTraceMsg dflags 3 (text "Successfully evaluated coercion") debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
return output return output
......
...@@ -325,6 +325,9 @@ isPromoted :: PromotionFlag -> Bool ...@@ -325,6 +325,9 @@ isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True isPromoted IsPromoted = True
isPromoted NotPromoted = False isPromoted NotPromoted = False
instance Outputable PromotionFlag where
ppr NotPromoted = text "NotPromoted"
ppr IsPromoted = text "IsPromoted"
{- {-
************************************************************************ ************************************************************************
......
...@@ -24,7 +24,7 @@ module DataCon ( ...@@ -24,7 +24,7 @@ module DataCon (
FieldLbl(..), FieldLabel, FieldLabelString, FieldLbl(..), FieldLabel, FieldLabelString,
-- ** Type construction -- ** Type construction
mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG, mkDataCon, fIRST_TAG,
-- ** Type deconstruction -- ** Type deconstruction
dataConRepType, dataConInstSig, dataConFullSig, dataConRepType, dataConInstSig, dataConFullSig,
...@@ -65,7 +65,6 @@ import GhcPrelude ...@@ -65,7 +65,6 @@ import GhcPrelude
import {-# SOURCE #-} MkId( DataConBoxer ) import {-# SOURCE #-} MkId( DataConBoxer )
import Type import Type
import ForeignCall ( CType )
import Coercion import Coercion
import Unify import Unify
import TyCon import TyCon
...@@ -75,7 +74,6 @@ import Name ...@@ -75,7 +74,6 @@ import Name
import PrelNames import PrelNames
import Predicate import Predicate
import Var import Var
import VarSet( emptyVarSet )
import Outputable import Outputable
import Util import Util
import BasicTypes import BasicTypes
...@@ -1381,6 +1379,10 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool ...@@ -1381,6 +1379,10 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool
-- scrutinee of type (T tys) -- scrutinee of type (T tys)
-- where T is the dcRepTyCon for the data con -- where T is the dcRepTyCon for the data con
dataConCannotMatch tys con dataConCannotMatch tys con
-- See (U6) in Note [Implementing unsafeCoerce]
-- in base:Unsafe.Coerce
| dataConName con == unsafeReflDataConName
= False
| null inst_theta = False -- Common | null inst_theta = False -- Common
| all isTyVarTy tys = False -- Also common | all isTyVarTy tys = False -- Also common
| otherwise = typesCantMatch (concatMap predEqs inst_theta) | otherwise = typesCantMatch (concatMap predEqs inst_theta)
...@@ -1464,38 +1466,3 @@ splitDataProductType_maybe ty ...@@ -1464,38 +1466,3 @@ splitDataProductType_maybe ty
| otherwise | otherwise
= Nothing = Nothing