compiler/nativeGen/NCGMonad.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 1993-2004
   4 --
   5 -- The native code generator's monad.
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module NCGMonad (
  10         NatM_State(..), mkNatM_State,
  11
  12         NatM, -- instance Monad
  13         initNat,
  14         addImportNat,
  15         getUniqueNat,
  16         mapAccumLNat,
  17         setDeltaNat,
  18         getDeltaNat,
  19         getBlockIdNat,
  20         getNewLabelNat,
  21         getNewRegNat,
  22         getNewRegPairNat,
  23         getPicBaseMaybeNat,
  24         getPicBaseNat,
  25         getDynFlagsNat
  26 )
  27
  28 where
  29
  30 #include "HsVersions.h"
  31
  32 import Reg
  33 import Size
  34 import TargetReg
  35
  36 import BlockId
  37 import CLabel           ( CLabel, mkAsmTempLabel )
  38 import UniqSupply
  39 import Unique           ( Unique )
  40 import DynFlags
  41
  42 data NatM_State
  43         = NatM_State {
  44                 natm_us      :: UniqSupply,
  45                 natm_delta   :: Int,
  46                 natm_imports :: [(CLabel)],
  47                 natm_pic     :: Maybe Reg,
  48                 natm_dflags  :: DynFlags
  49         }
  50
  51 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
  52
  53 unNat :: NatM a -> NatM_State -> (a, NatM_State)
  54 unNat (NatM a) = a
  55
  56 mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
  57 mkNatM_State us delta dflags
  58         = NatM_State us delta [] Nothing dflags
  59
  60 initNat :: NatM_State -> NatM a -> (a, NatM_State)
  61 initNat init_st m
  62         = case unNat m init_st of { (r,st) -> (r,st) }
  63
  64
  65 instance Monad NatM where
  66   (>>=) = thenNat
  67   return = returnNat
  68
  69
  70 thenNat :: NatM a -> (a -> NatM b) -> NatM b
  71 thenNat expr cont
  72         = NatM $ \st -> case unNat expr st of
  73                         (result, st') -> unNat (cont result) st'
  74
  75 returnNat :: a -> NatM a
  76 returnNat result
  77         = NatM $ \st ->  (result, st)
  78
  79 mapAccumLNat :: (acc -> x -> NatM (acc, y))
  80                 -> acc
  81                 -> [x]
  82                 -> NatM (acc, [y])
  83
  84 mapAccumLNat _ b []
  85   = return (b, [])
  86 mapAccumLNat f b (x:xs)
  87   = do (b__2, x__2)  <- f b x
  88        (b__3, xs__2) <- mapAccumLNat f b__2 xs
  89        return (b__3, x__2:xs__2)
  90
  91 getUniqueNat :: NatM Unique
  92 getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
  93     case splitUniqSupply us of
  94          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags))
  95
  96
  97 getDynFlagsNat :: NatM DynFlags
  98 getDynFlagsNat
  99         = NatM $ \ (NatM_State us delta imports pic dflags) ->
 100                   (dflags, (NatM_State us delta imports pic dflags))
 101
 102
 103 getDeltaNat :: NatM Int
 104 getDeltaNat
 105         = NatM $ \ st -> (natm_delta st, st)
 106
 107
 108 setDeltaNat :: Int -> NatM ()
 109 setDeltaNat delta
 110         = NatM $ \ (NatM_State us _ imports pic dflags) ->
 111                    ((), NatM_State us delta imports pic dflags)
 112
 113
 114 addImportNat :: CLabel -> NatM ()
 115 addImportNat imp
 116         = NatM $ \ (NatM_State us delta imports pic dflags) ->
 117                    ((), NatM_State us delta (imp:imports) pic dflags)
 118
 119
 120 getBlockIdNat :: NatM BlockId
 121 getBlockIdNat
 122  = do   u <- getUniqueNat
 123         return (BlockId u)
 124
 125
 126 getNewLabelNat :: NatM CLabel
 127 getNewLabelNat
 128  = do   u <- getUniqueNat
 129         return (mkAsmTempLabel u)
 130
 131
 132 getNewRegNat :: Size -> NatM Reg
 133 getNewRegNat rep
 134  = do   u <- getUniqueNat
 135         return (RegVirtual $ targetMkVirtualReg u rep)
 136
 137
 138 getNewRegPairNat :: Size -> NatM (Reg,Reg)
 139 getNewRegPairNat rep
 140  = do   u       <- getUniqueNat
 141         let vLo = targetMkVirtualReg u rep
 142         let lo  = RegVirtual $ targetMkVirtualReg u rep
 143         let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
 144         return (lo, hi)
 145
 146
 147 getPicBaseMaybeNat :: NatM (Maybe Reg)
 148 getPicBaseMaybeNat
 149         = NatM (\state -> (natm_pic state, state))
 150
 151
 152 getPicBaseNat :: Size -> NatM Reg
 153 getPicBaseNat rep
 154  = do   mbPicBase <- getPicBaseMaybeNat
 155         case mbPicBase of
 156                 Just picBase -> return picBase
 157                 Nothing
 158                  -> do
 159                         reg <- getNewRegNat rep
 160                         NatM (\state -> (reg, state { natm_pic = Just reg }))