diff options
Diffstat (limited to 'compiler/codeGen/StgCmmMonad.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 95 |
1 files changed, 90 insertions, 5 deletions
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index cab0897fe8..8001edc5d8 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,3 +1,4 @@ +{-# 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)) } - |