summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs16
-rw-r--r--compiler/cmm/CmmCallConv.hs27
-rw-r--r--compiler/cmm/CmmCommonBlockElim.hs2
-rw-r--r--compiler/cmm/CmmLayoutStack.hs19
-rw-r--r--compiler/cmm/CmmLint.hs2
-rw-r--r--compiler/cmm/CmmMachOp.hs1
-rw-r--r--compiler/cmm/CmmNode.hs46
-rw-r--r--compiler/cmm/CmmParse.y8
-rw-r--r--compiler/cmm/CmmPipeline.hs2
-rw-r--r--compiler/cmm/CmmSink.hs2
-rw-r--r--compiler/cmm/CmmUtils.hs2
-rw-r--r--compiler/cmm/PprC.hs35
-rw-r--r--compiler/cmm/PprCmm.hs5
-rw-r--r--compiler/cmm/SMRep.lhs42
14 files changed, 117 insertions, 92 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 8fe8c3c874..1b86f3d6b4 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -398,13 +398,13 @@ mkConEntryLabel name c = IdLabel name c ConEntry
mkStaticConEntryLabel name c = IdLabel name c StaticConEntry
-- Constructing Cmm Labels
-mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
+mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel :: CLabel
+mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
-mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode
mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo
mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo
@@ -837,13 +837,13 @@ idInfoLabelType info =
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool
-labelDynamic dflags this_pkg lbl =
+labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool
+labelDynamic dflags this_pkg this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId)
- IdLabel n _ _ -> isDllName dflags this_pkg n
+ IdLabel n _ _ -> isDllName dflags this_pkg this_mod n
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
@@ -1030,9 +1030,9 @@ pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast")
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
= hcat [ptext (sLit "stg_sel_"), text (show offset),
- ptext (if upd_reqd
- then (sLit "_upd_info")
- else (sLit "_noupd_info"))
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
]
pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 1546dd4a60..eeca0b4a54 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -70,10 +70,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
(W32, (vs, f:fs, ds, ls, ss))
- | not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss))
+ | not hasXmmRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss))
(W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
(W64, (vs, fs, d:ds, ls, ss))
- | not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss))
+ | not hasXmmRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss))
(W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
@@ -88,7 +88,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
- hasSseRegs = mAX_Real_SSE_REG dflags /= 0
+ hasXmmRegs = mAX_Real_XMM_REG dflags /= 0
assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
@@ -113,7 +113,7 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
, [GlobalReg] -- floats
, [GlobalReg] -- doubles
, [GlobalReg] -- longs (int64 and word64)
- , [Int] -- SSE (floats and doubles)
+ , [Int] -- XMM (floats and doubles)
)
-- Vanilla registers can contain pointers, Ints, Chars.
@@ -128,7 +128,7 @@ getRegsWithoutNode dflags =
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags
- , sseRegNos dflags)
+ , realXmmRegNos dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode dflags =
@@ -138,28 +138,27 @@ getRegsWithNode dflags =
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags
- , sseRegNos dflags)
+ , realXmmRegNos dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
-allSseRegs :: DynFlags -> [Int]
+allXmmRegs :: DynFlags -> [Int]
allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
-allSseRegs dflags = regList (mAX_SSE_REG dflags)
+allXmmRegs dflags = regList (mAX_XMM_REG dflags)
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+realXmmRegNos :: DynFlags -> [Int]
realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
-
-sseRegNos :: DynFlags -> [Int]
-sseRegNos dflags =regList (mAX_SSE_REG dflags)
+realXmmRegNos dflags = regList (mAX_Real_XMM_REG dflags)
regList :: Int -> [Int]
regList n = [1 .. n]
@@ -169,7 +168,7 @@ allRegs dflags = (allVanillaRegs dflags,
allFloatRegs dflags,
allDoubleRegs dflags,
allLongRegs dflags,
- allSseRegs dflags)
+ allXmmRegs dflags)
nodeOnly :: AvailRegs
nodeOnly = ([VanillaReg 1], [], [], [], [])
@@ -187,7 +186,7 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
- | hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++
+ | hasXmmRegs = map ($VGcPtr) (realVanillaRegs dflags) ++
realDoubleRegs dflags ++
realLongRegs dflags
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
@@ -195,4 +194,4 @@ realArgRegsCover dflags
realDoubleRegs dflags ++
realLongRegs dflags
where
- hasSseRegs = mAX_Real_SSE_REG dflags /= 0
+ hasXmmRegs = mAX_Real_XMM_REG dflags /= 0
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 6312fb9c50..34e22cecfb 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -96,7 +96,7 @@ hash_block block =
hash_node (CmmBranch _) = 23 -- NB. ignore the label
hash_node (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _ _) = hash_e e
- hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
+ hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
hash_node (CmmSwitch e _) = hash_e e
hash_reg :: CmmReg -> Word32
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index a48d48742d..2b2dccdaed 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -6,13 +6,13 @@ module CmmLayoutStack (
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
+import BasicTypes
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
import MkGraph
-import Module
import ForeignCall
import CmmLive
import CmmProcPoint
@@ -264,7 +264,7 @@ collectContInfo blocks
CmmCall { cml_cont = Just l, .. }
-> (Just (l, cml_ret_args), cml_ret_off)
CmmForeignCall { .. }
- -> (Just (succ, 0), updfr) -- ??
+ -> (Just (succ, ret_args), ret_off)
_other -> (Nothing, 0)
@@ -346,8 +346,8 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
- return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0)
- -- one word each for args and results: the return address
+ return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+ -- one word of args: the return address
CmmBranch{..} -> handleBranches
CmmCondBranch{..} -> handleBranches
@@ -932,9 +932,10 @@ lowerSafeForeignCall dflags block
caller_load <*>
loadThreadState dflags load_tso load_stack
- (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
- (map (CmmReg . CmmLocal) res)
- updfr []
+ (_, regs, copyout) =
+ copyOutOflow dflags NativeReturn Jump (Young succ)
+ (map (CmmReg . CmmLocal) res)
+ ret_off []
-- NB. after resumeThread returns, the top-of-stack probably contains
-- the stack frame for succ, but it might not: if the current thread
@@ -947,7 +948,7 @@ lowerSafeForeignCall dflags block
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
, cml_ret_args = ret_args
- , cml_ret_off = updfr }
+ , cml_ret_off = ret_off }
graph' <- lgraphOfAGraph $ suspend <*>
midCall <*>
@@ -965,7 +966,7 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
-foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
newTemp :: CmmType -> UniqSM LocalReg
newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index da7b094643..92a137b98b 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -178,7 +178,7 @@ lintCmmLast labels node = case node of
_ <- lintCmmExpr target
maybe (return ()) checkTarget cont
- CmmForeignCall tgt _ args succ _ _ -> do
+ CmmForeignCall tgt _ args succ _ _ _ -> do
lintTarget tgt
mapM_ lintCmmExpr args
checkTarget succ
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index fae84e5d53..8d42bbd2cb 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -529,6 +529,7 @@ data CallishMachOp
| MO_Memmove
| MO_PopCnt Width
+ | MO_BSwap Width
deriving (Eq, Show)
pprCallishMachOp :: CallishMachOp -> SDoc
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 61c0b80179..47811bcd7f 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -4,13 +4,6 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module CmmNode (
CmmNode(..), CmmFormal, CmmActual,
UpdFrameOffset, Convention(..),
@@ -50,13 +43,13 @@ data CmmNode e x where
-- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
- CmmUnsafeForeignCall :: -- An unsafe foreign call;
- -- see Note [Foreign calls]
- -- Like a "fat machine instruction"; can occur
- -- in the middle of a block
- ForeignTarget -> -- call target
- [CmmFormal] -> -- zero or more results
- [CmmActual] -> -- zero or more arguments
+ CmmUnsafeForeignCall :: -- An unsafe foreign call;
+ -- see Note [Foreign calls]
+ -- Like a "fat machine instruction"; can occur
+ -- in the middle of a block
+ ForeignTarget -> -- call target
+ [CmmFormal] -> -- zero or more results
+ [CmmActual] -> -- zero or more arguments
CmmNode O O
-- Semantics: clobbers any GlobalRegs for which callerSaves r == True
-- See Note [foreign calls clobber GlobalRegs]
@@ -124,12 +117,13 @@ data CmmNode e x where
} -> CmmNode O C
CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
- -- Always the last node of a block
+ -- Always the last node of a block
tgt :: ForeignTarget, -- call target and convention
res :: [CmmFormal], -- zero or more results
args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
succ :: ULabel, -- Label of continuation
- updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
+ ret_args :: ByteOff, -- same as cml_ret_args
+ ret_off :: ByteOff, -- same as cml_ret_off
intrbl:: Bool -- whether or not the call is interruptible
} -> CmmNode O C
@@ -143,14 +137,14 @@ instruction". In particular, they do *not* kill all live registers,
just the registers they return to (there was a bit of code in GHC that
conservatively assumed otherwise.) However, see [Register parameter passing].
-Safe ones are trickier. A safe foreign call
+Safe ones are trickier. A safe foreign call
r = f(x)
ultimately expands to
- push "return address" -- Never used to return to;
- -- just points an info table
+ push "return address" -- Never used to return to;
+ -- just points an info table
save registers into TSO
call suspendThread
- r = f(x) -- Make the call
+ r = f(x) -- Make the call
call resumeThread
restore registers
pop "return address"
@@ -354,7 +348,7 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
-----------------------------------
-- mapping Expr in CmmNode
-mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _ m@(PrimTarget _) = m
@@ -374,7 +368,7 @@ mapExp _ l@(CmmBranch _) = l
mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
-mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
+mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f
@@ -404,10 +398,10 @@ mapExpM f (CmmUnsafeForeignCall tgt fs as)
= case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
-mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
= case mapForeignTargetM f tgt of
- Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
- Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
+ Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+ Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
@@ -430,7 +424,7 @@ mapExpDeepM f = mapExpM $ wrapRecExpM f
-----------------------------------
-- folding Expr in CmmNode
-foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget _ (PrimTarget _) z = z
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index cb3bf0c829..8c36deafbb 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -557,7 +557,7 @@ stmt :: { CmmParse () }
-- we tweak the syntax to avoid the conflict. The later
-- option is taken here because the other way would require
-- multiple levels of expanding and get unwieldy.
- | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+ | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
{% foreignCall $3 $1 $4 $6 $8 $9 }
| foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
{% primCall $1 $4 $6 }
@@ -588,6 +588,9 @@ stmt :: { CmmParse () }
| 'push' '(' exprs0 ')' maybe_body
{ pushStackFrame $3 $5 }
+foreignLabel :: { CmmParse CmmExpr }
+ : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
+
opt_never_returns :: { CmmReturnInfo }
: { CmmMayReturn }
| 'never' 'returns' { CmmNeverReturns }
@@ -1002,8 +1005,7 @@ stmtMacros = listToUFM [
tickyAllocPAP goods slop ),
( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] ->
tickyAllocThunk goods slop ),
- ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode False reg ),
- ( fsLit "UPD_BH_SINGLE_ENTRY", \[reg] -> emitBlackHoleCode True reg )
+ ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg )
]
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 5e9bca30e3..50d02de04e 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -70,7 +70,7 @@ cpsTop hsc_env proc =
----------- Eliminate common blocks -------------------------------------
g <- {-# SCC "elimCommonBlocks" #-}
condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
- Opt_D_dump_cmm_cbe "Post common block elimination"
+ Opt_D_dump_cmm_cbe "Post common block elimination"
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 2a080c2e58..9f8a3975e7 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -390,7 +390,7 @@ tryToInline dflags live node assigs = go usages node [] assigs
occurs_once = not (l `elemRegSet` live)
&& lookupUFM usages l == Just 1
- inl_node = mapExpDeep inline node
+ inl_node = mapExpDeep inline node -- mapExpDeep is where the inlining actually takes place!
where inline (CmmReg (CmmLocal l')) | l == l' = rhs
inline (CmmRegOff (CmmLocal l') off) | l == l'
= cmmOffset dflags rhs off
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 78e5562d81..a5acffb2f7 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -424,7 +424,7 @@ ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyM
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
insertBlock block map =
- ASSERT (isNothing $ mapLookup id map)
+ ASSERT(isNothing $ mapLookup id map)
mapInsert id block map
where id = entryLabel block
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 45c415f35a..b0c9bd3f2f 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -189,7 +189,6 @@ pprStmt stmt =
rep = cmmExprType dflags src
CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
- maybe_proto $$
fnCall
where
(res_hints, arg_hints) = foreignTargetHints target
@@ -200,40 +199,29 @@ pprStmt stmt =
cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
- real_fun_proto lbl = char ';' <>
- pprCFunType (ppr lbl) cconv hresults hargs <>
- noreturn_attr <> semi
-
- noreturn_attr = case ret of
- CmmNeverReturns -> text "__attribute__ ((noreturn))"
- CmmMayReturn -> empty
-
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
- (maybe_proto, fnCall) =
+ fnCall =
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- let myCall = pprCall (ppr lbl) cconv hresults hargs
- in (real_fun_proto lbl, myCall)
+ pprCall (ppr lbl) cconv hresults hargs
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
- let myCall = pprCall (ppr lbl) cconv hresults hargs
- in (real_fun_proto lbl, myCall)
+ pprCall cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
pprForeignCall (ppr lbl) cconv hresults hargs
_ ->
- (empty {- no proto -},
- pprCall cast_fn cconv hresults hargs <> semi)
+ pprCall cast_fn cconv hresults hargs <> semi
-- for a dynamic call, no declaration is necessary.
CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
CmmUnsafeForeignCall target@(PrimTarget op) results args ->
- proto $$ fn_call
+ fn_call
where
cconv = CCallConv
fn = pprCallishMachOp_for_C op
@@ -242,15 +230,16 @@ pprStmt stmt =
hresults = zip results res_hints
hargs = zip args arg_hints
- (proto, fn_call)
+ fn_call
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
-- We also need to cast mem primops to prevent conflicts with GCC
-- builtins (see bug #5967).
| op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
- = pprForeignCall fn cconv hresults (init hargs)
+ = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$
+ pprForeignCall fn cconv hresults (init hargs)
| otherwise
- = (empty, pprCall fn cconv hresults hargs)
+ = pprCall fn cconv hresults hargs
CmmBranch ident -> pprBranch ident
CmmCondBranch expr yes no -> pprCondBranch expr yes no
@@ -263,8 +252,8 @@ pprStmt stmt =
type Hinted a = (a, ForeignHint)
pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
- -> (SDoc, SDoc)
-pprForeignCall fn cconv results args = (proto, fn_call)
+ -> SDoc
+pprForeignCall fn cconv results args = fn_call
where
fn_call = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
@@ -272,7 +261,6 @@ pprForeignCall fn cconv results args = (proto, fn_call)
$$ pprCall (text "ghcFunPtr") cconv results args <> semi
)
cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
- proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
@@ -750,6 +738,7 @@ pprCallishMachOp_for_C mop
MO_Memcpy -> ptext (sLit "memcpy")
MO_Memset -> ptext (sLit "memset")
MO_Memmove -> ptext (sLit "memmove")
+ (MO_BSwap w) -> ptext (sLit $ bSwapLabel w)
(MO_PopCnt w) -> ptext (sLit $ popCntLabel w)
(MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index f3e2a02737..46257b4188 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -247,14 +247,15 @@ pprNode node = pp_node <+> pp_debug
| Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma
| otherwise = empty
- CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
+ CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
[ ptext (sLit "foreign call"), space
, ppr t, ptext (sLit "(...)"), space
, ptext (sLit "returns to") <+> ppr s
<+> ptext (sLit "args:") <+> parens (ppr as)
<+> ptext (sLit "ress:") <+> parens (ppr rs)
- , ptext (sLit "upd:") <+> ppr u
+ , ptext (sLit "ret_args:") <+> ppr a
+ , ptext (sLit "ret_off:") <+> ppr u
, semi ]
pp_debug :: SDoc
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 6f569ef6fa..c54f6d5f9d 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -16,6 +16,11 @@ module SMRep (
WordOff, ByteOff,
roundUpToWords,
+#if __GLASGOW_HASKELL__ > 706
+ -- ** Immutable arrays of StgWords
+ UArrayStgWord, listArray, toByteArray,
+#endif
+
-- * Closure repesentation
SMRep(..), -- CmmInfo sees the rep; no one else does
IsStatic,
@@ -49,8 +54,13 @@ import DynFlags
import Outputable
import Platform
import FastString
+import qualified Data.Array.Base as Array
+
+#if __GLASGOW_HASKELL__ > 706
+import GHC.Base ( ByteArray# )
+import Data.Ix
+#endif
-import Data.Array.Base
import Data.Char( ord )
import Data.Word
import Data.Bits
@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64
#if __GLASGOW_HASKELL__ < 706
Num,
#endif
- Bits, IArray UArray)
+
+#if __GLASGOW_HASKELL__ <= 706
+ Array.IArray Array.UArray,
+#endif
+ Bits)
fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i
@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
\end{code}
+%************************************************************************
+%* *
+ Immutable arrays of StgWords
+%* *
+%************************************************************************
+
+\begin{code}
+
+#if __GLASGOW_HASKELL__ > 706
+-- TODO: Improve with newtype coercions!
+
+newtype UArrayStgWord i = UArrayStgWord (Array.UArray i Word64)
+
+listArray :: Ix i => (i, i) -> [StgWord] -> UArrayStgWord i
+listArray (i,j) words
+ = UArrayStgWord $ Array.listArray (i,j) (map unStgWord words)
+ where unStgWord (StgWord w64) = w64
+
+toByteArray :: UArrayStgWord i -> ByteArray#
+toByteArray (UArrayStgWord (Array.UArray _ _ _ b)) = b
+
+#endif
+
+\end{code}
%************************************************************************
%* *
View Lorry Controller Status