Monad.hs 12 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 73
import GHC.Utils.Outputable (SDoc, ppr)
import GHC.Utils.Panic      (pprPanic)
74
import GHC.Cmm (RawCmmDecl, RawCmmStatics)
Sylvain Henry's avatar
Sylvain Henry committed
75
import GHC.CmmToAsm.CFG
76 77

data NcgImpl statics instr jumpDest = NcgImpl {
78
    ncgConfig                 :: !NCGConfig,
79 80 81 82 83 84 85 86 87 88 89 90 91 92
    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.
93
    ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
94 95 96
    extractUnwindPoints       :: [instr] -> [UnwindPoint],
    -- ^ given the instruction sequence of a block, produce a list of
    -- the block's 'UnwindPoint's
97
    -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
98
    -- and Note [Unwinding information in the NCG] in this module.
99
    invertCondBranches        :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
100
                              -> [NatBasicBlock instr]
101
    -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
102 103 104
    -- when possible.
    }

105 106
data NatM_State
        = NatM_State {
107 108 109 110 111
                natm_us          :: UniqSupply,
                natm_delta       :: Int,
                natm_imports     :: [(CLabel)],
                natm_pic         :: Maybe Reg,
                natm_dflags      :: DynFlags,
112
                natm_config      :: NCGConfig,
113 114 115
                natm_this_module :: Module,
                natm_modloc      :: ModLocation,
                natm_fileid      :: DwarfFiles,
116 117 118 119 120
                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.
121
        }
122

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

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

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

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

149 150 151
-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
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
   , 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
initNat :: NatM_State -> NatM a -> (a, NatM_State)
193 194
initNat init_st m
        = case unNat m init_st of { (r,st) -> (r,st) }
195

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

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

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

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

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

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

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

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

241 242

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

245 246

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

249

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


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

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

-- | 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
281
        = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))
282 283 284 285 286


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

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

296 297

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

301

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

308

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

318

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

323

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

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

338 339 340 341 342 343 344 345
-- | 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

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