-absC :: AbstractC -> Code
-absC more_absC = do
- state@(MkCgState absC binds usage) <- getState
- setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
-\end{code}
-
-These two are just like @absC@, except they examine the compilation
-info (whether SCC profiling or profiling-ctrs going) and possibly emit
-nothing.
-
-\begin{code}
-costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args
- | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
- | otherwise = nopC
-
-profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args
- | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
- | otherwise = nopC
-
-profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
-profCtrAbsC macro args
- | opt_DoTickyProfiling = CCallProfCtrMacro macro args
- | otherwise = AbsCNop
-
-ldvEnter :: Code
-ldvEnter = costCentresC SLIT("LDV_ENTER") [CReg node]
-
-{- Try to avoid adding too many special compilation strategies here.
- It's better to modify the header files as necessary for particular
- targets, so that we can get away with as few variants of .hc files
- as possible.
--}
-\end{code}
-
-@getAbsC@ compiles the code in the current environment, and returns
-the abstract C thus constructed (leaving the abstract C being carried
-around in the state untouched). @getAbsC@ does not generate any
-in-line Abstract~C itself, but the environment it returns is that
-obtained from the compilation.
-
-\begin{code}
-getAbsC :: Code -> FCode AbstractC
-getAbsC code = do
- MkCgState absC binds usage <- getState
- ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
- setState $ MkCgState absC binds2 usage2
- return absC2
-\end{code}
+whenC :: Bool -> Code -> Code
+whenC True code = code
+whenC False code = nopC
+
+stmtC :: CmmStmt -> Code
+stmtC stmt = emitCgStmt (CgStmt stmt)
+
+labelC :: BlockId -> Code
+labelC id = emitCgStmt (CgLabel id)
+
+newLabelC :: FCode BlockId
+newLabelC = do { id <- newUnique; return (BlockId id) }
+
+checkedAbsC :: CmmStmt -> Code
+-- Emit code, eliminating no-ops
+checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
+ else unitOL stmt)
+
+stmtsC :: [CmmStmt] -> Code
+stmtsC stmts = emitStmts (toOL stmts)
+
+-- Emit code; no no-op checking
+emitStmts :: CmmStmts -> Code
+emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
+
+-- forkLabelledCode is for emitting a chunk of code with a label, outside
+-- of the current instruction stream.
+forkLabelledCode :: Code -> FCode BlockId
+forkLabelledCode code = getCgStmts code >>= forkCgStmts
+
+emitCgStmt :: CgStmt -> Code
+emitCgStmt stmt
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+ }
+
+emitData :: Section -> [CmmStatic] -> Code
+emitData sect lits
+ = do { state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
+ where
+ data_block = CmmData sect lits
+
+emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
+emitProc lits lbl args blocks
+ = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
+ ; state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+
+emitSimpleProc :: CLabel -> Code -> Code
+-- Emit a procedure whose body is the specified code; no info table
+emitSimpleProc lbl code
+ = do { stmts <- getCgStmts code
+ ; blks <- cgStmtsToBlocks stmts
+ ; emitProc [] lbl [] blks }
+
+getCmm :: Code -> FCode Cmm
+-- Get all the CmmTops (there should be no stmts)
+getCmm code
+ = do { state1 <- getState
+ ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
+ ; setState $ state2 { cgs_tops = cgs_tops state1 }
+ ; return (Cmm (fromOL (cgs_tops state2))) }
+
+-- ----------------------------------------------------------------------------
+-- CgStmts
+
+-- These functions deal in terms of CgStmts, which is an abstract type
+-- representing the code in the current proc.
+
+
+-- emit CgStmts into the current instruction stream
+emitCgStmts :: CgStmts -> Code
+emitCgStmts stmts
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
+
+-- emit CgStmts outside the current instruction stream, and return a label
+forkCgStmts :: CgStmts -> FCode BlockId
+forkCgStmts stmts
+ = do { id <- newLabelC
+ ; emitCgStmt (CgFork id stmts)
+ ; return id
+ }
+
+-- turn CgStmts into [CmmBasicBlock], for making a new proc.
+cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
+cgStmtsToBlocks stmts
+ = do { id <- newLabelC
+ ; return (flattenCgStmts id stmts)
+ }
+
+-- collect the code emitted by an FCode computation
+getCgStmts' :: FCode a -> FCode (a, CgStmts)
+getCgStmts' fcode
+ = do { state1 <- getState
+ ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
+ ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
+ ; return (a, cgs_stmts state2) }
+
+getCgStmts :: FCode a -> FCode CgStmts
+getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
+
+-- Simple ways to construct CgStmts:
+noCgStmts :: CgStmts
+noCgStmts = nilOL
+
+oneCgStmt :: CmmStmt -> CgStmts
+oneCgStmt stmt = unitOL (CgStmt stmt)
+
+consCgStmt :: CmmStmt -> CgStmts -> CgStmts
+consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
+
+-- ----------------------------------------------------------------------------
+-- Get the current module name