diff options
26 files changed, 130 insertions, 197 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 diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 70d219aa6a..6c1edf70b5 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -384,9 +384,6 @@ 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 diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T index 806f41568e..ed4108433c 100644 --- a/testsuite/tests/unboxedsums/all.T +++ b/testsuite/tests/unboxedsums/all.T @@ -15,6 +15,7 @@ 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('unboxedsums12', omit_ways(['ghci']), compile, ['']) test('ffi1', normal, compile_fail, ['']) test('thunk', only_ways(['normal']), compile_and_run, ['']) diff --git a/testsuite/tests/unboxedsums/unboxedsums12.hs b/testsuite/tests/unboxedsums/unboxedsums12.hs new file mode 100644 index 0000000000..93f1793e8a --- /dev/null +++ b/testsuite/tests/unboxedsums/unboxedsums12.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedSums, MagicHash, UnboxedTuples #-} + +module Lib where + +import GHC.Prim + +data B = B1 Int# Int# Int# Int# Int# | B2 Float# + +type UbxB = (# (# Int#, Int#, Int#, Int#, Int# #) | Float# #) + +{-# INLINE bToSum #-} +bToSum :: B -> UbxB +bToSum (B1 i1 i2 i3 i4 i5) = (# (# i1, i2, i3, i4, i5 #) | #) +bToSum (B2 f) = (# | f #) + +data C = C UbxB UbxB UbxB + +mkC :: B -> C +mkC b = C (bToSum b) (bToSum b) (bToSum b) |