Some -dynamic-too fixes
[ghc.git] / compiler / nativeGen / NCGMonad.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 1993-2004
4 --
5 -- The native code generator's monad.
6 --
7 -- -----------------------------------------------------------------------------
8
9 module NCGMonad (
10 NatM_State(..), mkNatM_State,
11
12 NatM, -- instance Monad
13 initNat,
14 addImportNat,
15 getUniqueNat,
16 mapAccumLNat,
17 setDeltaNat,
18 getDeltaNat,
19 getBlockIdNat,
20 getNewLabelNat,
21 getNewRegNat,
22 getNewRegPairNat,
23 getPicBaseMaybeNat,
24 getPicBaseNat,
25 getDynFlags
26 )
27
28 where
29
30 #include "HsVersions.h"
31
32 import Reg
33 import Size
34 import TargetReg
35
36 import BlockId
37 import CLabel ( CLabel, mkAsmTempLabel )
38 import UniqSupply
39 import Unique ( Unique )
40 import DynFlags
41
42 data NatM_State
43 = NatM_State {
44 natm_us :: UniqSupply,
45 natm_delta :: Int,
46 natm_imports :: [(CLabel)],
47 natm_pic :: Maybe Reg,
48 natm_dflags :: DynFlags
49 }
50
51 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
52
53 unNat :: NatM a -> NatM_State -> (a, NatM_State)
54 unNat (NatM a) = a
55
56 mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
57 mkNatM_State us delta dflags
58 = NatM_State us delta [] Nothing dflags
59
60 initNat :: NatM_State -> NatM a -> (a, NatM_State)
61 initNat init_st m
62 = case unNat m init_st of { (r,st) -> (r,st) }
63
64
65 instance Monad NatM where
66 (>>=) = thenNat
67 return = returnNat
68
69
70 thenNat :: NatM a -> (a -> NatM b) -> NatM b
71 thenNat expr cont
72 = NatM $ \st -> case unNat expr st of
73 (result, st') -> unNat (cont result) st'
74
75 returnNat :: a -> NatM a
76 returnNat result
77 = NatM $ \st -> (result, st)
78
79 mapAccumLNat :: (acc -> x -> NatM (acc, y))
80 -> acc
81 -> [x]
82 -> NatM (acc, [y])
83
84 mapAccumLNat _ b []
85 = return (b, [])
86 mapAccumLNat f b (x:xs)
87 = do (b__2, x__2) <- f b x
88 (b__3, xs__2) <- mapAccumLNat f b__2 xs
89 return (b__3, x__2:xs__2)
90
91 getUniqueNat :: NatM Unique
92 getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
93 case takeUniqFromSupply us of
94 (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags))
95
96 instance HasDynFlags NatM where
97 getDynFlags = NatM $ \ (NatM_State us delta imports pic dflags) ->
98 (dflags, (NatM_State us delta imports pic dflags))
99
100
101 getDeltaNat :: NatM Int
102 getDeltaNat
103 = NatM $ \ st -> (natm_delta st, st)
104
105
106 setDeltaNat :: Int -> NatM ()
107 setDeltaNat delta
108 = NatM $ \ (NatM_State us _ imports pic dflags) ->
109 ((), NatM_State us delta imports pic dflags)
110
111
112 addImportNat :: CLabel -> NatM ()
113 addImportNat imp
114 = NatM $ \ (NatM_State us delta imports pic dflags) ->
115 ((), NatM_State us delta (imp:imports) pic dflags)
116
117
118 getBlockIdNat :: NatM BlockId
119 getBlockIdNat
120 = do u <- getUniqueNat
121 return (mkBlockId u)
122
123
124 getNewLabelNat :: NatM CLabel
125 getNewLabelNat
126 = do u <- getUniqueNat
127 return (mkAsmTempLabel u)
128
129
130 getNewRegNat :: Size -> NatM Reg
131 getNewRegNat rep
132 = do u <- getUniqueNat
133 dflags <- getDynFlags
134 return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
135
136
137 getNewRegPairNat :: Size -> NatM (Reg,Reg)
138 getNewRegPairNat rep
139 = do u <- getUniqueNat
140 dflags <- getDynFlags
141 let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
142 let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
143 let hi = RegVirtual $ getHiVirtualRegFromLo vLo
144 return (lo, hi)
145
146
147 getPicBaseMaybeNat :: NatM (Maybe Reg)
148 getPicBaseMaybeNat
149 = NatM (\state -> (natm_pic state, state))
150
151
152 getPicBaseNat :: Size -> NatM Reg
153 getPicBaseNat rep
154 = do mbPicBase <- getPicBaseMaybeNat
155 case mbPicBase of
156 Just picBase -> return picBase
157 Nothing
158 -> do
159 reg <- getNewRegNat rep
160 NatM (\state -> (reg, state { natm_pic = Just reg }))