Commit e7985ed2 authored by Richard Eisenberg's avatar Richard Eisenberg

Update levity polymorphism

This commit implements the proposal in
https://github.com/ghc-proposals/ghc-proposals/pull/29 and
https://github.com/ghc-proposals/ghc-proposals/pull/35.

Here are some of the pieces of that proposal:

* Some of RuntimeRep's constructors have been shortened.

* TupleRep and SumRep are now parameterized over a list of RuntimeReps.
* This
means that two types with the same kind surely have the same
representation.
Previously, all unboxed tuples had the same kind, and thus the fact
above was
false.

* RepType.typePrimRep and friends now return a *list* of PrimReps. These
functions can now work successfully on unboxed tuples. This change is
necessary because we allow abstraction over unboxed tuple types and so
cannot
always handle unboxed tuples specially as we did before.

* We sometimes have to create an Id from a PrimRep. I thus split PtrRep
* into
LiftedRep and UnliftedRep, so that the created Ids have the right
strictness.

* The RepType.RepType type was removed, as it didn't seem to help with
* much.

* The RepType.repType function is also removed, in favor of typePrimRep.

* I have waffled a good deal on whether or not to keep VoidRep in
TyCon.PrimRep. In the end, I decided to keep it there. PrimRep is *not*
represented in RuntimeRep, and typePrimRep will never return a list
including
VoidRep. But it's handy to have in, e.g., ByteCodeGen and friends. I can
imagine another design choice where we have a PrimRepV type that is
PrimRep
with an extra constructor. That seemed to be a heavier design, though,
and I'm
not sure what the benefit would be.

* The last, unused vestiges of # (unliftedTypeKind) have been removed.

* There were several pretty-printing bugs that this change exposed;
* these are fixed.

* We previously checked for levity polymorphism in the types of binders.
* But we
also must exclude levity polymorphism in function arguments. This is
hard to check
for, requiring a good deal of care in the desugarer. See Note [Levity
polymorphism
checking] in DsMonad.

* In order to efficiently check for levity polymorphism in functions, it
* was necessary
to add a new bit of IdInfo. See Note [Levity info] in IdInfo.

* It is now safe for unlifted types to be unsaturated in Core. Core Lint
* is updated
accordingly.

* We can only know strictness after zonking, so several checks around
* strictness
in the type-checker (checkStrictBinds, the check for unlifted variables
under a ~
pattern) have been moved to the desugarer.

* Along the way, I improved the treatment of unlifted vs. banged
* bindings. See
Note [Strict binds checks] in DsBinds and #13075.

* Now that we print type-checked source, we must be careful to print
* ConLikes correctly.
This is facilitated by a new HsConLikeOut constructor to HsExpr.
Particularly troublesome
are unlifted pattern synonyms that get an extra void# argument.

* Includes a submodule update for haddock, getting rid of #.

* New testcases:
  typecheck/should_fail/StrictBinds
  typecheck/should_fail/T12973
  typecheck/should_run/StrictPats
  typecheck/should_run/T12809
  typecheck/should_fail/T13105
  patsyn/should_fail/UnliftedPSBind
  typecheck/should_fail/LevPolyBounded
  typecheck/should_compile/T12987
  typecheck/should_compile/T11736

* Fixed tickets:
  #12809
  #12973
  #11736
  #13075
  #12987

* This also adds a test case for #13105. This test case is
* "compile_fail" and
succeeds, because I want the testsuite to monitor the error message.
When #13105 is fixed, the test case will compile cleanly.
parent 38374caa
......@@ -753,7 +753,7 @@ pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use
-> SDoc -- ^ 'SDoc' where the alternative havs been pretty
-- printed and finally packed into a paragraph.
pprAlternative pp x alt arity =
fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt - 1) vbar)
fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar)
{-
************************************************************************
......
......@@ -85,12 +85,13 @@ module Id (
-- ** Reading 'IdInfo' fields
idArity,
idCallArity,
idCallArity, idFunRepArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
isNeverLevPolyId,
-- ** Writing 'IdInfo' fields
setIdUnfolding,
......@@ -125,6 +126,7 @@ import Var( Id, CoVar, DictId,
import qualified Var
import Type
import RepType
import TysPrim
import DataCon
import Demand
......@@ -563,6 +565,9 @@ idCallArity id = callArityInfo (idInfo id)
setIdCallArity :: Id -> Arity -> Id
setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id
idFunRepArity :: Id -> RepArity
idFunRepArity x = countFunRepArgs (idArity x) (idType x)
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
......@@ -863,3 +868,6 @@ transferPolyIdInfo old_id abstract_wrt new_id
`setInlinePragInfo` old_inline_prag
`setOccInfo` old_occ_info
`setStrictnessInfo` new_strictness
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
......@@ -8,6 +8,8 @@
Haskell. [WDP 94/11])
-}
{-# LANGUAGE CPP #-}
module IdInfo (
-- * The IdDetails type
IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
......@@ -66,8 +68,14 @@ module IdInfo (
-- ** Tick-box Info
TickBoxOp(..), TickBoxId,
-- ** Levity info
LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType,
isNeverLevPolyIdInfo
) where
#include "HsVersions.h"
import CoreSyn
import Class
......@@ -78,10 +86,12 @@ import BasicTypes
import DataCon
import TyCon
import PatSyn
import Type
import ForeignCall
import Outputable
import Module
import Demand
import Util
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setRuleInfo`,
......@@ -92,7 +102,9 @@ infixl 1 `setRuleInfo`,
`setOccInfo`,
`setCafInfo`,
`setStrictnessInfo`,
`setDemandInfo`
`setDemandInfo`,
`setNeverLevPoly`,
`setLevityInfoWithType`
{-
************************************************************************
......@@ -127,7 +139,8 @@ data IdDetails
-- or class operation of a class
| PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator
| FCallId ForeignCall -- ^ The 'Id' is for a foreign call
| FCallId ForeignCall -- ^ The 'Id' is for a foreign call.
-- Type will be simple: no type families, newtypes, etc
| TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
......@@ -169,18 +182,18 @@ pprIdDetails :: IdDetails -> SDoc
pprIdDetails VanillaId = empty
pprIdDetails other = brackets (pp other)
where
pp VanillaId = panic "pprIdDetails"
pp (DataConWorkId _) = text "DataCon"
pp (DataConWrapId _) = text "DataConWrapper"
pp (ClassOpId {}) = text "ClassOp"
pp (PrimOpId _) = text "PrimOp"
pp (FCallId _) = text "ForeignCall"
pp (TickBoxOpId _) = text "TickBoxOp"
pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)")
pp VanillaId = panic "pprIdDetails"
pp (DataConWorkId _) = text "DataCon"
pp (DataConWrapId _) = text "DataConWrapper"
pp (ClassOpId {}) = text "ClassOp"
pp (PrimOpId _) = text "PrimOp"
pp (FCallId _) = text "ForeignCall"
pp (TickBoxOpId _) = text "TickBoxOp"
pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)")
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ text "RecSel"
<> ppWhen is_naughty (text "(naughty)")
pp CoVarId = text "CoVarId"
= brackets $ text "RecSel" <>
ppWhen is_naughty (text "(naughty)")
pp CoVarId = text "CoVarId"
{-
************************************************************************
......@@ -221,8 +234,10 @@ data IdInfo
strictnessInfo :: StrictSig, -- ^ A strictness signature
demandInfo :: Demand, -- ^ ID demand information
callArityInfo :: !ArityInfo -- ^ How this is called.
callArityInfo :: !ArityInfo, -- ^ How this is called.
-- n <=> all calls have at least n arguments
levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type?
}
-- Setters
......@@ -272,7 +287,8 @@ vanillaIdInfo
occInfo = NoOccInfo,
demandInfo = topDmd,
strictnessInfo = nopSig,
callArityInfo = unknownArity
callArityInfo = unknownArity,
levityInfo = NoLevityInfo
}
-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
......@@ -520,3 +536,51 @@ data TickBoxOp
instance Outputable TickBoxOp where
ppr (TickBox mod n) = text "tick" <+> ppr (mod,n)
{-
************************************************************************
* *
Levity
* *
************************************************************************
Note [Levity info]
~~~~~~~~~~~~~~~~~~
Ids store whether or not they can be levity-polymorphic at any amount
of saturation. This is helpful in optimizing the levity-polymorphism check
done in the desugarer, where we can usually learn that something is not
levity-polymorphic without actually figuring out its type. See
isExprLevPoly in CoreUtils for where this info is used. Storing
this is required to prevent perf/compiler/T5631 from blowing up.
-}
-- See Note [Levity info]
data LevityInfo = NoLevityInfo -- always safe
| NeverLevityPolymorphic
deriving Eq
instance Outputable LevityInfo where
ppr NoLevityInfo = text "NoLevityInfo"
ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic"
-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when
-- applied). The Type is only there for checking that it's really never levity
-- polymorphic
setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo
setNeverLevPoly info ty
= ASSERT2( not (resultIsLevPoly ty), ppr ty )
info { levityInfo = NeverLevityPolymorphic }
setLevityInfoWithType :: IdInfo -> Type -> IdInfo
setLevityInfoWithType info ty
| not (resultIsLevPoly ty)
= info { levityInfo = NeverLevityPolymorphic }
| otherwise
= info
isNeverLevPolyIdInfo :: IdInfo -> Bool
isNeverLevPolyIdInfo info
| NeverLevityPolymorphic <- levityInfo info = True
| otherwise = False
......@@ -55,7 +55,6 @@ import TyCon
import CoAxiom
import Class
import NameSet
import VarSet
import Name
import PrimOp
import ForeignCall
......@@ -287,8 +286,9 @@ mkDictSelId name clas
getNth arg_tys val_index
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setLevityInfoWithType` sel_ty
info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma
......@@ -380,10 +380,13 @@ mkDataConWorkId wkr_name data_con
alg_wkr_ty = dataConRepType data_con
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` alg_wkr_ty
-- NB: unboxed tuples have workers, so we can't use
-- setNeverLevPoly
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
-- Note [Data-con worker strictness]
......@@ -409,8 +412,9 @@ mkDataConWorkId wkr_name data_con
nt_wrap_ty = dataConUserType data_con
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
`setLevityInfoWithType` nt_wrap_ty
id_arg1 = mkTemplateLocal 1 (head nt_arg_tys)
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
isSingleton nt_arg_tys, ppr data_con )
......@@ -520,6 +524,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
`setNeverLevPoly` wrap_ty
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
wrap_arg_dmds = map mk_dmd arg_ibangs
......@@ -965,10 +970,11 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setInlinePragInfo` neverInlinePragma
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setInlinePragInfo` neverInlinePragma
`setLevityInfoWithType` res_ty
-- We give PrimOps a NOINLINE pragma so that we don't
-- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-- test) about a RULE conflicting with a possible inlining
......@@ -985,7 +991,7 @@ mkPrimOpId prim_op
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId dflags uniq fcall ty
= ASSERT( isEmptyVarSet (tyCoVarsOfType ty) )
= ASSERT( noFreeVarsOfType ty )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
mkGlobalId (FCallId fcall) name ty info
......@@ -997,8 +1003,9 @@ mkFCallId dflags uniq fcall ty
name = mkFCallName uniq occ_str
info = noCafIdInfo
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setLevityInfoWithType` ty
(bndrs, _) = tcSplitPiTys ty
arity = count isAnonTyBinder bndrs
......@@ -1101,7 +1108,8 @@ dollarId = pcMiscPrelId dollarName ty
proxyHashId :: Id
proxyHashId
= pcMiscPrelId proxyName ty
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
`setNeverLevPoly` ty )
where
-- proxy# :: forall k (a:k). Proxy# k a
bndrs = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks)
......@@ -1139,6 +1147,7 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
`setNeverLevPoly` addrPrimTy
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
......@@ -1147,6 +1156,7 @@ seqId = pcMiscPrelId seqName ty info
info = noCafIdInfo `setInlinePragInfo` inline_prag
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setRuleInfo` mkRuleInfo [seq_cast_rule]
`setNeverLevPoly` ty
inline_prag
= alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
......@@ -1188,13 +1198,13 @@ match_seq_of_cast _ _ _ _ = Nothing
lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info
where
info = noCafIdInfo
info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
noinlineId :: Id -- See Note [noinlineId magic]
noinlineId = pcMiscPrelId noinlineIdName ty info
where
info = noCafIdInfo
info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function]
......@@ -1240,6 +1250,7 @@ magicDictId :: Id -- See Note [magicDictId magic]
magicDictId = pcMiscPrelId magicDictName ty info
where
info = noCafIdInfo `setInlinePragInfo` neverInlinePragma
`setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] alphaTy
--------------------------------------------------------------------------------
......@@ -1249,6 +1260,7 @@ coerceId = pcMiscPrelId coerceName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setNeverLevPoly` ty
eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind
, alphaTy, betaTy ]
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind
......@@ -1291,7 +1303,7 @@ 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 (a:OpenKind) (b:OpenKind). a -> b
forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b
Note [seqId magic]
~~~~~~~~~~~~~~~~~~
......@@ -1552,11 +1564,13 @@ inlined.
realWorldPrimId :: Id -- :: State# RealWorld
realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
`setOneShotInfo` stateHackOneShot)
`setOneShotInfo` stateHackOneShot
`setNeverLevPoly` realWorldStatePrimTy)
voidPrimId :: Id -- Global constant :: Void#
voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
`setNeverLevPoly` voidPrimTy)
voidArgId :: Id -- Local lambda-bound :: Void#
voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
......
......@@ -11,7 +11,7 @@
module CmmUtils(
-- CmmType
primRepCmmType, slotCmmType, slotForeignHint,
typeCmmType, typeForeignHint,
typeCmmType, typeForeignHint, primRepForeignHint,
-- CmmLit
zeroCLit, mkIntCLit,
......@@ -65,7 +65,7 @@ module CmmUtils(
#include "HsVersions.h"
import TyCon ( PrimRep(..), PrimElemRep(..) )
import RepType ( UnaryType, SlotTy (..), typePrimRep )
import RepType ( UnaryType, SlotTy (..), typePrimRep1 )
import SMRep
import Cmm
......@@ -90,7 +90,8 @@ import Hoopl
primRepCmmType :: DynFlags -> PrimRep -> CmmType
primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
primRepCmmType dflags PtrRep = gcWord dflags
primRepCmmType dflags LiftedRep = gcWord dflags
primRepCmmType dflags UnliftedRep = gcWord dflags
primRepCmmType dflags IntRep = bWord dflags
primRepCmmType dflags WordRep = bWord dflags
primRepCmmType _ Int64Rep = b64
......@@ -120,11 +121,12 @@ primElemRepCmmType FloatElemRep = f32
primElemRepCmmType DoubleElemRep = f64
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep = AddrHint
primRepForeignHint LiftedRep = AddrHint
primRepForeignHint UnliftedRep = AddrHint
primRepForeignHint IntRep = SignedHint
primRepForeignHint WordRep = NoHint
primRepForeignHint Int64Rep = SignedHint
......@@ -142,7 +144,7 @@ slotForeignHint FloatSlot = NoHint
slotForeignHint DoubleSlot = NoHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
typeForeignHint = primRepForeignHint . typePrimRep1
---------------------------------------------------
--
......
......@@ -232,10 +232,10 @@ cgDataCon data_con
-- We're generating info tables, so we don't know and care about
-- what the actual arguments are. Using () here as the place holder.
arg_reps :: [NonVoid PrimRep]
arg_reps = [ NonVoid (typePrimRep rep_ty)
arg_reps = [ NonVoid rep_ty
| ty <- dataConRepArgTys data_con
, rep_ty <- repTypeArgs ty
, not (isVoidTy rep_ty)]
, rep_ty <- typePrimRep ty
, not (isVoidRep rep_ty) ]
; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
-- NB: the closure pointer is assumed *untagged* on
......
......@@ -64,7 +64,8 @@ argRepString V64 = "V64"
toArgRep :: PrimRep -> ArgRep
toArgRep VoidRep = V
toArgRep PtrRep = P
toArgRep LiftedRep = P
toArgRep UnliftedRep = P
toArgRep IntRep = N
toArgRep WordRep = N
toArgRep AddrRep = N
......
......@@ -163,8 +163,8 @@ assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
-- Why are these here?
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
-- NB: typePrimRep fails on unboxed tuples,
idPrimRep id = typePrimRep1 (idType id)
-- NB: typePrimRep1 fails on unboxed tuples,
-- but by StgCmm no Ids have unboxed tuple type
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
......@@ -176,7 +176,7 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
in NonVoid (argPrimRep arg', arg'))
argPrimRep :: StgArg -> PrimRep
argPrimRep arg = typePrimRep (stgArgType arg)
argPrimRep arg = typePrimRep1 (stgArgType arg)
-----------------------------------------------------------------------------
......@@ -292,8 +292,8 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
| UnaryRep rep <- repType ty
, Just tc <- tyConAppTyCon_maybe rep
| [LiftedRep] <- typePrimRep ty
, Just tc <- tyConAppTyCon_maybe (unwrapType ty)
, isDataTyCon tc
= False
| otherwise
......
......@@ -193,7 +193,4 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg
-- about accidental collision
idToReg dflags (NonVoid id)
= LocalReg (idUnique id)
(case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
_ -> primRepCmmType dflags (idPrimRep id))
(primRepCmmType dflags (idPrimRep id))
......@@ -39,8 +39,8 @@ import ForeignCall
import Id
import PrimOp
import TyCon
import Type
import RepType ( isVoidTy, countConRepArgs )
import Type ( isUnliftedType )
import RepType ( isVoidTy, countConRepArgs, primRepSlot )
import CostCentre ( CostCentreStack, currentCCS )
import Maybes
import Util
......@@ -49,6 +49,7 @@ import Outputable
import Control.Monad (unless,void)
import Control.Arrow (first)
import Data.Function ( on )
import Prelude hiding ((<*>))
......@@ -402,14 +403,23 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
= -- assignment suffices for unlifted types
do { dflags <- getDynFlags
; unless reps_compatible $
panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
(pp_bndr v $$ pp_bndr bndr)
; v_info <- getCgIdInfo v
; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
(idInfoToAmode v_info)
; bindArgToReg (NonVoid bndr)
; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
where
reps_compatible = idPrimRep v == idPrimRep bndr
reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
-- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
-- the types of the binders are generated from slotPrimRep and might not
-- match. Test case:
-- swap :: (# Int | Int #) -> (# Int | Int #)
-- swap (# x | #) = (# | x #)
-- swap (# | y #) = (# y | #)
pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
{- Note [Dodgy unsafeCoerce 2, #3132]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -525,16 +525,16 @@ getFCallArgs args
= do { mb_cmms <- mapM get args
; return (catMaybes mb_cmms) }
where
get arg | isVoidRep arg_rep
get arg | null arg_reps
= return Nothing
| otherwise
= do { cmm <- getArgAmode (NonVoid arg)
; dflags <- getDynFlags
; return (Just (add_shim dflags arg_ty cmm, hint)) }
where
arg_ty = stgArgType arg
arg_rep = typePrimRep arg_ty
hint = typeForeignHint arg_ty
arg_ty = stgArgType arg
arg_reps = typePrimRep arg_ty
hint = typeForeignHint arg_ty
add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim dflags arg_ty expr
......@@ -549,6 +549,5 @@ add_shim dflags arg_ty expr
| otherwise = expr
where
UnaryRep rep_ty = repType arg_ty
tycon = tyConAppTyCon rep_ty
tycon = tyConAppTyCon (unwrapType arg_ty)
-- should be a tycon app, since this is a foreign call
......@@ -362,11 +362,11 @@ newUnboxedTupleRegs res_ty
; sequel <- getSequel
; regs <- choose_regs dflags sequel
; ASSERT( regs `equalLength` reps )
return (regs, map slotForeignHint reps) }
return (regs, map primRepForeignHint reps) }
where
MultiRep reps = repType res_ty
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
choose_regs dflags _ = mapM (newTemp . slotCmmType dflags) reps
choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
......
......@@ -987,6 +987,10 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
= go n subst' ty' (EtaVar tv' : eis)
| Just (arg_ty, res_ty) <- splitFunTy_maybe ty
, not (isTypeLevPoly arg_ty)
-- See Note [Levity polymorphism invariants] in CoreSyn
-- See also test case typecheck/should_run/EtaExpandLevPoly
, let (subst', eta_id') = freshEtaId n subst arg_ty
-- Avoid free vars of the original expression
= go (n-1) subst' res_ty (EtaVar eta_id' : eis)
......@@ -1001,7 +1005,8 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
go n subst ty' (EtaCo co : eis)
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
-- but its type isn't a function, or a binder
-- is levity-polymorphic
= WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTCvInScope subst, reverse eis)
-- This *can* legitmately happen:
......@@ -1011,6 +1016,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
-- with an explicit lambda having a non-function type
--------------
-- Avoiding unnecessary substitution; use short-cutting versions
......
......@@ -795,6 +795,12 @@ lintCoreArg fun_ty (Type arg_ty)
lintCoreArg fun_ty arg
= do { arg_ty <- lintCoreExpr arg
-- See Note [Levity polymorphism invariants] in CoreSyn
; lintL (not (isTypeLevPoly arg_ty))
(text "Levity-polymorphic argument:" <+>
(ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
-- check for levity polymorphism first, because otherwise isUnliftedType panics
; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
(mkLetAppMsg arg)
; lintValApp arg fun_ty arg_ty }
......@@ -1028,10 +1034,9 @@ lintIdBndr top_lvl id linterF
(mkNonTopExternalNameMsg id)
; (ty, k) <- lintInTy (idType id)
-- Check for levity polymorphism
; lintL (not (isLevityPolymorphic k))
(text "RuntimeRep-polymorphic binder:" <+>
-- See Note [Levity polymorphism invariants] in CoreSyn
; lintL (not (isKindLevPoly k))
(text "Levity-polymorphic binder:" <+>
(ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
; let id' = setIdType id ty
......@@ -1085,7 +1090,7 @@ lintType ty@(TyConApp tc tys)
= lintType ty' -- Expand type synonyms, so that we do not bogusly complain
-- about un-saturated type synonyms
| isUnliftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc