NCGMonad.hs 5.35 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
import GhcPrelude

42
import Reg
43
import Format
44 45
import TargetReg

46
import BlockId
47 48
import Hoopl.Collections
import Hoopl.Label
49
import CLabel           ( CLabel )
50 51 52
import Debug
import FastString       ( FastString )
import UniqFM
53
import UniqSupply
54
import Unique           ( Unique )
55
import DynFlags
56
import Module
57

Austin Seipp's avatar
Austin Seipp committed
58 59
import Control.Monad    ( liftM, ap )

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

73 74
type DwarfFiles = UniqFM (FastString, Int)

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
89 90 91 92
instance Functor NatM where
      fmap = liftM

instance Applicative NatM where
93
      pure = returnNat
Austin Seipp's avatar
Austin Seipp committed
94 95
      (<*>) = ap

96 97 98
instance Monad NatM where
  (>>=) = thenNat

99 100 101 102 103 104 105 106
instance MonadUnique NatM where
  getUniqueSupplyM = NatM $ \st ->
      case splitUniqSupply (natm_us st) of
          (us1, us2) -> (us1, st {natm_us = us2})

  getUniqueM = NatM $ \st ->
      case takeUniqFromSupply (natm_us st) of
          (uniq, us') -> (uniq, st {natm_us = us'})
107

108 109
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat expr cont
110 111
        = NatM $ \st -> case unNat expr st of
                        (result, st') -> unNat (cont result) st'
112 113

returnNat :: a -> NatM a
114 115
returnNat result
        = NatM $ \st ->  (result, st)
116 117 118

mapAccumLNat :: (acc -> x -> NatM (acc, y))
                -> acc
119 120
                -> [x]
                -> NatM (acc, [y])
121

Ian Lynagh's avatar
Ian Lynagh committed
122
mapAccumLNat _ b []
123 124 125 126 127 128 129
  = 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
130 131 132
getUniqueNat = NatM $ \ st ->
    case takeUniqFromSupply $ natm_us st of
    (uniq, us') -> (uniq, st {natm_us = us'})
133

134
instance HasDynFlags NatM where
135
    getDynFlags = NatM $ \ st -> (natm_dflags st, st)
136

137 138

getDeltaNat :: NatM Int
139
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
140

141 142

setDeltaNat :: Int -> NatM ()
143
setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
144

145

146 147 148 149
getThisModuleNat :: NatM Module
getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)


150
addImportNat :: CLabel -> NatM ()
151
addImportNat imp
152
        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
153

154 155

getBlockIdNat :: NatM BlockId
156 157 158
getBlockIdNat
 = do   u <- getUniqueNat
        return (mkBlockId u)
159

160 161

getNewLabelNat :: NatM CLabel
162
getNewLabelNat
163
 = blockLbl <$> getBlockIdNat
164

165

166
getNewRegNat :: Format -> NatM Reg
167 168
getNewRegNat rep
 = do u <- getUniqueNat
169
      dflags <- getDynFlags
170
      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
171

172

173
getNewRegPairNat :: Format -> NatM (Reg,Reg)
174 175
getNewRegPairNat rep
 = do u <- getUniqueNat
176
      dflags <- getDynFlags
177 178 179 180
      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
      return (lo, hi)
181

182

183
getPicBaseMaybeNat :: NatM (Maybe Reg)
184 185
getPicBaseMaybeNat
        = NatM (\state -> (natm_pic state, state))
186

187

188
getPicBaseNat :: Format -> NatM Reg
189 190 191 192 193 194 195 196
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 }))
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211

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)