diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 1 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExtCode.hs | 40 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 4 |
3 files changed, 30 insertions, 15 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 9097e7fa12..4a11fc98d8 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -863,5 +863,6 @@ cgTick tick ; case tick of ProfNote cc t p -> emitSetCCC cc t p HpcTick m n -> emit (mkTickBox dflags m n) + SourceNote s n -> emitTick $ SourceNote s n _other -> return () -- ignore } diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index 931b55624b..ef6540534b 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -18,6 +18,9 @@ module StgCmmExtCode ( loopDecls, getEnv, + withName, + getName, + newLocal, newLabel, newBlockId, @@ -72,15 +75,15 @@ type Decls = [(FastString,Named)] -- | Does a computation in the FCode monad, with a current environment -- and a list of local declarations. Returns the resulting list of declarations. newtype CmmParse a - = EC { unEC :: Env -> Decls -> FCode (Decls, a) } + = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } type ExtCode = CmmParse () returnExtFC :: a -> CmmParse a -returnExtFC a = EC $ \_ s -> return (s, a) +returnExtFC a = EC $ \_ _ s -> return (s, a) thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b -thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' +thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' instance Functor CmmParse where fmap = liftM @@ -94,8 +97,8 @@ instance Monad CmmParse where return = returnExtFC instance HasDynFlags CmmParse where - getDynFlags = EC (\_ d -> do dflags <- getDynFlags - return (d, dflags)) + getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags + return (d, dflags)) -- | Takes the variable decarations and imports from the monad @@ -106,18 +109,25 @@ instance HasDynFlags CmmParse where -- loopDecls :: CmmParse a -> CmmParse a loopDecls (EC fcode) = - EC $ \e globalDecls -> do - (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls) + EC $ \c e globalDecls -> do + (_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls) return (globalDecls, a) -- | Get the current environment from the monad. getEnv :: CmmParse Env -getEnv = EC $ \e s -> return (s, e) +getEnv = EC $ \_ e s -> return (s, e) + +-- | Get the current context name from the monad +getName :: CmmParse String +getName = EC $ \c _ s -> return (s, c) +-- | Set context name for a sub-parse +withName :: String -> CmmParse a -> CmmParse a +withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s addDecl :: FastString -> Named -> ExtCode -addDecl name named = EC $ \_ s -> return ((name, named) : s, ()) +addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ()) -- | Add a new variable to the list of local declarations. @@ -201,7 +211,7 @@ lookupName name = do -- | Lift an FCode computation into the CmmParse monad code :: FCode a -> CmmParse a -code fc = EC $ \_ s -> do +code fc = EC $ \_ _ s -> do r <- fc return (s, r) @@ -218,13 +228,13 @@ emitStore :: CmmExpr -> CmmExpr -> CmmParse () emitStore l r = code (F.emitStore l r) getCode :: CmmParse a -> CmmParse CmmAGraph -getCode (EC ec) = EC $ \e s -> do - ((s',_), gr) <- F.getCodeR (ec e s) +getCode (EC ec) = EC $ \c e s -> do + ((s',_), gr) <- F.getCodeR (ec c e s) return (s', gr) getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph) -getCodeR (EC ec) = EC $ \e s -> do - ((s', r), gr) <- F.getCodeR (ec e s) +getCodeR (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeR (ec c e s) return (s', (r,gr)) emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse () @@ -232,7 +242,7 @@ emitOutOfLine l g = code (F.emitOutOfLine l g) withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () withUpdFrameOff size inner - = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s + = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s getUpdFrameOff :: CmmParse UpdFrameOffset getUpdFrameOff = code $ F.getUpdFrameOff diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 57120cf5ce..252a815ee6 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -20,6 +20,7 @@ module StgCmmMonad ( emit, emitDecl, emitProc, emitProcWithConvention, emitProcWithStackFrame, emitOutOfLine, emitAssign, emitStore, emitComment, + emitTick, getCmm, aGraphToGraph, getCodeR, getCode, getHeapUsage, @@ -683,6 +684,9 @@ emitComment s = emitCgStmt (CgStmt (CmmComment s)) emitComment _ = return () #endif +emitTick :: CmmTickish -> FCode () +emitTick = emitCgStmt . CgStmt . CmmTick + emitAssign :: CmmReg -> CmmExpr -> FCode () emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) |