summaryrefslogtreecommitdiff
path: root/compiler/codeGen/StgCmmMonad.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen/StgCmmMonad.hs')
-rw-r--r--compiler/codeGen/StgCmmMonad.hs103
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