diff options
Diffstat (limited to 'compiler/codeGen/StgCmmMonad.hs')
-rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 103 |
1 files changed, 39 insertions, 64 deletions
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 5e62183fb5..9ddd8a3985 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} +{-# LANGUAGE GADTs, UnboxedTuples #-} ----------------------------------------------------------------------------- -- @@ -11,9 +11,8 @@ module StgCmmMonad ( FCode, -- type - initC, runC, thenC, thenFC, listCs, - returnFC, fixC, - newUnique, newUniqSupply, + initC, runC, fixC, + newUnique, emitLabel, @@ -30,7 +29,7 @@ module StgCmmMonad ( mkCall, mkCmmCall, - forkClosureBody, forkLneBody, forkAlts, codeOnly, + forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly, ConTagZ, @@ -59,13 +58,12 @@ module StgCmmMonad ( CgInfoDownwards(..), CgState(..) -- non-abstract ) where -#include "HsVersions.h" +import GhcPrelude hiding( sequence, succ ) import Cmm import StgCmmClosure import DynFlags import Hoopl.Collections -import Maybes import MkGraph import BlockId import CLabel @@ -79,13 +77,11 @@ import Unique import UniqSupply import FastString import Outputable +import Util import Control.Monad import Data.List -import Prelude hiding( sequence, succ ) -infixr 9 `thenC` -- Right-associative! -infixr 9 `thenFC` -------------------------------------------------------- @@ -114,27 +110,30 @@ infixr 9 `thenFC` -------------------------------------------------------- -newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #)) +newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } instance Functor FCode where - fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #) + fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s') instance Applicative FCode where - pure = returnFC - (<*>) = ap + pure val = FCode (\_info_down state -> (val, state)) + {-# INLINE pure #-} + (<*>) = ap instance Monad FCode where - (>>=) = thenFC - -{-# INLINE thenC #-} -{-# INLINE thenFC #-} -{-# INLINE returnFC #-} + FCode m >>= k = FCode $ + \info_down state -> + case m info_down state of + (m_result, new_state) -> + case k m_result of + FCode kcode -> kcode info_down new_state + {-# INLINE (>>=) #-} instance MonadUnique FCode where getUniqueSupplyM = cgs_uniqs <$> getState getUniqueM = FCode $ \_ st -> let (u, us') = takeUniqFromSupply (cgs_uniqs st) - in (# u, st { cgs_uniqs = us' } #) + in (u, st { cgs_uniqs = us' }) initC :: IO CgState initC = do { uniqs <- mkSplitUniqSupply 'c' @@ -143,36 +142,10 @@ initC = do { uniqs <- mkSplitUniqSupply 'c' runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st -returnFC :: a -> FCode a -returnFC val = FCode (\_info_down state -> (# val, state #)) - -thenC :: FCode () -> FCode a -> FCode a -thenC (FCode m) (FCode k) = - FCode $ \info_down state -> case m info_down state of - (# _,new_state #) -> k info_down new_state - -listCs :: [FCode ()] -> FCode () -listCs [] = return () -listCs (fc:fcs) = do - fc - listCs fcs - -thenFC :: FCode a -> (a -> FCode c) -> FCode c -thenFC (FCode m) k = FCode $ - \info_down state -> - case m info_down state of - (# m_result, new_state #) -> - case k m_result of - FCode kcode -> kcode info_down new_state - fixC :: (a -> FCode a) -> FCode a -fixC fcode = FCode ( - \info_down state -> - let - (v,s) = doFCode (fcode v) info_down state - in - (# v, s #) - ) +fixC fcode = FCode $ + \info_down state -> let (v, s) = doFCode (fcode v) info_down state + in (v, s) -------------------------------------------------------- -- The code generator environment @@ -432,10 +405,10 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } -------------------------------------------------------- getState :: FCode CgState -getState = FCode $ \_info_down state -> (# state, state #) +getState = FCode $ \_info_down state -> (state, state) setState :: CgState -> FCode () -setState state = FCode $ \_info_down _ -> (# (), state #) +setState state = FCode $ \_info_down _ -> ((), state) getHpUsage :: FCode HeapUsage getHpUsage = do @@ -475,7 +448,7 @@ setBinds new_binds = do withState :: FCode a -> CgState -> FCode (a,CgState) withState (FCode fcode) newstate = FCode $ \info_down state -> case fcode info_down newstate of - (# retval, state2 #) -> (# (retval,state2), state #) + (retval, state2) -> ((retval,state2), state) newUniqSupply :: FCode UniqSupply newUniqSupply = do @@ -493,7 +466,7 @@ newUnique = do ------------------ getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (# info_down,state #) +getInfoDown = FCode $ \info_down state -> (info_down,state) getSelfLoop :: FCode (Maybe SelfLoopInfo) getSelfLoop = do @@ -514,11 +487,6 @@ getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state -doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) -doFCode (FCode fcode) info_down state = - case fcode info_down state of - (# a, s #) -> ( a, s ) - -- ---------------------------------------------------------------------------- -- Get the current module name @@ -664,10 +632,19 @@ forkAlts branch_fcodes , cgs_hp_usg = cgs_hp_usg state } (_us, results) = mapAccumL compile us branch_fcodes (branch_results, branch_out_states) = unzip results - ; setState $ foldl stateIncUsage state branch_out_states + ; setState $ foldl' stateIncUsage state branch_out_states -- NB foldl. state is the *left* argument to stateIncUsage ; return branch_results } +forkAltPair :: FCode a -> FCode a -> FCode (a,a) +-- Most common use of 'forkAlts'; having this helper function avoids +-- accidental use of failible pattern-matches in @do@-notation +forkAltPair x y = do + xy' <- forkAlts [x,y] + case xy' of + [x',y'] -> return (x',y') + _ -> panic "forkAltPair" + -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode @@ -727,11 +704,9 @@ emitLabel id = do tscope <- getTickScope emitCgStmt (CgLabel id tscope) emitComment :: FastString -> FCode () -#if 0 /* def DEBUG */ -emitComment s = emitCgStmt (CgStmt (CmmComment s)) -#else -emitComment _ = return () -#endif +emitComment s + | debugIsOn = emitCgStmt (CgStmt (CmmComment s)) + | otherwise = return () emitTick :: CmmTickish -> FCode () emitTick = emitCgStmt . CgStmt . CmmTick |