2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -- -----------------------------------------------------------------------------
10 -- (c) The University of Glasgow 1993-2004
12 -- The native code generator's monad.
14 -- -----------------------------------------------------------------------------
17 NatM_State(..), mkNatM_State,
19 NatM, -- instance Monad
20 initNat, addImportNat, getUniqueNat,
21 mapAccumLNat, setDeltaNat, getDeltaNat,
22 getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
23 getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat
26 #include "HsVersions.h"
29 import CLabel ( CLabel, mkAsmTempLabel )
32 import Unique ( Unique )
35 data NatM_State = NatM_State {
36 natm_us :: UniqSupply,
38 natm_imports :: [(CLabel)],
39 natm_pic :: Maybe Reg,
40 natm_dflags :: DynFlags
43 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
47 mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
48 mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags
50 initNat :: NatM_State -> NatM a -> (a, NatM_State)
51 initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
53 instance Monad NatM where
57 thenNat :: NatM a -> (a -> NatM b) -> NatM b
59 = NatM $ \st -> case unNat expr st of
60 (result, st') -> unNat (cont result) st'
62 returnNat :: a -> NatM a
63 returnNat result = NatM $ \st -> (result, st)
65 mapAccumLNat :: (acc -> x -> NatM (acc, y))
72 mapAccumLNat f b (x:xs)
73 = do (b__2, x__2) <- f b x
74 (b__3, xs__2) <- mapAccumLNat f b__2 xs
75 return (b__3, x__2:xs__2)
77 getUniqueNat :: NatM Unique
78 getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
79 case splitUniqSupply us of
80 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags))
83 getDynFlagsNat :: NatM DynFlags
84 getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
85 (dflags, (NatM_State us delta imports pic dflags))
87 getDeltaNat :: NatM Int
88 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
90 setDeltaNat :: Int -> NatM ()
91 setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) ->
92 ((), NatM_State us delta imports pic dflags)
94 addImportNat :: CLabel -> NatM ()
95 addImportNat imp = NatM $ \ (NatM_State us delta imports pic dflags) ->
96 ((), NatM_State us delta (imp:imports) pic dflags)
98 getBlockIdNat :: NatM BlockId
99 getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
101 getNewLabelNat :: NatM CLabel
102 getNewLabelNat = do u <- getUniqueNat; return (mkAsmTempLabel u)
104 getNewRegNat :: Size -> NatM Reg
105 getNewRegNat rep = do u <- getUniqueNat; return (mkVReg u rep)
107 getNewRegPairNat :: Size -> NatM (Reg,Reg)
108 getNewRegPairNat rep = do
110 let lo = mkVReg u rep; hi = getHiVRegFromLo lo
113 getPicBaseMaybeNat :: NatM (Maybe Reg)
114 getPicBaseMaybeNat = NatM (\state -> (natm_pic state, state))
116 getPicBaseNat :: Size -> NatM Reg
117 getPicBaseNat rep = do
118 mbPicBase <- getPicBaseMaybeNat
120 Just picBase -> return picBase
122 reg <- getNewRegNat rep
123 NatM (\state -> (reg, state { natm_pic = Just reg }))