NCGMonad.hs 5.19 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3 4 5
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
6
--
7 8 9 10 11
-- The native code generator's monad.
--
-- -----------------------------------------------------------------------------

module NCGMonad (
12 13 14 15 16 17 18 19 20
        NatM_State(..), mkNatM_State,

        NatM, -- instance Monad
        initNat,
        addImportNat,
        getUniqueNat,
        mapAccumLNat,
        setDeltaNat,
        getDeltaNat,
21
        getThisModuleNat,
22 23 24 25 26 27
        getBlockIdNat,
        getNewLabelNat,
        getNewRegNat,
        getNewRegPairNat,
        getPicBaseMaybeNat,
        getPicBaseNat,
28 29 30 31 32 33
        getDynFlags,
        getModLoc,
        getFileId,
        getDebugBlock,

        DwarfFiles
34 35
)

36
where
37

38 39
#include "HsVersions.h"

40 41 42 43
import Reg
import Size
import TargetReg

44
import BlockId
45
import CLabel           ( CLabel, mkAsmTempLabel )
46 47 48
import Debug
import FastString       ( FastString )
import UniqFM
49
import UniqSupply
50
import Unique           ( Unique )
51
import DynFlags
52
import Module
53

Austin Seipp's avatar
Austin Seipp committed
54
import Control.Monad    ( liftM, ap )
55
#if __GLASGOW_HASKELL__ < 709
Austin Seipp's avatar
Austin Seipp committed
56
import Control.Applicative ( Applicative(..) )
57
#endif
Austin Seipp's avatar
Austin Seipp committed
58

59 60
import Compiler.Hoopl   ( LabelMap, Label )

61 62
data NatM_State
        = NatM_State {
63 64 65 66 67
                natm_us          :: UniqSupply,
                natm_delta       :: Int,
                natm_imports     :: [(CLabel)],
                natm_pic         :: Maybe Reg,
                natm_dflags      :: DynFlags,
68 69 70 71
                natm_this_module :: Module,
                natm_modloc      :: ModLocation,
                natm_fileid      :: DwarfFiles,
                natm_debug_map   :: LabelMap DebugBlock
72
        }
73

74 75
type DwarfFiles = UniqFM (FastString, Int)

76 77
newtype NatM result = NatM (NatM_State -> (result, NatM_State))

Ian Lynagh's avatar
Ian Lynagh committed
78
unNat :: NatM a -> NatM_State -> (a, NatM_State)
79 80
unNat (NatM a) = a

81 82
mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
                DwarfFiles -> LabelMap DebugBlock -> NatM_State
83 84
mkNatM_State us delta dflags this_mod
        = NatM_State us delta [] Nothing dflags this_mod
85 86

initNat :: NatM_State -> NatM a -> (a, NatM_State)
87 88
initNat init_st m
        = case unNat m init_st of { (r,st) -> (r,st) }
89

90

Austin Seipp's avatar
Austin Seipp committed
91 92 93 94 95 96 97
instance Functor NatM where
      fmap = liftM

instance Applicative NatM where
      pure = return
      (<*>) = ap

98 99 100 101
instance Monad NatM where
  (>>=) = thenNat
  return = returnNat

102

103 104
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat expr cont
105 106
        = NatM $ \st -> case unNat expr st of
                        (result, st') -> unNat (cont result) st'
107 108

returnNat :: a -> NatM a
109 110
returnNat result
        = NatM $ \st ->  (result, st)
111 112 113

mapAccumLNat :: (acc -> x -> NatM (acc, y))
                -> acc
114 115
                -> [x]
                -> NatM (acc, [y])
116

Ian Lynagh's avatar
Ian Lynagh committed
117
mapAccumLNat _ b []
118 119 120 121 122 123 124
  = return (b, [])
mapAccumLNat f b (x:xs)
  = do (b__2, x__2)  <- f b x
       (b__3, xs__2) <- mapAccumLNat f b__2 xs
       return (b__3, x__2:xs__2)

getUniqueNat :: NatM Unique
125 126 127
getUniqueNat = NatM $ \ st ->
    case takeUniqFromSupply $ natm_us st of
    (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 142 143 144
getThisModuleNat :: NatM Module
getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)


145
addImportNat :: CLabel -> NatM ()
146
addImportNat imp
147
        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
148

149 150

getBlockIdNat :: NatM BlockId
151 152 153
getBlockIdNat
 = do   u <- getUniqueNat
        return (mkBlockId u)
154

155 156

getNewLabelNat :: NatM CLabel
157 158 159
getNewLabelNat
 = do   u <- getUniqueNat
        return (mkAsmTempLabel u)
160

161

162
getNewRegNat :: Size -> NatM Reg
163 164
getNewRegNat rep
 = do u <- getUniqueNat
165
      dflags <- getDynFlags
166
      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
167

168

169
getNewRegPairNat :: Size -> NatM (Reg,Reg)
170 171
getNewRegPairNat rep
 = do u <- getUniqueNat
172
      dflags <- getDynFlags
173 174 175 176
      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
      return (lo, hi)
177

178

179
getPicBaseMaybeNat :: NatM (Maybe Reg)
180 181
getPicBaseMaybeNat
        = NatM (\state -> (natm_pic state, state))
182

183

184
getPicBaseNat :: Size -> NatM Reg
185 186 187 188 189 190 191 192
getPicBaseNat rep
 = do   mbPicBase <- getPicBaseMaybeNat
        case mbPicBase of
                Just picBase -> return picBase
                Nothing
                 -> do
                        reg <- getNewRegNat rep
                        NatM (\state -> (reg, state { natm_pic = Just reg }))
193 194 195 196 197 198 199 200 201 202 203 204 205 206 207

getModLoc :: NatM ModLocation
getModLoc
        = NatM $ \ st -> (natm_modloc st, st)

getFileId :: FastString -> NatM Int
getFileId f = NatM $ \st ->
  case lookupUFM (natm_fileid st) f of
    Just (_,n) -> (n, st)
    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
                      fids = addToUFM (natm_fileid st) f (f,n)
                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })

getDebugBlock :: Label -> NatM (Maybe DebugBlock)
getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)