NCGMonad.hs 5.39 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
import Reg
41
import Format
42 43
import TargetReg

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

Austin Seipp's avatar
Austin Seipp committed
55 56
import Control.Monad    ( liftM, ap )

57 58
import Compiler.Hoopl   ( LabelMap, Label )

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

72 73
type DwarfFiles = UniqFM (FastString, Int)

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

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

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

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

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 163 164
getNewLabelNat
 = do   u <- getUniqueNat
        return (mkAsmTempLabel u)
165

166

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

173

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

183

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

188

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

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)