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