Commit f13f9fca authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 735519b4 da15d0c5
module CmmCallConv (
ParamLocation(..),
ArgumentFormat,
assignArguments,
assignArgumentsPos,
argumentsSize,
assignArgumentsPos
) where
#include "HsVersions.h"
......@@ -21,25 +18,19 @@ import Outputable
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
data ParamLocation a
data ParamLocation
= RegisterParam GlobalReg
| StackParam a
| StackParam ByteOff
instance (Outputable a) => Outputable (ParamLocation a) where
instance Outputable ParamLocation where
ppr (RegisterParam g) = ppr g
ppr (StackParam p) = ppr p
type ArgumentFormat a b = [(a, ParamLocation b)]
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
-- Stack parameters are returned as word offsets.
assignArguments _ _ = panic "assignArguments only used in dead codegen" -- assignments
-- | JD: For the new stack story, I want arguments passed on the stack to manifest as
-- positive offsets in a CallArea, not negative offsets from the stack pointer.
-- Also, I want byte offsets, not word offsets.
assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
ArgumentFormat a ByteOff
assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] ->
[(a, ParamLocation)]
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
assignArgumentsPos conv arg_ty reps = assignments
......@@ -96,14 +87,6 @@ assignArgumentsPos conv arg_ty reps = assignments
where w = typeWidth (arg_ty r)
size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
off' = offset + size
argumentsSize :: (a -> CmmType) -> [a] -> WordOff
argumentsSize f reps = maximum (0 : map arg_top args)
where
args = assignArguments f reps
arg_top (_, StackParam offset) = -offset
arg_top (_, RegisterParam _) = 0
-----------------------------------------------------------------------------
-- Local information about the registers available
......
......@@ -83,7 +83,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
strip_hints :: [Old.CmmHinted a] -> [a]
strip_hints = map Old.hintlessCmm
convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget
convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget
convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
......
......@@ -10,7 +10,7 @@ module CmmDecl (
GenCmm(..), GenCmmTop(..),
CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
ProfilingInfo(..), ClosureTypeTag,
CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..),
CmmActual, CmmFormal, ForeignHint(..),
CmmStatic(..), Section(..),
) where
......@@ -114,8 +114,6 @@ type SelectorOffset = StgWord
type CmmActual = CmmExpr
type CmmFormal = LocalReg
type CmmActuals = [CmmActual]
type CmmFormals = [CmmFormal]
data ForeignHint
= NoHint | AddrHint | SignedHint
......
......@@ -42,8 +42,8 @@ data CmmNode e x where
-- Like a "fat machine instruction"; can occur
-- in the middle of a block
ForeignTarget -> -- call target
CmmFormals -> -- zero or more results
CmmActuals -> -- zero or more arguments
[CmmFormal] -> -- zero or more results
[CmmActual] -> -- zero or more arguments
CmmNode O O
-- Semantics: kills only result regs; all other regs (both GlobalReg
-- and LocalReg) are preserved. But there is a current
......@@ -105,8 +105,8 @@ data CmmNode e x where
CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
-- Always the last node of a block
tgt :: ForeignTarget, -- call target and convention
res :: CmmFormals, -- zero or more results
args :: CmmActuals, -- zero or more arguments; see Note [Register parameter passing]
res :: [CmmFormal], -- zero or more results
args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
succ :: Label, -- Label of continuation
updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
intrbl:: Bool -- whether or not the call is interruptible
......
......@@ -234,7 +234,7 @@ algorithm would be just as good, so that's what we do.
-}
data Protocol = Protocol Convention CmmFormals Area
data Protocol = Protocol Convention [CmmFormal] Area
deriving Eq
instance Outputable Protocol where
ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
......
......@@ -289,6 +289,10 @@ boundedOrdLattice n = DataflowLattice n minBound f
-- Custom node type we'll rewrite to. CmmAssign nodes to local
-- registers are replaced with AssignLocal nodes.
data WithRegUsage n e x where
-- Plain will not contain CmmAssign nodes immediately after
-- transformation, but as we rewrite assignments, we may have
-- assignments here: these are assignments that should not be
-- rewritten!
Plain :: n e x -> WithRegUsage n e x
AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
......
......@@ -119,25 +119,25 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
---------- Calls
mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] ->
UpdFrameOffset -> CmmAGraph
mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] ->
UpdFrameOffset -> CmmAGraph
-- Native C-- calling convention
mkSafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
mkUnsafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> Bool -> CmmAGraph
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-- Never returns; like exit() or barf()
---------- Control transfer
mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkDirectJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkBranch :: BlockId -> CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
......@@ -288,8 +288,8 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- the variables in their spill slots.
-- Therefore, for copying arguments and results, we provide different
-- functions to pass the arguments in an overflow area and to pass them in spill slots.
copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
copyInSlot :: Convention -> CmmFormals -> [CmmNode O O]
copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O]
copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
......@@ -298,7 +298,7 @@ copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slot
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
(ByteOff, [CmmNode O O])
type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O])
type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
......@@ -331,7 +331,7 @@ oneCopySlotI _ (reg, _) (n, ms) =
-- Factoring out the common parts of the copyout functions yielded something
-- more complicated:
copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset ->
(Int, CmmAGraph)
-- Generate code to move the actual parameters into the locations
-- required by the calling convention. This includes a store for the return address.
......@@ -355,7 +355,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
else ([], 0)
Old -> ([], updfr_off)
args :: [(CmmExpr, ParamLocation ByteOff)] -- The argument and where to put it
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
args = assignArgumentsPos conv cmmExprType actuals
args' = foldl adjust setRA args
......@@ -372,10 +372,10 @@ copyOutSlot conv actuals = foldr co [] args
toExp r = CmmReg (CmmLocal r)
args = assignArgumentsPos conv localRegType actuals
mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph)
mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset ->
(ByteOff -> CmmAGraph) -> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last =
let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
......
......@@ -14,7 +14,7 @@ module OldCmm (
cmmMapGraphM, cmmTopMapGraphM,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
HintedCmmFormal, HintedCmmActual,
CmmSafety(..), CmmCallTarget(..),
module CmmDecl,
module CmmExpr,
......@@ -146,8 +146,8 @@ data CmmStmt -- Old-style
| CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
HintedCmmFormals -- zero or more results
HintedCmmActuals -- zero or more arguments
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmSafety -- whether to build a continuation
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
......@@ -164,22 +164,20 @@ data CmmStmt -- Old-style
-- Undefined outside range, and when there's a Nothing
| CmmJump CmmExpr -- Jump to another C-- function,
HintedCmmActuals -- with these parameters. (parameters never used)
[HintedCmmActual] -- with these parameters. (parameters never used)
| CmmReturn -- Return from a native C-- function,
HintedCmmActuals -- with these return values. (parameters never used)
[HintedCmmActual] -- with these return values. (parameters never used)
data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint }
deriving( Eq )
type HintedCmmActuals = [HintedCmmActual]
type HintedCmmFormals = [HintedCmmFormal]
type HintedCmmFormal = CmmHinted CmmFormal
type HintedCmmActual = CmmHinted CmmActual
data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
-- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
instance UserOfLocalRegs CmmStmt where
foldRegsUsed f (set::b) s = stmt s set
where
......
......@@ -78,8 +78,8 @@ cheapEqReg _ _ = False
---------------------------------------------------
loadArgsIntoTemps :: [Unique]
-> HintedCmmActuals
-> ([Unique], [CmmStmt], HintedCmmActuals)
-> [HintedCmmActual]
-> ([Unique], [CmmStmt], [HintedCmmActual])
loadArgsIntoTemps uniques [] = (uniques, [], [])
loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
(uniques'',
......
......@@ -266,7 +266,7 @@ pprStmt stmt = case stmt of
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> SDoc
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
= res_type ress <+>
parens (text (ccallConvAttribute cconv) <> ppr_fn) <>
......@@ -807,7 +807,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety
pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
......
More notes (June 11)
~~~~~~~~~~~~~~~~~~~~
* Kill dead code assignArguments, argumentsSize in CmmCallConv.
Bake in ByteOff to ParamLocation and ArgumentFormat
CmmActuals -> [CmmActual] similary CmmFormals
* Possible refactoring: Nuke AGraph in favour of
mkIfThenElse :: Expr -> Graph -> Graph -> FCode Graph
or even
......
......@@ -43,7 +43,7 @@ import Control.Monad
-- Code generation for Foreign Calls
cgForeignCall
:: HintedCmmFormals -- where to put the results
:: [HintedCmmFormal] -- where to put the results
-> ForeignCall -- the op
-> [StgArg] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -64,7 +64,7 @@ cgForeignCall results fcall stg_args live
emitForeignCall
:: HintedCmmFormals -- where to put the results
:: [HintedCmmFormal] -- where to put the results
-> ForeignCall -- the op
-> [CmmHinted CmmExpr] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -109,9 +109,12 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
-- alternative entry point, used by CmmParse
-- the new code generator has utility function emitCCall and emitPrimCall
-- which should be used instead of this (the equivalent emitForeignCall
-- is not presently exported.)
emitForeignCall'
:: Safety
-> HintedCmmFormals -- where to put the results
-> [HintedCmmFormal] -- where to put the results
-> CmmCallTarget -- the op
-> [CmmHinted CmmExpr] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them
......
......@@ -53,7 +53,7 @@ import Outputable
-- representation as a list of 'CmmAddr' is handled later
-- in the pipeline by 'cmmToRawCmm'.
emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code
emitClosureCodeAndInfoTable cl_info args body
= do { blks <- cgStmtsToBlocks body
; info <- mkCmmInfo cl_info
......@@ -412,7 +412,7 @@ funInfoTable info_ptr
emitInfoTableAndCode
:: CLabel -- Label of entry or ret
-> CmmInfo -- ...the info table
-> CmmFormals -- ...args
-> [CmmFormal] -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
......
......@@ -701,6 +701,8 @@ whenC :: Bool -> Code -> Code
whenC True code = code
whenC False _ = nopC
-- Corresponds to 'emit' in new code generator with a smart constructor
-- from cmm/MkGraph.hs
stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)
......@@ -741,7 +743,7 @@ emitData sect lits
where
data_block = CmmData sect lits
emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks
= do { let proc_block = CmmProc info lbl (ListGraph blocks)
; state <- getState
......
......@@ -35,7 +35,7 @@ import FastString
-- ---------------------------------------------------------------------------
-- Code generation for PrimOps
cgPrimOp :: CmmFormals -- where to put the results
cgPrimOp :: [CmmFormal] -- where to put the results
-> PrimOp -- the op
-> [StgArg] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -47,7 +47,7 @@ cgPrimOp results op args live
emitPrimOp results op non_void_args live
emitPrimOp :: CmmFormals -- where to put the results
emitPrimOp :: [CmmFormal] -- where to put the results
-> PrimOp -- the op
-> [CmmExpr] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -638,6 +638,13 @@ setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
-- ----------------------------------------------------------------------------
-- Copying pointer arrays
-- EZY: This code has an unusually high amount of assignTemp calls, seen
-- nowhere else in the code generator. This is mostly because these
-- "primitive" ops result in a surprisingly large amount of code. It
-- will likely be worthwhile to optimize what is emitted here, so that
-- our optimization passes don't waste time repeatedly optimizing the
-- same bits of code.
-- | Takes a source 'Array#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy. Copies the given number of
......
......@@ -104,20 +104,20 @@ emitCCall hinted_results fn hinted_args
fc = ForeignConvention CCallConv arg_hints result_hints
emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode ()
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
emitPrimCall res op args
= emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
-- alternative entry point, used by CmmParse
emitForeignCall
:: Safety
-> CmmFormals -- where to put the results
-> ForeignTarget -- the op
-> CmmActuals -- arguments
:: Safety
-> [CmmFormal] -- where to put the results
-> ForeignTarget -- the op
-> [CmmActual] -- arguments
-> C_SRT -- the SRT of the calls continuation
-> CmmReturnInfo -- This can say "never returns"
-- only RTS procedures do this
-> FCode ()
-> CmmReturnInfo -- This can say "never returns"
-- only RTS procedures do this
-> FCode ()
emitForeignCall safety results target args _srt _ret
| not (playSafe safety) = do
let (caller_save, caller_load) = callerSaveVolatileRegs
......
......@@ -600,7 +600,7 @@ emitData sect lits
where
data_block = CmmData sect lits
emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals ->
emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] ->
CmmAGraph -> FCode ()
emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
......@@ -611,7 +611,7 @@ emitProcWithConvention conv info lbl args blocks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
emitProc :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
emitProc = emitProcWithConvention NativeNodeCall
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
......
......@@ -17,7 +17,11 @@ import StgCmmForeign
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
import StgCmmTicky
import StgCmmHeap
import StgCmmProf
import BasicTypes
import MkGraph
import StgSyn
import CmmDecl
......@@ -281,6 +285,21 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg]
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg]
= emit (mkAssign (CmmLocal res) arg)
-- Copying pointer arrays
emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] =
doCopyArrayOp src src_off dst dst_off n
emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] =
doCopyMutableArrayOp src src_off dst dst_off n
emitPrimOp [res] CloneArrayOp [src,src_off,n] =
emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] =
emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
emitPrimOp [res] FreezeArrayOp [src,src_off,n] =
emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
emitPrimOp [res] ThawArrayOp [src,src_off,n] =
emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
-- Reading/writing pointer arrays
emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix
......@@ -684,3 +703,193 @@ cmmLoadIndexOffExpr off ty base idx
setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
-- ----------------------------------------------------------------------------
-- Copying pointer arrays
-- EZY: This code has an unusually high amount of assignTemp calls, seen
-- nowhere else in the code generator. This is mostly because these
-- "primitive" ops result in a surprisingly large amount of code. It
-- will likely be worthwhile to optimize what is emitted here, so that
-- our optimization passes don't waste time repeatedly optimizing the
-- same bits of code.
-- More closely imitates 'assignTemp' from the old code generator, which
-- returns a CmmExpr rather than a LocalReg.
assignTempE :: CmmExpr -> FCode CmmExpr
assignTempE e = do
t <- assignTemp e
return (CmmReg (CmmLocal t))
-- | Takes a source 'Array#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy. Copies the given number of
-- elements from the source array to the destination array.
doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
doCopyArrayOp = emitCopyArray copy
where
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst = emitMemcpyCall
-- | Takes a source 'MutableArray#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy. Copies the given number of
-- elements from the source array to the destination array.
doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
doCopyMutableArrayOp = emitCopyArray copy
where
-- The only time the memory might overlap is when the two arrays
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
[moveCall, cpyCall] <- forkAlts [
getCode $ emitMemmoveCall dst_p src_p bytes,
getCode $ emitMemcpyCall dst_p src_p bytes
]
emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
-> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
-- Passed as arguments (be careful)
src <- assignTempE src0
src_off <- assignTempE src_off0
dst <- assignTempE dst0
dst_off <- assignTempE dst_off0
n <- assignTempE n0
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize
dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off
src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
copy src dst dst_p src_p bytes
-- The base address of the destination card table
dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
emitSetCards dst_off dst_cards_p n
-- | Takes an info table label, a register to return the newly
-- allocated array in, a source array, an offset in the source array,
-- and the number of elements to copy. Allocates a new array and
-- initializes it form the source array.
emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCloneArray info_p res_r src0 src_off0 n0 = do
-- Passed as arguments (be careful)
src <- assignTempE src0
src_off <- assignTempE src_off0
n <- assignTempE n0
card_words <- assignTempE $ (n `cmmUShrWord`
(CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
`cmmAddWord` CmmLit (mkIntCLit 1)
size <- assignTempE $ n `cmmAddWord` card_words
words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
arr_r <- newTemp bWord
emitAllocateCall arr_r myCapability words
tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
(CmmLit $ mkIntCLit 0)
let arr = CmmReg (CmmLocal arr_r)
emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
oFFSET_StgMutArrPtrs_ptrs)) n
emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
oFFSET_StgMutArrPtrs_size)) size
dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize
src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
src_off
emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize)
emitMemsetCall (cmmOffsetExprW dst_p n)
(CmmLit (mkIntCLit 1))
(card_words `cmmMulWord` wordSize)
emit $ mkAssign (CmmLocal res_r) arr