summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs4
-rw-r--r--compiler/cmm/CmmExpr.hs12
-rw-r--r--compiler/cmm/CmmLayoutStack.hs2
-rw-r--r--compiler/cmm/CmmLive.hs4
-rw-r--r--compiler/cmm/CmmParse.y8
-rw-r--r--compiler/cmm/CmmUtils.hs22
-rw-r--r--compiler/cmm/MkGraph.hs74
-rw-r--r--compiler/cmm/PprCmmExpr.hs9
8 files changed, 98 insertions, 37 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index b262371b65..447eee8e8d 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -66,6 +66,7 @@ module CLabel (
mkSMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel,
mkArrWords_infoLabel,
+ mkRUBBISH_ENTRY_infoLabel,
mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel,
@@ -506,7 +507,7 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
- mkSMAP_DIRTY_infoLabel :: CLabel
+ mkSMAP_DIRTY_infoLabel, mkRUBBISH_ENTRY_infoLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkSplitMarkerLabel = CmmLabel rtsUnitId (fsLit "__stg_split_marker") CmmCode
mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo
@@ -524,6 +525,7 @@ mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")
mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkRUBBISH_ENTRY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_RUBBISH_ENTRY") CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index de783aacce..784724da2d 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -6,6 +6,7 @@
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+ , CmmArg(..)
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
@@ -29,13 +30,14 @@ where
#include "HsVersions.h"
-import CmmType
-import CmmMachOp
import BlockId
import CLabel
+import CmmMachOp
+import CmmType
import DynFlags
-import Unique
import Outputable (panic)
+import Type
+import Unique
import Data.Set (Set)
import qualified Data.Set as Set
@@ -73,6 +75,10 @@ data CmmReg
| CmmGlobal GlobalReg
deriving( Eq, Ord )
+data CmmArg
+ = CmmExprArg CmmExpr
+ | CmmRubbishArg Type -- See StgRubbishArg in StgSyn.hs
+
-- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed.
data Area
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5c3be17e44..37bd7a010a 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -1032,7 +1032,7 @@ lowerSafeForeignCall dflags block
(_, regs, copyout) =
copyOutOflow dflags NativeReturn Jump (Young succ)
- (map (CmmReg . CmmLocal) res)
+ (map (CmmExprArg . CmmReg . CmmLocal) res)
ret_off []
-- NB. after resumeThread returns, the top-of-stack probably contains
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index dfacd139b6..80aceaf19a 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -8,11 +8,10 @@
module CmmLive
( CmmLocalLive
- , CmmGlobalLive
, cmmLocalLiveness
, cmmGlobalLiveness
, liveLattice
- , noLiveOnEntry, xferLive, gen, kill, gen_kill
+ , gen, kill, gen_kill
)
where
@@ -33,7 +32,6 @@ import Outputable
-- | The variables live on entry to a block
type CmmLive r = RegSet r
type CmmLocalLive = CmmLive LocalReg
-type CmmGlobalLive = CmmLive GlobalReg
-- | The dataflow lattice
liveLattice :: Ord r => DataflowLattice (CmmLive r)
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 6b326b8bfb..128cc4e4e1 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1100,7 +1100,7 @@ pushStackFrame fields body = do
exprs <- sequence fields
updfr_off <- getUpdFrameOff
let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
- [] updfr_off exprs
+ [] updfr_off (map CmmExprArg exprs)
emit g
withUpdFrameOff new_updfr_off body
@@ -1171,7 +1171,7 @@ doReturn exprs_code = do
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
- mkReturn dflags e actuals updfr_off
+ mkReturn dflags e (map CmmExprArg actuals) updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
(gcWord dflags))
@@ -1190,7 +1190,7 @@ doJumpWithStack expr_code stk_code args_code = do
stk_args <- sequence stk_code
args <- sequence args_code
updfr_off <- getUpdFrameOff
- emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+ emit (mkJumpExtra dflags NativeNodeCall expr (map CmmExprArg args) updfr_off (map CmmExprArg stk_args))
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse ()
@@ -1200,7 +1200,7 @@ doCall expr_code res_code args_code = do
args <- sequence args_code
ress <- sequence res_code
updfr_off <- getUpdFrameOff
- c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
+ c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress (map CmmExprArg args) updfr_off []
emit c
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index dca57dca01..e9f2612713 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -10,7 +10,7 @@
module CmmUtils(
-- CmmType
- primRepCmmType, primRepForeignHint,
+ primRepCmmType, slotCmmType, slotForeignHint, cmmArgType,
typeCmmType, typeForeignHint,
-- CmmLit
@@ -69,7 +69,7 @@ module CmmUtils(
#include "HsVersions.h"
import TyCon ( PrimRep(..), PrimElemRep(..) )
-import Type ( UnaryType, typePrimRep )
+import RepType ( UnaryType, SlotTy (..), typePrimRep )
import SMRep
import Cmm
@@ -105,6 +105,13 @@ primRepCmmType _ FloatRep = f32
primRepCmmType _ DoubleRep = f64
primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
+slotCmmType :: DynFlags -> SlotTy -> CmmType
+slotCmmType dflags PtrSlot = gcWord dflags
+slotCmmType dflags WordSlot = bWord dflags
+slotCmmType _ Word64Slot = b64
+slotCmmType _ FloatSlot = f32
+slotCmmType _ DoubleSlot = f64
+
primElemRepCmmType :: PrimElemRep -> CmmType
primElemRepCmmType Int8ElemRep = b8
primElemRepCmmType Int16ElemRep = b16
@@ -120,6 +127,10 @@ primElemRepCmmType DoubleElemRep = f64
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
+cmmArgType :: DynFlags -> CmmArg -> CmmType
+cmmArgType dflags (CmmExprArg e) = cmmExprType dflags e
+cmmArgType dflags (CmmRubbishArg ty) = typeCmmType dflags ty
+
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep = AddrHint
@@ -132,6 +143,13 @@ primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
primRepForeignHint (VecRep {}) = NoHint
+slotForeignHint :: SlotTy -> ForeignHint
+slotForeignHint PtrSlot = AddrHint
+slotForeignHint WordSlot = NoHint
+slotForeignHint Word64Slot = NoHint
+slotForeignHint FloatSlot = NoHint
+slotForeignHint DoubleSlot = NoHint
+
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 657585e75a..b1bd48a71f 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -7,7 +7,8 @@ module MkGraph
, lgraphOfAGraph, labelAGraph
, stackStubExpr
- , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+ , mkNop, mkAssign, mkAssign', mkStore, mkStore'
+ , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
, mkJumpReturnsTo
, mkJump, mkJumpExtra
, mkRawJump
@@ -16,26 +17,31 @@ module MkGraph
, copyInOflow, copyOutOflow
, noExtraStack
, toCall, Transfer(..)
+ , rubbishExpr
)
where
import BlockId
+import CLabel (mkRUBBISH_ENTRY_infoLabel)
import Cmm
import CmmCallConv
import CmmSwitch (SwitchTargets)
+import CmmUtils (cmmArgType)
+import TyCon (isGcPtrRep)
+import RepType (typePrimRep)
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags
import FastString
import ForeignCall
+import OrdList
import SMRep (ByteOff)
import UniqSupply
-import OrdList
import Control.Monad
import Data.List
import Data.Maybe
-import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
+import Prelude (($),Int,Bool,Eq(..),otherwise) -- avoid importing (<*>)
#include "HsVersions.h"
@@ -193,12 +199,30 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkAssign l (CmmReg r) | l == r = mkNop
mkAssign l r = mkMiddle $ CmmAssign l r
+mkAssign' :: CmmReg -> CmmArg -> CmmAGraph
+mkAssign' l (CmmRubbishArg ty)
+ | isGcPtrRep (typePrimRep ty)
+ = mkAssign l rubbishExpr
+ | otherwise
+ = mkNop
+mkAssign' l (CmmExprArg r)
+ = mkAssign l r
+
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r
+mkStore' :: CmmExpr -> CmmArg -> CmmAGraph
+mkStore' l (CmmRubbishArg ty)
+ | isGcPtrRep (typePrimRep ty)
+ = mkStore l rubbishExpr
+ | otherwise
+ = mkNop
+mkStore' l (CmmExprArg r)
+ = mkStore l r
+
---------- Control transfer
mkJump :: DynFlags -> Convention -> CmmExpr
- -> [CmmActual]
+ -> [CmmArg]
-> UpdFrameOffset
-> CmmAGraph
mkJump dflags conv e actuals updfr_off =
@@ -214,8 +238,8 @@ mkRawJump dflags e updfr_off vols =
\arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
-mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
- -> UpdFrameOffset -> [CmmActual]
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmArg]
+ -> UpdFrameOffset -> [CmmArg]
-> CmmAGraph
mkJumpExtra dflags conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
@@ -228,7 +252,7 @@ mkCbranch pred ifso ifnot likely =
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
-mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+mkReturn :: DynFlags -> CmmExpr -> [CmmArg] -> UpdFrameOffset
-> CmmAGraph
mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
@@ -238,17 +262,17 @@ mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: DynFlags
- -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
+ -> CmmExpr -> CCallConv -> [CmmArg] -> UpdFrameOffset
-> CmmAGraph
mkFinalCall dflags f _ actuals updfr_off =
lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
-mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg]
-> BlockId
-> ByteOff
-> UpdFrameOffset
- -> [CmmActual]
+ -> [CmmArg]
-> CmmAGraph
mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
@@ -257,7 +281,7 @@ mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg]
-> BlockId
-> ByteOff
-> UpdFrameOffset
@@ -325,9 +349,9 @@ copyIn dflags conv area formals extra_stk
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
-copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmArg]
-> UpdFrameOffset
- -> [CmmActual] -- extra stack args
+ -> [CmmArg] -- extra stack args
-> (Int, [GlobalReg], CmmAGraph)
-- Generate code to move the actual parameters into the locations
@@ -345,9 +369,9 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
co (v, RegisterParam r) (rs, ms)
- = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+ = (r:rs, mkAssign' (CmmGlobal r) v <*> ms)
co (v, StackParam off) (rs, ms)
- = (rs, mkStore (CmmStackSlot area off) v <*> ms)
+ = (rs, mkStore' (CmmStackSlot area off) v <*> ms)
(setRA, init_offset) =
case area of
@@ -355,7 +379,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
-- the return address if making a call
case transfer of
Call ->
- ([(CmmLit (CmmBlock id), StackParam init_offset)],
+ ([(CmmExprArg (CmmLit (CmmBlock id)), StackParam init_offset)],
widthInBytes (wordWidth dflags))
JumpRet ->
([],
@@ -365,11 +389,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
Old -> ([], updfr_off)
(extra_stack_off, stack_params) =
- assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+ assignStack dflags init_offset (cmmArgType dflags) extra_stack_stuff
- args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
+ args :: [(CmmArg, ParamLocation)] -- The argument and where to put it
(stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
- (cmmExprType dflags) actuals
+ (cmmArgType dflags) actuals
@@ -378,7 +402,7 @@ mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
mkCallEntry dflags conv formals extra_stk
= copyInOflow dflags conv Old formals extra_stk
-lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmArg]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
@@ -387,8 +411,8 @@ lastWithArgs dflags transfer area conv actuals updfr_off last =
updfr_off noExtraStack last
lastWithArgsAndExtraStack :: DynFlags
- -> Transfer -> Area -> Convention -> [CmmActual]
- -> UpdFrameOffset -> [CmmActual]
+ -> Transfer -> Area -> Convention -> [CmmArg]
+ -> UpdFrameOffset -> [CmmArg]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
@@ -399,7 +423,7 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
updfr_off extra_stack
-noExtraStack :: [CmmActual]
+noExtraStack :: [CmmArg]
noExtraStack = []
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
@@ -407,3 +431,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-> CmmAGraph
toCall e cont updfr_off res_space arg_space regs =
mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+
+--------------
+rubbishExpr :: CmmExpr
+rubbishExpr = CmmLit (CmmLabel mkRUBBISH_ENTRY_infoLabel)
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 77c92407bc..219b287f01 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -53,6 +53,9 @@ instance Outputable CmmExpr where
instance Outputable CmmReg where
ppr e = pprReg e
+instance Outputable CmmArg where
+ ppr a = pprArg a
+
instance Outputable CmmLit where
ppr l = pprLit l
@@ -275,5 +278,11 @@ pprGlobalReg gr
-----------------------------------------------------------------------------
+pprArg :: CmmArg -> SDoc
+pprArg (CmmExprArg e) = ppr e
+pprArg (CmmRubbishArg ty) = text "Rubbish" <+> dcolon <+> ppr ty
+
+-----------------------------------------------------------------------------
+
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs
View Lorry Controller Status