Monad.hs 12.1 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
{-# LANGUAGE DeriveFunctor #-}
3
{-# LANGUAGE BangPatterns #-}
4

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

Sylvain Henry's avatar
Sylvain Henry committed
13
module GHC.CmmToAsm.Monad (
14
        NcgImpl(..),
15 16 17 18
        NatM_State(..), mkNatM_State,

        NatM, -- instance Monad
        initNat,
19
        initConfig,
20
        addImportNat,
21 22 23
        addNodeBetweenNat,
        addImmediateSuccessorNat,
        updateCfgNat,
24 25 26
        getUniqueNat,
        mapAccumLNat,
        setDeltaNat,
27 28
        getConfig,
        getPlatform,
29
        getDeltaNat,
30
        getThisModuleNat,
31 32 33 34 35 36
        getBlockIdNat,
        getNewLabelNat,
        getNewRegNat,
        getNewRegPairNat,
        getPicBaseMaybeNat,
        getPicBaseNat,
37 38 39 40 41 42
        getDynFlags,
        getModLoc,
        getFileId,
        getDebugBlock,

        DwarfFiles
43 44
)

45
where
46

47 48
#include "HsVersions.h"

49
import GHC.Prelude
50

51
import GHC.Platform
Sylvain Henry's avatar
Sylvain Henry committed
52 53 54
import GHC.Platform.Reg
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
55
import GHC.CmmToAsm.Config
56

57 58 59 60 61
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.CLabel           ( CLabel )
import GHC.Cmm.DebugBlock
62
import GHC.Data.FastString      ( FastString )
Sylvain Henry's avatar
Sylvain Henry committed
63 64 65
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique         ( Unique )
Sylvain Henry's avatar
Sylvain Henry committed
66
import GHC.Driver.Session
Sylvain Henry's avatar
Sylvain Henry committed
67
import GHC.Unit.Module
68

69
import Control.Monad    ( ap )
Austin Seipp's avatar
Austin Seipp committed
70

Sylvain Henry's avatar
Sylvain Henry committed
71
import GHC.CmmToAsm.Instr
72
import GHC.Utils.Outputable (SDoc, pprPanic, ppr)
73
import GHC.Cmm (RawCmmDecl, RawCmmStatics)
Sylvain Henry's avatar
Sylvain Henry committed
74
import GHC.CmmToAsm.CFG
75 76

data NcgImpl statics instr jumpDest = NcgImpl {
77
    ncgConfig                 :: !NCGConfig,
78 79 80 81 82 83 84 85 86 87 88 89 90 91
    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
    canShortcut               :: instr -> Maybe jumpDest,
    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
    maxSpillSlots             :: Int,
    allocatableRegs           :: [RealReg],
    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
    -- ^ The list of block ids records the redirected jumps to allow us to update
    -- the CFG.
92
    ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
93 94 95
    extractUnwindPoints       :: [instr] -> [UnwindPoint],
    -- ^ given the instruction sequence of a block, produce a list of
    -- the block's 'UnwindPoint's
96
    -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
97
    -- and Note [Unwinding information in the NCG] in this module.
98
    invertCondBranches        :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
99
                              -> [NatBasicBlock instr]
100
    -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
101 102 103
    -- when possible.
    }

104 105
data NatM_State
        = NatM_State {
106 107 108 109 110
                natm_us          :: UniqSupply,
                natm_delta       :: Int,
                natm_imports     :: [(CLabel)],
                natm_pic         :: Maybe Reg,
                natm_dflags      :: DynFlags,
111
                natm_config      :: NCGConfig,
112 113 114
                natm_this_module :: Module,
                natm_modloc      :: ModLocation,
                natm_fileid      :: DwarfFiles,
115 116 117 118 119
                natm_debug_map   :: LabelMap DebugBlock,
                natm_cfg         :: CFG
        -- ^ Having a CFG with additional information is essential for some
        -- operations. However we can't reconstruct all information once we
        -- generated instructions. So instead we update the CFG as we go.
120
        }
121

122
type DwarfFiles = UniqFM FastString (FastString, Int)
123

124
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
125
    deriving (Functor)
126

Ian Lynagh's avatar
Ian Lynagh committed
127
unNat :: NatM a -> NatM_State -> (a, NatM_State)
128 129
unNat (NatM a) = a

130
mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
131
                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
132
mkNatM_State us delta dflags this_mod
133 134 135 136 137 138 139
        = \loc dwf dbg cfg ->
                NatM_State
                        { natm_us = us
                        , natm_delta = delta
                        , natm_imports = []
                        , natm_pic = Nothing
                        , natm_dflags = dflags
140
                        , natm_config = initConfig dflags
141 142 143 144 145 146
                        , natm_this_module = this_mod
                        , natm_modloc = loc
                        , natm_fileid = dwf
                        , natm_debug_map = dbg
                        , natm_cfg = cfg
                        }
147

148 149 150
-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
   { ncgPlatform              = targetPlatform dflags
   , ncgProcAlignment         = cmmProcAlignment dflags
   , ncgDebugLevel            = debugLevel dflags
   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags
   , ncgPIC                   = positionIndependent dflags
   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
   , ncgSplitSections         = gopt Opt_SplitSections dflags
   , ncgSpillPreallocSize     = rESERVED_C_STACK_BYTES dflags
   , ncgRegsIterative         = gopt Opt_RegsIterative dflags
   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags

     -- With -O1 and greater, the cmmSink pass does constant-folding, so
     -- we don't need to do it again in the native code generator.
   , ncgDoConstantFolding     = optLevel dflags < 1

   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags
   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags
   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags
   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of
                                 ArchX86_64 -> bmiVersion dflags
                                 ArchX86    -> bmiVersion dflags
                                 _          -> Nothing

     -- We Assume  SSE1 and SSE2 operations are available on both
     -- x86 and x86_64. Historically we didn't default to SSE2 and
     -- SSE1 on x86, which results in defacto nondeterminism for how
     -- rounding behaves in the associated x87 floating point instructions
     -- because variations in the spill/fpu stack placement of arguments for
     -- operations would change the precision and final result of what
     -- would otherwise be the same expressions with respect to single or
     -- double precision IEEE floating point computations.
   , ncgSseVersion =
      let v | sseVersion dflags < Just SSE2 = Just SSE2
            | otherwise                     = sseVersion dflags
      in case platformArch (targetPlatform dflags) of
            ArchX86_64 -> v
            ArchX86    -> v
            _          -> Nothing
190 191 192
   }


193
initNat :: NatM_State -> NatM a -> (a, NatM_State)
194 195
initNat init_st m
        = case unNat m init_st of { (r,st) -> (r,st) }
196

Austin Seipp's avatar
Austin Seipp committed
197
instance Applicative NatM where
198
      pure = returnNat
Austin Seipp's avatar
Austin Seipp committed
199 200
      (<*>) = ap

201 202 203
instance Monad NatM where
  (>>=) = thenNat

204 205 206 207 208 209 210 211
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'})
212

213 214
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat expr cont
215 216
        = NatM $ \st -> case unNat expr st of
                        (result, st') -> unNat (cont result) st'
217 218

returnNat :: a -> NatM a
219 220
returnNat result
        = NatM $ \st ->  (result, st)
221 222 223

mapAccumLNat :: (acc -> x -> NatM (acc, y))
                -> acc
224 225
                -> [x]
                -> NatM (acc, [y])
226

Ian Lynagh's avatar
Ian Lynagh committed
227
mapAccumLNat _ b []
228 229 230 231 232 233 234
  = 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
235 236 237
getUniqueNat = NatM $ \ st ->
    case takeUniqFromSupply $ natm_us st of
    (uniq, us') -> (uniq, st {natm_us = us'})
238

239
instance HasDynFlags NatM where
240
    getDynFlags = NatM $ \ st -> (natm_dflags st, st)
241

242 243

getDeltaNat :: NatM Int
244
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
245

246 247

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

250

251 252 253 254
getThisModuleNat :: NatM Module
getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)


255
addImportNat :: CLabel -> NatM ()
256
addImportNat imp
257
        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
258

259 260
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat f
261 262
        = NatM $ \ st -> let !cfg' = f (natm_cfg st)
                         in ((), st { natm_cfg = cfg'})
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281

-- | Record that we added a block between `from` and `old`.
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat from between to
 = do   df <- getDynFlags
        let jmpWeight = fromIntegral . uncondWeight .
                        cfgWeightInfo $ df
        updateCfgNat (updateCfg jmpWeight from between to)
  where
    -- When transforming A -> B to A -> A' -> B
    -- A -> A' keeps the old edge info while
    -- A' -> B gets the info for an unconditional
    -- jump.
    updateCfg weight from between old m
        | Just info <- getEdgeInfo from old m
        = addEdge from between info .
          addWeightEdge between old weight .
          delEdge from old $ m
        | otherwise
282
        = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))
283 284 285 286 287


-- | Place `succ` after `block` and change any edges
--   block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
288 289 290
addImmediateSuccessorNat block succ = do
   dflags <- getDynFlags
   updateCfgNat (addImmediateSuccessor dflags block succ)
291 292

getBlockIdNat :: NatM BlockId
293 294 295
getBlockIdNat
 = do   u <- getUniqueNat
        return (mkBlockId u)
296

297 298

getNewLabelNat :: NatM CLabel
299
getNewLabelNat
300
 = blockLbl <$> getBlockIdNat
301

302

303
getNewRegNat :: Format -> NatM Reg
304 305
getNewRegNat rep
 = do u <- getUniqueNat
306 307
      platform <- getPlatform
      return (RegVirtual $ targetMkVirtualReg platform u rep)
308

309

310
getNewRegPairNat :: Format -> NatM (Reg,Reg)
311 312
getNewRegPairNat rep
 = do u <- getUniqueNat
313 314 315
      platform <- getPlatform
      let vLo = targetMkVirtualReg platform u rep
      let lo  = RegVirtual $ targetMkVirtualReg platform u rep
316 317
      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
      return (lo, hi)
318

319

320
getPicBaseMaybeNat :: NatM (Maybe Reg)
321 322
getPicBaseMaybeNat
        = NatM (\state -> (natm_pic state, state))
323

324

325
getPicBaseNat :: Format -> NatM Reg
326 327 328 329 330 331 332 333
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 }))
334 335 336 337 338

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

339 340 341 342 343 344 345 346
-- | Get native code generator configuration
getConfig :: NatM NCGConfig
getConfig = NatM $ \st -> (natm_config st, st)

-- | Get target platform from native code generator configuration
getPlatform :: NatM Platform
getPlatform = ncgPlatform <$> getConfig

347 348 349 350 351 352 353 354 355 356
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)