34aaa177013e9596f59b9915a566b5692168240c
[ghc.git] / compiler / nativeGen / NCGMonad.hs
1 {-# LANGUAGE CPP #-}
2
3 -- -----------------------------------------------------------------------------
4 --
5 -- (c) The University of Glasgow 1993-2004
6 --
7 -- The native code generator's monad.
8 --
9 -- -----------------------------------------------------------------------------
10
11 module NCGMonad (
12 NatM_State(..), mkNatM_State,
13
14 NatM, -- instance Monad
15 initNat,
16 addImportNat,
17 getUniqueNat,
18 mapAccumLNat,
19 setDeltaNat,
20 getDeltaNat,
21 getThisModuleNat,
22 getBlockIdNat,
23 getNewLabelNat,
24 getNewRegNat,
25 getNewRegPairNat,
26 getPicBaseMaybeNat,
27 getPicBaseNat,
28 getDynFlags,
29 getModLoc,
30 getFileId,
31 getDebugBlock,
32
33 DwarfFiles
34 )
35
36 where
37
38 #include "HsVersions.h"
39
40 import Reg
41 import Format
42 import TargetReg
43
44 import BlockId
45 import Hoopl
46 import CLabel ( CLabel, mkAsmTempLabel )
47 import Debug
48 import FastString ( FastString )
49 import UniqFM
50 import UniqSupply
51 import Unique ( Unique )
52 import DynFlags
53 import Module
54
55 import Control.Monad ( liftM, ap )
56
57 import Compiler.Hoopl ( LabelMap, Label )
58
59 data NatM_State
60 = NatM_State {
61 natm_us :: UniqSupply,
62 natm_delta :: Int,
63 natm_imports :: [(CLabel)],
64 natm_pic :: Maybe Reg,
65 natm_dflags :: DynFlags,
66 natm_this_module :: Module,
67 natm_modloc :: ModLocation,
68 natm_fileid :: DwarfFiles,
69 natm_debug_map :: LabelMap DebugBlock
70 }
71
72 type DwarfFiles = UniqFM (FastString, Int)
73
74 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
75
76 unNat :: NatM a -> NatM_State -> (a, NatM_State)
77 unNat (NatM a) = a
78
79 mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
80 DwarfFiles -> LabelMap DebugBlock -> NatM_State
81 mkNatM_State us delta dflags this_mod
82 = NatM_State us delta [] Nothing dflags this_mod
83
84 initNat :: NatM_State -> NatM a -> (a, NatM_State)
85 initNat init_st m
86 = case unNat m init_st of { (r,st) -> (r,st) }
87
88 instance Functor NatM where
89 fmap = liftM
90
91 instance Applicative NatM where
92 pure = returnNat
93 (<*>) = ap
94
95 instance Monad NatM where
96 (>>=) = thenNat
97
98 instance MonadUnique NatM where
99 getUniqueSupplyM = NatM $ \st ->
100 case splitUniqSupply (natm_us st) of
101 (us1, us2) -> (us1, st {natm_us = us2})
102
103 getUniqueM = NatM $ \st ->
104 case takeUniqFromSupply (natm_us st) of
105 (uniq, us') -> (uniq, st {natm_us = us'})
106
107 thenNat :: NatM a -> (a -> NatM b) -> NatM b
108 thenNat expr cont
109 = NatM $ \st -> case unNat expr st of
110 (result, st') -> unNat (cont result) st'
111
112 returnNat :: a -> NatM a
113 returnNat result
114 = NatM $ \st -> (result, st)
115
116 mapAccumLNat :: (acc -> x -> NatM (acc, y))
117 -> acc
118 -> [x]
119 -> NatM (acc, [y])
120
121 mapAccumLNat _ b []
122 = return (b, [])
123 mapAccumLNat f b (x:xs)
124 = do (b__2, x__2) <- f b x
125 (b__3, xs__2) <- mapAccumLNat f b__2 xs
126 return (b__3, x__2:xs__2)
127
128 getUniqueNat :: NatM Unique
129 getUniqueNat = NatM $ \ st ->
130 case takeUniqFromSupply $ natm_us st of
131 (uniq, us') -> (uniq, st {natm_us = us'})
132
133 instance HasDynFlags NatM where
134 getDynFlags = NatM $ \ st -> (natm_dflags st, st)
135
136
137 getDeltaNat :: NatM Int
138 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
139
140
141 setDeltaNat :: Int -> NatM ()
142 setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
143
144
145 getThisModuleNat :: NatM Module
146 getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)
147
148
149 addImportNat :: CLabel -> NatM ()
150 addImportNat imp
151 = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
152
153
154 getBlockIdNat :: NatM BlockId
155 getBlockIdNat
156 = do u <- getUniqueNat
157 return (mkBlockId u)
158
159
160 getNewLabelNat :: NatM CLabel
161 getNewLabelNat
162 = do u <- getUniqueNat
163 return (mkAsmTempLabel u)
164
165
166 getNewRegNat :: Format -> NatM Reg
167 getNewRegNat rep
168 = do u <- getUniqueNat
169 dflags <- getDynFlags
170 return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
171
172
173 getNewRegPairNat :: Format -> NatM (Reg,Reg)
174 getNewRegPairNat rep
175 = do u <- getUniqueNat
176 dflags <- getDynFlags
177 let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
178 let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
179 let hi = RegVirtual $ getHiVirtualRegFromLo vLo
180 return (lo, hi)
181
182
183 getPicBaseMaybeNat :: NatM (Maybe Reg)
184 getPicBaseMaybeNat
185 = NatM (\state -> (natm_pic state, state))
186
187
188 getPicBaseNat :: Format -> NatM Reg
189 getPicBaseNat rep
190 = do mbPicBase <- getPicBaseMaybeNat
191 case mbPicBase of
192 Just picBase -> return picBase
193 Nothing
194 -> do
195 reg <- getNewRegNat rep
196 NatM (\state -> (reg, state { natm_pic = Just reg }))
197
198 getModLoc :: NatM ModLocation
199 getModLoc
200 = NatM $ \ st -> (natm_modloc st, st)
201
202 getFileId :: FastString -> NatM Int
203 getFileId f = NatM $ \st ->
204 case lookupUFM (natm_fileid st) f of
205 Just (_,n) -> (n, st)
206 Nothing -> let n = 1 + sizeUFM (natm_fileid st)
207 fids = addToUFM (natm_fileid st) f (f,n)
208 in n `seq` fids `seq` (n, st { natm_fileid = fids })
209
210 getDebugBlock :: Label -> NatM (Maybe DebugBlock)
211 getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)