Commit 714bebff authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan

Implement unboxed sum primitive type

Summary:
This patch implements primitive unboxed sum types, as described in
https://ghc.haskell.org/trac/ghc/wiki/UnpackedSumTypes.

Main changes are:

- Add new syntax for unboxed sums types, terms and patterns. Hidden
  behind `-XUnboxedSums`.

- Add unlifted unboxed sum type constructors and data constructors,
  extend type and pattern checkers and desugarer.

- Add new RuntimeRep for unboxed sums.

- Extend unarise pass to translate unboxed sums to unboxed tuples right
  before code generation.

- Add `StgRubbishArg` to `StgArg`, and a new type `CmmArg` for better
  code generation when sum values are involved.

- Add user manual section for unboxed sums.

Some other changes:

- Generalize `UbxTupleRep` to `MultiRep` and `UbxTupAlt` to
  `MultiValAlt` to be able to use those with both sums and tuples.

- Don't use `tyConPrimRep` in `isVoidTy`: `tyConPrimRep` is really
  wrong, given an `Any` `TyCon`, there's no way to tell what its kind
  is, but `kindPrimRep` and in turn `tyConPrimRep` returns `PtrRep`.

- Fix some bugs on the way: #12375.

Not included in this patch:

- Update Haddock for new the new unboxed sum syntax.

- `TemplateHaskell` support is left as future work.

For reviewers:

- Front-end code is mostly trivial and adapted from unboxed tuple code
  for type checking, pattern checking, renaming, desugaring etc.

- Main translation routines are in `RepType` and `UnariseStg`.
  Documentation in `UnariseStg` should be enough for understanding
  what's going on.

Credits:

- Johan Tibell wrote the initial front-end and interface file
  extensions.

- Simon Peyton Jones reviewed this patch many times, wrote some code,
  and helped with debugging.

Reviewers: bgamari, alanz, goldfire, RyanGlScott, simonpj, austin,
           simonmar, hvr, erikd

Reviewed By: simonpj

Subscribers: Iceland_jack, ggreif, ezyang, RyanGlScott, goldfire,
             thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2259
parent 83e4f495
......@@ -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
......@@ -616,6 +621,27 @@ tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
| opt_PprStyle_Debug = text "(%" <+> p <+> ptext (sLit "%)")
| otherwise = parens p
{-
************************************************************************
* *
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)
{-
************************************************************************
* *
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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) ]
......
......@@ -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
......
......@@ -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)
......@@ -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
......@@ -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))
......
......@@ -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
......
......@@ -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)
......
<
......@@ -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