Skip to content

GitLab

GHC
GHC
Commit 19be2021 authored by Simon Marlow's avatar Simon Marlow
Browse files
Options

Different implementation of MkGraph

parent 9b6dbdea
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 466 additions and 448 deletions
compiler/cmm/MkGraph.hs
View file @ 19be2021
This diff is collapsed.
compiler/codeGen/StgCmmBind.hs
View file @ 19be2021
......@@ -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 }
......
compiler/codeGen/StgCmmExpr.hs
View file @ 19be2021
......@@ -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" -- ???
......
compiler/codeGen/StgCmmForeign.hs
View file @ 19be2021
......@@ -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
......
compiler/codeGen/StgCmmHeap.hs
View file @ 19be2021
......@@ -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
......
compiler/codeGen/StgCmmLayout.hs
View file @ 19be2021
......@@ -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
......
compiler/codeGen/StgCmmMonad.hs
View file @ 19be2021
{-# 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)) }
compiler/codeGen/StgCmmPrim.hs
View file @ 19be2021
......@@ -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 ())
......
compiler/codeGen/StgCmmProf.hs
View file @ 19be2021
......@@ -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
......
compiler/codeGen/StgCmmTicky.hs
View file @ 19be2021
......@@ -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