diff options
| author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-07-21 08:07:41 +0000 |
|---|---|---|
| committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-07-21 08:11:27 +0000 |
| commit | 714bebff44076061d0a719c4eda2cfd213b7ac3d (patch) | |
| tree | b697e786a8f5f25e8a47886bc5d5487c01678ec6 /compiler | |
| parent | 83e4f49577665278fe08fbaafe2239553f3c448e (diff) | |
| download | haskell-714bebff44076061d0a719c4eda2cfd213b7ac3d.tar.gz | |
Implement unboxed sum primitive type
Summary:
This patch implements primitive unboxed sum types, as described in
https://ghc.haskell.org/trac/ghc/wiki/UnpackedSumTypes.
Main changes are:
- Add new syntax for unboxed sums types, terms and patterns. Hidden
behind `-XUnboxedSums`.
- Add unlifted unboxed sum type constructors and data constructors,
extend type and pattern checkers and desugarer.
- Add new RuntimeRep for unboxed sums.
- Extend unarise pass to translate unboxed sums to unboxed tuples right
before code generation.
- Add `StgRubbishArg` to `StgArg`, and a new type `CmmArg` for better
code generation when sum values are involved.
- Add user manual section for unboxed sums.
Some other changes:
- Generalize `UbxTupleRep` to `MultiRep` and `UbxTupAlt` to
`MultiValAlt` to be able to use those with both sums and tuples.
- Don't use `tyConPrimRep` in `isVoidTy`: `tyConPrimRep` is really
wrong, given an `Any` `TyCon`, there's no way to tell what its kind
is, but `kindPrimRep` and in turn `tyConPrimRep` returns `PtrRep`.
- Fix some bugs on the way: #12375.
Not included in this patch:
- Update Haddock for new the new unboxed sum syntax.
- `TemplateHaskell` support is left as future work.
For reviewers:
- Front-end code is mostly trivial and adapted from unboxed tuple code
for type checking, pattern checking, renaming, desugaring etc.
- Main translation routines are in `RepType` and `UnariseStg`.
Documentation in `UnariseStg` should be enough for understanding
what's going on.
Credits:
- Johan Tibell wrote the initial front-end and interface file
extensions.
- Simon Peyton Jones reviewed this patch many times, wrote some code,
and helped with debugging.
Reviewers: bgamari, alanz, goldfire, RyanGlScott, simonpj, austin,
simonmar, hvr, erikd
Reviewed By: simonpj
Subscribers: Iceland_jack, ggreif, ezyang, RyanGlScott, goldfire,
thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D2259
Diffstat (limited to 'compiler')
80 files changed, 2036 insertions, 700 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 7fe4cb9c54..9711edb75a 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -19,7 +19,7 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - ConTag, fIRST_TAG, + ConTag, ConTagZ, fIRST_TAG, Arity, RepArity, @@ -49,6 +49,8 @@ module BasicTypes( TupleSort(..), tupleSortBoxity, boxityTupleSort, tupleParens, + sumParens, pprAlternative, + -- ** The OneShotInfo type OneShotInfo(..), noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, @@ -132,6 +134,9 @@ type RepArity = Int -- or superclass selector type ConTag = Int +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + fIRST_TAG :: ConTag -- ^ Tags are allocated from here for real constructors -- or for superclass selectors @@ -619,6 +624,27 @@ tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) {- ************************************************************************ * * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> 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) + +{- +************************************************************************ +* * \subsection[Generic]{Generic flag} * * ************************************************************************ diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 27ac483120..2ab29aae95 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -39,7 +39,7 @@ module DataCon ( dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConSrcBangs, - dataConSourceArity, dataConRepArity, dataConRepRepArity, + dataConSourceArity, dataConRepArity, dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, @@ -49,6 +49,7 @@ module DataCon ( -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isUnboxedSumCon, isVanillaDataCon, classDataCon, dataConCannotMatch, isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon, @@ -977,12 +978,6 @@ dataConSourceArity (MkData { dcSourceArity = arity }) = arity dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity - --- | The number of fields in the /representation/ of the constructor --- AFTER taking into account the unpacking of any unboxed tuple fields -dataConRepRepArity :: DataCon -> RepArity -dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc) - -- | Return whether there are any argument types for this 'DataCon's original source type isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = null (dcOrigArgTys dc) @@ -1164,6 +1159,9 @@ isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc +isUnboxedSumCon :: DataCon -> Bool +isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + -- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 6045937173..387de1ec83 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -40,7 +40,7 @@ module Id ( mkWorkerId, -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, idRepArity, + idName, idType, idUnique, idInfo, idDetails, recordSelectorTyCon, -- ** Modifying an Id @@ -488,7 +488,7 @@ hasNoBinding :: Id -> Bool hasNoBinding id = case Var.idDetails id of PrimOpId _ -> True -- See Note [Primop wrappers] FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc + DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc _ -> False isImplicitId :: Id -> Bool @@ -566,9 +566,6 @@ idCallArity id = callArityInfo (idInfo id) setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id -idRepArity :: Id -> RepArity -idRepArity x = typeRepArity (idArity x) (idType x) - -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool isBottomingId id = isBottomingSig (idStrictness id) diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index 97d4186d4f..0cd2e95c52 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -304,7 +304,7 @@ type ArityInfo = Arity -- | It is always safe to assume that an 'Id' has an arity of 0 unknownArity :: Arity -unknownArity = 0 :: Arity +unknownArity = 0 ppArityInfo :: Int -> SDoc ppArityInfo 0 = empty diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index b919da2144..800198bc95 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -44,6 +44,7 @@ module Unique ( mkAlphaTyVarUnique, mkPrimOpIdUnique, mkTupleTyConUnique, mkTupleDataConUnique, + mkSumTyConUnique, mkSumDataConUnique, mkCTupleTyConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, @@ -328,9 +329,11 @@ mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkSumTyConUnique :: Arity -> Unique mkCTupleTyConUnique :: Arity -> Unique mkPreludeDataConUnique :: Arity -> Unique mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique @@ -348,6 +351,7 @@ mkPreludeTyConUnique i = mkUnique '3' (2*i) mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) mkCTupleTyConUnique a = mkUnique 'k' (2*a) +mkSumTyConUnique a = mkUnique 'z' (2*a) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u @@ -368,6 +372,11 @@ tyConRepNameUnique u = incrUnique u mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels) mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) +mkSumDataConUnique alt arity + | alt >= arity + = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) + | otherwise + = mkUnique 'z' (2 * alt * arity) dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index b262371b65..447eee8e8d 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -66,6 +66,7 @@ module CLabel ( mkSMAP_DIRTY_infoLabel, mkEMPTY_MVAR_infoLabel, mkArrWords_infoLabel, + mkRUBBISH_ENTRY_infoLabel, mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, @@ -506,7 +507,7 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel, mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel, - mkSMAP_DIRTY_infoLabel :: CLabel + mkSMAP_DIRTY_infoLabel, mkRUBBISH_ENTRY_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkSplitMarkerLabel = CmmLabel rtsUnitId (fsLit "__stg_split_marker") CmmCode mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo @@ -524,6 +525,7 @@ mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS") mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo +mkRUBBISH_ENTRY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_RUBBISH_ENTRY") CmmInfo ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index de783aacce..784724da2d 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -6,6 +6,7 @@ module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr + , CmmArg(..) , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType @@ -29,13 +30,14 @@ where #include "HsVersions.h" -import CmmType -import CmmMachOp import BlockId import CLabel +import CmmMachOp +import CmmType import DynFlags -import Unique import Outputable (panic) +import Type +import Unique import Data.Set (Set) import qualified Data.Set as Set @@ -73,6 +75,10 @@ data CmmReg | CmmGlobal GlobalReg deriving( Eq, Ord ) +data CmmArg + = CmmExprArg CmmExpr + | CmmRubbishArg Type -- See StgRubbishArg in StgSyn.hs + -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed. data Area diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 5c3be17e44..37bd7a010a 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -1032,7 +1032,7 @@ lowerSafeForeignCall dflags block (_, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) - (map (CmmReg . CmmLocal) res) + (map (CmmExprArg . CmmReg . CmmLocal) res) ret_off [] -- NB. after resumeThread returns, the top-of-stack probably contains diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index dfacd139b6..80aceaf19a 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -8,11 +8,10 @@ module CmmLive ( CmmLocalLive - , CmmGlobalLive , cmmLocalLiveness , cmmGlobalLiveness , liveLattice - , noLiveOnEntry, xferLive, gen, kill, gen_kill + , gen, kill, gen_kill ) where @@ -33,7 +32,6 @@ import Outputable -- | The variables live on entry to a block type CmmLive r = RegSet r type CmmLocalLive = CmmLive LocalReg -type CmmGlobalLive = CmmLive GlobalReg -- | The dataflow lattice liveLattice :: Ord r => DataflowLattice (CmmLive r) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 6b326b8bfb..128cc4e4e1 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1100,7 +1100,7 @@ pushStackFrame fields body = do exprs <- sequence fields updfr_off <- getUpdFrameOff let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old - [] updfr_off exprs + [] updfr_off (map CmmExprArg exprs) emit g withUpdFrameOff new_updfr_off body @@ -1171,7 +1171,7 @@ doReturn exprs_code = do mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off + mkReturn dflags e (map CmmExprArg actuals) updfr_off where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)) @@ -1190,7 +1190,7 @@ doJumpWithStack expr_code stk_code args_code = do stk_args <- sequence stk_code args <- sequence args_code updfr_off <- getUpdFrameOff - emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) + emit (mkJumpExtra dflags NativeNodeCall expr (map CmmExprArg args) updfr_off (map CmmExprArg stk_args)) doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] -> CmmParse () @@ -1200,7 +1200,7 @@ doCall expr_code res_code args_code = do args <- sequence args_code ress <- sequence res_code updfr_off <- getUpdFrameOff - c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress (map CmmExprArg args) updfr_off [] emit c adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index dca57dca01..e9f2612713 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -10,7 +10,7 @@ module CmmUtils( -- CmmType - primRepCmmType, primRepForeignHint, + primRepCmmType, slotCmmType, slotForeignHint, cmmArgType, typeCmmType, typeForeignHint, -- CmmLit @@ -69,7 +69,7 @@ module CmmUtils( #include "HsVersions.h" import TyCon ( PrimRep(..), PrimElemRep(..) ) -import Type ( UnaryType, typePrimRep ) +import RepType ( UnaryType, SlotTy (..), typePrimRep ) import SMRep import Cmm @@ -105,6 +105,13 @@ primRepCmmType _ FloatRep = f32 primRepCmmType _ DoubleRep = f64 primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep) +slotCmmType :: DynFlags -> SlotTy -> CmmType +slotCmmType dflags PtrSlot = gcWord dflags +slotCmmType dflags WordSlot = bWord dflags +slotCmmType _ Word64Slot = b64 +slotCmmType _ FloatSlot = f32 +slotCmmType _ DoubleSlot = f64 + primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep = b8 primElemRepCmmType Int16ElemRep = b16 @@ -120,6 +127,10 @@ primElemRepCmmType DoubleElemRep = f64 typeCmmType :: DynFlags -> UnaryType -> CmmType typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty) +cmmArgType :: DynFlags -> CmmArg -> CmmType +cmmArgType dflags (CmmExprArg e) = cmmExprType dflags e +cmmArgType dflags (CmmRubbishArg ty) = typeCmmType dflags ty + primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint PtrRep = AddrHint @@ -132,6 +143,13 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint +slotForeignHint :: SlotTy -> ForeignHint +slotForeignHint PtrSlot = AddrHint +slotForeignHint WordSlot = NoHint +slotForeignHint Word64Slot = NoHint +slotForeignHint FloatSlot = NoHint +slotForeignHint DoubleSlot = NoHint + typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 657585e75a..b1bd48a71f 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -7,7 +7,8 @@ module MkGraph , lgraphOfAGraph, labelAGraph , stackStubExpr - , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo + , mkNop, mkAssign, mkAssign', mkStore, mkStore' + , mkUnsafeCall, mkFinalCall, mkCallReturnsTo , mkJumpReturnsTo , mkJump, mkJumpExtra , mkRawJump @@ -16,26 +17,31 @@ module MkGraph , copyInOflow, copyOutOflow , noExtraStack , toCall, Transfer(..) + , rubbishExpr ) where import BlockId +import CLabel (mkRUBBISH_ENTRY_infoLabel) import Cmm import CmmCallConv import CmmSwitch (SwitchTargets) +import CmmUtils (cmmArgType) +import TyCon (isGcPtrRep) +import RepType (typePrimRep) import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) import DynFlags import FastString import ForeignCall +import OrdList import SMRep (ByteOff) import UniqSupply -import OrdList import Control.Monad import Data.List import Data.Maybe -import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>) +import Prelude (($),Int,Bool,Eq(..),otherwise) -- avoid importing (<*>) #include "HsVersions.h" @@ -193,12 +199,30 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkAssign l (CmmReg r) | l == r = mkNop mkAssign l r = mkMiddle $ CmmAssign l r +mkAssign' :: CmmReg -> CmmArg -> CmmAGraph +mkAssign' l (CmmRubbishArg ty) + | isGcPtrRep (typePrimRep ty) + = mkAssign l rubbishExpr + | otherwise + = mkNop +mkAssign' l (CmmExprArg r) + = mkAssign l r + mkStore :: CmmExpr -> CmmExpr -> CmmAGraph mkStore l r = mkMiddle $ CmmStore l r +mkStore' :: CmmExpr -> CmmArg -> CmmAGraph +mkStore' l (CmmRubbishArg ty) + | isGcPtrRep (typePrimRep ty) + = mkStore l rubbishExpr + | otherwise + = mkNop +mkStore' l (CmmExprArg r) + = mkStore l r + ---------- Control transfer mkJump :: DynFlags -> Convention -> CmmExpr - -> [CmmActual] + -> [CmmArg] -> UpdFrameOffset -> CmmAGraph mkJump dflags conv e actuals updfr_off = @@ -214,8 +238,8 @@ mkRawJump dflags e updfr_off vols = \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols -mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual] - -> UpdFrameOffset -> [CmmActual] +mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmArg] + -> UpdFrameOffset -> [CmmArg] -> CmmAGraph mkJumpExtra dflags conv e actuals updfr_off extra_stack = lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ @@ -228,7 +252,7 @@ mkCbranch pred ifso ifnot likely = mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph mkSwitch e tbl = mkLast $ CmmSwitch e tbl -mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset +mkReturn :: DynFlags -> CmmExpr -> [CmmArg] -> UpdFrameOffset -> CmmAGraph mkReturn dflags e actuals updfr_off = lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ @@ -238,17 +262,17 @@ mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) mkFinalCall :: DynFlags - -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset + -> CmmExpr -> CCallConv -> [CmmArg] -> UpdFrameOffset -> CmmAGraph mkFinalCall dflags f _ actuals updfr_off = lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual] +mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg] -> BlockId -> ByteOff -> UpdFrameOffset - -> [CmmActual] + -> [CmmArg] -> CmmAGraph mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals @@ -257,7 +281,7 @@ mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- already on the stack). -mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual] +mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg] -> BlockId -> ByteOff -> UpdFrameOffset @@ -325,9 +349,9 @@ copyIn dflags conv area formals extra_stk data Transfer = Call | JumpRet | Jump | Ret deriving Eq -copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual] +copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmArg] -> UpdFrameOffset - -> [CmmActual] -- extra stack args + -> [CmmArg] -- extra stack args -> (Int, [GlobalReg], CmmAGraph) -- Generate code to move the actual parameters into the locations @@ -345,9 +369,9 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) co (v, RegisterParam r) (rs, ms) - = (r:rs, mkAssign (CmmGlobal r) v <*> ms) + = (r:rs, mkAssign' (CmmGlobal r) v <*> ms) co (v, StackParam off) (rs, ms) - = (rs, mkStore (CmmStackSlot area off) v <*> ms) + = (rs, mkStore' (CmmStackSlot area off) v <*> ms) (setRA, init_offset) = case area of @@ -355,7 +379,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff -- the return address if making a call case transfer of Call -> - ([(CmmLit (CmmBlock id), StackParam init_offset)], + ([(CmmExprArg (CmmLit (CmmBlock id)), StackParam init_offset)], widthInBytes (wordWidth dflags)) JumpRet -> ([], @@ -365,11 +389,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff Old -> ([], updfr_off) (extra_stack_off, stack_params) = - assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff + assignStack dflags init_offset (cmmArgType dflags) extra_stack_stuff - args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it + args :: [(CmmArg, ParamLocation)] -- The argument and where to put it (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv - (cmmExprType dflags) actuals + (cmmArgType dflags) actuals @@ -378,7 +402,7 @@ mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] mkCallEntry dflags conv formals extra_stk = copyInOflow dflags conv Old formals extra_stk -lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual] +lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmArg] -> UpdFrameOffset -> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph @@ -387,8 +411,8 @@ lastWithArgs dflags transfer area conv actuals updfr_off last = updfr_off noExtraStack last lastWithArgsAndExtraStack :: DynFlags - -> Transfer -> Area -> Convention -> [CmmActual] - -> UpdFrameOffset -> [CmmActual] + -> Transfer -> Area -> Convention -> [CmmArg] + -> UpdFrameOffset -> [CmmArg] -> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off @@ -399,7 +423,7 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off updfr_off extra_stack -noExtraStack :: [CmmActual] +noExtraStack :: [CmmArg] noExtraStack = [] toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff @@ -407,3 +431,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> CmmAGraph toCall e cont updfr_off res_space arg_space regs = mkLast $ CmmCall e cont regs arg_space res_space updfr_off + +-------------- +rubbishExpr :: CmmExpr +rubbishExpr = CmmLit (CmmLabel mkRUBBISH_ENTRY_infoLabel) diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 77c92407bc..219b287f01 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -53,6 +53,9 @@ instance Outputable CmmExpr where instance Outputable CmmReg where ppr e = pprReg e +instance Outputable CmmArg where + ppr a = pprArg a + instance Outputable CmmLit where ppr l = pprLit l @@ -275,5 +278,11 @@ pprGlobalReg gr ----------------------------------------------------------------------------- +pprArg :: CmmArg -> SDoc +pprArg (CmmExprArg e) = ppr e +pprArg (CmmRubbishArg ty) = text "Rubbish" <+> dcolon <+> ppr ty + +----------------------------------------------------------------------------- + commafy :: [SDoc] -> SDoc commafy xs = fsep $ punctuate comma xs diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 73b9bf62ff..d6e0cf2f72 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -33,7 +33,7 @@ import HscTypes import CostCentre import Id import IdInfo -import Type +import RepType import DataCon import Name import TyCon @@ -241,13 +241,13 @@ cgDataCon data_con do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) - ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) - (tagForCon dflags data_con)] + ; void $ emitReturn [CmmExprArg (cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con))] } -- The case continuation code expects a tagged pointer arg_reps :: [(PrimRep, UnaryType)] - arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con + , rep_ty <- repTypeArgs ty] -- Dynamic closure code for non-nullary constructors only ; when (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 8adf3b088e..e8fd8f8d9b 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -210,9 +210,9 @@ cgRhs id (StgRhsCon cc con args) buildDynCon id True cc con args {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} -cgRhs name (StgRhsClosure cc bi fvs upd_flag args body) +cgRhs id (StgRhsClosure cc bi fvs upd_flag args body) = do dflags <- getDynFlags - mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body + mkRhsClosure dflags id cc bi (nonVoidIds fvs) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides @@ -551,7 +551,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump dflags NativeNodeCall (mkLblExpr fast_lbl) - (map (CmmReg . CmmLocal) (node : arg_regs)) + (map (CmmExprArg . CmmReg . CmmLocal) (node : arg_regs)) (initUpdFrameOff dflags) tscope <- getTickScope emitProcWithConvention Slow Nothing slow_lbl diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 8c1aeef55d..f831789454 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -78,6 +78,7 @@ import Type import TyCoRep import TcType import TyCon +import RepType import BasicTypes import Outputable import DynFlags @@ -286,14 +287,12 @@ mkLFImported id | otherwise = mkLFArgument id -- Not sure of exact arity where - arity = idRepArity id + arity = idFunRepArity id ----------------------------------------------------- -- Dynamic pointer tagging ----------------------------------------------------- -type ConTagZ = Int -- A *zero-indexed* constructor tag - type DynTag = Int -- The tag on a *pointer* -- (from the dynamic-tagging paper) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 04257dd991..c77816a819 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -38,6 +38,7 @@ import DataCon import DynFlags import FastString import Id +import RepType (countConRepArgs) import Literal import PrelInfo import Outputable @@ -72,7 +73,7 @@ cgTopRhsCon dflags id con args = ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags this_mod con args) ) return () - ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () + ; ASSERT( args `lengthIs` countConRepArgs con ) return () -- LAY IT OUT ; let @@ -87,12 +88,13 @@ cgTopRhsCon dflags id con args = -- needs to poke around inside it. info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds - get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg + get_lit (arg, _offset) = do { CmmExprArg (CmmLit lit) <- getArgAmode arg ; return lit } ; payload <- mapM get_lit nv_args_w_offsets -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs -- NB2: all the amodes should be Lits! + -- TODO (osa): Why? ; let closure_rep = mkStaticClosureFields dflags @@ -113,7 +115,8 @@ cgTopRhsCon dflags id con args = buildDynCon :: Id -- Name of the thing to which this constr will -- be bound - -> Bool -- is it genuinely bound to that name, or just for profiling? + -> Bool -- is it genuinely bound to that name, or just + -- for profiling? -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor @@ -155,6 +158,7 @@ premature looking at the args will cause the compiler to black-hole! -- at all. buildDynCon' dflags _ binder _ _cc con [] + | isNullaryRepDataCon con = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index d60828cd0d..ec4c75f0bc 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -19,7 +19,8 @@ module StgCmmEnv ( bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, - getArgAmode, getNonVoidArgAmodes, + getArgAmode, getArgAmode_no_rubbish, + getNonVoidArgAmodes, getNonVoidArgAmodes_no_rubbish, getCgIdInfo, maybeLetNoEscape, ) where @@ -33,18 +34,18 @@ import StgCmmClosure import CLabel -import DynFlags -import MkGraph import BlockId import CmmExpr import CmmUtils -import Id -import VarEnv import Control.Monad +import DynFlags +import Id +import MkGraph import Name -import StgSyn import Outputable +import StgSyn import UniqFM +import VarEnv ------------------------------------- -- Non-void types @@ -165,20 +166,34 @@ cgLookupPanic id -------------------- -getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode :: NonVoid StgArg -> FCode CmmArg getArgAmode (NonVoid (StgVarArg var)) = + do { info <- getCgIdInfo var; return (CmmExprArg (idInfoToAmode info)) } +getArgAmode (NonVoid (StgLitArg lit)) = liftM (CmmExprArg . CmmLit) $ cgLit lit +getArgAmode (NonVoid (StgRubbishArg ty)) = return (CmmRubbishArg ty) + +getArgAmode_no_rubbish :: NonVoid StgArg -> FCode CmmExpr +getArgAmode_no_rubbish (NonVoid (StgVarArg var)) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } -getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit +getArgAmode_no_rubbish (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit +getArgAmode_no_rubbish arg@(NonVoid (StgRubbishArg _)) = pprPanic "getArgAmode_no_rubbish" (ppr arg) -getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] +getNonVoidArgAmodes :: [StgArg] -> FCode [CmmArg] -- NB: Filters out void args, -- so the result list may be shorter than the argument list getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } + ; amodes <- getNonVoidArgAmodes args + ; return ( amode : amodes ) } + +-- This version assumes arguments are not rubbish. I think this assumption holds +-- as long as we don't pass unboxed sums to primops and foreign fns. +getNonVoidArgAmodes_no_rubbish :: [StgArg] -> FCode [CmmExpr] +getNonVoidArgAmodes_no_rubbish + = mapM (getArgAmode_no_rubbish . NonVoid) . filter (not . isVoidRep . argPrimRep) + ------------------------------------------------------------------------ -- Interface functions for binding and re-binding names diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 811ea3c44a..142d30cddb 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -40,6 +40,7 @@ import Id import PrimOp import TyCon import Type +import RepType ( isVoidTy, countConRepArgs ) import CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util @@ -64,10 +65,10 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] cgExpr (StgOpApp op args ty) = cgOpApp op args ty -cgExpr (StgConApp con args) = cgConApp con args +cgExpr (StgConApp con args _)= cgConApp con args cgExpr (StgTick t e) = cgTick t >> cgExpr e cgExpr (StgLit lit) = do cmm_lit <- cgLit lit - emitReturn [CmmLit cmm_lit] + emitReturn [CmmExprArg (CmmLit cmm_lit)] cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape binds expr) = @@ -142,7 +143,9 @@ cgLetNoEscapeRhsBody cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) - = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) + = cgLetNoEscapeClosure bndr local_cc cc [] + (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $ + text "StgRhsCon doesn't have type args")) -- For a constructor RHS we want to generate a single chunk of -- code which can be jumped to from many places, which will -- return the constructor. It's easy; just behave as if it @@ -306,7 +309,7 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts where do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr do_enum_primop TagToEnumOp [arg] -- No code! - = getArgAmode (NonVoid arg) + = getArgAmode_no_rubbish (NonVoid arg) do_enum_primop primop args = do dflags <- getDynFlags tmp <- newTemp (bWord dflags) @@ -514,7 +517,7 @@ isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) isSimpleOp (StgPrimOp op) stg_args = do - arg_exprs <- getNonVoidArgAmodes stg_args + arg_exprs <- getNonVoidArgAmodes_no_rubbish stg_args dflags <- getDynFlags -- See Note [Inlining out-of-line primops and heap checks] return $! isJust $ shouldInlinePrimOp dflags op arg_exprs @@ -528,8 +531,9 @@ chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] chooseReturnBndrs bndr (PrimAlt _) _alts = nonVoidIds [bndr] -chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _)] - = nonVoidIds ids -- 'bndr' is not assigned! +chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)] + = ASSERT2(n == length (nonVoidIds ids), ppr n $$ ppr ids $$ ppr _bndr) + nonVoidIds ids -- 'bndr' is not assigned! chooseReturnBndrs bndr (AlgAlt _) _alts = nonVoidIds [bndr] -- Only 'bndr' is assigned @@ -547,7 +551,7 @@ cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt] cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)] = maybeAltHeapCheck gc_plan (cgExpr rhs) -cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, rhs)] +cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)] = maybeAltHeapCheck gc_plan (cgExpr rhs) -- Here bndrs are *already* in scope, so don't rebind them @@ -671,7 +675,7 @@ cgConApp con stg_args ; emitReturn arg_exprs } | otherwise -- Boxed constructors; allocate and return - = ASSERT2( stg_args `lengthIs` dataConRepRepArity con, ppr con <+> ppr stg_args ) + = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args ) do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False currentCCS con stg_args -- The first "con" says that the name bound to this @@ -680,7 +684,7 @@ cgConApp con stg_args ; emit =<< fcode_init ; tickyReturnNewCon (length stg_args) - ; emitReturn [idInfoToAmode idinfo] } + ; emitReturn [CmmExprArg (idInfoToAmode idinfo)] } cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id [] | isVoidTy (idType fun_id) = emitReturn [] @@ -703,7 +707,7 @@ cgIdApp fun_id args = do case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. - ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? + ReturnIt -> emitReturn [CmmExprArg fun] -- ToDo: does ReturnIt guarantee tagged? EnterIt -> ASSERT( null args ) -- Discarding arguments emitEnter fun @@ -853,7 +857,7 @@ emitEnter fun = do Return _ -> do { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkJump dflags NativeNodeCall entry - [cmmUntag dflags fun] updfr_off + [CmmExprArg (cmmUntag dflags fun)] updfr_off ; return AssignedDirectly } @@ -889,7 +893,7 @@ emitEnter fun = do ; updfr_off <- getUpdFrameOff ; let area = Young lret ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area - [fun] updfr_off [] + [CmmExprArg fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index c8db8644db..eb14e8cce6 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,6 +34,7 @@ import Cmm import CmmUtils import MkGraph import Type +import RepType import TysPrim import CLabel import SMRep @@ -110,7 +111,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty _something_else -> do { _ <- emitForeignCall safety res_regs call_target call_args - ; emitReturn (map (CmmReg . CmmLocal) res_regs) + ; emitReturn (map (CmmExprArg . CmmReg . CmmLocal) res_regs) } } @@ -523,10 +524,12 @@ getFCallArgs args = do { mb_cmms <- mapM get args ; return (catMaybes mb_cmms) } where + get arg@(StgRubbishArg{}) + = pprPanic "getFCallArgs" (text "Rubbish arg in foreign call:" <+> ppr arg) get arg | isVoidRep arg_rep = return Nothing | otherwise - = do { cmm <- getArgAmode (NonVoid arg) + = do { cmm <- getArgAmode_no_rubbish (NonVoid arg) ; dflags <- getDynFlags ; return (Just (add_shim dflags arg_ty cmm, hint)) } where diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index ebff4402d0..fa1780449d 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -72,7 +72,7 @@ allocDynClosure allocDynClosureCmm :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr - -> [(CmmExpr, ByteOff)] + -> [(CmmArg, ByteOff)] -> FCode CmmExpr -- returns Hp+n -- allocDynClosure allocates the thing in the heap, @@ -113,7 +113,7 @@ allocHeapClosure :: SMRep -- ^ representation of the object -> CmmExpr -- ^ info pointer -> CmmExpr -- ^ cost centre - -> [(CmmExpr,ByteOff)] -- ^ payload + -> [(CmmArg,ByteOff)] -- ^ payload -> FCode CmmExpr -- ^ returns the address of the object allocHeapClosure rep info_ptr use_cc payload = do profDynAlloc rep use_cc @@ -144,7 +144,7 @@ allocHeapClosure rep info_ptr use_cc payload = do emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs = do dflags <- getDynFlags - hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..]) + hpStore base (zip (map CmmExprArg (header dflags)) [0, wORD_SIZE dflags ..]) where header :: DynFlags -> [CmmExpr] header dflags = [info_ptr] ++ dynProfHdr dflags ccs @@ -152,11 +152,11 @@ emitSetDynHdr base info_ptr ccs -- No ticky header -- Store the item (expr,off) in base[off] -hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () +hpStore :: CmmExpr -> [(CmmArg, ByteOff)] -> FCode () hpStore base vals = do dflags <- getDynFlags sequence_ $ - [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ] + [ emitStore (cmmOffsetB dflags base off) val | (CmmExprArg val,off) <- vals ] ----------------------------------------------------------- -- Layout of static closures @@ -364,7 +364,7 @@ entryHeapCheck' is_fastf node arity args code = do dflags <- getDynFlags let is_thunk = arity == 0 - args' = map (CmmReg . CmmLocal) args + args' = map (CmmExprArg . CmmReg . CmmLocal) args stg_gc_fun = CmmReg (CmmGlobal GCFun) stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) @@ -376,13 +376,13 @@ entryHeapCheck' is_fastf node arity args code -} gc_call upd | is_thunk - = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd + = mkJump dflags NativeNodeCall stg_gc_enter1 [CmmExprArg node] upd | is_fastf - = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd + = mkJump dflags NativeNodeCall stg_gc_fun (CmmExprArg node : args') upd | otherwise - = mkJump dflags Slow stg_gc_fun (node : args') upd + = mkJump dflags Slow stg_gc_fun (CmmExprArg node : args') upd updfr_sz <- getUpdFrameOff @@ -446,7 +446,7 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code updfr_sz <- getUpdFrameOff heapCheck False checkYield (gc_call dflags gc updfr_sz) code where - reg_exprs = map (CmmReg . CmmLocal) regs + reg_exprs = map (CmmExprArg . CmmReg . CmmLocal) regs -- Note [stg_gc arguments] -- NB. we use the NativeReturn convention for passing arguments diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 47ee370212..713d542bdc 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -68,7 +68,7 @@ import Control.Monad -- -- > p=x; q=y; -- -emitReturn :: [CmmExpr] -> FCode ReturnKind +emitReturn :: [CmmArg] -> FCode ReturnKind emitReturn results = do { dflags <- getDynFlags ; sequel <- getSequel @@ -90,7 +90,7 @@ emitReturn results -- using the call/return convention @conv@, passing @args@, and -- returning the results to the current sequel. -- -emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind +emitCall :: (Convention, Convention) -> CmmExpr -> [CmmArg] -> FCode ReturnKind emitCall convs fun args = emitCallWithExtraStack convs fun args noExtraStack @@ -101,8 +101,8 @@ emitCall convs fun args -- @stack@, and returning the results to the current sequel. -- emitCallWithExtraStack - :: (Convention, Convention) -> CmmExpr -> [CmmExpr] - -> [CmmExpr] -> FCode ReturnKind + :: (Convention, Convention) -> CmmExpr -> [CmmArg] + -> [CmmArg] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack = do { dflags <- getDynFlags ; adjustHpBackwards @@ -187,7 +187,7 @@ slowCall fun stg_args (r, slow_code) <- getCodeR $ do r <- direct_call "slow_call" NativeNodeCall - (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) + (mkRtsApFastLabel rts_fun) arity ((P,Just (CmmExprArg fun)):argsreps) emitComment $ mkFastString ("slow_call for " ++ showSDoc dflags (ppr fun) ++ " with pat " ++ unpackFS rts_fun) @@ -213,7 +213,7 @@ slowCall fun stg_args fast_code <- getCode $ emitCall (NativeNodeCall, NativeReturn) (entryCode dflags fun_iptr) - (nonVArgs ((P,Just funv):argsreps)) + (nonVArgs ((P,Just (CmmExprArg funv)):argsreps)) slow_lbl <- newLabelC fast_lbl <- newLabelC @@ -271,7 +271,7 @@ slowCall fun stg_args direct_call :: String -> Convention -- e.g. NativeNodeCall or NativeDirectCall -> CLabel -> RepArity - -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind + -> [(ArgRep,Maybe CmmArg)] -> FCode ReturnKind direct_call caller call_conv lbl arity args | debugIsOn && real_arity > length args -- Too few args = do -- Caller should ensure that there enough args! @@ -299,11 +299,11 @@ direct_call caller call_conv lbl arity args -- When constructing calls, it is easier to keep the ArgReps and the --- CmmExprs zipped together. However, a void argument has no --- representation, so we need to use Maybe CmmExpr (the alternative of +-- CmmArgs zipped together. However, a void argument has no +-- representation, so we need to use Maybe CmmArg (the alternative of -- using zeroCLit or even undefined would work, but would be ugly). -- -getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)] +getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmArg)] getArgRepsAmodes = mapM getArgRepAmode where getArgRepAmode arg | V <- rep = return (V, Nothing) @@ -311,7 +311,7 @@ getArgRepsAmodes = mapM getArgRepAmode return (rep, Just expr) where rep = toArgRep (argPrimRep arg) -nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] +nonVArgs :: [(ArgRep, Maybe CmmArg)] -> [CmmArg] nonVArgs [] = [] nonVArgs ((_,Nothing) : args) = nonVArgs args nonVArgs ((_,Just arg) : args) = arg : nonVArgs args @@ -354,7 +354,7 @@ just more arguments that we are passing on the stack (cml_args). -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] +slowArgs :: DynFlags -> [(ArgRep, Maybe CmmArg)] -> [(ArgRep, Maybe CmmArg)] slowArgs _ [] = [] slowArgs dflags args -- careful: reps contains voids (V), but args does not | gopt Opt_SccProfilingOn dflags @@ -365,8 +365,8 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not (call_args, rest_args) = splitAt n args stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat - this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args - save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] + this_pat = (N, Just (CmmExprArg (mkLblExpr stg_ap_pat))) : call_args + save_cccs = [(N, Just (CmmExprArg (mkLblExpr save_cccs_lbl))), (N, Just (CmmExprArg curCCS))] save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 2742acdcdb..8f66cfaa91 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -19,8 +19,8 @@ module StgCmmMonad ( emit, emitDecl, emitProc, emitProcWithConvention, emitProcWithStackFrame, - emitOutOfLine, emitAssign, emitStore, emitComment, - emitTick, emitUnwind, + emitOutOfLine, emitAssign, emitAssign', emitStore, + emitComment, emitTick, emitUnwind, getCmm, aGraphToGraph, getCodeR, getCode, getCodeScoped, getHeapUsage, @@ -76,6 +76,7 @@ import Unique import UniqSupply import FastString import Outputable +import RepType (typePrimRep) import Control.Monad import Data.List @@ -743,6 +744,14 @@ emitUnwind g e = do emitAssign :: CmmReg -> CmmExpr -> FCode () emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) +emitAssign' :: CmmReg -> CmmArg -> FCode () +emitAssign' l (CmmExprArg r) = emitAssign l r +emitAssign' l (CmmRubbishArg ty) + | isGcPtrRep (typePrimRep ty) + = emitAssign l rubbishExpr + | otherwise + = return () + emitStore :: CmmExpr -> CmmExpr -> FCode () emitStore l r = emitCgStmt (CgStmt (CmmStore l r)) @@ -858,8 +867,8 @@ mkCmmIfThen e tbranch = do , mkLabel tid tscp, tbranch, mkLabel endif tscp ] -mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] - -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph +mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmArg] + -> UpdFrameOffset -> [CmmArg] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC @@ -869,7 +878,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack return $ catAGraphs [copyout, mkLabel k tscp, copyin] -mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset +mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmArg] -> UpdFrameOffset -> FCode CmmAGraph mkCmmCall f results actuals updfr_off = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off [] diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index d3c09c584e..c02f992bed 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -46,6 +46,7 @@ import Util import Prelude hiding ((<*>)) import Data.Bits ((.&.), bit) +import Data.Bifunctor (first) import Control.Monad (liftM, when) ------------------------------------------------------------------------ @@ -79,10 +80,10 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) do { dflags <- getDynFlags - ; args' <- getNonVoidArgAmodes [arg] + ; args' <- getNonVoidArgAmodes_no_rubbish [arg] ; let amode = case args' of [amode] -> amode _ -> panic "TagToEnumOp had void arg" - ; emitReturn [tagToClosure dflags tycon amode] } + ; emitReturn [CmmExprArg (tagToClosure dflags tycon amode)] } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -93,11 +94,11 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty cgOpApp (StgPrimOp primop) args res_ty = do dflags <- getDynFlags - cmm_args <- getNonVoidArgAmodes args + cmm_args <- getNonVoidArgAmodes_no_rubbish args case shouldInlinePrimOp dflags primop cmm_args of Nothing -> do -- out-of-line let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - emitCall (NativeNodeCall, NativeReturn) fun cmm_args + emitCall (NativeNodeCall, NativeReturn) fun (map CmmExprArg cmm_args) Just f -- inline | ReturnsPrim VoidRep <- result_info @@ -108,12 +109,12 @@ cgOpApp (StgPrimOp primop) args res_ty = do -> do dflags <- getDynFlags res <- newTemp (primRepCmmType dflags rep) f [res] - emitReturn [CmmReg (CmmLocal res)] + emitReturn [CmmExprArg (CmmReg (CmmLocal res))] | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon -> do (regs, _hints) <- newUnboxedTupleRegs res_ty f regs - emitReturn (map (CmmReg . CmmLocal) regs) + emitReturn (map (CmmExprArg . CmmReg . CmmLocal) regs) | otherwise -> panic "cgPrimop" where @@ -256,7 +257,7 @@ cgPrimOp :: [LocalReg] -- where to put the results cgPrimOp results op args = do dflags <- getDynFlags - arg_exprs <- getNonVoidArgAmodes args + arg_exprs <- getNonVoidArgAmodes_no_rubbish args emitPrimOp dflags results op arg_exprs @@ -1657,7 +1658,7 @@ doNewByteArrayOp res_r n = do let hdr_size = fixedHdrSize dflags base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, + [ (CmmExprArg (mkIntExpr dflags n), hdr_size + oFFSET_StgArrBytes_bytes dflags) ] @@ -1770,7 +1771,7 @@ doNewArrayOp res_r rep info payload n init = do (mkIntExpr dflags (nonHdrSize dflags rep)) (zeroExpr dflags) - base <- allocHeapClosure rep info_ptr curCCS payload + base <- allocHeapClosure rep info_ptr curCCS (map (first CmmExprArg) payload) arr <- CmmLocal `fmap` newTemp (bWord dflags) emit $ mkAssign arr base @@ -1953,9 +1954,9 @@ emitCloneArray info_p res_r src src_off n = do let hdr_size = fixedHdrSize dflags base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, + [ (CmmExprArg (mkIntExpr dflags n), hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr dflags (nonHdrSizeW rep), + , (CmmExprArg (mkIntExpr dflags (nonHdrSizeW rep)), hdr_size + oFFSET_StgMutArrPtrs_size dflags) ] @@ -1992,7 +1993,7 @@ emitCloneSmallArray info_p res_r src src_off n = do let hdr_size = fixedHdrSize dflags base <- allocHeapClosure rep info_ptr curCCS - [ (mkIntExpr dflags n, + [ (CmmExprArg (mkIntExpr dflags n), hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) ] diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 5d6710197b..f1437eb640 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -38,7 +38,7 @@ module StgCmmUtils ( addToMem, addToMemE, addToMemLblE, addToMemLbl, mkWordCLit, newStringCLit, newByteStringCLit, - blankWord + blankWord, rubbishExpr ) where #include "HsVersions.h" @@ -67,6 +67,7 @@ import UniqSupply (MonadUnique(..)) import DynFlags import FastString import Outputable +import RepType import qualified Data.ByteString as BS import qualified Data.Map as M @@ -193,7 +194,7 @@ emitRtsCallGen res lbl args safe where call updfr_off = if safe then - emit =<< mkCmmCall fun_expr res' args' updfr_off + emit =<< mkCmmCall fun_expr res' (map CmmExprArg args') updfr_off else do let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' @@ -251,7 +252,7 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) callerRestoreGlobalReg reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) -- ----------------------------------------------------------------------------- -- Global registers @@ -361,15 +362,11 @@ newUnboxedTupleRegs res_ty ; sequel <- getSequel ; regs <- choose_regs dflags sequel ; ASSERT( regs `equalLength` reps ) - return (regs, map primRepForeignHint reps) } + return (regs, map slotForeignHint reps) } where - UbxTupleRep ty_args = repType res_ty - reps = [ rep - | ty <- ty_args - , let rep = typePrimRep ty - , not (isVoidRep rep) ] + MultiRep reps = repType res_ty choose_regs _ (AssignTo regs _) = return regs - choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps + choose_regs dflags _ = mapM (newTemp . slotCmmType dflags) reps @@ -377,14 +374,14 @@ newUnboxedTupleRegs res_ty -- emitMultiAssign ------------------------------------------------------------------------- -emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode () +emitMultiAssign :: [LocalReg] -> [CmmArg] -> FCode () -- Emit code to perform the assignments in the -- input simultaneously, using temporary variables when necessary. type Key = Int type Vrtx = (Key, Stmt) -- Give each vertex a unique number, -- for fast comparison -type Stmt = (LocalReg, CmmExpr) -- r := e +type Stmt = (LocalReg, CmmArg) -- r := e -- We use the strongly-connected component algorithm, in which -- * the vertices are the statements @@ -393,7 +390,7 @@ type Stmt = (LocalReg, CmmExpr) -- r := e -- that is, if s1 should *follow* s2 in the final order emitMultiAssign [] [] = return () -emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs +emitMultiAssign [reg] [rhs] = emitAssign' (CmmLocal reg) rhs emitMultiAssign regs rhss = do dflags <- getDynFlags ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss ) @@ -432,16 +429,20 @@ unscramble dflags vertices = mapM_ do_component components split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) split dflags uniq (reg, rhs) - = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) + = ((tmp, rhs), (reg, CmmExprArg (CmmReg (CmmLocal tmp)))) where - rep = cmmExprType dflags rhs + rep = cmmArgType dflags rhs tmp = LocalReg uniq rep mk_graph :: Stmt -> FCode () - mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs + mk_graph (reg, rhs) = emitAssign' (CmmLocal reg) rhs mustFollow :: Stmt -> Stmt -> Bool - (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs + (reg, _) `mustFollow` (_, rhs) = regUsedIn' dflags (CmmLocal reg) rhs + +regUsedIn' :: DynFlags -> CmmReg -> CmmArg -> Bool +regUsedIn' _ _ (CmmRubbishArg _) = False +regUsedIn' dflags reg (CmmExprArg expr) = regUsedIn dflags reg expr ------------------------------------------------------------------------- -- mkSwitch diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index ef87656a0e..f5e76736ce 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -855,6 +855,9 @@ to re-add floats on the top. etaExpand :: Arity -- ^ Result should have this number of value args -> CoreExpr -- ^ Expression to expand -> CoreExpr +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- -- etaExpand deals with for-alls. For example: -- etaExpand 1 E -- where E :: forall a. a -> a diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 73e93eaf35..dead929943 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -42,6 +42,7 @@ import Coercion import SrcLoc import Kind import Type +import RepType import TyCoRep -- checks validity of types/coercions import TyCon import CoAxiom @@ -1401,13 +1402,10 @@ lintCoercion co@(UnivCo prov r ty1 ty2) checkTypes t1 t2 = case (repType t1, repType t2) of (UnaryRep _, UnaryRep _) -> - validateCoercion (typePrimRep t1) - (typePrimRep t2) - (UbxTupleRep rep1, UbxTupleRep rep2) -> do - checkWarnL (length rep1 == length rep2) - (report "unboxed tuples of different length") - zipWithM_ checkTypes rep1 rep2 - _ -> addWarnL (report "unboxed tuple and ordinary type") + validateCoercion (typePrimRep t1) (typePrimRep t2) + (MultiRep rep1, MultiRep rep2) -> + checkWarnL (rep1 == rep2) (report "multi values with different reps") + _ -> addWarnL (report "multi rep and unary rep") validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2 = do { dflags <- getDynFlags diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index d3364332c5..6ee5bffe35 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -368,6 +368,11 @@ translatePat fam_insts pat = case pat of let tuple_con = tupleDataCon boxity (length ps) return [vanillaConPattern tuple_con tys (concat tidy_ps)] + SumPat p alt arity ty -> do + tidy_p <- translatePat fam_insts (unLoc p) + let sum_con = sumDataCon alt arity + return [vanillaConPattern sum_con ty tidy_p] + -- -------------------------------------------------------------------------- -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 5287320daa..b96491231a 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -546,6 +546,9 @@ addTickHsExpr (ExplicitTuple es boxity) = liftM2 ExplicitTuple (mapM addTickTupArg es) (return boxity) +addTickHsExpr (ExplicitSum tag arity e ty) = do + e' <- addTickLHsExpr e + return (ExplicitSum tag arity e' ty) addTickHsExpr (HsCase e mgs) = liftM2 HsCase (addTickLHsExpr e) -- not an EvalInner; e might not necessarily diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 822708808c..0ce6f50656 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -1138,6 +1138,7 @@ collectl (L _ pat) bndrs go (ListPat pats _ _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats + go (SumPat pat _ _ _) = collectl pat bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index bf04f13ce9..a08c3ac7cb 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -314,6 +314,13 @@ dsExpr (ExplicitTuple tup_args boxity) ; return $ mkCoreLams lam_vars $ mkCoreTupBoxity boxity args } +dsExpr (ExplicitSum alt arity expr types) + = do { core_expr <- dsLExpr expr + ; return $ mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++ + map Type types ++ + [core_expr]) } + dsExpr (HsSCC _ cc expr@(L loc _)) = do dflags <- getDynFlags if gopt Opt_SccProfilingOn dflags diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 00ed621bd2..981745e602 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -26,6 +26,7 @@ import Literal import Module import Name import Type +import RepType import TyCon import Coercion import TcEnv diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index ecbed46185..93d43c8d26 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -456,6 +456,11 @@ tidy1 _ (TuplePat pats boxity tys) arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys +tidy1 _ (SumPat pat alt arity tys) + = return (idDsWrapper, unLoc sum_ConPat) + where + sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys + -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ (LitPat lit) = return (idDsWrapper, tidyLitPat lit) @@ -485,6 +490,7 @@ tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p +tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p -- Data/newtype constructors @@ -943,6 +949,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 lexp e1 e1' && lexp e2 e2' exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = eq_list tup_arg es1 es2 + exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index cfe350fa8f..3042d1d747 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -384,6 +384,7 @@ Library SimplStg StgStats UnariseStg + RepType Rules SpecConstr Specialise diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 9f45a51842..5aeda53d91 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -517,6 +517,7 @@ compiler_stage2_dll0_MODULES = \ PrelRules \ Pretty \ PrimOp \ + RepType \ RdrName \ Rules \ SrcLoc \ diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 8839ffa544..9c7d25a5ec 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -31,6 +31,7 @@ import Literal import PrimOp import CoreFVs import Type +import RepType import Kind ( isLiftedTypeKind ) import DataCon import TyCon @@ -303,8 +304,8 @@ collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' go xs (AnnLam x (_,e)) - | UbxTupleRep _ <- repType (idType x) - = unboxedTupleException + | repTypeArgs (idType x) `lengthExceeds` 1 + = multiValException | otherwise = go (x:xs) e go xs not_lambda = (reverse xs, not_lambda) @@ -532,8 +533,9 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut -- no alts: scrut is guaranteed to diverge schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc - , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2) + | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) + , [rep_ty1] <- repTypeArgs (idType bind1) + , [rep_ty2] <- repTypeArgs (idType bind2) -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } -- to @@ -543,43 +545,25 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. , Just res <- case () of - _ | VoidRep <- typePrimRep rep_ty1 - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | VoidRep <- typePrimRep rep_ty2 - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2) + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + | isVoidTy rep_ty2 && not (isVoidTy rep_ty1) + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) | otherwise -> Nothing = res schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1) - -- Similarly, convert - -- case .... of x { (# a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - -schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)]) - | Just (tc, tys) <- splitTyConApp_maybe (idType bndr) - , isUnboxedTupleTyCon tc - , Just res <- case tys of - [ty] | UnaryRep _ <- repType ty - , let bind = bndr `setIdType` ty - -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1 - , UnaryRep rep_ty2 <- repType ty2 - -> case () of - _ | VoidRep <- typePrimRep rep_ty1 - , let bind2 = bndr `setIdType` ty2 - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | VoidRep <- typePrimRep rep_ty2 - , let bind1 = bndr `setIdType` ty1 - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | otherwise - -> Nothing - _ -> Nothing - = res + | isUnboxedTupleCon dc + , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples + = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + +schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) + | isUnboxedTupleType (idType bndr) + , [ty] <- repTypeArgs (idType bndr) + -- handles any pattern with a single non-void binder; in particular I/O + -- monad returns (# RealWorld#, a #) + = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) schemeE d s p (AnnCase scrut bndr _ alts) = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} @@ -647,14 +631,14 @@ schemeT d s p app -- Case 2: Constructor application - | Just con <- maybe_saturated_dcon, - isUnboxedTupleCon con + | Just con <- maybe_saturated_dcon + , isUnboxedTupleCon con = case args_r_to_l of [arg1,arg2] | isVAtom arg1 -> unboxedTupleReturn d s p arg2 [arg1,arg2] | isVAtom arg2 -> unboxedTupleReturn d s p arg1 - _other -> unboxedTupleException + _other -> multiValException -- Case 3: Ordinary data constructor | Just con <- maybe_saturated_dcon @@ -792,8 +776,8 @@ doCase :: Word -> Sequel -> BCEnv -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result -> BcM BCInstrList doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | UbxTupleRep _ <- repType (idType bndr) - = unboxedTupleException + | repTypeArgs (idType bndr) `lengthExceeds` 1 + = multiValException | otherwise = do dflags <- getDynFlags @@ -848,8 +832,6 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) - | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs - = unboxedTupleException -- algebraic alt with some binders | otherwise = let @@ -872,8 +854,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) - | isUnboxedTupleCon dc - = unboxedTupleException + | isUnboxedTupleCon dc || isUnboxedSumCon dc + = multiValException | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) my_discr (LitAlt l, _, _) @@ -971,7 +953,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l pargs _ [] = return [] pargs d (a:az) - = let UnaryRep arg_ty = repType (exprType (deAnnotate' a)) + = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a)) in case tyConAppTyCon_maybe arg_ty of -- Don't push the FO; instead push the Addr# it @@ -1104,10 +1086,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- this is a V (tag). r_sizeW = fromIntegral (primRepSizeW dflags r_rep) d_after_r = d_after_Addr + fromIntegral r_sizeW - r_lit = mkDummyLiteral r_rep push_r = (if returns_void then nilOL - else unitOL (PUSH_UBX r_lit r_sizeW)) + else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW)) -- generate the marshalling code we're going to call @@ -1176,7 +1157,7 @@ mkDummyLiteral pr FloatRep -> MachFloat 0 Int64Rep -> MachInt64 0 Word64Rep -> MachWord64 0 - _ -> panic "mkDummyLiteral" + _ -> pprPanic "mkDummyLiteral" (ppr pr) -- Convert (eg) @@ -1195,27 +1176,26 @@ mkDummyLiteral pr maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty - = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - maybe_r_rep_to_go - = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - r_reps = case repType r_ty of - UbxTupleRep reps -> map typePrimRep reps - UnaryRep _ -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) - && case maybe_r_rep_to_go of - Nothing -> True - Just r_rep -> r_rep /= PtrRep - -- if it was, it would be impossible - -- to create a valid return value - -- placeholder on the stack - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + r_reps = repTypeArgs r_ty + + blargh :: a -- Used at more than one type + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) in - --trace (showSDoc (ppr (a_reps, r_reps))) $ - if ok then maybe_r_rep_to_go else blargh + case r_reps of + [] -> panic "empty repTypeArgs" + [ty] + | typePrimRep ty == PtrRep + -> blargh + | isVoidTy ty + -> Nothing + | otherwise + -> Just (typePrimRep ty) + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> blargh maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -1227,14 +1207,14 @@ maybe_is_tagToEnum_call app = Nothing where extract_constr_Names ty - | UnaryRep rep_ty <- repType ty - , Just tyc <- tyConAppTyCon_maybe rep_ty, - isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.hs for details. + | [rep_ty] <- repTypeArgs ty + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.hs for details. | otherwise - = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) {- ----------------------------------------------------------------------------- Note [Implementing tagToEnum#] @@ -1334,7 +1314,7 @@ pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 = pushAtom d p a pushAtom d p (AnnVar v) - | UnaryRep rep_ty <- repType (idType v) + | [rep_ty] <- repTypeArgs (idType v) , V <- typeArgRep rep_ty = return (nilOL, 0) @@ -1556,18 +1536,14 @@ isVoidArg V = True isVoidArg _ = False bcIdUnaryType :: Id -> UnaryType -bcIdUnaryType x = case repType (idType x) of - UnaryRep rep_ty -> rep_ty - UbxTupleRep [rep_ty] -> rep_ty - UbxTupleRep [rep_ty1, rep_ty2] - | VoidRep <- typePrimRep rep_ty1 -> rep_ty2 - | VoidRep <- typePrimRep rep_ty2 -> rep_ty1 +bcIdUnaryType x = case repTypeArgs (idType x) of + [rep_ty] -> rep_ty _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x)) -- See bug #1257 -unboxedTupleException :: a -unboxedTupleException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle unboxed tuples.\n"++ +multiValException :: a +multiValException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ " Possibly due to foreign import/export decls in source.\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 4e1c828a4d..25d4f4a257 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -17,7 +17,7 @@ import Name ( Name, getName ) import NameEnv import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import Type ( flattenRepType, repType, typePrimRep ) +import RepType ( typePrimRep, repTypeArgs ) import StgCmmLayout ( mkVirtHeapOffsets ) import Util import Panic @@ -55,7 +55,7 @@ make_constr_itbls hsc_env cons = mk_itbl dcon conNo = do let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon - , rep_arg <- flattenRepType (repType arg) ] + , rep_arg <- repTypeArgs arg ] (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f4076bb21b..7a59847fd1 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -34,6 +34,7 @@ import HscTypes import DataCon import Type +import RepType import qualified Unify as U import Var import TcRnMonad @@ -464,7 +465,7 @@ cPprTermBase y = ppr_list :: Precedence -> Term -> m SDoc ppr_list p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t - isConsLast = not(termType(last elems) `eqType` termType h) + isConsLast = not (termType (last elems) `eqType` termType h) is_string = all (isCharTy . ty) elems print_elems <- mapM (y cons_prec) elems @@ -804,15 +805,15 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case repType ty of - UnaryRep rep_ty -> do + = case repTypeArgs ty of + [rep_ty] -> do (ptr_i, ws, term0) <- go_rep ptr_i ws ty (typePrimRep rep_ty) (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, term0 : terms1) - UbxTupleRep rep_tys -> do - (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys - (ptr_i, ws, terms1) <- go ptr_i ws tys - return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + rep_tys -> do + (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) go_unary_types ptr_i ws [] = return (ptr_i, ws, []) go_unary_types ptr_i ws (rep_ty:rep_tys) = do @@ -919,19 +920,25 @@ findPtrTys i ty = findPtrTyss i elem_tys | otherwise - = case repType ty of + = -- Can't directly call repTypeArgs here -- we lose type information in + -- some cases (e.g. singleton tuples) + case repType ty of UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) | otherwise -> return (i, []) - UbxTupleRep rep_tys -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep - then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) - else return (i, extras)) - (i, []) rep_tys + MultiRep slot_tys -> + foldM (\(i, extras) rep_ty -> + if typePrimRep rep_ty == PtrRep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) (map slotTyToType slot_tys) findPtrTyss :: Int -> [Type] -> TR (Int, [(Int, Type)]) findPtrTyss i tys = foldM step (i, []) tys - where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras) + where step (i, discovered) elem_ty = do + (i, extras) <- findPtrTys i elem_ty + return (i, discovered ++ extras) -- Compute the difference between a base type and the type found by RTTI diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index ffba782dfd..b2c40caa8a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -356,6 +356,12 @@ data HsExpr id [LHsTupArg id] Boxity + | ExplicitSum + ConTag -- Alternative (one-based) + Arity -- Sum arity + (LHsExpr id) + (PostTc id [Type]) -- the type arguments + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ @@ -848,6 +854,11 @@ ppr_expr (ExplicitTuple exprs boxity) punc (Missing {} : _) = comma punc [] = empty +ppr_expr (ExplicitSum alt arity expr _) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + ppr_expr (HsLam matches) = pprMatches matches diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index ef667a1d71..719cd97c17 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -136,6 +136,16 @@ data Pat id -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ + | SumPat (LPat id) -- Sum sub-pattern + ConTag -- Alternative (one-based) + Arity -- Arity + (PostTc id [Type]) -- PlaceHolder before typechecker, filled in + -- afterwards with the types of the + -- alternative + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' @'#)'@ + -- For details on above see note [Api annotations] in ApiAnnotation | PArrPat [LPat id] -- Syntactic parallel array (PostTc id Type) -- The type of the elements @@ -415,6 +425,7 @@ pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat pats _ _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) +pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity) pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) @@ -513,10 +524,12 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. isUnliftedLPat :: LPat id -> Bool isUnliftedLPat (L _ (ParPat p)) = isUnliftedLPat p isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True +isUnliftedLPat (L _ (SumPat _ _ _ _)) = True isUnliftedLPat _ = False isUnliftedHsBind :: HsBind id -> Bool --- A pattern binding with an outermost bang or unboxed tuple must be matched strictly +-- A pattern binding with an outermost bang or unboxed tuple or sum must be +-- matched strictly. -- Defined in this module because HsPat is above HsBinds in the import graph isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p isUnliftedHsBind _ = False @@ -543,6 +556,7 @@ looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p looksLazyLPat (L _ (BangPat {})) = False looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False +looksLazyLPat (L _ (SumPat _ _ _ _)) = False looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True @@ -576,6 +590,7 @@ isIrrefutableHsPat pat go1 (SigPatIn pat _) = go pat go1 (SigPatOut pat _) = go pat go1 (TuplePat pats _ _) = all go pats + go1 (SumPat pat _ _ _) = go pat go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? @@ -614,6 +629,7 @@ hsPatNeedsParens (BangPat {}) = False hsPatNeedsParens (ParPat {}) = False hsPatNeedsParens (AsPat {}) = False hsPatNeedsParens (TuplePat {}) = False +hsPatNeedsParens (SumPat {}) = False hsPatNeedsParens (ListPat {}) = False hsPatNeedsParens (PArrPat {}) = False hsPatNeedsParens (LitPat {}) = False @@ -644,6 +660,7 @@ collectEvVarsPat pat = BangPat p -> collectEvVarsLPat p ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps + SumPat p _ _ _ -> collectEvVarsLPat p PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps ConPatOut {pat_dicts = dicts, pat_args = args} -> unionBags (listToBag dicts) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index a0676c98d6..bf98ca3c99 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -457,6 +457,12 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation + | HsSumTy [LHsType name] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsOpTy (LHsType name) (Located name) (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -1225,6 +1231,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr ty where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple +ppr_mono_ty _ (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys) ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty) ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index f530272b23..6d1f15fd38 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -853,6 +853,7 @@ collect_lpat (L _ pat) bndrs go (ListPat pats _ _) = foldr collect_lpat bndrs pats go (PArrPat pats _) = foldr collect_lpat bndrs pats go (TuplePat pats _ _) = foldr collect_lpat bndrs pats + go (SumPat pat _ _ _) = collect_lpat pat bndrs go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 42907049f3..588909130b 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002-2006 @@ -23,7 +23,6 @@ module BinIface ( import TcRnMonad import TyCon import ConLike -import DataCon ( dataConName, dataConWorkId, dataConTyCon ) import PrelInfo ( knownKeyNames ) import Id ( idName, isDataConWorkId_maybe ) import TysWiredIn @@ -46,6 +45,7 @@ import Platform import FastString import Constants import Util +import DataCon import Data.Bits import Data.Char @@ -294,21 +294,31 @@ serialiseName bh name _ = do -- -- An occurrence of a name in an interface file is serialized as a single 32-bit word. -- The format of this word is: --- 00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +-- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx -- A normal name. x is an index into the symbol table --- 01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy +-- 01xxxxxx xxyyyyyy yyyyyyyy yyyyyyyyyy -- A known-key name. x is the Unique's Char, y is the int part --- 10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz +-- 100xxyyz zzzzzzzz zzzzzzzz zzzzzzzz -- A tuple name: -- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint) -- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker) -- z is the arity --- 11xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +-- +-- 10100xxx xxxxxxxx xxxxxxxx xxxxxxxx +-- A sum tycon name: +-- x is the arity +-- 10101xxx xxxxxxxx xxyyyyyy yyyyyyyy +-- A sum datacon name: +-- x is the arity +-- y is the alternative +-- 10110xxx xxxxxxxx xxyyyyyy yyyyyyyy +-- worker +-- 11xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx -- An implicit parameter TyCon name. x is an index into the FastString *dictionary* -- --- Note that we have to have special representation for tuples and IP TyCons because they --- form an "infinite" family and hence are not recorded explicitly in wiredInTyThings or --- basicKnownKeyNames. +-- Note that we have to have special representation for tuples, sums, and IP +-- TyCons because they form an "infinite" family and hence are not recorded +-- explicitly in wiredInTyThings or basicKnownKeyNames. knownKeyNamesMap :: UniqFM Name knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames] @@ -326,13 +336,19 @@ putName _dict BinSymbolTable{ = case wiredInNameTyThing_maybe name of Just (ATyCon tc) | Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 0 + | isUnboxedSumTyCon tc -> putSumTyConName_ bh tc Just (AConLike (RealDataCon dc)) | let tc = dataConTyCon dc , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 1 + | isUnboxedSumCon dc -> putSumDataConName_ bh dc Just (AnId x) | Just dc <- isDataConWorkId_maybe x , let tc = dataConTyCon dc , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 2 + Just (AnId x) + | Just dc <- isDataConWorkId_maybe x + , isUnboxedSumCon dc + -> putSumWorkerId_ bh dc _ -> do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of @@ -347,8 +363,8 @@ putName _dict BinSymbolTable{ putTupleName_ :: BinHandle -> TyCon -> TupleSort -> Word32 -> IO () putTupleName_ bh tc tup_sort thing_tag - = -- ASSERT(arity < 2^(30 :: Int)) - put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity) + = ASSERT(arity < 2^(25 :: Int)) + put_ bh (0x80000000 .|. (sort_tag `shiftL` 27) .|. (thing_tag `shiftL` 25) .|. arity) where (sort_tag, arity) = case tup_sort of BoxedTuple -> (0, fromIntegral (tyConArity tc)) @@ -356,33 +372,92 @@ putTupleName_ bh tc tup_sort thing_tag -- See Note [Unboxed tuple RuntimeRep vars] in TyCon ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) +putSumTyConName_ :: BinHandle -> TyCon -> IO () +putSumTyConName_ bh tc + = ASSERT(arity < 2^(27 :: Int)) + put_ bh (0xA0000000 .|. arity) + where + arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 + +putSumDataConName_ :: BinHandle -> DataCon -> IO () +putSumDataConName_ bh dc + = ASSERT(arity < 2^(13 :: Int) && alt < 2^(14 :: Int)) + put_ bh (0xA8000000 .|. (arity `shiftL` 14) .|. alt) + where + tc = dataConTyCon dc + alt = fromIntegral (dataConTag dc) + arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 + +putSumWorkerId_ :: BinHandle -> DataCon -> IO () +putSumWorkerId_ bh dc + = put_ bh (0xB0000000 .|. (arity `shiftL` 14) .|. alt) + where + tc = dataConTyCon dc + alt = fromIntegral (dataConTag dc) + arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 + -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater -> Dictionary -> SymbolTable -> BinHandle -> IO Name getSymtabName _ncu _dict symtab bh = do - i <- get bh + i :: Word32 <- get bh case i .&. 0xC0000000 of - 0x00000000 -> return $! symtab ! fromIntegral (i :: Â Word32) - 0x40000000 -> return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of - Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i) - Just n -> n - where tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) - ix = fromIntegral i .&. 0x003FFFFF - 0x80000000 -> return $! case thing_tag of - 0 -> tyConName (tupleTyCon sort arity) - 1 -> dataConName dc - 2 -> idName (dataConWorkId dc) - _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) - where - dc = tupleDataCon sort arity - sort = case (i .&. 0x30000000) `shiftR` 28 of - 0 -> Boxed - 1 -> Unboxed - _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) - thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26 - arity = fromIntegral (i .&. 0x03FFFFFF) - _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x40000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + in + return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i) + Just n -> n + + 0x80000000 -> + case i .&. 0x20000000 of + 0x00000000 -> + let + dc = tupleDataCon sort arity + sort = case (i .&. 0x18000000) `shiftR` 27 of + 0 -> Boxed + 1 -> Unboxed + _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) + arity = fromIntegral (i .&. 0x01FFFFFF) + in + return $! case ( (i .&. 0x06FFFFFF) `shiftR` 25 ) of + 0 -> tyConName (tupleTyCon sort arity) + 1 -> dataConName dc + 2 -> idName (dataConWorkId dc) + _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) + + 0x20000000 -> + return $! case ((i .&. 0x18000000) `shiftR` 27) of + 0 -> tyConName $ sumTyCon ( fromIntegral (i .&. 0x7ffffff) ) + 1 -> let + alt = + -- first (least significant) 14 bits + fromIntegral (i .&. 0b11111111111111) + arity = + -- next 13 bits + fromIntegral ((i `shiftR` 14) .&. 0b1111111111111) + in + ASSERT( arity >= alt ) + dataConName (sumDataCon alt arity) + 2 -> let + alt = + -- first (least significant) 14 bits + fromIntegral (i .&. 0b11111111111111) + arity = + -- next 13 bits + fromIntegral ((i `shiftR` 14) .&. 0b1111111111111) + in + ASSERT( arity >= alt ) + idName (dataConWorkId (sumDataCon alt arity)) + + _ -> pprPanic "getSymtabName:unknown sum sort" (ppr i) + _ -> pprPanic "getSyntabName:unknown `tuple or sum` tag" (ppr i) + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 9ebc03c143..edab3508d1 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1460,6 +1460,7 @@ tyConToIfaceDecl env tycon ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds) ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds) ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False [] + ifaceConDecls (SumTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds) ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct -- The AbstractTyCon case happens when a TyCon has been trimmed -- during tidying. diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs index 6a442e02ab..3dafbac996 100644 --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -20,6 +20,9 @@ mAX_TUPLE_SIZE = 62 -- Should really match the number mAX_CTUPLE_SIZE :: Int -- Constraint tuples mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes +mAX_SUM_SIZE :: Int +mAX_SUM_SIZE = 62 + -- | Default maximum depth for both class instance search and type family -- reduction. See also Trac #5395. mAX_REDUCTION_DEPTH :: Int diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index dc29176ddf..744562e26e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -3643,6 +3643,7 @@ xFlagsDeps = [ flagSpec "TypeOperators" LangExt.TypeOperators, flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, flagSpec "UnboxedTuples" LangExt.UnboxedTuples, + flagSpec "UnboxedSums" LangExt.UnboxedSums, flagSpec "UndecidableInstances" LangExt.UndecidableInstances, flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 9877e9a0c7..a421c72baf 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -61,7 +61,8 @@ import IfaceEnv ( newInteractiveBinder ) import FamInstEnv ( FamInst ) import CoreFVs ( orphNamesOfFamInst ) import TyCon -import Type hiding( typeKind ) +import Type hiding( typeKind ) +import RepType import TcType hiding( typeKind ) import Var import Id diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 39ce506094..436ffc9ce6 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -433,9 +433,9 @@ $tab { warnTab } } <0> { - "(#" / { ifExtension unboxedTuplesEnabled } + "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled } { token IToubxparen } - "#)" / { ifExtension unboxedTuplesEnabled } + "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled } { token ITcubxparen } } @@ -995,6 +995,9 @@ atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap ifExtension pred bits _ _ _ = pred bits +orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap +orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits + multiline_doc_comment :: Action multiline_doc_comment span buf _len = withLexedDocType (worker "") where @@ -2094,6 +2097,7 @@ data ExtBits | RecursiveDoBit -- mdo | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc | UnboxedTuplesBit -- (# and #) + | UnboxedSumsBit -- (# and #) | DatatypeContextsBit | TransformComprehensionsBit | QqBit -- enable quasiquoting @@ -2141,6 +2145,8 @@ unicodeSyntaxEnabled :: ExtsBitmap -> Bool unicodeSyntaxEnabled = xtest UnicodeSyntaxBit unboxedTuplesEnabled :: ExtsBitmap -> Bool unboxedTuplesEnabled = xtest UnboxedTuplesBit +unboxedSumsEnabled :: ExtsBitmap -> Bool +unboxedSumsEnabled = xtest UnboxedSumsBit datatypeContextsEnabled :: ExtsBitmap -> Bool datatypeContextsEnabled = xtest DatatypeContextsBit qqEnabled :: ExtsBitmap -> Bool @@ -2211,6 +2217,7 @@ mkParserFlags flags = .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags + .|. UnboxedSumsBit `setBitIf` xopt LangExt.UnboxedSums flags .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index fea9203811..cd10a29703 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1682,6 +1682,8 @@ atype :: { LHsType RdrName } [mo $1,mc $2] } | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) [mo $1,mc $3] } + | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2) + [mo $1,mc $3] } | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } @@ -1741,6 +1743,12 @@ comma_types1 :: { [LHsType RdrName] } -- One or more: ty,ty,ty | ctype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return ($1 : $3) } +bar_types2 :: { [LHsType RdrName] } -- Two or more: ty|ty|ty + : ctype '|' ctype {% addAnnotation (gl $1) AnnVbar (gl $2) + >> return [$1,$3] } + | ctype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) + >> return ($1 : $3) } + tv_bndrs :: { [LHsTyVarBndr RdrName] } : tv_bndr tv_bndrs { $1 : $2 } | {- empty -} { [] } @@ -2289,14 +2297,14 @@ aexp2 :: { LHsExpr RdrName } -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } - | '(' tup_exprs ')' {% ams (sLL $1 $> (ExplicitTuple $2 Boxed)) - [mop $1,mcp $3] } + | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) $2 + ; ams (sLL $1 $> e) [mop $1,mcp $3] } } | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) (Present $2)] Unboxed)) [mo $1,mc $3] } - | '(#' tup_exprs '#)' {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed)) - [mo $1,mc $3] } + | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) $2 + ; ams (sLL $1 $> e) [mo $1,mc $3] } } | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } @@ -2384,16 +2392,25 @@ texp :: { LHsExpr RdrName } -- View patterns get parenthesized above | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] } --- Always at least one comma -tup_exprs :: { [LHsTupArg RdrName] } +-- Always at least one comma or bar. +tup_exprs :: { SumOrTuple } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ((sL1 $1 (Present $1)) : snd $2) } } + ; return (Tuple ((sL1 $1 (Present $1)) : snd $2)) } } + + | texp bars + {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $2) + ; return (Sum 1 (snd $2 + 1) $1) } } | commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - (map (\l -> L l missingTupArg) (fst $1) ++ $2) } } + (Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } } + + | bars texp bars0 + {% do { mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $1) + ; mapM_ (\ll -> addAnnotation ll AnnVbar ll) (fst $3) + ; return (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } } -- Always starts with commas; always follows an expr commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) } @@ -3121,6 +3138,14 @@ commas :: { ([SrcSpan],Int) } -- One or more commas : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } | ',' { ([gl $1],1) } +bars0 :: { ([SrcSpan],Int) } -- Zero or more bars + : bars { $1 } + | { ([], 0) } + +bars :: { ([SrcSpan],Int) } -- One or more bars + : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } + | '|' { ([gl $1],1) } + ----------------------------------------------------------------------------- -- Documentation comments diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index af1e53e866..4fc1c9c274 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -59,7 +59,9 @@ module RdrHsSyn ( mkModuleImpExp, mkTypeImpExp, mkImpExpSubSpec, - checkImportSpec + checkImportSpec, + + SumOrTuple (..), mkSumOrTuple ) where @@ -866,6 +868,10 @@ checkAPat msg loc e0 = do return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) + ExplicitSum alt arity expr _ -> do + p <- checkLPat msg expr + return (SumPat p alt arity placeHolderType) + RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } -> do fs <- mapM (checkPatField msg) fs return (ConPatIn c (RecCon (HsRecFields fs dd))) @@ -1475,3 +1481,24 @@ mkImpExpSubSpec xs = parseErrorSDoc :: SrcSpan -> SDoc -> P a parseErrorSDoc span s = failSpanMsgP span s + +data SumOrTuple + = Sum ConTag Arity (LHsExpr RdrName) + | Tuple [LHsTupArg RdrName] + +mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName) + +-- Tuple +mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) + +-- Sum +mkSumOrTuple Unboxed _ (Sum alt arity e) = + return (ExplicitSum alt arity e PlaceHolder) +mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = + parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) + where + ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc + ppr_boxed_sum alt arity e = + text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" + + ppr_bars n = hsep (replicate n (Outputable.char '|')) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 3905afa1bd..02d59b01e3 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1876,17 +1876,17 @@ runtimeRepSimpleDataConKeys :: [Unique] ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey :: Unique runtimeRepSimpleDataConKeys@( ptrRepLiftedDataConKey : ptrRepUnliftedDataConKey : _) - = map mkPreludeDataConUnique [72..82] + = map mkPreludeDataConUnique [72..83] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [83..88] +vecCountDataConKeys = map mkPreludeDataConUnique [84..89] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [89..98] +vecElemDataConKeys = map mkPreludeDataConUnique [90..99] ---------------- Template Haskell ------------------- -- THNames.hs: USES DataUniques 100-150 @@ -1909,7 +1909,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, realWorldPrimIdKey, recConErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey, - typeErrorIdKey :: Unique + typeErrorIdKey, rubbishEntryErrorIdKey :: Unique wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] absentErrorIdKey = mkPreludeMiscIdUnique 1 @@ -1934,6 +1934,7 @@ unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 unpackCStringIdKey = mkPreludeMiscIdUnique 20 voidPrimIdKey = mkPreludeMiscIdUnique 21 typeErrorIdKey = mkPreludeMiscIdUnique 22 +rubbishEntryErrorIdKey = mkPreludeMiscIdUnique 23 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index be91ae65ec..e174aedcf4 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -37,6 +37,7 @@ import Demand import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type +import RepType ( typePrimRep, tyConPrimRep ) import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) @@ -585,8 +586,8 @@ getPrimOpResultInfo op where tc = tyConAppTyCon ty -- All primops return a tycon-app result - -- The tycon can be an unboxed tuple, though, which - -- gives rise to a ReturnAlg + -- The tycon can be an unboxed tuple or sum, though, + -- which gives rise to a ReturnAlg {- We do not currently make use of whether primops are commutable. diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 7111d7a555..11aea78549 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -78,6 +78,9 @@ module TysWiredIn ( -- * Any anyTyCon, anyTy, anyTypeOfKind, + -- * Sums + mkSumTy, sumTyCon, sumDataCon, + -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, @@ -104,6 +107,7 @@ module TysWiredIn ( voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy, + unboxedSumRepDataConTy, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy, @@ -127,7 +131,7 @@ import TysPrim -- others: import CoAxiom import Id -import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) +import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import Module ( Module ) import Type import DataCon @@ -137,8 +141,7 @@ import Class ( Class, mkClass ) import RdrName import Name import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes ( Arity, Boxity(..), - TupleSort(..) ) +import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ ) import ForeignCall import SrcLoc ( noSrcSpan ) import Unique @@ -395,7 +398,7 @@ runtimeRepSimpleDataConNames , fsLit "VoidRep", fsLit "IntRep" , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep" , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" - , fsLit "UnboxedTupleRep" ] + , fsLit "UnboxedTupleRep", fsLit "UnboxedSumRep" ] runtimeRepSimpleDataConKeys runtimeRepSimpleDataCons @@ -786,7 +789,10 @@ mk_tuple Unboxed arity = (tycon, tuple_con) -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k2 -> TYPE k2 -> # tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) (\ks -> map tYPE ks) - tc_res_kind = unboxedTupleKind + + tc_res_kind | arity == 0 = tYPE voidRepDataConTy -- Nullary unboxed tuple + | otherwise = unboxedTupleKind + tc_arity = arity * 2 flavour = UnboxedAlgTyCon @@ -827,6 +833,95 @@ unboxedUnitDataCon = tupleDataCon Unboxed 0 {- ********************************************************************* * * + Unboxed sums +* * +********************************************************************* -} + +-- | OccName for n-ary unboxed sum type constructor. +mkSumTyConOcc :: Arity -> OccName +mkSumTyConOcc n = mkOccName tcName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars ++ "#)" + bars = replicate (n-1) '|' + +-- | OccName for i-th alternative of n-ary unboxed sum data constructor. +mkSumDataConOcc :: ConTag -> Arity -> OccName +mkSumDataConOcc alt n = mkOccName dataName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" + bars i = replicate i '|' + +-- | Type constructor for n-ary unboxed sum. +sumTyCon :: Arity -> TyCon +sumTyCon n | n > mAX_SUM_SIZE = fst (mk_sum n) -- Build one specially +sumTyCon n = fst (unboxedSumArr ! n) + +-- | Data constructor for i-th alternative of a n-ary unboxed sum. +sumDataCon :: ConTag -- Alternative + -> Arity -- Arity + -> DataCon +sumDataCon alt arity + | alt > arity + = panic ("sumDataCon: index out of bounds: alt " + ++ show alt ++ " > arity " ++ show arity) + + | alt <= 0 + = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_SUM_SIZE + = snd (mk_sum arity) ! (alt - 1) -- Build one specially + + | otherwise + = snd (unboxedSumArr ! arity) ! (alt - 1) + +-- | Cached type and data constructors for sums. The outer array is +-- indexed by the arity of the sum and the inner array is indexed by +-- the alternative. +unboxedSumArr :: Array Int (TyCon, Array Int DataCon) +unboxedSumArr = listArray (0,mAX_SUM_SIZE) [mk_sum i | i <- [0..mAX_SUM_SIZE]] + +-- | Create type constructor and data constructors for n-ary unboxed sum. +mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) +mk_sum arity = (tycon, sum_cons) + where + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) + UnboxedAlgTyCon + + tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) + (\ks -> map tYPE ks) + + tyvars = mkTemplateTyVars (replicate arity runtimeRepTy ++ + map (tYPE . mkTyVarTy) (take arity tyvars)) + + tc_res_kind = tYPE unboxedSumRepDataConTy + + open_tvs = drop arity tyvars + + tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + + sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] + sum_con i = let dc = pcDataCon dc_name + tyvars -- univ tyvars + [tyvar_tys !! i] -- arg types + tycon + + dc_name = mkWiredInName gHC_PRIM + (mkSumDataConOcc i arity) + (dc_uniq i) + (AConLike (RealDataCon dc)) + BuiltInSyntax + in dc + tyvar_tys = mkTyVarTys open_tvs + tc_uniq = mkSumTyConUnique arity + dc_uniq i = mkSumDataConUnique i arity + +{- +************************************************************************ +* * Equality types and classes * * ********************************************************************* -} @@ -935,7 +1030,7 @@ runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _) = zipWithLazy mk_runtime_rep_dc [ PtrRep, PtrRep, VoidRep, IntRep, WordRep, Int64Rep , Word64Rep, AddrRep, FloatRep, DoubleRep - , panic "unboxed tuple PrimRep" ] + , panic "unboxed tuple PrimRep", panic "unboxed sum PrimRep" ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name @@ -944,10 +1039,10 @@ runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _) -- See Note [Wiring in RuntimeRep] voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, - unboxedTupleRepDataConTy :: Type + unboxedTupleRepDataConTy, unboxedSumRepDataConTy :: Type [_, _, voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, - unboxedTupleRepDataConTy] = map (mkTyConTy . promoteDataCon) + unboxedTupleRepDataConTy, unboxedSumRepDataConTy] = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons vecCountTyCon :: TyCon @@ -1257,6 +1352,16 @@ mkBoxedTupleTy tys = mkTupleTy Boxed tys unitTy :: Type unitTy = mkTupleTy Boxed [] +{- ********************************************************************* +* * + The sum types +* * +************************************************************************ +-} + +mkSumTy :: [Type] -> Type +mkSumTy tys = mkTyConApp (sumTyCon (length tys)) + (map (getRuntimeRep "mkSumTy") tys ++ tys) {- ********************************************************************* * * diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index 6c1619e35d..b759644448 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -32,3 +32,5 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, doubleElemRepDataConTy :: Type + +anyTypeOfKind :: Kind -> Type diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs index 2b2e329841..ee37ab14b6 100644 --- a/compiler/profiling/SCCfinal.hs +++ b/compiler/profiling/SCCfinal.hs @@ -92,7 +92,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds do_top_rhs _ (StgRhsClosure _ _ _ _ [] (StgTick (ProfNote _cc False{-not tick-} _push) - (StgConApp con args))) + (StgConApp con args _))) | not (isDllConApp dflags mod_name con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon @@ -139,8 +139,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds do_expr (StgApp fn args) = return (StgApp fn args) - do_expr (StgConApp con args) - = return (StgConApp con args) + do_expr (StgConApp con args ty_args) + = return (StgConApp con args ty_args) do_expr (StgOpApp con args res_ty) = return (StgOpApp con args res_ty) @@ -202,7 +202,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds -- but need to reinstate PushCC for that. do_rhs (StgRhsClosure _closure_cc _bi _fv _u [] (StgTick (ProfNote cc False{-not tick-} _push) - (StgConApp con args))) + (StgConApp con args _))) = do collectCC cc return (StgRhsCon currentCCS con args) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index f8a53e0689..f964e772f5 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -271,6 +271,10 @@ rnExpr (ExplicitTuple tup_args boxity) rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) , emptyFVs) +rnExpr (ExplicitSum alt arity expr _) + = do { (expr', fvs) <- rnLExpr expr + ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) } + rnExpr (RecordCon { rcon_con_name = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 0ec15a969f..7e41bec9d2 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -446,6 +446,11 @@ rnPatAndThen mk (TuplePat pats boxed _) ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed []) } +rnPatAndThen mk (SumPat pat alt arity _) + = do { pat <- rnLPatAndThen mk pat + ; return (SumPat pat alt arity PlaceHolder) + } + -- If a splice has been run already, just rename the result. rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat))) = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 36264310f9..f201b221a6 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -537,6 +537,13 @@ rnHsTyKi env tupleTy@(HsTupleTy tup_con tys) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsTupleTy tup_con tys', fvs) } +rnHsTyKi env sumTy@(HsSumTy tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env sumTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsSumTy tys', fvs) } + -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit t) = do { data_kinds <- xoptM LangExt.DataKinds @@ -1599,6 +1606,7 @@ extract_lty t_or_k (L _ ty) acc HsListTy ty -> extract_lty t_or_k ty acc HsPArrTy ty -> extract_lty t_or_k ty acc HsTupleTy _ tys -> extract_ltys t_or_k tys acc + HsSumTy tys -> extract_ltys t_or_k tys acc HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< extract_lty t_or_k ty2 acc HsIParamTy _ ty -> extract_lty t_or_k ty acc diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs new file mode 100644 index 0000000000..7e42a866b0 --- /dev/null +++ b/compiler/simplStg/RepType.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} + +module RepType + ( -- * Code generator views onto Types + UnaryType, NvUnaryType, isNvUnaryType, + RepType(..), repType, repTypeArgs, isUnaryRep, isMultiRep, + + -- * Predicates on types + isVoidTy, typePrimRep, + + -- * Type representation for the code generator + countConRepArgs, idFunRepArity, tyConPrimRep, + + -- * Unboxed sum representation type + ubxSumRepType, layout, typeSlotTy, SlotTy (..), slotTyToType, + slotPrimRep, repTypeSlots + ) where + +#include "HsVersions.h" + +import BasicTypes (Arity, RepArity) +import DataCon +import Id +import Outputable +import PrelNames +import TyCon +import TyCoRep +import Type +import TysPrim +import TysWiredIn +import Util + +import Data.List (foldl', sort) +import Data.Maybe (maybeToList) +import qualified Data.IntSet as IS + +{- ********************************************************************** +* * + Representation types +* * +********************************************************************** -} + +type NvUnaryType = Type +type UnaryType = Type + -- Both are always a value type; i.e. its kind is TYPE rr + -- for some rr; moreover the rr is never a variable. + -- + -- NvUnaryType : never an unboxed tuple or sum, or void + -- + -- UnaryType : never an unboxed tuple or sum; + -- can be Void# (but not (# #)) + +isNvUnaryType :: Type -> Bool +isNvUnaryType ty + = case repType ty of + UnaryRep _ -> True + MultiRep ss -> not (null ss) + +data RepType + = MultiRep [SlotTy] -- Represented by multiple values (e.g. unboxed tuple or sum) + | UnaryRep NvUnaryType -- Represented by a single value; but never Void#, or any + -- other zero-width type (isVoidTy) + +instance Outputable RepType where + ppr (MultiRep slots) = text "MultiRep" <+> ppr slots + ppr (UnaryRep ty) = text "UnaryRep" <+> ppr ty + +isMultiRep :: RepType -> Bool +isMultiRep (MultiRep _) = True +isMultiRep _ = False + +isUnaryRep :: RepType -> Bool +isUnaryRep (UnaryRep _) = True +isUnaryRep _ = False + +-- INVARIANT: the result list is never empty. +repTypeArgs :: Type -> [UnaryType] +repTypeArgs ty = case repType ty of + MultiRep [] -> [voidPrimTy] + MultiRep slots -> map slotTyToType slots + UnaryRep ty -> [ty] + +repTypeSlots :: RepType -> [SlotTy] +repTypeSlots (MultiRep slots) = slots +repTypeSlots (UnaryRep ty) = maybeToList (typeSlotTy ty) + +-- | 'repType' figure out how a type will be represented at runtime. It looks +-- through +-- +-- 1. For-alls +-- 2. Synonyms +-- 3. Predicates +-- 4. All newtypes, including recursive ones, but not newtype families +-- 5. Casts +-- +repType :: Type -> RepType +repType ty + = go initRecTc ty + where + go :: RecTcChecker -> Type -> RepType + go rec_nts ty -- Expand predicates and synonyms + | Just ty' <- coreView ty + = go rec_nts ty' + + go rec_nts (ForAllTy _ ty2) -- Drop type foralls + = go rec_nts ty2 + + go rec_nts ty@(TyConApp tc tys) -- Expand newtypes + | isNewTyCon tc + , tys `lengthAtLeast` tyConArity tc + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon + = go rec_nts' (newTyConInstRhs tc tys) + + | isUnboxedTupleTyCon tc + = MultiRep (concatMap (repTypeSlots . go rec_nts) non_rr_tys) + + | isUnboxedSumTyCon tc + = MultiRep (ubxSumRepType non_rr_tys) + + | isVoidTy ty + = MultiRep [] + where + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + non_rr_tys = dropRuntimeRepArgs tys + + go rec_nts (CastTy ty _) + = go rec_nts ty + + go _ ty@(CoercionTy _) + = pprPanic "repType" (ppr ty) + + go _ ty = UnaryRep ty + + +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +countFunRepArgs :: Arity -> Type -> RepArity +countFunRepArgs 0 _ + = 0 +countFunRepArgs n ty + | UnaryRep (FunTy arg res) <- repType ty + = length (repTypeArgs arg) + countFunRepArgs (n - 1) res + | otherwise + = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty)) + +countConRepArgs :: DataCon -> RepArity +countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) + where + go :: Arity -> Type -> RepArity + go 0 _ + = 0 + go n ty + | UnaryRep (FunTy arg res) <- repType ty + = length (repTypeSlots (repType arg)) + go (n - 1) res + | otherwise + = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, repType ty)) + +-- | True if the type has zero width. +isVoidTy :: Type -> Bool +isVoidTy ty = typePrimRep ty == VoidRep + + +{- ********************************************************************** +* * + Unboxed sums + See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs +* * +********************************************************************** -} + +type SortedSlotTys = [SlotTy] + +-- | Given the arguments of a sum type constructor application, +-- return the unboxed sum rep type. +-- +-- E.g. +-- +-- (# Int | Maybe Int | (# Int, Bool #) #) +-- +-- We call `ubxSumRepType [ Int, Maybe Int, (# Int,Bool #) ]`, +-- which returns [Tag#, PtrSlot, PtrSlot] +-- +-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head +-- of the list we have the slot for the tag. +ubxSumRepType :: [Type] -> [SlotTy] +ubxSumRepType constrs0 = + ASSERT2( length constrs0 > 1, ppr constrs0 ) -- otherwise it isn't a sum type + let + combine_alts :: [SortedSlotTys] -- slots of constructors + -> SortedSlotTys -- final slots + combine_alts constrs = foldl' merge [] constrs + + merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys + merge existing_slots [] + = existing_slots + merge [] needed_slots + = needed_slots + merge (es : ess) (s : ss) + | Just s' <- s `fitsIn` es + = -- found a slot, use it + s' : merge ess ss + + | otherwise + = -- keep searching for a slot + es : merge ess (s : ss) + + -- Nesting unboxed tuples and sums is OK, so we need to flatten first. + rep :: Type -> SortedSlotTys + rep ty = sort (repTypeSlots (repType ty)) + + sumRep = WordSlot : combine_alts (map rep constrs0) + -- WordSlot: for the tag of the sum + in + sumRep + +layout :: SortedSlotTys -- Layout of sum. Does not include tag. + -- We assume that they are in increasing order + -> [SlotTy] -- Slot types of things we want to map to locations in the + -- sum layout + -> [Int] -- Where to map 'things' in the sum layout +layout sum_slots0 arg_slots0 = + go arg_slots0 IS.empty + where + go :: [SlotTy] -> IS.IntSet -> [Int] + go [] _ + = [] + go (arg : args) used + = let slot_idx = findSlot arg 0 sum_slots0 used + in slot_idx : go args (IS.insert slot_idx used) + + findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int + findSlot arg slot_idx (slot : slots) useds + | not (IS.member slot_idx useds) + , Just slot == arg `fitsIn` slot + = slot_idx + | otherwise + = findSlot arg (slot_idx + 1) slots useds + findSlot _ _ [] _ + = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) + +-------------------------------------------------------------------------------- + +-- We have 3 kinds of slots: +-- +-- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. +-- boxed objects) +-- +-- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. +-- +-- - Float slots: Shared between floating point types. +-- +-- - Void slots: Shared between void types. Not used in sums. +data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot + deriving (Eq, Ord) + -- Constructor order is important! If slot A could fit into slot B + -- then slot A must occur first. E.g. FloatSlot before DoubleSlot + -- + -- We are assuming that WordSlot is smaller than or equal to Word64Slot + -- (would not be true on a 128-bit machine) + +instance Outputable SlotTy where + ppr PtrSlot = text "PtrSlot" + ppr Word64Slot = text "Word64Slot" + ppr WordSlot = text "WordSlot" + ppr DoubleSlot = text "DoubleSlot" + ppr FloatSlot = text "FloatSlot" + +typeSlotTy :: UnaryType -> Maybe SlotTy +typeSlotTy ty + | isVoidTy ty + = Nothing + | otherwise + = Just (primRepSlot (typePrimRep ty)) + +primRepSlot :: PrimRep -> SlotTy +primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") +primRepSlot PtrRep = PtrSlot +primRepSlot IntRep = WordSlot +primRepSlot WordRep = WordSlot +primRepSlot Int64Rep = Word64Slot +primRepSlot Word64Rep = Word64Slot +primRepSlot AddrRep = WordSlot +primRepSlot FloatRep = FloatSlot +primRepSlot DoubleRep = DoubleSlot +primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") + +-- Used when unarising sum binders (need to give unarised Ids types) +slotTyToType :: SlotTy -> Type +slotTyToType PtrSlot = anyTypeOfKind liftedTypeKind +slotTyToType Word64Slot = int64PrimTy +slotTyToType WordSlot = intPrimTy +slotTyToType DoubleSlot = doublePrimTy +slotTyToType FloatSlot = floatPrimTy + +slotPrimRep :: SlotTy -> PrimRep +slotPrimRep PtrSlot = PtrRep +slotPrimRep Word64Slot = Word64Rep +slotPrimRep WordSlot = WordRep +slotPrimRep DoubleSlot = DoubleRep +slotPrimRep FloatSlot = FloatRep + +-- | Returns the bigger type if one fits into the other. (commutative) +fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy +fitsIn ty1 ty2 + | isWordSlot ty1 && isWordSlot ty2 + = Just (max ty1 ty2) + | isFloatSlot ty1 && isFloatSlot ty2 + = Just (max ty1 ty2) + | isPtrSlot ty1 && isPtrSlot ty2 + = Just PtrSlot + | otherwise + = Nothing + where + isPtrSlot PtrSlot = True + isPtrSlot _ = False + + isWordSlot Word64Slot = True + isWordSlot WordSlot = True + isWordSlot _ = False + + isFloatSlot DoubleSlot = True + isFloatSlot FloatSlot = True + isFloatSlot _ = False + + +{- ********************************************************************** +* * + PrimRep +* * +********************************************************************** -} + +-- | Discovers the primitive representation of a more abstract 'UnaryType' +typePrimRep :: UnaryType -> PrimRep +typePrimRep ty = kindPrimRep (text "kindRep ty" <+> ppr ty $$ ppr (typeKind ty)) + (typeKind ty) + +-- | Find the runtime representation of a 'TyCon'. Defined here to +-- avoid module loops. Do not call this on unboxed tuples or sums, +-- because they don't /have/ a runtime representation +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep tc + = ASSERT2( not (isUnboxedTupleTyCon tc), ppr tc ) + ASSERT2( not (isUnboxedSumTyCon tc), ppr tc ) + kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) + res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' +-- of values of types of this kind. +kindPrimRep :: SDoc -> Kind -> PrimRep +kindPrimRep doc ki + | Just ki' <- coreViewOneStarKind ki + = kindPrimRep doc ki' +kindPrimRep _ (TyConApp typ [runtime_rep]) + = ASSERT( typ `hasKey` tYPETyConKey ) + go runtime_rep + where + go rr + | Just rr' <- coreView rr + = go rr' + go (TyConApp rr_dc args) + | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + = fun args + go rr + = pprPanic "kindPrimRep.go" (ppr rr) +kindPrimRep doc ki + = WARN( True, text "kindPrimRep defaulting to PtrRep on" <+> ppr ki $$ doc ) + PtrRep -- this can happen legitimately for, e.g., Any diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index 3b636882fe..771df871cc 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -46,6 +46,9 @@ stg2stg dflags module_name binds ; (processed_binds, _, cost_centres) <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags) + ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:" + (pprStgBindings processed_binds) + ; let un_binds = unarise us1 processed_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs index 2c72266ad6..38544822d2 100644 --- a/compiler/simplStg/StgStats.hs +++ b/compiler/simplStg/StgStats.hs @@ -149,7 +149,7 @@ statExpr :: StgExpr -> StatEnv statExpr (StgApp _ _) = countOne Applications statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _) = countOne ConstructorApps +statExpr (StgConApp _ _ _)= countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e) = statExpr e diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 1b94cbcbc6..af2928d770 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -1,266 +1,740 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 - Note [Unarisation] ~~~~~~~~~~~~~~~~~~ -The idea of this pass is to translate away *all* unboxed-tuple binders. -So for example: +The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum +binders. So for example: + + f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + + ==> -f (x :: (# Int, Bool #)) = f x + f (# 1, True #) - ==> -f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True -It is important that we do this at the STG level and NOT at the core level -because it would be very hard to make this pass Core-type-preserving. In -this example the type of 'f' changes, for example. +It is important that we do this at the STG level and NOT at the Core level +because it would be very hard to make this pass Core-type-preserving. In this +example the type of 'f' changes, for example. STG fed to the code generators *must* be unarised because the code generators do -not support unboxed tuple binders natively. +not support unboxed tuple and unboxed sum binders natively. -In more detail: +In more detail: (see next note for unboxed sums) Suppose that a variable x : (# t1, t2 #). * At the binding site for x, make up fresh vars x1:t1, x2:t2 - * Extend the UnariseEnv x :-> [x1,x2] + * Extend the UnariseEnv x :-> MultiVal [x1,x2] * Replace the binding with a curried binding for x1,x2 + Lambda: \x.e ==> \x1 x2. e Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e - * Replace argument occurrences with a sequence of args - via a lookup in UnariseEnv + * Replace argument occurrences with a sequence of args via a lookup in + UnariseEnv + f a b x c d ==> f a b x1 x2 c d - * Replace tail-call occurrences with an unboxed tuple - via a lookup in UnariseEnv + * Replace tail-call occurrences with an unboxed tuple via a lookup in + UnariseEnv + x ==> (# x1, x2 #) + So, for example + f x = x ==> f x1 x2 = (# x1, x2 #) - This applies to case scrutinees too - case x of (# a,b #) -> e ==> case (# x1,x2 #) of (# a,b #) -> e - I think we rely on the code generator to short-circuit this - case without generating any actual code. + * We /always/ eliminate a case expression when + + - It scrutinises an unboxed tuple or unboxed sum + + - The scrutinee is a variable (or when it is an explicit tuple, but the + simplifier eliminates those) + + The case alternative (there can be only one) can be one of these two + things: + + - An unboxed tuple pattern. e.g. + + case v of x { (# x1, x2, x3 #) -> ... } + + Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the + environment with + + x :-> MultiVal [t1,t2,t3] + x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3 + + - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3 + +By the end of this pass, we only have unboxed tuples in return positions. +Unboxed sums are completely eliminated, see next note. + +Note [Translating unboxed sums to unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unarise also eliminates unboxed sum binders, and translates unboxed sums in +return positions to unboxed tuples. We want to overlap fields of a sum when +translating it to a tuple to have efficient memory layout. When translating a +sum pattern to a tuple pattern, we need to translate it so that binders of sum +alternatives will be mapped to right arguments after the term translation. So +translation of sum DataCon applications to tuple DataCon applications and +translation of sum patterns to tuple patterns need to be in sync. + +These translations work like this. Suppose we have + + (# x1 | | ... #) :: (# t1 | t2 | ... #) + +remember that t1, t2 ... can be sums and tuples too. So we first generate +layouts of those. Then we "merge" layouts of each alternative, which gives us a +sum layout with best overlapping possible. + +Layout of a flat type 'ty1' is just [ty1]. +Layout of a tuple is just concatenation of layouts of its fields. + +For layout of a sum type, -Of course all this applies recursively, so that we flatten out nested tuples. + - We first get layouts of all alternatives. + - We sort these layouts based on their "slot types". + - We merge all the alternatives. -Note [Unarisation and nullary tuples] +For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) + + - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ] + - Sorted: [ [Ptr, Word], [Word, Word], [Word] ] + - Merge all alternatives together: [ Ptr, Word, Word ] + +We add a slot for the tag to the first position. So our tuple type is + + (# Tag#, Any, Word#, Word# #) + (we use Any for pointer slots) + +Now, any term of this sum type needs to generate a tuple of this type instead. +The translation works by simply putting arguments to first slots that they fit +in. Suppose we had + + (# (# 42#, 'c' #) | | #) + +42# fits in Word#, 'c' fits in Any, so we generate this application: + + (# 1#, 'c', 42#, rubbish #) + +Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#, +3# fits in Word #, so we get: + + (# 2#, rubbish, 2#, 3# #). + +Note [Types in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this unboxed sum term: + + (# 123 | #) + +What will be the unboxed tuple representation? We can't tell without knowing the +type of this term. For example, these are all valid tuples for this: + + (# 1#, 123 #) -- when type is (# Int | String #) + (# 1#, 123, rubbish #) -- when type is (# Int | Float# #) + (# 1#, 123, rubbish, rubbish #) + -- when type is (# Int | (# Int, Int, Int #) #) + +So we pass type arguments of the DataCon's TyCon in StgConApp to decide what +layout to use. Note that unlifted values can't be let-bound, so we don't need +types in StgRhsCon. + +Note [UnariseEnv can map to literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The above scheme has a special cases for nullary unboxed tuples, x :: (# #) -To see why, consider - f2 :: (# Int, Int #) -> Int - f1 :: (# Int #) -> Int - f0 :: (# #) -> Int +To avoid redundant case expressions when unarising unboxed sums, UnariseEnv +needs to map variables to literals too. Suppose we have this Core: + + f (# x | #) -When we "unarise" to eliminate unboxed tuples (this is done at the STG level), -we'll transform to - f2 :: Int -> Int -> Int - f1 :: Int -> Int - f0 :: ?? + ==> (CorePrep) -We do not want to give f0 zero arguments, otherwise a lambda will -turn into a thunk! So we want to get - f0 :: Void# -> Int + case (# x | #) of y { + _ -> f y + } -So here is what we do for nullary tuples + ==> (MultiVal) - * Extend the UnariseEnv with x :-> [voidPrimId] + case (# 1#, x #) of [x1, x2] { + _ -> f x1 x2 + } - * Replace bindings with a binding for void:Void# - \x. e => \void. e - and similarly case alternatives +To eliminate this case expression we need to map x1 to 1# in UnariseEnv: - * If we find (# #) as an argument all by itself - f ...(# #)... - it looks like an Id, so we look up in UnariseEnv. We want to replace it - with voidPrimId, so the convenient thing is to initalise the UnariseEnv - with (# #) :-> [voidPrimId] + x1 :-> UnaryVal 1#, x2 :-> UnaryVal x -See also Note [Nullary unboxed tuple] in Type.hs. +so that `f x1 x2` becomes `f 1# x`. Note [Unarisation and arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of unarisation, the arity that will be recorded in the generated info table -for an Id may be larger than the idArity. Instead we record what we call the RepArity, -which is the Arity taking into account any expanded arguments, and corresponds to -the number of (possibly-void) *registers* arguments will arrive in. +Because of unarisation, the arity that will be recorded in the generated info +table for an Id may be larger than the idArity. Instead we record what we call +the RepArity, which is the Arity taking into account any expanded arguments, and +corresponds to the number of (possibly-void) *registers* arguments will arrive +in. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections #-} module UnariseStg (unarise) where #include "HsVersions.h" +import BasicTypes import CoreSyn -import StgSyn -import VarEnv -import UniqSupply +import DataCon +import FastString (FastString, mkFastString) import Id -import MkId ( voidPrimId, voidArgId ) +import Literal (Literal (..)) +import MkId (voidPrimId, voidArgId) +import MonadUtils (mapAccumLM) +import Outputable +import RepType +import StgSyn import Type +import TysPrim (intPrimTyCon, intPrimTy) import TysWiredIn -import DataCon -import OccName -import Name +import UniqSupply import Util -import Outputable -import BasicTypes +import VarEnv +import Data.Bifunctor (second) +import Data.Maybe (mapMaybe) +import qualified Data.IntMap as IM --- | A mapping from unboxed-tuple binders to the Ids they were expanded to. +-------------------------------------------------------------------------------- + +-- | A mapping from binders to the Ids they were expanded/renamed to. +-- +-- x :-> MultiVal [a,b,c] in rho +-- +-- iff x's repType is a MultiRep, or equivalently +-- x's type is an unboxed tuple, sum or void. +-- +-- x :-> UnaryVal x' +-- +-- iff x's RepType is UnaryRep or equivalently +-- x's type is not unboxed tuple, sum or void. -- --- INVARIANT: Ids in the range don't have unboxed tuple types. +-- So +-- x :-> MultiVal [a] in rho +-- means x is represented by singleton tuple. -- --- Those in-scope variables without unboxed-tuple types are not present in --- the domain of the mapping at all. -type UnariseEnv = VarEnv [Id] +-- x :-> MultiVal [] in rho +-- means x is void. +-- +-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes +-- (i.e. no unboxed tuples, sums or voids) +-- +type UnariseEnv = VarEnv UnariseVal + +data UnariseVal + = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). + | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. + +instance Outputable UnariseVal where + ppr (MultiVal args) = text "MultiVal" <+> ppr args + ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg + +-- | Extend the environment, checking the UnariseEnv invariant. +extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv +extendRho rho x (MultiVal args) + = ASSERT (all (isNvUnaryType . stgArgType) args) + extendVarEnv rho x (MultiVal args) +extendRho rho x (UnaryVal val) + = ASSERT (isNvUnaryType (stgArgType val)) + extendVarEnv rho x (UnaryVal val) + +-------------------------------------------------------------------------------- + +type OutStgExpr = StgExpr +type InId = Id +type OutId = Id +type InStgAlt = StgAlt +type InStgArg = StgArg +type OutStgArg = StgArg unarise :: UniqSupply -> [StgBinding] -> [StgBinding] -unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds +unarise us binds = initUs_ us (mapM (unariseBinding emptyVarEnv) binds) + +unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding +unariseBinding rho (StgNonRec x rhs) + = StgNonRec x <$> unariseRhs rho rhs +unariseBinding rho (StgRec xrhss) + = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss + +unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs +unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr) + = do (rho', args1) <- unariseFunArgBinders rho args + expr' <- unariseExpr rho' expr + let fvs' = unariseFreeVars rho fvs + return (StgRhsClosure ccs b_info fvs' update_flag args1 expr') + +unariseRhs rho (StgRhsCon ccs con args) + = ASSERT (not (isUnboxedTupleCon con || isUnboxedSumCon con)) + return (StgRhsCon ccs con (unariseConArgs rho args)) + +-------------------------------------------------------------------------------- + +unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr + +unariseExpr rho e@(StgApp f []) + = case lookupVarEnv rho f of + Just (MultiVal args) -- Including empty tuples + -> return (mkTuple args) + Just (UnaryVal (StgVarArg f')) + -> return (StgApp f' []) + Just (UnaryVal (StgLitArg f')) + -> return (StgLit f') + Just (UnaryVal arg@(StgRubbishArg {})) + -> pprPanic "unariseExpr - app1" (ppr e $$ ppr arg) + Nothing + -> return e + +unariseExpr rho e@(StgApp f args) + = return (StgApp f' (unariseFunArgs rho args)) where - -- See Note [Unarisation and nullary tuples] - nullary_tup = dataConWorkId unboxedUnitDataCon - init_env = unitVarEnv nullary_tup [voidPrimId] - -unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding -unariseBinding us rho bind = case bind of - StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs) - StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) - (listSplitUniqSupply us) xrhss - -unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs -unariseRhs us rho rhs = case rhs of - StgRhsClosure ccs b_info fvs update_flag args expr - -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag - args' (unariseExpr us' rho' expr) - where (us', rho', args') = unariseIdBinders us rho args - StgRhsCon ccs con args - -> StgRhsCon ccs con (unariseArgs rho args) - ------------------------- -unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr -unariseExpr _ rho (StgApp f args) - | null args - , UbxTupleRep tys <- repType (idType f) - = -- Particularly important where (##) is concerned - -- See Note [Nullary unboxed tuple] - StgConApp (tupleDataCon Unboxed (length tys)) - (map StgVarArg (unariseId rho f)) + f' = case lookupVarEnv rho f of + Just (UnaryVal (StgVarArg f')) -> f' + Nothing -> f + err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err) + -- Can't happen because 'args' is non-empty, and + -- a tuple or sum cannot be applied to anything + +unariseExpr _ (StgLit l) + = return (StgLit l) + +unariseExpr rho (StgConApp dc args ty_args) + | Just args' <- unariseMulti_maybe rho dc args ty_args + = return (mkTuple args') | otherwise - = StgApp f (unariseArgs rho args) + , let args' = unariseConArgs rho args + = return (StgConApp dc args' (map stgArgType args')) -unariseExpr _ _ (StgLit l) - = StgLit l +unariseExpr rho (StgOpApp op args ty) + = return (StgOpApp op (unariseFunArgs rho args) ty) -unariseExpr _ rho (StgConApp dc args) - | isUnboxedTupleCon dc = StgConApp (tupleDataCon Unboxed (length args')) args' - | otherwise = StgConApp dc args' - where - args' = unariseArgs rho args +unariseExpr _ e@StgLam{} + = pprPanic "unariseExpr: found lambda" (ppr e) -unariseExpr _ rho (StgOpApp op args ty) - = StgOpApp op (unariseArgs rho args) ty +unariseExpr rho (StgCase scrut bndr alt_ty alts) + -- a tuple/sum binders in the scrutinee can always be eliminated + | StgApp v [] <- scrut + , Just (MultiVal xs) <- lookupVarEnv rho v + = elimCase rho xs bndr alt_ty alts -unariseExpr us rho (StgLam xs e) - = StgLam xs' (unariseExpr us' rho' e) - where - (us', rho', xs') = unariseIdBinders us rho xs + -- Handle strict lets for tuples and sums: + -- case (# a,b #) of r -> rhs + -- and analogously for sums + | StgConApp dc args ty_args <- scrut + , Just args' <- unariseMulti_maybe rho dc args ty_args + = elimCase rho args' bndr alt_ty alts -unariseExpr us rho (StgCase e bndr alt_ty alts) - = StgCase (unariseExpr us1 rho e) bndr alt_ty alts' - where - (us1, us2) = splitUniqSupply us - alts' = unariseAlts us2 rho alt_ty bndr alts + -- general case + | otherwise + = do scrut' <- unariseExpr rho scrut + alts' <- unariseAlts rho alt_ty bndr alts + return (StgCase scrut' bndr alt_ty alts') + -- bndr will be dead after unarise -unariseExpr us rho (StgLet bind e) - = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) - where - (us1, us2) = splitUniqSupply us +unariseExpr rho (StgLet bind e) + = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e -unariseExpr us rho (StgLetNoEscape bind e) - = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e) - where - (us1, us2) = splitUniqSupply us +unariseExpr rho (StgLetNoEscape bind e) + = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e -unariseExpr us rho (StgTick tick e) - = StgTick tick (unariseExpr us rho e) +unariseExpr rho (StgTick tick e) + = StgTick tick <$> unariseExpr rho e ------------------------- -unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> [StgAlt] -> [StgAlt] -unariseAlts us rho (UbxTupAlt n) bndr [(DEFAULT, [], e)] - = [(DataAlt (tupleDataCon Unboxed n), ys, unariseExpr us2' rho' e)] - where - (us2', rho', ys) = unariseIdBinder us rho bndr +-- Doesn't return void args. +unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] +unariseMulti_maybe rho dc args ty_args + | isUnboxedTupleCon dc + = Just (unariseConArgs rho args) -unariseAlts us rho (UbxTupAlt n) bndr [(DataAlt _, ys, e)] - = [(DataAlt (tupleDataCon Unboxed n), ys', unariseExpr us2' rho'' e)] - where - (us2', rho', ys') = unariseIdBinders us rho ys - rho'' = extendVarEnv rho' bndr ys' + | isUnboxedSumCon dc + , let args1 = ASSERT (isSingleton args) (unariseConArgs rho args) + = Just (mkUbxSum dc ty_args args1) -unariseAlts _ _ (UbxTupAlt _) _ alts - = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts) + | otherwise + = Nothing + +-------------------------------------------------------------------------------- + +elimCase :: UnariseEnv + -> [OutStgArg] -- non-void args + -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr + +elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)] + = do let rho1 = extendRho rho bndr (MultiVal args) + rho2 + | isUnboxedTupleBndr bndr + = mapTupleIdBinders bndrs args rho1 + | otherwise + = ASSERT (isUnboxedSumBndr bndr) + if null bndrs then rho1 + else mapSumIdBinders bndrs args rho1 + + unariseExpr rho2 rhs + +elimCase rho args bndr (MultiValAlt _) alts + | isUnboxedSumBndr bndr + = do let (tag_arg : real_args) = args + tag_bndr <- mkId (mkFastString "tag") tagTy + -- this won't be used but we need a binder anyway + let rho1 = extendRho rho bndr (MultiVal args) + scrut' = case tag_arg of + StgVarArg v -> StgApp v [] + StgLitArg l -> StgLit l + StgRubbishArg _ -> pprPanic "unariseExpr" (ppr args) + + alts' <- unariseSumAlts rho1 real_args alts + return (StgCase scrut' tag_bndr tagAltTy alts') + +elimCase _ args bndr alt_ty alts + = pprPanic "elimCase - unhandled case" + (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts) + +-------------------------------------------------------------------------------- + +unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt] +unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)] + | isUnboxedTupleBndr bndr + = do (rho', ys) <- unariseConArgBinder rho bndr + e' <- unariseExpr rho' e + return [(DataAlt (tupleDataCon Unboxed n), ys, e')] + +unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)] + | isUnboxedTupleBndr bndr + = do (rho', ys1) <- unariseConArgBinders rho ys + MASSERT(n == length ys1) + let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1)) + e' <- unariseExpr rho'' e + return [(DataAlt (tupleDataCon Unboxed n), ys1, e')] + +unariseAlts _ (MultiValAlt _) bndr alts + | isUnboxedTupleBndr bndr + = pprPanic "unariseExpr: strange multi val alts" (ppr alts) + +-- In this case we don't need to scrutinize the tag bit +unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)] + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr + rhs' <- unariseExpr rho_sum_bndrs rhs + return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')] + +unariseAlts rho (MultiValAlt _) bndr alts + | isUnboxedSumBndr bndr + = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr + alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts + let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts' + return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)), + scrt_bndrs, + inner_case) ] + +unariseAlts rho _ _ alts + = mapM (\alt -> unariseAlt rho alt) alts + +unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt +unariseAlt rho (con, xs, e) + = do (rho', xs') <- unariseConArgBinders rho xs + (con, xs',) <$> unariseExpr rho' e + +-------------------------------------------------------------------------------- + +-- | Make alternatives that match on the tag of a sum +-- (i.e. generate LitAlts for the tag) +unariseSumAlts :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> [StgAlt] -- original alternative with sum LHS + -> UniqSM [StgAlt] +unariseSumAlts env args alts + = do alts' <- mapM (unariseSumAlt env args) alts + return (mkDefaultLitAlt alts') + +unariseSumAlt :: UnariseEnv + -> [StgArg] -- sum components _excluding_ the tag bit. + -> StgAlt -- original alternative with sum LHS + -> UniqSM StgAlt +unariseSumAlt rho _ (DEFAULT, _, e) + = ( DEFAULT, [], ) <$> unariseExpr rho e + +unariseSumAlt rho args (DataAlt sumCon, bs, e) + = do let rho' = mapSumIdBinders bs args rho + e' <- unariseExpr rho' e + return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' ) + +unariseSumAlt _ scrt alt + = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt) + +-------------------------------------------------------------------------------- + +mapTupleIdBinders + :: [InId] -- Un-processed binders of a tuple alternative. + -- Can have void binders. + -> [OutStgArg] -- Arguments that form the tuple (after unarisation). + -- Can't have void args. + -> UnariseEnv + -> UnariseEnv +mapTupleIdBinders ids args0 rho0 + = ASSERT (not (any (isVoidTy . stgArgType) args0)) + let + ids_unarised :: [(Id, RepType)] + ids_unarised = map (\id -> (id, repType (idType id))) ids + + map_ids :: UnariseEnv -> [(Id, RepType)] -> [StgArg] -> UnariseEnv + map_ids rho [] _ = rho + map_ids rho ((x, x_rep) : xs) args = + let + x_arity = length (repTypeSlots x_rep) + (x_args, args') = + ASSERT(args `lengthAtLeast` x_arity) + splitAt x_arity args + + rho' + | isMultiRep x_rep + = extendRho rho x (MultiVal x_args) + | otherwise + = ASSERT (x_args `lengthIs` 1) + extendRho rho x (UnaryVal (head x_args)) + in + map_ids rho' xs args' + in + map_ids rho0 ids_unarised args0 + +mapSumIdBinders + :: [InId] -- Binder of a sum alternative (remember that sum patterns + -- only have one binder, so this list should be a singleton) + -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). + -- Can't have void args. + -> UnariseEnv + -> UnariseEnv + +mapSumIdBinders [id] args rho0 + = ASSERT (not (any (isVoidTy . stgArgType) args)) + let + arg_slots = concatMap (repTypeSlots . repType . stgArgType) args + id_slots = repTypeSlots (repType (idType id)) + layout1 = layout arg_slots id_slots + in + if isMultiValBndr id + then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) + else ASSERT(layout1 `lengthIs` 1) + extendRho rho0 id (UnaryVal (args !! head layout1)) + +mapSumIdBinders ids sum_args _ + = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) + +-- | Build a unboxed sum term from arguments of an alternative. +-- +-- Example, for (# x | #) :: (# (# #) | Int #) we call +-- +-- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- +-- which returns +-- +-- [ 1#, rubbish ] +-- +mkUbxSum + :: DataCon -- Sum data con + -> [Type] -- Type arguments of the sum data con + -> [OutStgArg] -- Actual arguments of the alternative. + -> [OutStgArg] -- Final tuple arguments +mkUbxSum dc ty_args args0 + = let + (_ : sum_slots) = ubxSumRepType ty_args + -- drop tag slot + + tag = dataConTag dc + + layout' = layout sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) + tag_arg = StgLitArg (MachInt (fromIntegral tag)) + arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) + + mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] + mkTupArgs _ [] _ + = [] + mkTupArgs arg_idx (slot : slots_left) arg_map + | Just stg_arg <- IM.lookup arg_idx arg_map + = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map + | otherwise + = StgRubbishArg (slotTyToType slot) : mkTupArgs (arg_idx + 1) slots_left arg_map + in + tag_arg : mkTupArgs 0 sum_slots arg_idxs + +-------------------------------------------------------------------------------- -unariseAlts us rho _ _ alts - = zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts +{- +For arguments (StgArg) and binders (Id) we have two kind of unarisation: --------------------------- -unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt -unariseAlt us rho (con, xs, e) - = (con, xs', unariseExpr us' rho' e) - where - (us', rho', xs') = unariseIdBinders us rho xs + - When unarising function arg binders and arguments, we don't want to remove + void binders and arguments. For example, ------------------------- -unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg] -unariseArgs rho = concatMap (unariseArg rho) + f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ... + f x y z = <body> -unariseArg :: UnariseEnv -> StgArg -> [StgArg] -unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x) -unariseArg _ (StgLitArg l) = [StgLitArg l] + Here after unarise we should still get a function with arity 3. Similarly + in the call site we shouldn't remove void arguments: -unariseIds :: UnariseEnv -> [Id] -> [Id] -unariseIds rho = concatMap (unariseId rho) + f (# (# #), (# #) #) voidId rw -unariseId :: UnariseEnv -> Id -> [Id] -unariseId rho x - | Just ys <- lookupVarEnv rho x - = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> False - , text "unariseId: not unboxed tuple" <+> ppr x ) - ys + When unarising <body>, we extend the environment with these binders: - | otherwise - = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True - , text "unariseId: was unboxed tuple" <+> ppr x ) - [x] - -unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id]) -unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs - -unariseIdBinder :: UniqSupply -> UnariseEnv - -> Id -- Binder - -> (UniqSupply, - UnariseEnv, -- What to expand to at occurrence sites - [Id]) -- What to expand to at binding site -unariseIdBinder us rho x = case repType (idType x) of - UnaryRep {} -> (us, rho, [x]) - - UbxTupleRep tys - | null tys -> -- See Note [Unarisation and nullary tuples] - let ys = [voidPrimId] - rho' = extendVarEnv rho x ys - in (us, rho', [voidArgId]) - - | otherwise -> let (us0, us1) = splitUniqSupply us - ys = unboxedTupleBindersFrom us0 x tys - rho' = extendVarEnv rho x ys - in (us1, rho', ys) - -unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] -unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys - where fs = occNameFS (getOccName x) + x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal [] + + Because their rep types are `MultiRep []` (aka. void). This means that when + we see `x` in a function argument position, we actually replace it with a + void argument. When we see it in a DataCon argument position, we just get + rid of it, because DataCon applications in STG are always saturated. + + - When unarising case alternative binders we remove void binders, but we + still update the environment the same way, because those binders may be + used in the RHS. Example: + + case x of y { + (# x1, x2, x3 #) -> <RHS> + } + + We know that y can't be void, because we don't scrutinize voids, so x will + be unarised to some number of arguments, and those arguments will have at + least one non-void thing. So in the rho we will have something like: + + x :-> MultiVal [xu1, xu2] + + Now, after we eliminate void binders in the pattern, we get exactly the same + number of binders, and extend rho again with these: + + x1 :-> UnaryVal xu1 + x2 :-> MultiVal [] -- x2 is void + x3 :-> UnaryVal xu2 + + Now when we see x2 in a function argument position or in return position, we + generate void#. In constructor argument position, we just remove it. + +So in short, when we have a void id, + + - We keep it if it's a lambda argument binder or + in argument position of an application. + + - We remove it if it's a DataCon field binder or + in argument position of a DataCon application. +-} + +-------------------------------------------------------------------------------- + +-- | MultiVal a function argument. Never returns an empty list. +unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] +unariseFunArg rho (StgVarArg x) = + case lookupVarEnv rho x of + Just (MultiVal []) -> [voidArg] -- NB: do not remove void args + Just (MultiVal as) -> as + Just (UnaryVal arg) -> [arg] + Nothing -> [StgVarArg x] +unariseFunArg _ arg = [arg] + +unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseFunArgs = concatMap . unariseFunArg + +unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs + +unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +-- Result list of binders is never empty +unariseFunArgBinder rho x = + case repType (idType x) of + UnaryRep _ -> return (rho, [x]) + MultiRep [] -> return (extendRho rho x (MultiVal []), [voidArgId]) + -- NB: do not remove void binders + MultiRep slots -> do + xs <- mkIds (mkFastString "us") (map slotTyToType slots) + return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) + +-------------------------------------------------------------------------------- + +-- | MultiVal a DataCon argument. Returns an empty list when argument is void. +unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] +unariseConArg rho (StgVarArg x) = + case lookupVarEnv rho x of + Just (UnaryVal arg) -> [arg] + Just (MultiVal as) -> as -- 'as' can be empty + Nothing + | isVoidTy (idType x) -> [] -- e.g. C realWorld# + -- Here realWorld# is not in the envt, but + -- is a void, and so should be eliminated + | otherwise -> [StgVarArg x] +unariseConArg _ arg = [arg] -- We have no void literals + +unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] +unariseConArgs = concatMap . unariseConArg + +unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs + +unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]) +unariseConArgBinder rho x = + case repType (idType x) of + UnaryRep _ -> return (rho, [x]) + MultiRep slots -> do + xs <- mkIds (mkFastString "us") (map slotTyToType slots) + return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) + +unariseFreeVars :: UnariseEnv -> [InId] -> [OutId] +unariseFreeVars rho fvs + = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ] + -- Notice that we filter out any StgLitArgs + -- e.g. case e of (x :: (# Int | Bool #)) + -- (# v | #) -> ... let {g = \y. ..x...} in ... + -- (# | w #) -> ... + -- Here 'x' is free in g's closure, and the env will have + -- x :-> [1, v] + -- we want to capture 'v', but not 1, in the free vars + +unariseFreeVar :: UnariseEnv -> Id -> [StgArg] +unariseFreeVar rho x = + case lookupVarEnv rho x of + Just (MultiVal args) -> args + Just (UnaryVal arg) -> [arg] + Nothing -> [StgVarArg x] + +-------------------------------------------------------------------------------- + +mkIds :: FastString -> [UnaryType] -> UniqSM [Id] +mkIds fs tys = mapM (mkId fs) tys + +mkId :: FastString -> UnaryType -> UniqSM Id +mkId = mkSysLocalOrCoVarM + +isMultiValBndr :: Id -> Bool +isMultiValBndr = isMultiRep . repType . idType + +isUnboxedSumBndr :: Id -> Bool +isUnboxedSumBndr = isUnboxedSumType . idType + +isUnboxedTupleBndr :: Id -> Bool +isUnboxedTupleBndr = isUnboxedTupleType . idType + +mkTuple :: [StgArg] -> StgExpr +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) + +tagAltTy :: AltType +tagAltTy = PrimAlt intPrimTyCon + +tagTy :: Type +tagTy = intPrimTy + +voidArg :: StgArg +voidArg = StgVarArg voidPrimId + +mkDefaultLitAlt :: [StgAlt] -> [StgAlt] +-- We have an exhauseive list of literal alternatives +-- 1# -> e1 +-- 2# -> e2 +-- Since they are exhaustive, we can replace one with DEFAULT, to avoid +-- generating a final test. Remember, the DEFAULT comes first if it exists. +mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts") +mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts +mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts +mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 2d9ca8cb2a..cba139a532 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -21,6 +21,7 @@ import CoreArity ( manifestArity ) import StgSyn import Type +import RepType import TyCon import MkId ( coercionTokenId ) import Id @@ -45,7 +46,7 @@ import Demand ( isUsedOnce ) import PrimOp ( PrimCall(..) ) import UniqFM -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Control.Monad (liftM, ap) -- Note [Live vs free] @@ -451,8 +452,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) PolyAlt Nothing -> PolyAlt - UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) - -- UbxTupAlt includes nullary and and singleton unboxed tuples + MultiRep slots -> MultiValAlt (length slots) where _is_poly_alt_tycon tc = isFunTyCon tc @@ -537,7 +537,9 @@ coreToStgApp _ f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of - DataConWorkId dc | saturated -> StgConApp dc args' + DataConWorkId dc + | saturated -> StgConApp dc args' + (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. PrimOpId op -> ASSERT( saturated ) @@ -602,10 +604,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument (aticks, arg'') = stripStgTicksTop tickishFloatable arg' stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con [] -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) + StgApp v [] -> StgVarArg v + StgConApp con [] _ -> StgVarArg (dataConWorkId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) -- WARNING: what if we have an argument like (v `cast` co) -- where 'co' changes the representation type? @@ -620,8 +622,8 @@ coreToStgArgs (arg : args) = do -- Non-type argument arg_ty = exprType arg stg_arg_ty = stgArgType stg_arg bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty)) - || (map typePrimRep (flattenRepType (repType arg_ty)) - /= map typePrimRep (flattenRepType (repType stg_arg_ty))) + || (map typePrimRep (repTypeArgs arg_ty) + /= map typePrimRep (repTypeArgs stg_arg_ty)) -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), -- and pass it to a function expecting an HValue (arg_ty). This is ok because -- we can treat an unlifted value as lifted. But the other way round @@ -769,9 +771,11 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs (getFVs rhs_fvs) ReEntrant bndrs body - | StgConApp con args <- unticked_rhs + | StgConApp con args _ <- unticked_rhs , not (con_updateable con args) - = StgRhsCon noCCS con args + = -- CorePrep does this right, but just to make sure + ASSERT (not (isUnboxedTupleCon con || isUnboxedSumCon con)) + StgRhsCon noCCS con args | otherwise = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index b3f718241e..eb07e6b447 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -21,6 +21,7 @@ import Maybes import Name ( getSrcLoc ) import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) import Type +import RepType import TyCon import Util import SrcLoc @@ -81,6 +82,7 @@ lintStgBindings whodunnit binds lintStgArg :: StgArg -> LintM (Maybe Type) lintStgArg (StgLitArg lit) = return (Just (literalType lit)) lintStgArg (StgVarArg v) = lintStgVar v +lintStgArg (StgRubbishArg ty) = return (Just ty) lintStgVar :: Id -> LintM (Maybe Kind) lintStgVar v = do checkInScope v @@ -133,9 +135,14 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr) body_ty <- MaybeT $ lintStgExpr expr return (mkFunTys (map idType binders) body_ty) -lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do - arg_tys <- mapM (MaybeT . lintStgArg) args - MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) +lintStgRhs rhs@(StgRhsCon _ con args) = do + -- TODO: Check arg_tys + when (isUnboxedTupleCon con || isUnboxedSumCon con) $ + addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ + ppr rhs) + runMaybeT $ do + arg_tys <- mapM (MaybeT . lintStgArg) args + MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) where con_ty = dataConRepType con @@ -148,7 +155,8 @@ lintStgExpr e@(StgApp fun args) = runMaybeT $ do arg_tys <- mapM (MaybeT . lintStgArg) args MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) -lintStgExpr e@(StgConApp con args) = runMaybeT $ do +lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do + -- TODO: Check arg_tys arg_tys <- mapM (MaybeT . lintStgArg) args MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) where @@ -189,16 +197,16 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do in_scope <- MaybeT $ liftM Just $ case alts_type of - AlgAlt tc -> check_bndr tc >> return True - PrimAlt tc -> check_bndr tc >> return True - UbxTupAlt _ -> return False -- Binder is always dead in this case - PolyAlt -> return True + AlgAlt tc -> check_bndr tc >> return True + PrimAlt tc -> check_bndr tc >> return True + MultiValAlt _ -> return False -- Binder is always dead in this case + PolyAlt -> return True MaybeT $ addInScopeVars [bndr | in_scope] $ lintStgAlts alts scrut_ty where scrut_ty = idType bndr - UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple + UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple or sum check_bndr tc = case tyConAppTyCon_maybe scrut_rep of Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr Nothing -> addErrL bad_bndr @@ -362,7 +370,7 @@ have long since disappeared. checkFunApp :: Type -- The function type -> [Type] -- The arg type(s) - -> MsgDoc -- Error message + -> MsgDoc -- Error message -> LintM (Maybe Type) -- Just ty => result type is accurate checkFunApp fun_ty arg_tys msg @@ -414,8 +422,8 @@ stgEqType orig_ty1 orig_ty2 = gos (repType orig_ty1) (repType orig_ty2) where gos :: RepType -> RepType -> Bool - gos (UbxTupleRep tys1) (UbxTupleRep tys2) - = equalLength tys1 tys2 && and (zipWith go tys1 tys2) + gos (MultiRep slots1) (MultiRep slots2) + = slots1 == slots2 gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 gos _ _ = False diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index f3a02c83aa..2c22a29f76 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -59,13 +59,12 @@ import Packages ( isDllName ) import Platform import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..) ) -import TyCon ( TyCon ) +import TyCon ( PrimRep(..), TyCon ) import Type ( Type ) -import Type ( typePrimRep ) +import RepType ( typePrimRep ) +import UniqFM import UniqSet import Unique ( Unique ) -import UniqFM import Util {- @@ -97,6 +96,10 @@ data GenStgArg occ = StgVarArg occ | StgLitArg Literal + -- A rubbish arg is a value that's not supposed to be used by the generated + -- code, but it may be a GC root (i.e. used by GC) if the type is boxed. + | StgRubbishArg Type + -- | Does this constructor application refer to -- anything in a different *Windows* DLL? -- If so, we can't allocate it statically @@ -138,6 +141,7 @@ isAddrRep _ = False stgArgType :: StgArg -> Type stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit +stgArgType (StgRubbishArg ty) = ty -- | Strip ticks of a given type from an STG expression @@ -192,13 +196,14 @@ primitives, and literals. | StgLit Literal - -- StgConApp is vital for returning unboxed tuples + -- StgConApp is vital for returning unboxed tuples or sums -- which can't be let-bound first | StgConApp DataCon [GenStgArg occ] -- Saturated + [Type] -- See Note [Types in StgConApp] in UnariseStg | StgOpApp StgOp -- Primitive op or foreign call - [GenStgArg occ] -- Saturated + [GenStgArg occ] -- Saturated. Not rubbish. Type -- Result type -- We need to know this so that we can -- assign result registers @@ -402,8 +407,9 @@ The second flavour of right-hand-side is for constructors (simple but important) -- DontCareCCS, because we don't count static -- data in heap profiles, and we don't set CCCS -- from static closure. - DataCon -- constructor - [GenStgArg occ] -- args + DataCon -- Constructor. Never an unboxed tuple or sum, as those + -- are not allocated. + [GenStgArg occ] -- Args stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) @@ -442,7 +448,7 @@ exprHasCafRefs (StgApp f args) = stgIdHasCafRefs f || any stgArgHasCafRefs args exprHasCafRefs StgLit{} = False -exprHasCafRefs (StgConApp _ args) +exprHasCafRefs (StgConApp _ args _) = any stgArgHasCafRefs args exprHasCafRefs (StgOpApp _ args _) = any stgArgHasCafRefs args @@ -538,9 +544,9 @@ type GenStgAlt bndr occ data AltType = PolyAlt -- Polymorphic (a type variable) - | UbxTupAlt Int -- Unboxed tuple of this arity - | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts - | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts + | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts {- ************************************************************************ @@ -660,6 +666,7 @@ instance (OutputableBndr bndr, Outputable bdee, Ord bdee) pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con +pprStgArg (StgRubbishArg ty) = text "StgRubbishArg" <> dcolon <> ppr ty pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc @@ -670,8 +677,8 @@ pprStgExpr (StgLit lit) = ppr lit pprStgExpr (StgApp func args) = hang (ppr func) 4 (sep (map (ppr) args)) -pprStgExpr (StgConApp con args) - = hsep [ ppr con, brackets (interppSP args)] +pprStgExpr (StgConApp con args _) + = hsep [ ppr con, brackets (interppSP args) ] pprStgExpr (StgOpApp op args _) = hsep [ pprStgOp op, brackets (interppSP args)] @@ -750,10 +757,10 @@ pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where - ppr PolyAlt = text "Polymorphic" - ppr (UbxTupAlt n) = text "UbxTup" <+> ppr n - ppr (AlgAlt tc) = text "Alg" <+> ppr tc - ppr (PrimAlt tc) = text "Prim" <+> ppr tc + ppr PolyAlt = text "Polymorphic" + ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n + ppr (AlgAlt tc) = text "Alg" <+> ppr tc + ppr (PrimAlt tc) = text "Prim" <+> ppr tc pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc pprStgLVs lvs @@ -768,7 +775,7 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) -- special case pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) - = hcat [ ppr cc, + = hsep [ ppr cc, pp_binder_info bi, brackets (ifPprDebug (ppr free_var)), text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index d285159a2f..812252cee8 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -24,6 +24,7 @@ import TysPrim ( voidPrimTy ) import TysWiredIn ( tupleDataCon ) import VarEnv ( mkInScopeSet ) import Type +import RepType ( isVoidTy ) import Coercion import FamInstEnv import BasicTypes ( Boxity(..) ) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index a6918b6cf8..54d02548c7 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -472,6 +472,15 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) } +tcExpr (ExplicitSum alt arity expr _) res_ty + = do { let sum_tc = sumTyCon arity + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty + ; -- Drop levity vars, we don't care about them here + let arg_tys' = drop arity arg_tys + ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) + ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') } + tcExpr (ExplicitList _ witness exprs) res_ty = case witness of Nothing -> do { res_ty <- expTypeToType res_ty diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index ad75033932..458f96538d 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -100,6 +100,7 @@ hsPatType (ListPat _ ty Nothing) = mkListTy ty hsPatType (ListPat _ _ (Just (ty,_))) = ty hsPatType (PArrPat _ ty) = mkPArrTy ty hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys +hsPatType (SumPat _ _ _ tys) = mkSumTy tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty @@ -693,6 +694,11 @@ zonkExpr env (ExplicitTuple tup_args boxed) zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t ; return (L l (Missing t')) } +zonkExpr env (ExplicitSum alt arity expr args) + = do new_args <- mapM (zonkTcTypeToType env) args + new_expr <- zonkLExpr env expr + return (ExplicitSum alt arity new_expr new_args) + zonkExpr env (HsCase expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLExpr ms @@ -1217,6 +1223,11 @@ zonk_pat env (TuplePat pats boxed tys) ; (env', pats') <- zonkPats env pats ; return (env', TuplePat pats' boxed tys') } +zonk_pat env (SumPat pat alt arity tys) + = do { tys' <- mapM (zonkTcTypeToType env) tys + ; (env', pat') <- zonkPat env pat + ; return (env', SumPat pat' alt arity tys') } + zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds , pat_args = args, pat_wrap = wrapper }) @@ -1718,14 +1729,14 @@ ensureNotRepresentationPolymorphic ty doc checkForRepresentationPolymorphism :: SDoc -> Type -> TcM () checkForRepresentationPolymorphism extra ty | Just (tc, tys) <- splitTyConApp_maybe ty - , isUnboxedTupleTyCon tc + , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc = mapM_ (checkForRepresentationPolymorphism extra) (dropRuntimeRepArgs tys) - | runtime_rep `eqType` unboxedTupleRepDataConTy + | tuple_rep || sum_rep = addErr (vcat [ text "The type" <+> quotes (ppr tidy_ty) <+> - text "is not an unboxed tuple," + (text "is not an unboxed" <+> tuple_or_sum <> comma) , text "and yet its kind suggests that it has the representation" - , text "of an unboxed tuple. This is not allowed." ] $$ + , text "of an unboxed" <+> tuple_or_sum <> text ". This is not allowed." ] $$ extra) | not (isEmptyVarSet (tyCoVarsOfType runtime_rep)) @@ -1738,6 +1749,10 @@ checkForRepresentationPolymorphism extra ty | otherwise = return () where + tuple_rep = runtime_rep `eqType` unboxedTupleRepDataConTy + sum_rep = runtime_rep `eqType` unboxedSumRepDataConTy + tuple_or_sum = text (if tuple_rep then "tuple" else "sum") + ki = typeKind ty runtime_rep = getRuntimeRepFromKind "check_type" ki diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index ea65a73643..ad1f3ba782 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -604,6 +604,13 @@ tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind HsConstraintTuple -> ConstraintTuple _ -> panic "tc_hs_type HsTupleTy" +tc_hs_type mode (HsSumTy hs_tys) exp_kind + = do { let arity = length hs_tys + ; arg_kinds <- map tYPE `fmap` newFlexiTyVarTys arity runtimeRepTy + ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds + ; let arg_tys = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds ++ tau_tys + ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) (tYPE unboxedSumRepDataConTy) exp_kind + } --------- Promoted lists and tuples tc_hs_type mode (HsExplicitListTy _k tys) exp_kind @@ -731,7 +738,9 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind where arity = length tau_tys res_kind = case tup_sort of - UnboxedTuple -> unboxedTupleKind + UnboxedTuple + | arity == 0 -> tYPE voidRepDataConTy + | otherwise -> unboxedTupleKind BoxedTuple -> liftedTypeKind ConstraintTuple -> constraintKind diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index e62b30030d..dd889929e7 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -47,6 +47,7 @@ import Outputable import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Control.Arrow ( second ) +import ListSetOps ( getNth ) {- ************************************************************************ @@ -467,6 +468,18 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } +tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside + = do { let tc = sumTyCon arity + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) + penv pat_ty + ; -- Drop levity vars, we don't care about them here + let con_arg_tys = drop arity arg_tys + ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) + penv thing_inside + ; pat_ty <- readExpType pat_ty + ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res) + } + ------------------------ -- Data constructors tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index b53c71539b..171c1adf55 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -649,6 +649,9 @@ tcPatToExpr args pat = go pat go1 (TuplePat pats box _) = do { exprs <- mapM go pats ; return $ ExplicitTuple (map (noLoc . Present) exprs) box } + go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder + } go1 (LitPat lit) = return $ HsLit lit go1 (NPat (L _ n) mb_neg _ _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] @@ -755,6 +758,7 @@ tcCheckPatSynPat = go go1 (PArrPat pats _) = mapM_ go pats go1 (ListPat pats _ _) = mapM_ go pats go1 (TuplePat pats _ _) = mapM_ go pats + go1 (SumPat pat _ _ _) = go pat go1 LitPat{} = return () go1 NPat{} = return () go1 (SigPatIn pat _) = go pat @@ -813,6 +817,7 @@ tcCollectEx pat = let (fv, evs) = go pat in (fvVarListVarSet fv, evs) go1 (BangPat p) = go p go1 (ListPat ps _ _) = mergeMany . map go $ ps go1 (TuplePat ps _ _) = mergeMany . map go $ ps + go1 (SumPat p _ _ _) = go p go1 (PArrPat ps _) = mergeMany . map go $ ps go1 (ViewPat _ p _) = go p go1 con@ConPatOut{} = merge (FV.mkFVs (pat_tvs con), pat_dicts con) $ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index d952d2309e..4a5588de8d 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2926,6 +2926,7 @@ exprCtOrigin (HsPar (L _ e)) = exprCtOrigin e exprCtOrigin (SectionL _ _) = SectionOrigin exprCtOrigin (SectionR _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index aa8ca712f5..e4d6a4b05e 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -196,6 +196,7 @@ import ForeignCall import VarSet import Coercion import Type +import RepType (tyConPrimRep) import TyCon -- others: @@ -2317,9 +2318,9 @@ isFFIPrimArgumentTy dflags ty | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty isFFIPrimResultTy :: DynFlags -> Type -> Validity --- Checks for valid result type for a 'foreign import prim' --- Currently it must be an unlifted type, including unboxed tuples, --- or the well-known type Any. +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any. isFFIPrimResultTy dflags ty | isAnyTy ty = IsValid | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty @@ -2403,10 +2404,8 @@ legalFFITyCon tc marshalableTyCon :: DynFlags -> TyCon -> Validity marshalableTyCon dflags tc | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc) - , case tyConPrimRep tc of -- Note [Marshalling VoidRep] - VoidRep -> False - _ -> True + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + , tyConPrimRep tc /= VoidRep -- Note [Marshalling VoidRep] = validIfUnliftedFFITypes dflags | otherwise = boxedMarshalableTyCon tc @@ -2429,24 +2428,22 @@ boxedMarshalableTyCon tc legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity -- Check args of 'foreign import prim', only allow simple unlifted types. --- Strictly speaking it is unnecessary to ban unboxed tuples here since +-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since -- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc) + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) = validIfUnliftedFFITypes dflags | otherwise = NotValid unlifted_only legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity -- Check result type of 'foreign import prim'. Allow simple unlifted --- types and also unboxed tuple result types '... -> (# , , #)' +-- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc | isUnliftedTyCon tc - , (isUnboxedTupleTyCon tc - || case tyConPrimRep tc of -- Note [Marshalling VoidRep] - VoidRep -> False - _ -> True) + , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + || tyConPrimRep tc /= VoidRep -- Note [Marshalling VoidRep] = validIfUnliftedFFITypes dflags | otherwise diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 3d9d73d061..cd221a2ebf 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -2942,10 +2942,16 @@ pprTcApp style to_type p pp tc tys = pprPromotionQuote tc <> (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) + | not (debugStyle style) + , isUnboxedSumTyCon tc + , let arity = tyConArity tc + ty_args = drop (arity `div` 2) tys -- Drop the kind args + , tys `lengthIs` arity -- Not a partial application + = pprSumApp pp tc ty_args + | otherwise = sdocWithDynFlags $ \dflags -> pprTcApp_help to_type p pp tc tys dflags style - where pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> SDoc @@ -2960,6 +2966,11 @@ pprTupleApp p pp tc sort tys = pprPromotionQuote tc <> tupleParens sort (pprWithCommas (pp TopPrec) tys) +pprSumApp :: (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +pprSumApp pp tc tys + = pprPromotionQuote tc <> + sumParens (pprWithBars (pp TopPrec) tys) + pprTcApp_help :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> PprStyle -> SDoc -- This one has accss to the DynFlags diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index a31ecddd72..195c3a7505 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -33,6 +33,7 @@ module TyCon( mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, + mkSumTyCon, mkSynonymTyCon, mkFamilyTyCon, mkPromotedDataCon, @@ -44,12 +45,14 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isTypeSynonymTyCon, mightBeUnsaturatedTyCon, isPromotedDataCon, isPromotedDataCon_maybe, isKindTyCon, isLiftedTypeKindTyConName, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isDataSumTyCon_maybe, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isOpenFamilyTyCon, @@ -751,6 +754,10 @@ data AlgTyConRhs -- tuple? } + | SumTyCon { + data_cons :: [DataCon] + } + -- | Information about those 'TyCon's derived from a @newtype@ declaration | NewTyCon { data_con :: DataCon, -- ^ The unique constructor for the @newtype@. @@ -803,6 +810,7 @@ visibleDataCons (AbstractTyCon {}) = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent @@ -1362,21 +1370,47 @@ mkTupleTyCon :: Name -> TyCon mkTupleTyCon name binders res_kind arity con sort parent = AlgTyCon { - tyConName = name, tyConUnique = nameUnique name, + tyConName = name, tyConBinders = binders, + tyConTyVars = binderVars binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = arity, - tyConTyVars = binderVars binders, tcRoles = replicate arity Representational, tyConCType = Nothing, + algTcGadtSyntax = False, algTcStupidTheta = [], algTcRhs = TupleTyCon { data_con = con, tup_sort = sort }, algTcFields = emptyDFsEnv, - algTcParent = parent, - algTcGadtSyntax = False + algTcParent = parent + } + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the sum + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind arity tyvars cons parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = SumTyCon { data_cons = cons }, + algTcFields = emptyDFsEnv, + algTcParent = parent } -- | Makes a tycon suitable for use during type-checking. @@ -1530,6 +1564,9 @@ isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) | TupleTyCon { tup_sort = sort } <- rhs = not (isBoxed (tupleSortBoxity sort)) +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | SumTyCon {} <- rhs + = True isUnliftedTyCon _ = False -- | Returns @True@ if the supplied 'TyCon' resulted from either a @@ -1550,8 +1587,9 @@ isDataTyCon :: TyCon -> Bool -- @case@ expressions, and they get info tables allocated for them. -- -- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples and type family 'TyCon's. But it is --- not guaranteed to return @True@ in all cases that it could. +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. -- -- NB: for a data type family, only the /instance/ 'TyCon's -- get an info table. The family declaration 'TyCon' does not @@ -1559,6 +1597,7 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of TupleTyCon { tup_sort = sort } -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False DataTyCon {} -> True NewTyCon {} -> False AbstractTyCon {} -> False -- We don't know, so return False @@ -1599,6 +1638,7 @@ isGenerativeTyCon tc r = isInjectiveTyCon tc r -- with respect to representational equality? isGenInjAlgRhs :: AlgTyConRhs -> Bool isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True isGenInjAlgRhs (DataTyCon {}) = True isGenInjAlgRhs (AbstractTyCon distinct) = distinct isGenInjAlgRhs (NewTyCon {}) = False @@ -1651,6 +1691,19 @@ isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) _ -> Nothing isDataProductTyCon_maybe _ = Nothing +isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] +isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = cons } + | length cons > 1 + , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + SumTyCon { data_cons = cons } + | all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + _ -> Nothing +isDataSumTyCon_maybe _ = Nothing + {- Note [Product types] ~~~~~~~~~~~~~~~~~~~~~~~ A product type is @@ -1809,6 +1862,13 @@ isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) = isBoxed (tupleSortBoxity sort) isBoxedTupleTyCon _ = False +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) + | SumTyCon {} <- rhs + = True +isUnboxedSumTyCon _ = False + -- | Is this a PromotedDataCon? isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True @@ -1862,6 +1922,7 @@ isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True | otherwise = False isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent isImplicitTyCon (SynonymTyCon {}) = False @@ -1936,6 +1997,7 @@ tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) DataTyCon { data_cons = cons } -> Just cons NewTyCon { data_con = con } -> Just [con] TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons _ -> Nothing tyConDataCons_maybe _ = Nothing @@ -1977,6 +2039,7 @@ tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) DataTyCon { data_cons = cons } -> length cons NewTyCon {} -> 1 TupleTyCon {} -> 1 + SumTyCon { data_cons = cons } -> length cons _ -> pprPanic "tyConFamilySize 1" (ppr tc) tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) @@ -2148,6 +2211,7 @@ tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) TupleTyCon { tup_sort = sort } | isBoxed (tupleSortBoxity sort) -> "tuple" | otherwise -> "unboxed tuple" + SumTyCon {} -> "unboxed sum" DataTyCon {} -> "data type" NewTyCon {} -> "newtype" AbstractTyCon {} -> "abstract type" diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 823b51e8b9..1765ff5fe7 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -97,12 +97,13 @@ module Type ( funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, isCoercionTy, + isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy, isCoercionTy_maybe, isCoercionType, isForAllTy, isPiTy, -- (Lifting and boxity) - isUnliftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, + isUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, @@ -142,12 +143,8 @@ module Type ( -- * Other views onto Types coreView, coreViewOneStarKind, - UnaryType, RepType(..), flattenRepType, repType, tyConsOfType, - -- * Type representation for the code generator - typePrimRep, typeRepArity, tyConPrimRep, - -- * Main type substitution data types TvSubstEnv, -- Representation widely visible TCvSubst(..), -- Representation visible to a few friends @@ -221,7 +218,6 @@ import CoAxiom import {-# SOURCE #-} Coercion -- others -import BasicTypes ( Arity, RepArity ) import Util import Outputable import FastString @@ -274,13 +270,14 @@ import Control.Arrow ( first, second ) -- Some examples of type classifications that may make this a bit clearer are: -- -- @ --- Type primitive boxed lifted algebraic +-- Type primitive boxed lifted algebraic -- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes -- @ -- $representation_types @@ -1738,114 +1735,6 @@ typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) typeSize (CastTy ty co) = typeSize ty + coercionSize co typeSize (CoercionTy co) = coercionSize co - -{- ********************************************************************** -* * - Representation types -* * -********************************************************************** -} - -type UnaryType = Type - -data RepType - = UbxTupleRep [UnaryType] -- Represented by multiple values - -- Can be zero, one, or more - | UnaryRep UnaryType -- Represented by a single value - -instance Outputable RepType where - ppr (UbxTupleRep tys) = text "UbxTupleRep" <+> ppr tys - ppr (UnaryRep ty) = text "UnaryRep" <+> ppr ty - -flattenRepType :: RepType -> [UnaryType] -flattenRepType (UbxTupleRep tys) = tys -flattenRepType (UnaryRep ty) = [ty] - --- | 'repType' figure out how a type will be represented --- at runtime. It looks through --- --- 1. For-alls --- 2. Synonyms --- 3. Predicates --- 4. All newtypes, including recursive ones, but not newtype families --- 5. Casts --- -repType :: Type -> RepType -repType ty - = go initRecTc ty - where - go :: RecTcChecker -> Type -> RepType - go rec_nts ty -- Expand predicates and synonyms - | Just ty' <- coreView ty - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty2) -- Drop type foralls - = go rec_nts ty2 - - go rec_nts (TyConApp tc tys) -- Expand newtypes - | isNewTyCon tc - , tys `lengthAtLeast` tyConArity tc - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon - = go rec_nts' (newTyConInstRhs tc tys) - - | isUnboxedTupleTyCon tc - = UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_rr_tys) - where - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - non_rr_tys = dropRuntimeRepArgs tys - - go rec_nts (CastTy ty _) - = go rec_nts ty - - go _ ty@(CoercionTy _) - = pprPanic "repType" (ppr ty) - - go _ ty = UnaryRep ty - --- ToDo: this could be moved to the code generator, using splitTyConApp instead --- of inspecting the type directly. - --- | Discovers the primitive representation of a more abstract 'UnaryType' -typePrimRep :: UnaryType -> PrimRep -typePrimRep ty = kindPrimRep (typeKind ty) - --- | Find the primitive representation of a 'TyCon'. Defined here to --- avoid module loops. Call this only on unlifted tycons. -tyConPrimRep :: TyCon -> PrimRep -tyConPrimRep tc = kindPrimRep res_kind - where - res_kind = tyConResKind tc - --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' of values --- of types of this kind. -kindPrimRep :: Kind -> PrimRep -kindPrimRep ki | Just ki' <- coreViewOneStarKind ki = kindPrimRep ki' -kindPrimRep (TyConApp typ [runtime_rep]) - = ASSERT( typ `hasKey` tYPETyConKey ) - go runtime_rep - where - go rr | Just rr' <- coreView rr = go rr' - go (TyConApp rr_dc args) - | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc - = fun args - go rr = pprPanic "kindPrimRep.go" (ppr rr) -kindPrimRep ki = WARN( True - , text "kindPrimRep defaulting to PtrRep on" <+> ppr ki ) - PtrRep -- this can happen legitimately for, e.g., Any - -typeRepArity :: Arity -> Type -> RepArity -typeRepArity 0 _ = 0 -typeRepArity n ty = case repType ty of - UnaryRep (FunTy arg res) -> length (flattenRepType (repType arg)) + typeRepArity (n - 1) res - _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty, repType ty)) - -isVoidTy :: Type -> Bool --- True if the type has zero width -isVoidTy ty = case repType ty of - UnaryRep (TyConApp tc _) -> isUnliftedTyCon tc && - isVoidRep (tyConPrimRep tc) - _ -> False - - {- %************************************************************************ %* * @@ -1985,6 +1874,11 @@ isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of Just tc -> isUnboxedTupleTyCon tc _ -> False +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty = case tyConAppTyCon_maybe ty of + Just tc -> isUnboxedSumTyCon tc + _ -> False + -- | See "Type#type_classification" for what an algebraic type is. -- Should only be applied to /types/, as opposed to e.g. partially -- saturated type constructors diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index f4c7939a19..9436d195cc 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -19,4 +19,3 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) coreView :: Type -> Maybe Type tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] - diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index d61b1ec802..ee0147d308 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -19,6 +19,7 @@ module Outputable ( docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + pprWithBars, empty, isEmpty, nest, char, text, ftext, ptext, ztext, @@ -113,6 +114,7 @@ import System.FilePath import Text.Printf import Numeric (showFFloat) import Data.Graph (SCC(..)) +import Data.List (intersperse) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -936,6 +938,12 @@ pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use -- comma-separated and finally packed into a paragraph. pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) +pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- bar-separated and finally packed into a paragraph. +pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) + -- | Returns the separated concatenation of the pretty printed things. interppSP :: Outputable a => [a] -> SDoc interppSP xs = sep (map ppr xs) diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 30438f0d1a..4837bde208 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -34,7 +34,7 @@ import TysPrim import BasicTypes import Class import CoreSyn -import TysWiredIn +import TysWiredIn hiding (sumTyCon) import Type import TyCon import DataCon diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 7aa79215d5..a9498a5423 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -155,6 +155,12 @@ vectAlgTyConRhs tc (TupleTyCon { data_con = con }) -- but it's the behaviour we had before I refactored the -- representation of AlgTyConRhs to add tuples +vectAlgTyConRhs tc (SumTyCon { data_cons = cons }) + = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably + -- also broken when the tuple is unboxed. + vectAlgTyConRhs tc (DataTyCon { data_cons = cons + , is_enum = all (((==) 0) . dataConRepArity) cons }) + vectAlgTyConRhs tc (NewTyCon {}) = do dflags <- getDynFlags cantVectorise dflags noNewtypeErr (ppr tc) |