Implement unboxed sum primitive type
authorÖmer Sinan Ağacan <omeragacan@gmail.com>
Thu, 21 Jul 2016 08:07:41 +0000 (08:07 +0000)
committerÖmer Sinan Ağacan <omeragacan@gmail.com>
Thu, 21 Jul 2016 08:11:27 +0000 (08:11 +0000)
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

128 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/DataCon.hs
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/basicTypes/Unique.hs
compiler/cmm/CLabel.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmLive.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmUtils.hs
compiler/cmm/MkGraph.hs
compiler/cmm/PprCmmExpr.hs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreArity.hs
compiler/coreSyn/CoreLint.hs
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsForeign.hs
compiler/deSugar/Match.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/iface/BinIface.hs
compiler/iface/MkIface.hs
compiler/main/Constants.hs
compiler/main/DynFlags.hs
compiler/main/InteractiveEval.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/PrelNames.hs
compiler/prelude/PrimOp.hs
compiler/prelude/TysWiredIn.hs
compiler/prelude/TysWiredIn.hs-boot
compiler/profiling/SCCfinal.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/rename/RnTypes.hs
compiler/simplStg/RepType.hs [new file with mode: 0644]
compiler/simplStg/SimplStg.hs
compiler/simplStg/StgStats.hs
compiler/simplStg/UnariseStg.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgLint.hs
compiler/stgSyn/StgSyn.hs
compiler/stranal/WwLib.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcType.hs
compiler/types/TyCoRep.hs
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/types/Type.hs-boot
compiler/utils/Outputable.hs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
docs/users_guide/glasgow_exts.rst
includes/stg/MiscClosures.h
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
libraries/ghc-prim/GHC/Types.hs
rts/StgMiscClosures.cmm
testsuite/tests/driver/T4437.hs
testsuite/tests/unboxedsums/Makefile [new file with mode: 0644]
testsuite/tests/unboxedsums/T12375.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/T12375.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/all.T [new file with mode: 0644]
testsuite/tests/unboxedsums/empty_sum.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/empty_sum.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/ffi1.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/ffi1.stderr [new file with mode: 0644]
testsuite/tests/unboxedsums/module/Lib.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/module/Main.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/module/Makefile [new file with mode: 0644]
testsuite/tests/unboxedsums/module/all.T [new file with mode: 0644]
testsuite/tests/unboxedsums/module/sum_mod.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/sum_rr.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/sum_rr.stderr [new file with mode: 0644]
testsuite/tests/unboxedsums/thunk.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/thunk.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unarise.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unarise.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums1.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums1.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums10.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums10.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums11.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums11.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums2.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums2.stdin [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums2.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums3.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums3.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums4.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums4.stderr [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums5.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums6.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums6.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums7.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums7.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums8.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums8.stdout [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums9.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/unboxedsums9.stdout [new file with mode: 0644]
utils/mkUserGuidePart/Options/Language.hs

index 7fe4cb9..9711edb 100644 (file)
@@ -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}
 *                                                                      *
 ************************************************************************
index 27ac483..2ab29aa 100644 (file)
@@ -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
index 6045937..387de1e 100644 (file)
@@ -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)
index 97d4186..0cd2e95 100644 (file)
@@ -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
index b919da2..800198b 100644 (file)
@@ -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
index b262371..447eee8 100644 (file)
@@ -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,
index de783aa..784724d 100644 (file)
@@ -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
index 5c3be17..37bd7a0 100644 (file)
@@ -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
index dfacd13..80aceaf 100644 (file)
@@ -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)
index 6b326b8..128cc4e 100644 (file)
@@ -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) ]
index dca57dc..e9f2612 100644 (file)
@@ -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
 
index 657585e..b1bd48a 100644 (file)
@@ -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)
index 77c9240..219b287 100644 (file)
@@ -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
index 73b9bf6..d6e0cf2 100644 (file)
@@ -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))
index 8adf3b0..e8fd8f8 100644 (file)
@@ -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
index 8c1aeef..f831789 100644 (file)
@@ -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)
 
index 04257dd..c77816a 100644 (file)
@@ -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)
index d60828c..ec4c75f 100644 (file)
@@ -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
index 811ea3c..142d30c 100644 (file)
@@ -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.
index c8db864..eb14e8c 100644 (file)
@@ -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
index ebff440..fa17804 100644 (file)
@@ -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
index 47ee370..713d542 100644 (file)
@@ -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")
 
 -------------------------------------------------------------------------
index 2742acd..8f66cfa 100644 (file)
@@ -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 []
index d3c09c5..c02f992 100644 (file)
@@ -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)
                      ]
 
index 5d67101..f1437eb 100644 (file)
@@ -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
index ef87656..f5e7673 100644 (file)
@@ -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
index 73e93ea..dead929 100644 (file)
@@ -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
index d336433..6ee5bff 100644 (file)
@@ -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"
index 5287320..b964912 100644 (file)
@@ -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
index 8227088..0ce6f50 100644 (file)
@@ -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}) =
index bf04f13..a08c3ac 100644 (file)
@@ -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
index 00ed621..981745e 100644 (file)
@@ -26,6 +26,7 @@ import Literal
 import Module
 import Name
 import Type
+import RepType
 import TyCon
 import Coercion
 import TcEnv
index ecbed46..93d43c8 100644 (file)
@@ -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'
 
index cfe350f..3042d1d 100644 (file)
@@ -384,6 +384,7 @@ Library
         SimplStg
         StgStats
         UnariseStg
+        RepType
         Rules
         SpecConstr
         Specialise
index 9f45a51..5aeda53 100644 (file)
@@ -517,6 +517,7 @@ compiler_stage2_dll0_MODULES = \
        PrelRules \
        Pretty \
        PrimOp \
+       RepType \
        RdrName \
        Rules \
        SrcLoc \
index 8839ffa..9c7d25a 100644 (file)
@@ -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."))
 
index 4e1c828..25d4f4a 100644 (file)
@@ -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
index f4076bb..7a59847 100644 (file)
@@ -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
index ffba782..b2c40ca 100644 (file)
@@ -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
 
index ef667a1..719cd97 100644 (file)
@@ -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)
index a0676c9..bf98ca3 100644 (file)
@@ -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)
index f530272..6d1f15f 100644 (file)
@@ -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)
index 4290704..5889091 100644 (file)
@@ -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
index 9ebc03c..edab350 100644 (file)
@@ -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.
index 6a442e0..3dafbac 100644 (file)
@@ -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
index dc29176..744562e 100644 (file)
@@ -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,
index 9877e9a..a421c72 100644 (file)
@@ -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
index 39ce506..436ffc9 100644 (file)
@@ -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
index fea9203..cd10a29 100644 (file)
@@ -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
 
index af1e53e..4fc1c9c 100644 (file)
@@ -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 '|'))
index 3905afa..02d59b0 100644 (file)
@@ -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,
index be91ae6..e174aed 100644 (file)
@@ -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.
index 7111d7a..11aea78 100644 (file)
@@ -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)
 
 {- *********************************************************************
 *                                                                      *
index 6c1619e..b759644 100644 (file)
@@ -32,3 +32,5 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
   int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
   word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
   doubleElemRepDataConTy :: Type
+
+anyTypeOfKind :: Kind -> Type
index 2b2e329..ee37ab1 100644 (file)
@@ -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)
 
index f8a53e0..f964e77 100644 (file)
@@ -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
index 0ec15a9..7e41bec 100644 (file)
@@ -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
index 3626431..f201b22 100644 (file)
@@ -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 (file)
index 0000000..7e42a86
--- /dev/null
@@ -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
index 3b63688..771df87 100644 (file)
@@ -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:"
index 2c72266..3854482 100644 (file)
@@ -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
 
index 1b94cbc..af2928d 100644 (file)
 {-
 (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)
index 2d9ca8c..cba139a 100644 (file)
@@ -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)
index b3f7182..eb07e6b 100644 (file)
@@ -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
 
index f3a02c8..2c22a29 100644 (file)
@@ -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 ]
index d285159..812252c 100644 (file)
@@ -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(..) )
index a6918b6..54d0254 100644 (file)
@@ -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
index ad75033..458f965 100644 (file)
@@ -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
 
index ea65a73..ad1f3ba 100644 (file)
@@ -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
 
index e62b300..dd88992 100644 (file)
@@ -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
index b53c715..171c1ad 100644 (file)
@@ -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) $
index d952d23..4a5588d 100644 (file)
@@ -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"
index aa8ca71..e4d6a4b 100644 (file)
@@ -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
index 3d9d73d..cd221a2 100644 (file)
@@ -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
index a31ecdd..195c3a7 100644 (file)
@@ -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"
index 823b51e..1765ff5 100644 (file)
@@ -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
index f4c7939..9436d19 100644 (file)
@@ -19,4 +19,3 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])
 coreView :: Type -> Maybe Type
 
 tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
-
index d61b1ec..ee0147d 100644 (file)
@@ -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)
index 30438f0..4837bde 100644 (file)
@@ -34,7 +34,7 @@ import TysPrim
 import BasicTypes
 import Class
 import CoreSyn
-import TysWiredIn
+import TysWiredIn hiding (sumTyCon)
 import Type
 import TyCon
 import DataCon
index 7aa7921..a9498a5 100644 (file)
@@ -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)
index 56bf3f8..94172e3 100644 (file)
@@ -259,6 +259,83 @@ There are some restrictions on the use of unboxed tuples:
 
    Indeed, the bindings can even be recursive.
 
+.. _unboxed-sums:
+
+Unboxed sums
+------------
+
+.. ghc-flag:: -XUnboxedSums
+
+    Enable the use of unboxed sum syntax.
+
+`-XUnboxedSums` enables new syntax for anonymous, unboxed sum types. The syntax
+for an unboxed sum type with N alternatives is ::
+
+    (# t_1 | t_2 | ... | t_N #)
+
+where `t_1` ... `t_N` are types (which can be unlifted, including unboxed tuple
+and sums).
+
+Unboxed tuples can be used for multi-arity alternatives. For example: ::
+
+    (# (# Int, String #) | Bool #)
+
+Term level syntax is similar. Leading and preceding bars (`|`) indicate which
+alternative it is. Here is two terms of the type shown above: ::
+
+    (# (# 1, "foo" #) | #) -- first alternative
+
+    (# | True #) -- second alternative
+
+Pattern syntax reflects the term syntax: ::
+
+    case x of
+      (# (# i, str #) | #) -> ...
+      (# | bool #) -> ...
+
+Unboxed sums are "unboxed" in the sense that, instead of allocating sums in the
+heap and representing values as pointers, unboxed sums are represented as their
+components, just like unboxed tuples. These "components" depend on alternatives
+of a sum type. Code generator tries to generate as compact layout as possible.
+In the best case, size of an unboxed sum is size of its biggest alternative +
+one word (for tag). The algorithm for generating memory layout for a sum type
+works like this:
+
+- All types are classified as one of these classes: 32bit word, 64bit word,
+  32bit float, 64bit float, pointer.
+
+- For each alternative of the sum type, a layout that consists of these fields
+  is generated. For example, if an alternative has `Int`, `Float#` and `String`
+  fields, the layout will have an 32bit word, 32bit float and pointer fields.
+
+- Layout fields are then overlapped so that the final layout will be as compact
+  as possible. E.g. say two alternatives have these fields: ::
+
+    Word32, String, Float#
+    Float#, Float#, Maybe Int
+
+  Final layout will be something like ::
+
+    Int32, Float32, Float32, Word32, Pointer
+
+  First `Int32` is for the tag. It has two `Float32` fields because floating
+  point types can't overlap with other types, because of limitations of the code
+  generator that we're hoping to overcome in the future, and second alternative
+  needs two `Float32` fields. `Word32` field is for the `Word32` in the first
+  alternative. `Pointer` field is shared between `String` and `Maybe Int` values
+  of the alternatives.
+
+  In the case of enumeration types (like `Bool`), the unboxed sum layout only
+  has an `Int32` field (i.e. the whole thing is represented by an integer).
+
+In the example above, a value of this type is thus represented as 5 values. As
+an another example, this is the layout for unboxed version of `Maybe a` type: ::
+
+    Int32, Pointer
+
+The `Pointer` field is not used when tag says that it's `Nothing`. Otherwise
+`Pointer` points to the value in `Just`.
+
 .. _syntax-extns:
 
 Syntactic extensions
@@ -422,9 +499,9 @@ Pattern guards
     :implied by: :ghc-flag:`-XHaskell98`
     :since: 6.8.1
 
-Disable `pattern guards 
+Disable `pattern guards
 <http://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-460003.13>`__.
-   
+
 .. _view-patterns:
 
 View patterns
index 0b8fbdc..3f5e403 100644 (file)
@@ -105,6 +105,7 @@ RTS_ENTRY(stg_TVAR_CLEAN);
 RTS_ENTRY(stg_TVAR_DIRTY);
 RTS_ENTRY(stg_TSO);
 RTS_ENTRY(stg_STACK);
+RTS_ENTRY(stg_RUBBISH_ENTRY);
 RTS_ENTRY(stg_ARR_WORDS);
 RTS_ENTRY(stg_MUT_ARR_WORDS);
 RTS_ENTRY(stg_MUT_ARR_PTRS_CLEAN);
index 39613b0..85664c2 100644 (file)
@@ -47,6 +47,7 @@ data Extension
    | ScopedTypeVariables
    | AllowAmbiguousTypes
    | UnboxedTuples
+   | UnboxedSums
    | BangPatterns
    | TypeFamilies
    | TypeFamilyDependencies
index 827c346..fe21e41 100644 (file)
@@ -385,6 +385,7 @@ data RuntimeRep = VecRep VecCount VecElem   -- ^ a SIMD vector type
                 | FloatRep        -- ^ a 32-bit floating point number
                 | DoubleRep       -- ^ a 64-bit floating point number
                 | UnboxedTupleRep -- ^ An unboxed tuple; this doesn't specify a concrete rep
+                | UnboxedSumRep   -- ^ An unboxed sum; this doesn't specify a concrete rep
 
 -- See also Note [Wiring in RuntimeRep] in TysWiredIn
 
index 6c1edf7..70d219a 100644 (file)
@@ -384,6 +384,9 @@ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO")
 INFO_TABLE(stg_STACK, 0,0, STACK, "STACK", "STACK")
 { foreign "C" barf("STACK object entered!") never returns; }
 
+INFO_TABLE(stg_RUBBISH_ENTRY, 0, 0, THUNK, "RUBBISH_ENTRY", "RUBBISH_ENTRY")
+{ foreign "C" barf("RUBBISH object entered!") never returns; }
+
 /* ----------------------------------------------------------------------------
    Weak pointers
 
index 7bdbaef..45e257e 100644 (file)
@@ -39,7 +39,8 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "TypeFamilyDependencies"]
+                             "TypeFamilyDependencies",
+                             "UnboxedSums"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/unboxedsums/Makefile b/testsuite/tests/unboxedsums/Makefile
new file mode 100644 (file)
index 0000000..ff17bcc
--- /dev/null
@@ -0,0 +1,10 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: sum_api_annots
+sum_api_annots:
+       number=1 ; while [[ $$number -le 11 ]] ; do \
+         $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" unboxedsums$$number.hs ; \
+               ((number = number + 1)) ; \
+       done
diff --git a/testsuite/tests/unboxedsums/T12375.hs b/testsuite/tests/unboxedsums/T12375.hs
new file mode 100644 (file)
index 0000000..62b6094
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+type Null = (# #)
+
+{-# NOINLINE showNull #-}
+showNull :: Null -> String
+showNull (# #) = "(# #)"
+
+{-# NOINLINE showNullPair #-}
+showNullPair :: (# Null, Null #) -> String
+showNullPair (# n1, n2 #) = "(# " ++ showNull n1 ++ ", " ++ showNull n2 ++ " #)"
+
+main :: IO ()
+main = do
+    putStrLn (showNullPair (# (# #), (# #) #))
diff --git a/testsuite/tests/unboxedsums/T12375.stdout b/testsuite/tests/unboxedsums/T12375.stdout
new file mode 100644 (file)
index 0000000..7cfa66f
--- /dev/null
@@ -0,0 +1 @@
+(# (# #), (# #) #)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
new file mode 100644 (file)
index 0000000..274045f
--- /dev/null
@@ -0,0 +1,25 @@
+test('unarise',       omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums1',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums2',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums3',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums4',  omit_ways(['ghci']), compile_fail, [''])
+test('unboxedsums5',  omit_ways(['ghci']), compile, [''])
+test('unboxedsums6',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums7',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums8',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums9',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums10', omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums11', omit_ways(['ghci']), compile_and_run, [''])
+
+test('ffi1', normal, compile_fail, [''])
+test('thunk', only_ways(['normal']), compile_and_run, [''])
+test('T12375', only_ways(['normal']), compile_and_run, [''])
+test('empty_sum', only_ways(['normal']), compile_and_run, [''])
+test('sum_rr', normal, compile_fail, [''])
+
+# TODO: Need to run this in --slow mode only
+# test('sum_api_annots',
+#      [only_ways(['normal']),
+#       extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
+#      run_command,
+#      ['$MAKE -s --no-print-directory sum_api_annots'])
diff --git a/testsuite/tests/unboxedsums/empty_sum.hs b/testsuite/tests/unboxedsums/empty_sum.hs
new file mode 100644 (file)
index 0000000..7abbfd8
--- /dev/null
@@ -0,0 +1,20 @@
+{-# LANGUAGE UnboxedTuples, UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Null = (# #)
+
+{-# NOINLINE showNull #-}
+showNull :: Null -> String
+showNull (# #) = "(# #)"
+
+{-# NOINLINE showNullAlt #-}
+showNullAlt :: (# Null | Null #) -> String
+showNullAlt (# n1 | #) = "(# " ++ showNull n1 ++ " | #)"
+showNullAlt (# | n2 #) = "(# | " ++ showNull n2 ++ " #)"
+
+main :: IO ()
+main = do
+    putStrLn (showNull (# #))
+    putStrLn (showNullAlt (# (# #) | #))
+    putStrLn (showNullAlt (# | (# #) #))
diff --git a/testsuite/tests/unboxedsums/empty_sum.stdout b/testsuite/tests/unboxedsums/empty_sum.stdout
new file mode 100644 (file)
index 0000000..7d3a7bf
--- /dev/null
@@ -0,0 +1,3 @@
+(# #)
+(# (# #) | #)
+(# | (# #) #)
diff --git a/testsuite/tests/unboxedsums/ffi1.hs b/testsuite/tests/unboxedsums/ffi1.hs
new file mode 100644 (file)
index 0000000..e6128e4
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Lib where
+
+import GHC.Prim
+
+-- Can't unboxed tuples and sums to FFI, we should fail appropriately.
+
+foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int
+foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
+foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int
diff --git a/testsuite/tests/unboxedsums/ffi1.stderr b/testsuite/tests/unboxedsums/ffi1.stderr
new file mode 100644 (file)
index 0000000..3a97270
--- /dev/null
@@ -0,0 +1,23 @@
+
+ffi1.hs:9:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# Int | Int #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f1" f1
+          :: (# Int | Int #) -> IO Int
+
+ffi1.hs:10:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# (# Int, Int #) |
+            (# Float#, Float# #) #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f2" f2
+          :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
+
+ffi1.hs:11:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# (# #) | Void# |
+            (# Int# | String #) #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f3" f3
+          :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int
diff --git a/testsuite/tests/unboxedsums/module/Lib.hs b/testsuite/tests/unboxedsums/module/Lib.hs
new file mode 100644 (file)
index 0000000..569da49
--- /dev/null
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Lib (flip, getInt) where
+
+import GHC.Exts
+import Prelude (Int)
+
+{-# NOINLINE flip #-}
+flip :: (# Int | Int# #) -> (# Int# | Int #)
+flip (# i | #) = (# | i #)
+flip (# | i #) = (# i | #)
+
+{-# NOINLINE getInt #-}
+getInt :: (# Int# | Int #) -> Int
+getInt (# i | #) = I# i
+getInt (# | i #) = i
diff --git a/testsuite/tests/unboxedsums/module/Main.hs b/testsuite/tests/unboxedsums/module/Main.hs
new file mode 100644 (file)
index 0000000..6940dee
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module Main where
+
+import Lib
+
+import Prelude (print, IO)
+
+main :: IO ()
+main = do
+    print (getInt (flip (# 123 | #)))
diff --git a/testsuite/tests/unboxedsums/module/Makefile b/testsuite/tests/unboxedsums/module/Makefile
new file mode 100644 (file)
index 0000000..2c95545
--- /dev/null
@@ -0,0 +1,16 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+       rm -f *.o
+       rm -f *.hi
+       rm -f Main
+
+main:
+       rm -f *.o
+       rm -f *.hi
+       rm -f Main
+       '$(TEST_HC)' $(TEST_HC_OPTS) -c Lib.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS) Main.hs
+       ./Main
diff --git a/testsuite/tests/unboxedsums/module/all.T b/testsuite/tests/unboxedsums/module/all.T
new file mode 100644 (file)
index 0000000..fe76aac
--- /dev/null
@@ -0,0 +1,4 @@
+test('sum_mod',
+     [normalise_slashes, clean_cmd('$MAKE -s clean'), extra_files(['Lib.hs', 'Main.hs'])],
+     run_command,
+     ['$MAKE -s main --no-print-director'])
diff --git a/testsuite/tests/unboxedsums/module/sum_mod.stdout b/testsuite/tests/unboxedsums/module/sum_mod.stdout
new file mode 100644 (file)
index 0000000..615266b
--- /dev/null
@@ -0,0 +1,3 @@
+[2 of 2] Compiling Main             ( Main.hs, Main.o )
+Linking Main ...
+123
diff --git a/testsuite/tests/unboxedsums/sum_rr.hs b/testsuite/tests/unboxedsums/sum_rr.hs
new file mode 100644 (file)
index 0000000..287edcf
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds, KindSignatures #-}
+
+module Example where
+
+import Data.Typeable
+import GHC.Exts
+
+data Wat (a :: TYPE 'UnboxedSumRep) = Wat a
diff --git a/testsuite/tests/unboxedsums/sum_rr.stderr b/testsuite/tests/unboxedsums/sum_rr.stderr
new file mode 100644 (file)
index 0000000..2ac9b74
--- /dev/null
@@ -0,0 +1,7 @@
+
+sum_rr.hs:8:39: error:
+    • The type ‘a’ is not an unboxed sum,
+      and yet its kind suggests that it has the representation
+      of an unboxed sum. This is not allowed.
+    • In the definition of data constructor ‘Wat’
+      In the data type declaration for ‘Wat’
diff --git a/testsuite/tests/unboxedsums/thunk.hs b/testsuite/tests/unboxedsums/thunk.hs
new file mode 100644 (file)
index 0000000..53e941d
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# NOINLINE f #-}
+f :: (# #) -> [Int]
+f (# #) = [ 1 .. ]
+
+main :: IO ()
+main = print (sum (take 10 (f (# #))))
diff --git a/testsuite/tests/unboxedsums/thunk.stdout b/testsuite/tests/unboxedsums/thunk.stdout
new file mode 100644 (file)
index 0000000..c3f407c
--- /dev/null
@@ -0,0 +1 @@
+55
diff --git a/testsuite/tests/unboxedsums/unarise.hs b/testsuite/tests/unboxedsums/unarise.hs
new file mode 100644 (file)
index 0000000..9cdabc4
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+{-# NOINLINE f1 #-}
+f1 :: (# #) -> (# #) -> String
+f1 (# #) (# #) = "o"
+
+{-# NOINLINE f2 #-}
+f2 :: (# (# #), (# #) #) -> String
+f2 (# (# #), (# #) #) = "k"
+
+main :: IO ()
+main = do
+    let t = (# (# #), (# #) #)
+    case t of
+      (# t1, t2 #) -> putStrLn (f1 t1 t2 ++ f2 t)
diff --git a/testsuite/tests/unboxedsums/unarise.stdout b/testsuite/tests/unboxedsums/unarise.stdout
new file mode 100644 (file)
index 0000000..9766475
--- /dev/null
@@ -0,0 +1 @@
+ok
diff --git a/testsuite/tests/unboxedsums/unboxedsums1.hs b/testsuite/tests/unboxedsums/unboxedsums1.hs
new file mode 100644 (file)
index 0000000..42a04ae
--- /dev/null
@@ -0,0 +1,81 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type Either1 a b = (# a | b #)
+
+showEither1 :: (Show a, Show b) => Either1 a b -> String
+showEither1 (# left | #)  = "Left " ++ show left
+showEither1 (# | right #) = "Right " ++ show right
+
+showEither2 :: (# Int# | Float# #) -> String
+showEither2 (# i | #) = "Left " ++ show (I# i)
+showEither2 (# | f #) = "Right " ++ show (F# f)
+
+showEither3 :: Show a => (# a | Int# #) -> String
+showEither3 (# a | #) = "Left " ++ show a
+showEither3 (# | i #) = "Right " ++ show (I# i)
+
+type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)
+
+showEither4 :: T -> String
+showEither4 (# i | | | | | | #) = "Alt0: " ++ show i
+showEither4 (# | b | | | | | #) = "Alt1: " ++ show b
+showEither4 (# | | s | | | | #) = "Alt2: " ++ show s
+showEither4 (# | | | c | | | #) = "Alt3: " ++ show c
+showEither4 (# | | | | e | | #) = "Alt4: " ++ show e
+showEither4 (# | | | | | i | #) = "Alt5: " ++ show (I# i)
+showEither4 (# | | | | | | f #) = "Alt6: " ++ show (F# f)
+
+main :: IO ()
+main = do
+    putStrLn (showEither1 e1_1)
+    putStrLn (showEither1 e1_2)
+    putStrLn (showEither2 e2_1)
+    putStrLn (showEither2 e2_2)
+    putStrLn (showEither3 e3_1)
+    putStrLn (showEither3 e3_2)
+
+    putStrLn (showEither4 e4_1)
+    putStrLn (showEither4 e4_2)
+    putStrLn (showEither4 e4_3)
+    putStrLn (showEither4 e4_4)
+    putStrLn (showEither4 e4_5)
+    putStrLn (showEither4 e4_6)
+    putStrLn (showEither4 e4_7)
+
+    -- make sure we don't put pointers to non-pointer slots
+    performMajorGC
+
+    -- make sure pointers in unboxed sums are really roots
+    putStrLn (showEither1 e1_1)
+  where
+    -- boxed types only
+    e1_1, e1_2 :: Either1 String Int
+    e1_1 = (# "error" | #)
+    e1_2 = (# | 10 #)
+
+    -- prim types only
+    e2_1, e2_2 :: (# Int# | Float# #)
+    e2_1 = (# 10# | #)
+    e2_2 = (# | 1.2# #)
+
+    -- a mix of prim and boxed types
+    e3_1, e3_2 :: (# String | Int# #)
+    e3_1 = (# "OK" | #)
+    e3_2 = (# | 123# #)
+
+    -- big arity
+    e4_1, e4_2, e4_3, e4_4, e4_5, e4_6, e4_7 :: T
+    e4_1 = (# 10 | | | | | | #)
+    e4_2 = (# | False | | | | | #)
+    e4_3 = (# | | "ok" | | | | #)
+    e4_4 = (# | | | 'a' | | | #)
+    e4_5 = (# | | | | Right True | | #)
+    e4_6 = (# | | | | | 123# | #)
+    e4_7 = (# | | | | | | 54.3# #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums1.stdout b/testsuite/tests/unboxedsums/unboxedsums1.stdout
new file mode 100644 (file)
index 0000000..3dba0a0
--- /dev/null
@@ -0,0 +1,14 @@
+Left "error"
+Right 10
+Left 10
+Right 1.2
+Left "OK"
+Right 123
+Alt0: 10
+Alt1: False
+Alt2: "ok"
+Alt3: 'a'
+Alt4: Right True
+Alt5: 123
+Alt6: 54.3
+Left "error"
diff --git a/testsuite/tests/unboxedsums/unboxedsums10.hs b/testsuite/tests/unboxedsums/unboxedsums10.hs
new file mode 100644 (file)
index 0000000..00f5e54
--- /dev/null
@@ -0,0 +1,15 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Ty = (# (Int -> Int) | (Int -> Int) #)
+
+{-# NOINLINE apply #-}
+apply :: Ty -> Int
+apply (# f | #) = f 0
+apply (# | f #) = f 1
+
+main :: IO ()
+main = do
+  print (apply (# (\x -> x * 2) | #))
+  print (apply (# | (\x -> x * 3) #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums10.stdout b/testsuite/tests/unboxedsums/unboxedsums10.stdout
new file mode 100644 (file)
index 0000000..12decc1
--- /dev/null
@@ -0,0 +1,2 @@
+0
+3
diff --git a/testsuite/tests/unboxedsums/unboxedsums11.hs b/testsuite/tests/unboxedsums/unboxedsums11.hs
new file mode 100644 (file)
index 0000000..2cac847
--- /dev/null
@@ -0,0 +1,15 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Ty = (# () | () #)
+
+{-# NOINLINE showTy #-}
+showTy :: Ty -> String
+showTy (# _ | #)  = "(# _ | #)"
+showTy (# | () #) = "(# | () #)"
+
+main :: IO ()
+main = do
+  print (showTy (# undefined | #))
+  print (showTy (# | () #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums11.stdout b/testsuite/tests/unboxedsums/unboxedsums11.stdout
new file mode 100644 (file)
index 0000000..b32d36a
--- /dev/null
@@ -0,0 +1,2 @@
+"(# _ | #)"
+"(# | () #)"
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.hs b/testsuite/tests/unboxedsums/unboxedsums2.hs
new file mode 100644 (file)
index 0000000..115415f
--- /dev/null
@@ -0,0 +1,34 @@
+{-# LANGUAGE UnboxedSums, MagicHash, BangPatterns #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+-- Code generator used to fail with illegal instruction errors when Float# is
+-- involved.
+
+toInt :: (# Int# | Float# #) -> Int#
+toInt (# i | #) = i
+toInt (# | f #) = let !(I# i) = ceiling (F# f) in i
+
+toFloat :: (# Int# | Float# #) -> Float#
+toFloat (# i | #) = let !(F# f) = fromIntegral (I# i) in f
+toFloat (# | f #) = f
+
+data D = D { f1 :: (# Int# | Float# #) }
+
+instance Show D where
+  show (D (# i | #)) = "D " ++ show (I# i)
+  show (D (# | f #)) = "D " ++ show (F# f)
+
+main :: IO ()
+main = do
+    !(F# f) <- readLn
+    print (I# (toInt (# | f #)))
+
+    !(I# i) <- readLn
+    print (F# (toFloat (# i | #)))
+
+    print (D (# | f #))
+    print (D (# i | #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.stdin b/testsuite/tests/unboxedsums/unboxedsums2.stdin
new file mode 100644 (file)
index 0000000..82ef7c5
--- /dev/null
@@ -0,0 +1,2 @@
+20.123
+10
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.stdout b/testsuite/tests/unboxedsums/unboxedsums2.stdout
new file mode 100644 (file)
index 0000000..5d7d3ff
--- /dev/null
@@ -0,0 +1,4 @@
+21
+10.0
+D 20.123
+D 10
diff --git a/testsuite/tests/unboxedsums/unboxedsums3.hs b/testsuite/tests/unboxedsums/unboxedsums3.hs
new file mode 100644 (file)
index 0000000..add8aa7
--- /dev/null
@@ -0,0 +1,33 @@
+{-# LANGUAGE UnboxedSums, MagicHash, BangPatterns, UnboxedTuples #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import Data.Void (Void)
+import System.Mem (performMajorGC)
+
+showAlt0 :: (# Void# | (# #) | () #) -> String
+showAlt0 (# | (# #) | #) = "(# | (# #) | #)"
+showAlt0 (# | | () #) = "(# | | () #)"
+
+showAlt1 :: (# Void | Float# #) -> String
+showAlt1 (# _ | #) = "(# Void | #)"
+showAlt1 (# | f #) = "(# | " ++ show (F# f) ++ "# #)"
+
+data D = D { f1 :: (# Void# | (# #) | () #)
+           , f2 :: (# Void | Float# #)
+           }
+
+showD :: D -> String
+showD (D f1 f2) = showAlt0 f1 ++ "\n" ++ showAlt1 f2
+
+main :: IO ()
+main = do
+    putStrLn (showAlt0 (# | (# #) | #))
+    putStrLn (showAlt0 (# | | () #))
+    putStrLn (showAlt1 (# undefined | #))
+    putStrLn (showAlt1 (# | 8.1# #))
+    putStrLn (showD (D (# | (# #) | #) (# | 1.2# #)))
+    performMajorGC
diff --git a/testsuite/tests/unboxedsums/unboxedsums3.stdout b/testsuite/tests/unboxedsums/unboxedsums3.stdout
new file mode 100644 (file)
index 0000000..b37cc04
--- /dev/null
@@ -0,0 +1,6 @@
+(# | (# #) | #)
+(# | | () #)
+(# Void | #)
+(# | 8.1# #)
+(# | (# #) | #)
+(# | 1.2# #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums4.hs b/testsuite/tests/unboxedsums/unboxedsums4.hs
new file mode 100644 (file)
index 0000000..3257a70
--- /dev/null
@@ -0,0 +1,3 @@
+module Lib where
+
+sum = (10 |)
diff --git a/testsuite/tests/unboxedsums/unboxedsums4.stderr b/testsuite/tests/unboxedsums/unboxedsums4.stderr
new file mode 100644 (file)
index 0000000..2cd4be6
--- /dev/null
@@ -0,0 +1,2 @@
+
+unboxedsums4.hs:3:7: error: Boxed sums not supported: ( 10 | )
diff --git a/testsuite/tests/unboxedsums/unboxedsums5.hs b/testsuite/tests/unboxedsums/unboxedsums5.hs
new file mode 100644 (file)
index 0000000..0bb8c67
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module Lib where
+
+-- No spaces needed in the type syntax
+type T = (#Int|Bool|String#)
+
+-- Term syntax needs spaces, otherwise we parser bars as sections
+-- for ||, ||| etc.
+--
+-- t1 :: T
+-- t1 = (# 10 | | #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums6.hs b/testsuite/tests/unboxedsums/unboxedsums6.hs
new file mode 100644 (file)
index 0000000..767366d
--- /dev/null
@@ -0,0 +1,35 @@
+{-# LANGUAGE UnboxedSums, MagicHash, UnboxedTuples #-}
+
+-- Nesting sums and tuples is OK
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type S_T_T a b c d = (# (# a , b #) | (# c , d #) #)
+type S_S_S a b c d = (# (# a | b #) | (# c | d #) #)
+
+show_stt :: (Show a, Show b, Show c, Show d) => S_T_T a b c d -> String
+show_stt (# (# a, b #) | #) = show a ++ show b
+show_stt (# | (# c, d #) #) = show c ++ show d
+
+show_sss :: (Show a, Show b, Show c, Show d) => S_S_S a b c d -> String
+show_sss (# (# a | #) | #) = show a
+show_sss (# (# | b #) | #) = show b
+show_sss (# | (# c | #) #) = show c
+show_sss (# | (# | d #) #) = show d
+
+main :: IO ()
+main = do
+    putStrLn (show_stt stt)
+    putStrLn (show_sss sss)
+    performMajorGC
+  where
+    stt :: S_T_T Int Bool Float String
+    stt = (# (# 123, True #) | #)
+
+    sss :: S_S_S Int Bool Float String
+    sss = (# | (# 1.2 | #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums6.stdout b/testsuite/tests/unboxedsums/unboxedsums6.stdout
new file mode 100644 (file)
index 0000000..f2448cc
--- /dev/null
@@ -0,0 +1,2 @@
+123True
+1.2
diff --git a/testsuite/tests/unboxedsums/unboxedsums7.hs b/testsuite/tests/unboxedsums/unboxedsums7.hs
new file mode 100644 (file)
index 0000000..d64dabb
--- /dev/null
@@ -0,0 +1,24 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+type Either1 a b c = (# a | (# b, c #) #)
+
+-- The bug disappears when this is inlined
+{-# NOINLINE showEither1 #-}
+
+showEither1 :: Either1 String Int Bool -> String
+showEither1 (# left | #) = "Left " ++ show left
+showEither1 (# | (# right1, right2 #) #) = "Right " ++ show right1 ++ " " ++ show right2
+
+main :: IO ()
+main = do
+    -- This line used to print "Right -4611686018427359531 False"
+    putStrLn (showEither1 e1_2)
+  where
+    -- boxed types only
+    e1_2 :: Either1 String Int Bool
+    e1_2 = (# | (# 10, True #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums7.stdout b/testsuite/tests/unboxedsums/unboxedsums7.stdout
new file mode 100644 (file)
index 0000000..7c59422
--- /dev/null
@@ -0,0 +1 @@
+Right 10 True
diff --git a/testsuite/tests/unboxedsums/unboxedsums8.hs b/testsuite/tests/unboxedsums/unboxedsums8.hs
new file mode 100644 (file)
index 0000000..07ef122
--- /dev/null
@@ -0,0 +1,37 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+type Sum1 = (# (# Int#, Int #) | (# Int#, Int# #) | (# Int, Int# #) #)
+
+{-# NOINLINE showSum1 #-}
+showSum1 :: Sum1 -> String
+showSum1 (# p1 | | #) = showP1 p1
+showSum1 (# | p2 | #) = showP2 p2
+showSum1 (# | | p3 #) = showP3 p3
+
+{-# NOINLINE showP1 #-}
+showP1 :: (# Int#, Int #) -> String
+showP1 (# i1, i2 #) = show (I# i1) ++ show i2
+
+{-# NOINLINE showP2 #-}
+showP2 :: (# Int#, Int# #) -> String
+showP2 (# i1, i2 #) = show (I# i1) ++ show (I# i2)
+
+{-# NOINLINE showP3 #-}
+showP3 :: (# Int, Int# #) -> String
+showP3 (# i1, i2 #) = show i1 ++ show (I# i2)
+
+main :: IO ()
+main = do
+    putStrLn (showSum1 s1)
+    putStrLn (showSum1 s2)
+    putStrLn (showSum1 s3)
+  where
+    s1, s2, s3 :: Sum1
+    s1 = (# (# 123#, 456 #) | | #)
+    s2 = (# | (# 876#, 543# #) | #)
+    s3 = (# | | (# 123, 456# #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums8.stdout b/testsuite/tests/unboxedsums/unboxedsums8.stdout
new file mode 100644 (file)
index 0000000..35242be
--- /dev/null
@@ -0,0 +1,3 @@
+123456
+876543
+123456
diff --git a/testsuite/tests/unboxedsums/unboxedsums9.hs b/testsuite/tests/unboxedsums/unboxedsums9.hs
new file mode 100644 (file)
index 0000000..79927fc
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+type UbxBool = (# (# #) | (# #) #)
+
+{-# NOINLINE packBool #-}
+packBool :: UbxBool -> Bool
+packBool (# _ | #) = True
+packBool (# | _ #) = False
+
+{-# NOINLINE unpackBool #-}
+unpackBool :: Bool -> UbxBool
+unpackBool True  = (# (# #) | #)
+unpackBool False = (# | (# #) #)
+
+{-# NOINLINE showUbxBool #-}
+showUbxBool :: UbxBool -> String
+showUbxBool b = show (packBool b)
+
+main :: IO ()
+main = do
+  putStrLn (showUbxBool (unpackBool True))
+  putStrLn (showUbxBool (unpackBool False))
+  putStrLn (show (packBool (# (# #) | #)))
+  putStrLn (show (packBool (# | (# #) #)))
diff --git a/testsuite/tests/unboxedsums/unboxedsums9.stdout b/testsuite/tests/unboxedsums/unboxedsums9.stdout
new file mode 100644 (file)
index 0000000..7474532
--- /dev/null
@@ -0,0 +1,4 @@
+True
+False
+True
+False
index 750342c..0d9014e 100644 (file)
@@ -725,6 +725,12 @@ languageOptions =
          , flagReverse = "-XNoUnboxedTuples"
          , flagSince = "6.8.1"
          }
+  , flag { flagName ="-XUnboxedSums"
+         , flagDescription = "Enable :ref: `unboxed sums <unboxed-sums>`."
+         , flagType = DynamicFlag
+         , flagReverse = "-XNoUnboxedSums"
+         , flagSince = "8.2.1"
+         }
   , flag { flagName = "-XUndecidableInstances"
          , flagDescription =
            "Enable :ref:`undecidable instances <undecidable-instances>`."