summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CLabel.hs4
-rw-r--r--compiler/cmm/CmmExpr.hs6
-rw-r--r--compiler/cmm/CmmLayoutStack.hs2
-rw-r--r--compiler/cmm/CmmParse.y8
-rw-r--r--compiler/cmm/CmmUtils.hs6
-rw-r--r--compiler/cmm/MkGraph.hs71
-rw-r--r--compiler/cmm/PprCmmExpr.hs9
-rw-r--r--compiler/codeGen/StgCmm.hs2
-rw-r--r--compiler/codeGen/StgCmmBind.hs2
-rw-r--r--compiler/codeGen/StgCmmCon.hs2
-rw-r--r--compiler/codeGen/StgCmmEnv.hs28
-rw-r--r--compiler/codeGen/StgCmmExpr.hs14
-rw-r--r--compiler/codeGen/StgCmmForeign.hs6
-rw-r--r--compiler/codeGen/StgCmmHeap.hs20
-rw-r--r--compiler/codeGen/StgCmmLayout.hs28
-rw-r--r--compiler/codeGen/StgCmmMonad.hs17
-rw-r--r--compiler/codeGen/StgCmmPrim.hs25
-rw-r--r--compiler/codeGen/StgCmmUtils.hs22
-rw-r--r--compiler/coreSyn/MkCore.hs5
-rw-r--r--compiler/prelude/PrelNames.hs3
-rw-r--r--compiler/simplStg/UnariseStg.hs15
-rw-r--r--compiler/stgSyn/StgLint.hs1
-rw-r--r--compiler/stgSyn/StgSyn.hs8
23 files changed, 110 insertions, 194 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 447eee8e8d..b262371b65 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -66,7 +66,6 @@ module CLabel (
mkSMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel,
mkArrWords_infoLabel,
- mkRUBBISH_ENTRY_infoLabel,
mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel,
@@ -507,7 +506,7 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
- mkSMAP_DIRTY_infoLabel, mkRUBBISH_ENTRY_infoLabel :: CLabel
+ mkSMAP_DIRTY_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
@@ -525,7 +524,6 @@ mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")
mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkRUBBISH_ENTRY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_RUBBISH_ENTRY") CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 784724da2d..985db0ee31 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -6,7 +6,6 @@
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
- , CmmArg(..)
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
@@ -36,7 +35,6 @@ import CmmMachOp
import CmmType
import DynFlags
import Outputable (panic)
-import Type
import Unique
import Data.Set (Set)
@@ -75,10 +73,6 @@ data CmmReg
| CmmGlobal GlobalReg
deriving( Eq, Ord )
-data CmmArg
- = CmmExprArg CmmExpr
- | CmmRubbishArg Type -- See StgRubbishArg in StgSyn.hs
-
-- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed.
data Area
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 2536030f1d..96231ec732 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -1032,7 +1032,7 @@ lowerSafeForeignCall dflags block
(_, regs, copyout) =
copyOutOflow dflags NativeReturn Jump (Young succ)
- (map (CmmExprArg . CmmReg . CmmLocal) res)
+ (map (CmmReg . CmmLocal) res)
ret_off []
-- NB. after resumeThread returns, the top-of-stack probably contains
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index b8c100a3c0..c836e2cf44 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1105,7 +1105,7 @@ pushStackFrame fields body = do
exprs <- sequence fields
updfr_off <- getUpdFrameOff
let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
- [] updfr_off (map CmmExprArg exprs)
+ [] updfr_off exprs
emit g
withUpdFrameOff new_updfr_off body
@@ -1176,7 +1176,7 @@ doReturn exprs_code = do
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
- mkReturn dflags e (map CmmExprArg actuals) updfr_off
+ mkReturn dflags e actuals updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
(gcWord dflags))
@@ -1195,7 +1195,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 (map CmmExprArg args) updfr_off (map CmmExprArg stk_args))
+ emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse ()
@@ -1205,7 +1205,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 (map CmmExprArg args) updfr_off []
+ c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
emit c
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index e9f2612713..b82f780c08 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -10,7 +10,7 @@
module CmmUtils(
-- CmmType
- primRepCmmType, slotCmmType, slotForeignHint, cmmArgType,
+ primRepCmmType, slotCmmType, slotForeignHint,
typeCmmType, typeForeignHint,
-- CmmLit
@@ -127,10 +127,6 @@ 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
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index b1bd48a71f..ae7c5097af 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -7,7 +7,7 @@ module MkGraph
, lgraphOfAGraph, labelAGraph
, stackStubExpr
- , mkNop, mkAssign, mkAssign', mkStore, mkStore'
+ , mkNop, mkAssign, mkStore
, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
, mkJumpReturnsTo
, mkJump, mkJumpExtra
@@ -17,18 +17,13 @@ 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
@@ -41,7 +36,7 @@ import UniqSupply
import Control.Monad
import Data.List
import Data.Maybe
-import Prelude (($),Int,Bool,Eq(..),otherwise) -- avoid importing (<*>)
+import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
#include "HsVersions.h"
@@ -199,30 +194,12 @@ 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
- -> [CmmArg]
+ -> [CmmExpr]
-> UpdFrameOffset
-> CmmAGraph
mkJump dflags conv e actuals updfr_off =
@@ -238,8 +215,8 @@ mkRawJump dflags e updfr_off vols =
\arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
-mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmArg]
- -> UpdFrameOffset -> [CmmArg]
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
+ -> UpdFrameOffset -> [CmmExpr]
-> CmmAGraph
mkJumpExtra dflags conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
@@ -252,7 +229,7 @@ mkCbranch pred ifso ifnot likely =
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
-mkReturn :: DynFlags -> CmmExpr -> [CmmArg] -> UpdFrameOffset
+mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
@@ -262,17 +239,17 @@ mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: DynFlags
- -> CmmExpr -> CCallConv -> [CmmArg] -> UpdFrameOffset
+ -> CmmExpr -> CCallConv -> [CmmExpr] -> 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 -> [CmmArg]
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
- -> [CmmArg]
+ -> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
@@ -281,7 +258,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 -> [CmmArg]
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
@@ -349,9 +326,9 @@ copyIn dflags conv area formals extra_stk
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
-copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmArg]
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
-> UpdFrameOffset
- -> [CmmArg] -- extra stack args
+ -> [CmmExpr] -- extra stack args
-> (Int, [GlobalReg], CmmAGraph)
-- Generate code to move the actual parameters into the locations
@@ -369,9 +346,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
@@ -379,7 +356,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
-- the return address if making a call
case transfer of
Call ->
- ([(CmmExprArg (CmmLit (CmmBlock id)), StackParam init_offset)],
+ ([(CmmLit (CmmBlock id), StackParam init_offset)],
widthInBytes (wordWidth dflags))
JumpRet ->
([],
@@ -389,11 +366,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
Old -> ([], updfr_off)
(extra_stack_off, stack_params) =
- assignStack dflags init_offset (cmmArgType dflags) extra_stack_stuff
+ assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
- args :: [(CmmArg, ParamLocation)] -- The argument and where to put it
+ args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
(stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
- (cmmArgType dflags) actuals
+ (cmmExprType dflags) actuals
@@ -402,7 +379,7 @@ mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
mkCallEntry dflags conv formals extra_stk
= copyInOflow dflags conv Old formals extra_stk
-lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmArg]
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
@@ -411,8 +388,8 @@ lastWithArgs dflags transfer area conv actuals updfr_off last =
updfr_off noExtraStack last
lastWithArgsAndExtraStack :: DynFlags
- -> Transfer -> Area -> Convention -> [CmmArg]
- -> UpdFrameOffset -> [CmmArg]
+ -> Transfer -> Area -> Convention -> [CmmExpr]
+ -> UpdFrameOffset -> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
@@ -423,7 +400,7 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
updfr_off extra_stack
-noExtraStack :: [CmmArg]
+noExtraStack :: [CmmExpr]
noExtraStack = []
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
@@ -431,7 +408,3 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-> CmmAGraph
toCall e cont updfr_off res_space arg_space regs =
mkLast $ CmmCall e cont regs arg_space res_space updfr_off
-
---------------
-rubbishExpr :: CmmExpr
-rubbishExpr = CmmLit (CmmLabel mkRUBBISH_ENTRY_infoLabel)
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 219b287f01..77c92407bc 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -53,9 +53,6 @@ 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
@@ -278,11 +275,5 @@ pprGlobalReg gr
-----------------------------------------------------------------------------
-pprArg :: CmmArg -> SDoc
-pprArg (CmmExprArg e) = ppr e
-pprArg (CmmRubbishArg ty) = text "Rubbish" <+> dcolon <+> ppr ty
-
------------------------------------------------------------------------------
-
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index d6e0cf2f72..85f8845c8a 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -241,7 +241,7 @@ cgDataCon data_con
do { _ <- ticky_code
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_things)
- ; void $ emitReturn [CmmExprArg (cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con))]
+ ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
}
-- The case continuation code expects a tagged pointer
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 745fd33f73..93756ec406 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -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 (CmmExprArg . CmmReg . CmmLocal) (node : arg_regs))
+ (map (CmmReg . CmmLocal) (node : arg_regs))
(initUpdFrameOff dflags)
tscope <- getTickScope
emitProcWithConvention Slow Nothing slow_lbl
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index c77816a819..4255f10201 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -88,7 +88,7 @@ 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 { CmmExprArg (CmmLit lit) <- getArgAmode arg
+ get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
; return lit }
; payload <- mapM get_lit nv_args_w_offsets
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index ec4c75f0bc..44d3df84ee 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -19,8 +19,7 @@ module StgCmmEnv (
bindArgsToRegs, bindToReg, rebindToReg,
bindArgToReg, idToReg,
- getArgAmode, getArgAmode_no_rubbish,
- getNonVoidArgAmodes, getNonVoidArgAmodes_no_rubbish,
+ getArgAmode, getNonVoidArgAmodes,
getCgIdInfo,
maybeLetNoEscape,
) where
@@ -37,7 +36,6 @@ import CLabel
import BlockId
import CmmExpr
import CmmUtils
-import Control.Monad
import DynFlags
import Id
import MkGraph
@@ -166,19 +164,11 @@ cgLookupPanic id
--------------------
-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_no_rubbish (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
-getArgAmode_no_rubbish arg@(NonVoid (StgRubbishArg _)) = pprPanic "getArgAmode_no_rubbish" (ppr arg)
-
-getNonVoidArgAmodes :: [StgArg] -> FCode [CmmArg]
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
+
+getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
-- so the result list may be shorter than the argument list
getNonVoidArgAmodes [] = return []
@@ -188,12 +178,6 @@ getNonVoidArgAmodes (arg:args)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
--- This version assumes arguments are not rubbish. I think this assumption holds
--- as long as we don't pass unboxed sums to primops and foreign fns.
-getNonVoidArgAmodes_no_rubbish :: [StgArg] -> FCode [CmmExpr]
-getNonVoidArgAmodes_no_rubbish
- = mapM (getArgAmode_no_rubbish . NonVoid) . filter (not . isVoidRep . argPrimRep)
-
------------------------------------------------------------------------
-- Interface functions for binding and re-binding names
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 005e332d07..91cfba6bd0 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -68,7 +68,7 @@ cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args _)= cgConApp con args
cgExpr (StgTick t e) = cgTick t >> cgExpr e
cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
- emitReturn [CmmExprArg (CmmLit cmm_lit)]
+ emitReturn [CmmLit cmm_lit]
cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape binds expr) =
@@ -309,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_no_rubbish (NonVoid arg)
+ = getArgAmode (NonVoid arg)
do_enum_primop primop args
= do dflags <- getDynFlags
tmp <- newTemp (bWord dflags)
@@ -517,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_no_rubbish stg_args
+ arg_exprs <- getNonVoidArgAmodes stg_args
dflags <- getDynFlags
-- See Note [Inlining out-of-line primops and heap checks]
return $! isJust $ shouldInlinePrimOp dflags op arg_exprs
@@ -684,7 +684,7 @@ cgConApp con stg_args
; emit =<< fcode_init
; tickyReturnNewCon (length stg_args)
- ; emitReturn [CmmExprArg (idInfoToAmode idinfo)] }
+ ; emitReturn [idInfoToAmode idinfo] }
cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
cgIdApp fun_id [] | isVoidTy (idType fun_id) = emitReturn []
@@ -707,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 [CmmExprArg fun] -- ToDo: does ReturnIt guarantee tagged?
+ ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
EnterIt -> ASSERT( null args ) -- Discarding arguments
emitEnter fun
@@ -857,7 +857,7 @@ emitEnter fun = do
Return -> do
{ let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg
; emit $ mkJump dflags NativeNodeCall entry
- [CmmExprArg (cmmUntag dflags fun)] updfr_off
+ [cmmUntag dflags fun] updfr_off
; return AssignedDirectly
}
@@ -893,7 +893,7 @@ emitEnter fun = do
; updfr_off <- getUpdFrameOff
; let area = Young lret
; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
- [CmmExprArg fun] updfr_off []
+ [fun] updfr_off []
-- refer to fun via nodeReg after the copyout, to avoid having
-- both live simultaneously; this sometimes enables fun to be
-- inlined in the RHS of the R1 assignment.
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index eb14e8cce6..fdfdb77375 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -111,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 (CmmExprArg . CmmReg . CmmLocal) res_regs)
+ ; emitReturn (map (CmmReg . CmmLocal) res_regs)
}
}
@@ -524,12 +524,10 @@ 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_no_rubbish (NonVoid arg)
+ = do { cmm <- getArgAmode (NonVoid arg)
; dflags <- getDynFlags
; return (Just (add_shim dflags arg_ty cmm, hint)) }
where
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index fa1780449d..ebff4402d0 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -72,7 +72,7 @@ allocDynClosure
allocDynClosureCmm
:: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
- -> [(CmmArg, ByteOff)]
+ -> [(CmmExpr, 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
- -> [(CmmArg,ByteOff)] -- ^ payload
+ -> [(CmmExpr,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 (map CmmExprArg (header dflags)) [0, wORD_SIZE dflags ..])
+ hpStore base (zip (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 -> [(CmmArg, ByteOff)] -> FCode ()
+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
hpStore base vals = do
dflags <- getDynFlags
sequence_ $
- [ emitStore (cmmOffsetB dflags base off) val | (CmmExprArg val,off) <- vals ]
+ [ emitStore (cmmOffsetB dflags base off) val | (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 (CmmExprArg . CmmReg . CmmLocal) args
+ args' = map (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 [CmmExprArg node] upd
+ = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd
| is_fastf
- = mkJump dflags NativeNodeCall stg_gc_fun (CmmExprArg node : args') upd
+ = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd
| otherwise
- = mkJump dflags Slow stg_gc_fun (CmmExprArg node : args') upd
+ = mkJump dflags Slow stg_gc_fun (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 (CmmExprArg . CmmReg . CmmLocal) regs
+ reg_exprs = map (CmmReg . CmmLocal) regs
-- Note [stg_gc arguments]
-- NB. we use the NativeReturn convention for passing arguments
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 39f3cd7fa3..59bbc8d5ea 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -68,7 +68,7 @@ import Control.Monad
--
-- > p=x; q=y;
--
-emitReturn :: [CmmArg] -> FCode ReturnKind
+emitReturn :: [CmmExpr] -> 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 -> [CmmArg] -> FCode ReturnKind
+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> 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 -> [CmmArg]
- -> [CmmArg] -> FCode ReturnKind
+ :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
+ -> [CmmExpr] -> 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 (CmmExprArg fun)):argsreps)
+ (mkRtsApFastLabel rts_fun) arity ((P,Just 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 (CmmExprArg funv)):argsreps))
+ (nonVArgs ((P,Just 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 CmmArg)] -> FCode ReturnKind
+ -> [(ArgRep,Maybe CmmExpr)] -> 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
--- CmmArgs zipped together. However, a void argument has no
--- representation, so we need to use Maybe CmmArg (the alternative of
+-- CmmExprs zipped together. However, a void argument has no
+-- representation, so we need to use Maybe CmmExpr (the alternative of
-- using zeroCLit or even undefined would work, but would be ugly).
--
-getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmArg)]
+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
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 CmmArg)] -> [CmmArg]
+nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
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 CmmArg)] -> [(ArgRep, Maybe CmmArg)]
+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
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 (CmmExprArg (mkLblExpr stg_ap_pat))) : call_args
- save_cccs = [(N, Just (CmmExprArg (mkLblExpr save_cccs_lbl))), (N, Just (CmmExprArg curCCS))]
+ this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
+ save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
-------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 471a94df64..836bf30f29 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -19,7 +19,7 @@ module StgCmmMonad (
emit, emitDecl, emitProc,
emitProcWithConvention, emitProcWithStackFrame,
- emitOutOfLine, emitAssign, emitAssign', emitStore,
+ emitOutOfLine, emitAssign, emitStore,
emitComment, emitTick, emitUnwind,
getCmm, aGraphToGraph,
@@ -76,7 +76,6 @@ import Unique
import UniqSupply
import FastString
import Outputable
-import RepType (typePrimRep)
import Control.Monad
import Data.List
@@ -743,14 +742,6 @@ 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))
@@ -866,8 +857,8 @@ mkCmmIfThen e tbranch = do
, mkLabel tid tscp, tbranch, mkLabel endif tscp ]
-mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmArg]
- -> UpdFrameOffset -> [CmmArg] -> FCode CmmAGraph
+mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
+ -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
dflags <- getDynFlags
k <- newLabelC
@@ -877,7 +868,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] -> [CmmArg] -> UpdFrameOffset
+mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
-> FCode CmmAGraph
mkCmmCall f results actuals updfr_off
= mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index c02f992bed..d3c09c584e 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -46,7 +46,6 @@ import Util
import Prelude hiding ((<*>))
import Data.Bits ((.&.), bit)
-import Data.Bifunctor (first)
import Control.Monad (liftM, when)
------------------------------------------------------------------------
@@ -80,10 +79,10 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty
cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
= ASSERT(isEnumerationTyCon tycon)
do { dflags <- getDynFlags
- ; args' <- getNonVoidArgAmodes_no_rubbish [arg]
+ ; args' <- getNonVoidArgAmodes [arg]
; let amode = case args' of [amode] -> amode
_ -> panic "TagToEnumOp had void arg"
- ; emitReturn [CmmExprArg (tagToClosure dflags tycon amode)] }
+ ; emitReturn [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
@@ -94,11 +93,11 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
cgOpApp (StgPrimOp primop) args res_ty = do
dflags <- getDynFlags
- cmm_args <- getNonVoidArgAmodes_no_rubbish args
+ cmm_args <- getNonVoidArgAmodes args
case shouldInlinePrimOp dflags primop cmm_args of
Nothing -> do -- out-of-line
let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
- emitCall (NativeNodeCall, NativeReturn) fun (map CmmExprArg cmm_args)
+ emitCall (NativeNodeCall, NativeReturn) fun cmm_args
Just f -- inline
| ReturnsPrim VoidRep <- result_info
@@ -109,12 +108,12 @@ cgOpApp (StgPrimOp primop) args res_ty = do
-> do dflags <- getDynFlags
res <- newTemp (primRepCmmType dflags rep)
f [res]
- emitReturn [CmmExprArg (CmmReg (CmmLocal res))]
+ emitReturn [CmmReg (CmmLocal res)]
| ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
-> do (regs, _hints) <- newUnboxedTupleRegs res_ty
f regs
- emitReturn (map (CmmExprArg . CmmReg . CmmLocal) regs)
+ emitReturn (map (CmmReg . CmmLocal) regs)
| otherwise -> panic "cgPrimop"
where
@@ -257,7 +256,7 @@ cgPrimOp :: [LocalReg] -- where to put the results
cgPrimOp results op args
= do dflags <- getDynFlags
- arg_exprs <- getNonVoidArgAmodes_no_rubbish args
+ arg_exprs <- getNonVoidArgAmodes args
emitPrimOp dflags results op arg_exprs
@@ -1658,7 +1657,7 @@ doNewByteArrayOp res_r n = do
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr curCCS
- [ (CmmExprArg (mkIntExpr dflags n),
+ [ (mkIntExpr dflags n,
hdr_size + oFFSET_StgArrBytes_bytes dflags)
]
@@ -1771,7 +1770,7 @@ doNewArrayOp res_r rep info payload n init = do
(mkIntExpr dflags (nonHdrSize dflags rep))
(zeroExpr dflags)
- base <- allocHeapClosure rep info_ptr curCCS (map (first CmmExprArg) payload)
+ base <- allocHeapClosure rep info_ptr curCCS payload
arr <- CmmLocal `fmap` newTemp (bWord dflags)
emit $ mkAssign arr base
@@ -1954,9 +1953,9 @@ emitCloneArray info_p res_r src src_off n = do
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr curCCS
- [ (CmmExprArg (mkIntExpr dflags n),
+ [ (mkIntExpr dflags n,
hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
- , (CmmExprArg (mkIntExpr dflags (nonHdrSizeW rep)),
+ , (mkIntExpr dflags (nonHdrSizeW rep),
hdr_size + oFFSET_StgMutArrPtrs_size dflags)
]
@@ -1993,7 +1992,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr curCCS
- [ (CmmExprArg (mkIntExpr dflags n),
+ [ (mkIntExpr dflags n,
hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
]
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index f1437eb640..7372ab9102 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -38,7 +38,7 @@ module StgCmmUtils (
addToMem, addToMemE, addToMemLblE, addToMemLbl,
mkWordCLit,
newStringCLit, newByteStringCLit,
- blankWord, rubbishExpr
+ blankWord,
) where
#include "HsVersions.h"
@@ -194,7 +194,7 @@ emitRtsCallGen res lbl args safe
where
call updfr_off =
if safe then
- emit =<< mkCmmCall fun_expr res' (map CmmExprArg args') updfr_off
+ emit =<< mkCmmCall fun_expr res' args' updfr_off
else do
let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
@@ -374,14 +374,14 @@ newUnboxedTupleRegs res_ty
-- emitMultiAssign
-------------------------------------------------------------------------
-emitMultiAssign :: [LocalReg] -> [CmmArg] -> FCode ()
+emitMultiAssign :: [LocalReg] -> [CmmExpr] -> 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, CmmArg) -- r := e
+type Stmt = (LocalReg, CmmExpr) -- r := e
-- We use the strongly-connected component algorithm, in which
-- * the vertices are the statements
@@ -390,7 +390,7 @@ type Stmt = (LocalReg, CmmArg) -- 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 )
@@ -429,20 +429,16 @@ unscramble dflags vertices = mapM_ do_component components
split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
split dflags uniq (reg, rhs)
- = ((tmp, rhs), (reg, CmmExprArg (CmmReg (CmmLocal tmp))))
+ = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
where
- rep = cmmArgType dflags rhs
+ rep = cmmExprType 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
-
-regUsedIn' :: DynFlags -> CmmReg -> CmmArg -> Bool
-regUsedIn' _ _ (CmmRubbishArg _) = False
-regUsedIn' dflags reg (CmmExprArg expr) = regUsedIn dflags reg expr
+ (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
-------------------------------------------------------------------------
-- mkSwitch
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index b575e8a48a..e7fc7f9608 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -46,7 +46,7 @@ module MkCore (
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
- tYPE_ERROR_ID
+ tYPE_ERROR_ID,
) where
#include "HsVersions.h"
@@ -703,8 +703,7 @@ err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
-tYPE_ERROR_ID :: Id
-aBSENT_ERROR_ID :: Id
+tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 02d59b01e3..e5e458d626 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -1909,7 +1909,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
realWorldPrimIdKey, recConErrorIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
unpackCStringFoldrIdKey, unpackCStringIdKey,
- typeErrorIdKey, rubbishEntryErrorIdKey :: Unique
+ typeErrorIdKey :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
@@ -1934,7 +1934,6 @@ unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19
unpackCStringIdKey = mkPreludeMiscIdUnique 20
voidPrimIdKey = mkPreludeMiscIdUnique 21
typeErrorIdKey = mkPreludeMiscIdUnique 22
-rubbishEntryErrorIdKey = mkPreludeMiscIdUnique 23
unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 24c0ce84a8..80848793fc 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -188,6 +188,7 @@ import DataCon
import FastString (FastString, mkFastString)
import Id
import Literal (Literal (..))
+import MkCore (aBSENT_ERROR_ID)
import MkId (voidPrimId, voidArgId)
import MonadUtils (mapAccumLM)
import Outputable
@@ -288,8 +289,6 @@ unariseExpr rho e@(StgApp 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
@@ -389,7 +388,6 @@ elimCase rho args bndr (MultiValAlt _) alts
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')
@@ -561,7 +559,14 @@ mkUbxSum dc ty_args args0
| 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
+ = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
+
+ slotRubbishArg :: SlotTy -> StgArg
+ slotRubbishArg PtrSlot = StgVarArg aBSENT_ERROR_ID
+ slotRubbishArg WordSlot = StgLitArg (MachWord 0)
+ slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
+ slotRubbishArg FloatSlot = StgLitArg (MachFloat 0)
+ slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
in
tag_arg : mkTupArgs 0 sum_slots arg_idxs
@@ -659,7 +664,7 @@ 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
+ Just (MultiVal as) -> as -- 'as' can be empty
Nothing
| isVoidTy (idType x) -> [] -- e.g. C realWorld#
-- Here realWorld# is not in the envt, but
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index eb07e6b447..0dba8d8359 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -82,7 +82,6 @@ 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
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 60147bc8d8..b553cd74dd 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -92,10 +92,6 @@ 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
@@ -137,7 +133,6 @@ 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
@@ -197,7 +192,7 @@ primitives, and literals.
[Type] -- See Note [Types in StgConApp] in UnariseStg
| StgOpApp StgOp -- Primitive op or foreign call
- [GenStgArg occ] -- Saturated. Not rubbish.
+ [GenStgArg occ] -- Saturated.
Type -- Result type
-- We need to know this so that we can
-- assign result registers
@@ -659,7 +654,6 @@ 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
View Lorry Controller Status