Commit 19be2021 authored by Simon Marlow's avatar Simon Marlow

Different implementation of MkGraph

parent 9b6dbdea
This diff is collapsed.
......@@ -109,7 +109,7 @@ cgBind (StgNonRec name rhs)
; emit (init <*> body) }
cgBind (StgRec pairs)
= do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
= do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
; addBindsC new_binds
......@@ -547,10 +547,10 @@ emitBlackHoleCode is_single_entry = do
whenC eager_blackholing $ do
tickyBlackHole (not is_single_entry)
emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
(CmmReg (CmmGlobal CurrentTSO)))
emitStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
(CmmReg (CmmGlobal CurrentTSO))
emitPrimCall [] MO_WriteBarrier []
emit (mkStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)))
emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
......@@ -596,7 +596,7 @@ pushUpdateFrame es body
offset <- foldM push updfr es
withUpdFrameOff offset body
where push off e =
do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
do emitStore (CmmStackSlot (CallArea Old) base) e
return base
where base = off + widthInBytes (cmmExprWidth e)
......@@ -664,13 +664,13 @@ link_caf _is_upd = do
-- node is live, so save it.
-- see Note [atomic CAF entry] in rts/sm/Storage.c
; emit $ mkCmmIfThen
(CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $
; emit =<< mkCmmIfThen
(CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit])
-- re-enter R1. Doing this directly is slightly dodgy; we're
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in
mkJump target [] 0
(let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in
mkJump target [] 0)
; return hp_rel }
......
......@@ -77,7 +77,7 @@ cgExpr (StgLetNoEscape _ _ binds expr) =
; let join_id = mkBlockId (uniqFromSupply us)
; cgLneBinds join_id binds
; cgExpr expr
; emit $ mkLabel join_id}
; emitLabel join_id}
cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
cgCase expr bndr srt alt_type alts
......@@ -130,7 +130,7 @@ cgLetNoEscapeRhs
cgLetNoEscapeRhs join_id local_cc bndr rhs =
do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
; emitOutOfLine bid $ rhs_body <*> mkBranch join_id
; return info
}
......@@ -319,7 +319,7 @@ cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts
do { when (not reps_compatible) $
panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
; v_info <- getCgIdInfo v
; emit (mkAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info))
; emitAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info)
; _ <- bindArgsToRegs [NonVoid bndr]
; cgAlts NoGcInAlts (NonVoid bndr) alt_type alts }
where
......@@ -330,8 +330,11 @@ cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _
do { mb_cc <- maybeSaveCostCentre True
; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut)
; restoreCurrentCostCentre mb_cc
; emit $ mkComment $ mkFastString "should be unreachable code"
; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)}
; emitComment $ mkFastString "should be unreachable code"
; l <- newLabelC
; emitLabel l
; emit (mkBranch l)
}
{-
case seq# a s of v
......@@ -433,7 +436,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts
tagged_cmms' = [(lit,code)
| (LitAlt lit, code) <- tagged_cmms]
; emit (mkCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt) }
; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt }
cgAlts gc_plan bndr (AlgAlt tycon) alts
= do { tagged_cmms <- cgAltRhss gc_plan bndr alts
......@@ -517,8 +520,8 @@ cgIdApp fun_id args
cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
cgLneJump blk_id lne_regs args -- Join point; discard sequel
= do { cmm_args <- getNonVoidArgAmodes args
; emit (mkMultiAssign lne_regs cmm_args
<*> mkBranch blk_id) }
; emitMultiAssign lne_regs cmm_args
; emit (mkBranch blk_id) }
cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
cgTailCall fun_id fun_info args = do
......@@ -532,24 +535,24 @@ cgTailCall fun_id fun_info args = do
do { let fun' = CmmLoad fun (cmmExprType fun)
; [ret,call] <- forkAlts [
getCode $ emitReturn [fun], -- Is tagged; no need to untag
getCode $ do -- emit (mkAssign nodeReg fun)
getCode $ do -- emitAssign nodeReg fun
emitCall (NativeNodeCall, NativeReturn)
(entryCode fun') [fun]] -- Not tagged
; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
; emit =<< mkCmmIfThenElse (cmmIsTagged fun) ret call }
SlowCall -> do -- A slow function call via the RTS apply routines
{ tickySlowCall lf_info args
; emit $ mkComment $ mkFastString "slowCall"
; emitComment $ mkFastString "slowCall"
; slowCall fun args }
-- A direct function call (possibly with some left-over arguments)
DirectEntry lbl arity -> do
{ tickyDirectCall arity args
; if node_points then
do emit $ mkComment $ mkFastString "directEntry"
emit (mkAssign nodeReg fun)
do emitComment $ mkFastString "directEntry"
emitAssign nodeReg fun
directCall lbl arity args
else do emit $ mkComment $ mkFastString "directEntry else"
else do emitComment $ mkFastString "directEntry else"
directCall lbl arity args }
JumpToIt {} -> panic "cgTailCall" -- ???
......
......@@ -127,7 +127,8 @@ emitForeignCall safety results target args _srt _ret
| otherwise = do
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
emit =<< mkSafeCall temp_target results args updfr_off
(playInterruptible safety)
{-
......@@ -160,7 +161,7 @@ maybe_assign_temp e
-- expressions, which are wrong here.
-- this is a NonPtr because it only duplicates an existing
reg <- newTemp (cmmExprType e) --TODO FIXME NOW
emit (mkAssign (CmmLocal reg) e)
emitAssign (CmmLocal reg) e
return (CmmReg (CmmLocal reg))
-- -----------------------------------------------------------------------------
......@@ -182,12 +183,12 @@ saveThreadState =
emitSaveThreadState :: BlockId -> FCode ()
emitSaveThreadState bid = do
-- CurrentTSO->stackobj->sp = Sp;
emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
(CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
emit closeNursery
-- and save the current cost centre stack in the TSO when profiling:
when opt_SccProfilingOn $
emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
emitStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
-- CurrentNursery->free = Hp+1;
closeNursery :: CmmAGraph
......
......@@ -109,7 +109,7 @@ allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
-- ALLOCATE THE OBJECT
; base <- getHpRelOffset info_offset
; emit (mkComment $ mkFastString "allocDynClosure")
; emitComment $ mkFastString "allocDynClosure"
; emitSetDynHdr base info_ptr use_cc
; let (cmm_args, offsets) = unzip amodes_w_offsets
; hpStore base cmm_args offsets
......@@ -410,7 +410,8 @@ entryHeapCheck cl_info offset nodeSet arity args code
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
altHeapCheck regs code
= do updfr_sz <- getUpdFrameOff
heapCheck False (gc_call updfr_sz) code
gc_call_code <- gc_call updfr_sz
heapCheck False gc_call_code code
where
reg_exprs = map (CmmReg . CmmLocal) regs
......@@ -451,7 +452,7 @@ heapCheck checkStack do_gc code
= getHeapUsage $ \ hpHw ->
-- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
do { emit $ do_checks checkStack hpHw do_gc
do { codeOnly $ do_checks checkStack hpHw do_gc
; tickyAllocHeap hpHw
; doGranAllocate hpHw
; setRealHp hpHw
......@@ -460,22 +461,27 @@ heapCheck checkStack do_gc code
do_checks :: Bool -- Should we check the stack?
-> WordOff -- Heap headroom
-> CmmAGraph -- What to do on failure
-> CmmAGraph
do_checks checkStack alloc do_gc
= withFreshLabel "gc" $ \ loop_id ->
withFreshLabel "gc" $ \ gc_id ->
mkLabel loop_id
<*> (let hpCheck = if alloc == 0 then mkNop
else mkAssign hpReg bump_hp <*>
mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
in if checkStack
then mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
else hpCheck)
<*> mkComment (mkFastString "outOfLine should follow:")
<*> outOfLine (mkLabel gc_id
<*> mkComment (mkFastString "outOfLine here")
<*> do_gc
<*> mkBranch loop_id)
-> FCode ()
do_checks checkStack alloc do_gc = do
loop_id <- newLabelC
gc_id <- newLabelC
emitLabel loop_id
hp_check <- if alloc == 0
then return mkNop
else do
ifthen <- mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
return (mkAssign hpReg bump_hp <*> ifthen)
if checkStack
then emit =<< mkCmmIfThenElse sp_oflo (mkBranch gc_id) hp_check
else emit hp_check
emit $ mkComment (mkFastString "outOfLine should follow:")
emitOutOfLine gc_id $
mkComment (mkFastString "outOfLine here") <*>
do_gc <*>
mkBranch loop_id
-- Test for stack pointer exhaustion, then
-- bump heap pointer, and test for heap exhaustion
-- Note that we don't move the heap pointer unless the
......
......@@ -74,14 +74,14 @@ emitReturn :: [CmmExpr] -> FCode ()
emitReturn results
= do { sequel <- getSequel;
; updfr_off <- getUpdFrameOff
; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
; emitComment $ mkFastString ("emitReturn: " ++ show sequel)
; case sequel of
Return _ ->
do { adjustHpBackwards
; emit (mkReturnSimple results updfr_off) }
AssignTo regs adjust ->
do { if adjust then adjustHpBackwards else return ()
; emit (mkMultiAssign regs results) }
; emitMultiAssign regs results }
}
emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ()
......@@ -91,10 +91,10 @@ emitCall convs@(callConv, _) fun args
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
; emitComment $ mkFastString ("emitCall: " ++ show sequel)
; case sequel of
Return _ -> emit (mkForeignJump callConv fun args updfr_off)
AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off)
AssignTo res_regs _ -> emit =<< mkCall fun convs res_regs args updfr_off
}
adjustHpBackwards :: FCode ()
......@@ -179,7 +179,7 @@ slow_call fun args reps
= do dflags <- getDynFlags
let platform = targetPlatform dflags
call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++
emitComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++
" with pat " ++ showSDoc (ftext rts_fun))
emit (mkAssign nodeReg fun <*> call)
where
......
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
--
-- Monad for Stg to C-- code generation
......@@ -20,12 +21,17 @@ module StgCmmMonad (
returnFC, fixC, fixC_, nopC, whenC,
newUnique, newUniqSupply,
newLabelC, emitLabel,
emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc,
emitOutOfLine, emitAssign, emitStore, emitComment,
getCmm, cgStmtsToBlocks,
getCodeR, getCode, getHeapUsage,
forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
mkCmmIfThenElse, mkCmmIfThen, mkCall, mkCmmCall, mkSafeCall,
forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
ConTagZ,
......@@ -69,12 +75,14 @@ import VarEnv
import OrdList
import Unique
import UniqSupply
import FastString(sLit)
import FastString
import Outputable
import Compiler.Hoopl hiding (Unique, (<*>), mkLabel, mkBranch, mkLast)
import Control.Monad
import Data.List
import Prelude hiding( sequence )
import Prelude hiding( sequence, succ )
import qualified Prelude( sequence )
infixr 9 `thenC` -- Right-associative!
......@@ -270,6 +278,8 @@ data HeapUsage =
type VirtualHpOffset = WordOff
initCgState :: UniqSupply -> CgState
initCgState uniqs
= MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
......@@ -308,7 +318,6 @@ initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
--------------------------------------------------------
-- Operators for getting and setting the state and "info_down".
--------------------------------------------------------
......@@ -591,6 +600,33 @@ getHeapUsage fcode
-- ----------------------------------------------------------------------------
-- Combinators for emitting code
emitCgStmt :: CgStmt -> FCode ()
emitCgStmt stmt
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
}
emitLabel :: BlockId -> FCode ()
emitLabel id = emitCgStmt (CgLabel id)
emitComment :: FastString -> FCode ()
#ifdef DEBUG
emitComment s = emitCgStmt (CgStmt (CmmComment s))
#else
emitComment s = return ()
#endif
emitAssign :: CmmReg -> CmmExpr -> FCode ()
emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
emitStore :: CmmExpr -> CmmExpr -> FCode ()
emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
newLabelC :: FCode BlockId
newLabelC = do { u <- newUnique
; return $ mkBlockId u }
emit :: CmmAGraph -> FCode ()
emit ag
= do { state <- getState
......@@ -601,6 +637,9 @@ emitDecl decl
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] ->
CmmAGraph -> FCode ()
emitProcWithConvention conv info lbl args blocks
......@@ -629,6 +668,53 @@ getCmm code
; setState $ state2 { cgs_tops = cgs_tops state1 }
; return (fromOL (cgs_tops state2)) }
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse e tbranch fbranch = do
endif <- newLabelC
tid <- newLabelC
fid <- newLabelC
return $ mkCbranch e tid fid <*>
mkLabel tid <*> tbranch <*> mkBranch endif <*>
mkLabel fid <*> fbranch <*> mkLabel endif
mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen e tbranch = do
endif <- newLabelC
tid <- newLabelC
return $ mkCbranch e tid endif <*>
mkLabel tid <*> tbranch <*> mkLabel endif
mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
-> UpdFrameOffset -> FCode CmmAGraph
mkCall f (callConv, retConv) results actuals updfr_off = do
k <- newLabelC
let area = CallArea $ Young k
(off, copyin) = copyInOflow retConv area results
copyout = lastWithArgs Call area callConv actuals updfr_off
(toCall f (Just k) updfr_off off)
return (copyout <*> mkLabel k <*> copyin)
mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
-> FCode CmmAGraph
mkCmmCall f results actuals
= mkCall f (NativeDirectCall, NativeReturn) results actuals
mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
-> UpdFrameOffset -> Bool
-> FCode CmmAGraph
mkSafeCall t fs as upd i = do
k <- newLabelC
return
( mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i})
<*> mkLabel k)
-- ----------------------------------------------------------------------------
-- CgStmts
......@@ -640,4 +726,3 @@ cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
cgStmtsToBlocks stmts
= do { us <- newUniqSupply
; return (initUs_ us (lgraphOfAGraph stmts)) }
......@@ -228,23 +228,23 @@ emitPrimOp [res] SparkOp [arg]
[(tmp2,NoHint)]
(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
[(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
emitPrimOp [res] GetCCSOfOp [arg]
= emit (mkAssign (CmmLocal res) val)
= emitAssign (CmmLocal res) val
where
val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg)
| otherwise = CmmLit zeroCLit
emitPrimOp [res] GetCurrentCCSOp [_dummy_arg]
= emit (mkAssign (CmmLocal res) curCCS)
= emitAssign (CmmLocal res) curCCS
emitPrimOp [res] ReadMutVarOp [mutv]
= emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
= emitAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)
emitPrimOp [] WriteMutVarOp [mutv,var]
= do
emit (mkStore (cmmOffsetW mutv fixedHdrSize) var)
emitStore (cmmOffsetW mutv fixedHdrSize) var
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
......@@ -268,32 +268,32 @@ emitPrimOp res@[] TouchOp args@[_arg]
-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
emitPrimOp [res] ByteArrayContents_Char [arg]
= emit (mkAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
= emitAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)
-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
emitPrimOp [res] StableNameToIntOp [arg]
= emit (mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
= emitAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
-- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp [res] EqStableNameOp [arg1,arg2]
= emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [
= emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [
cmmLoadIndexW arg1 fixedHdrSize bWord,
cmmLoadIndexW arg2 fixedHdrSize bWord
]))
])
emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
= emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
= emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])
-- #define addrToHValuezh(r,a) r=(P_)a
emitPrimOp [res] AddrToAnyOp [arg]
= emit (mkAssign (CmmLocal res) arg)
= emitAssign (CmmLocal res) arg
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- Note: argument may be tagged!
emitPrimOp [res] DataToTagOp [arg]
= emit (mkAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
= emitAssign (CmmLocal res) (getConstrTag (cmmUntag arg))
{- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
......@@ -316,7 +316,7 @@ emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg]
-- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg]
= emit (mkAssign (CmmLocal res) arg)
= emitAssign (CmmLocal res) arg
-- Copying pointer arrays
......@@ -474,11 +474,11 @@ emitPrimOp [res] PopCntOp [w] = emitPopCntCall res w wordWidth
-- The rest just translate straightforwardly
emitPrimOp [res] op [arg]
| nopOp op
= emit (mkAssign (CmmLocal res) arg)
= emitAssign (CmmLocal res) arg
| Just (mop,rep) <- narrowOp op
= emit (mkAssign (CmmLocal res) $
CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
= emitAssign (CmmLocal res) $
CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]
emitPrimOp r@[res] op args
| Just prim <- callishOp op
......@@ -723,15 +723,15 @@ loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
-> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
mkBasicIndexedRead off Nothing read_rep res base idx
= emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
= emitAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)
mkBasicIndexedRead off (Just cast) read_rep res base idx
= emit (mkAssign (CmmLocal res) (CmmMachOp cast [
cmmLoadIndexOffExpr off read_rep base idx]))
= emitAssign (CmmLocal res) (CmmMachOp cast [
cmmLoadIndexOffExpr off read_rep base idx])
mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
-> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
mkBasicIndexedWrite off Nothing base idx val
= emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val)
= emitStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val
mkBasicIndexedWrite off (Just cast) base idx val
= mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
......@@ -782,7 +782,7 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)),
getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1))
]
emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
......@@ -840,7 +840,7 @@ doCopyMutableArrayOp = emitCopyArray copy
getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)),
getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE))
]
emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
......
......@@ -103,7 +103,7 @@ initUpdFrameProf :: CmmExpr -> FCode ()
-- Initialise the profiling field of an update frame
initUpdFrameProf frame_amode
= ifProfiling $ -- frame->header.prof.ccs = CCCS
emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
emitStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS
-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
-- is unnecessary because it is not used anyhow.
......@@ -143,7 +143,7 @@ saveCurrentCostCentre
= return Nothing
| otherwise
= do { local_cc <- newTemp ccType
; emit (mkAssign (CmmLocal local_cc) curCCS)
; emitAssign (CmmLocal local_cc) curCCS
; return (Just local_cc) }
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
......@@ -337,9 +337,9 @@ ldvEnter cl_ptr
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-- era | LDV_STATE_USE }
emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
(mkStore ldv_wd new_ldv_wd)
mkNop)
mkNop
where
-- don't forget to substract node's tag
ldv_wd = ldvWord cl_ptr
......
......@@ -181,7 +181,7 @@ registerTickyCtr :: CLabel -> FCode ()
-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
-- f_ct.registeredp = 1 }
registerTickyCtr ctr_lbl
= emit (mkCmmIfThen test (catAGraphs register_stmts))
= emit =<< mkCmmIfThen test (catAGraphs register_stmts)
where
-- krc: code generator doesn't handle Not, so we test for Eq 0 instead
test = CmmMachOp (MO_Eq wordWidth)
......@@ -353,7 +353,7 @@ bumpHistogram _lbl _n
bumpHistogramE :: LitString -> CmmExpr -> FCode ()
bumpHistogramE lbl n
= do t <- newTemp cLong
emit (mkAssign (CmmLocal t) n)
emitAssign (CmmLocal t) n