Hoopl: remove dependency on Hoopl package
[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.Collections
46 import Hoopl.Label
47 import CLabel ( CLabel, mkAsmTempLabel )
48 import Debug
49 import FastString ( FastString )
50 import UniqFM
51 import UniqSupply
52 import Unique ( Unique )
53 import DynFlags
54 import Module
55
56 import Control.Monad ( liftM, ap )
57
58 data NatM_State
59 = NatM_State {
60 natm_us :: UniqSupply,
61 natm_delta :: Int,
62 natm_imports :: [(CLabel)],
63 natm_pic :: Maybe Reg,
64 natm_dflags :: DynFlags,
65 natm_this_module :: Module,
66 natm_modloc :: ModLocation,
67 natm_fileid :: DwarfFiles,
68 natm_debug_map :: LabelMap DebugBlock
69 }
70
71 type DwarfFiles = UniqFM (FastString, Int)
72
73 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
74
75 unNat :: NatM a -> NatM_State -> (a, NatM_State)
76 unNat (NatM a) = a
77
78 mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
79 DwarfFiles -> LabelMap DebugBlock -> NatM_State
80 mkNatM_State us delta dflags this_mod
81 = NatM_State us delta [] Nothing dflags this_mod
82
83 initNat :: NatM_State -> NatM a -> (a, NatM_State)
84 initNat init_st m
85 = case unNat m init_st of { (r,st) -> (r,st) }
86
87 instance Functor NatM where
88 fmap = liftM
89
90 instance Applicative NatM where
91 pure = returnNat
92 (<*>) = ap
93
94 instance Monad NatM where
95 (>>=) = thenNat
96
97 instance MonadUnique NatM where
98 getUniqueSupplyM = NatM $ \st ->
99 case splitUniqSupply (natm_us st) of
100 (us1, us2) -> (us1, st {natm_us = us2})
101
102 getUniqueM = NatM $ \st ->
103 case takeUniqFromSupply (natm_us st) of
104 (uniq, us') -> (uniq, st {natm_us = us'})
105
106 thenNat :: NatM a -> (a -> NatM b) -> NatM b
107 thenNat expr cont
108 = NatM $ \st -> case unNat expr st of
109 (result, st') -> unNat (cont result) st'
110
111 returnNat :: a -> NatM a
112 returnNat result
113 = NatM $ \st -> (result, st)
114
115 mapAccumLNat :: (acc -> x -> NatM (acc, y))
116 -> acc
117 -> [x]
118 -> NatM (acc, [y])
119
120 mapAccumLNat _ b []
121 = return (b, [])
122 mapAccumLNat f b (x:xs)
123 = do (b__2, x__2) <- f b x
124 (b__3, xs__2) <- mapAccumLNat f b__2 xs
125 return (b__3, x__2:xs__2)
126
127 getUniqueNat :: NatM Unique
128 getUniqueNat = NatM $ \ st ->
129 case takeUniqFromSupply $ natm_us st of
130 (uniq, us') -> (uniq, st {natm_us = us'})
131
132 instance HasDynFlags NatM where
133 getDynFlags = NatM $ \ st -> (natm_dflags st, st)
134
135
136 getDeltaNat :: NatM Int
137 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
138
139
140 setDeltaNat :: Int -> NatM ()
141 setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
142
143
144 getThisModuleNat :: NatM Module
145 getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)
146
147
148 addImportNat :: CLabel -> NatM ()
149 addImportNat imp
150 = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
151
152
153 getBlockIdNat :: NatM BlockId
154 getBlockIdNat
155 = do u <- getUniqueNat
156 return (mkBlockId u)
157
158
159 getNewLabelNat :: NatM CLabel
160 getNewLabelNat
161 = do u <- getUniqueNat
162 return (mkAsmTempLabel u)
163
164
165 getNewRegNat :: Format -> NatM Reg
166 getNewRegNat rep
167 = do u <- getUniqueNat
168 dflags <- getDynFlags
169 return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
170
171
172 getNewRegPairNat :: Format -> NatM (Reg,Reg)
173 getNewRegPairNat rep
174 = do u <- getUniqueNat
175 dflags <- getDynFlags
176 let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
177 let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
178 let hi = RegVirtual $ getHiVirtualRegFromLo vLo
179 return (lo, hi)
180
181
182 getPicBaseMaybeNat :: NatM (Maybe Reg)
183 getPicBaseMaybeNat
184 = NatM (\state -> (natm_pic state, state))
185
186
187 getPicBaseNat :: Format -> NatM Reg
188 getPicBaseNat rep
189 = do mbPicBase <- getPicBaseMaybeNat
190 case mbPicBase of
191 Just picBase -> return picBase
192 Nothing
193 -> do
194 reg <- getNewRegNat rep
195 NatM (\state -> (reg, state { natm_pic = Just reg }))
196
197 getModLoc :: NatM ModLocation
198 getModLoc
199 = NatM $ \ st -> (natm_modloc st, st)
200
201 getFileId :: FastString -> NatM Int
202 getFileId f = NatM $ \st ->
203 case lookupUFM (natm_fileid st) f of
204 Just (_,n) -> (n, st)
205 Nothing -> let n = 1 + sizeUFM (natm_fileid st)
206 fids = addToUFM (natm_fileid st) f (f,n)
207 in n `seq` fids `seq` (n, st { natm_fileid = fids })
208
209 getDebugBlock :: Label -> NatM (Maybe DebugBlock)
210 getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)