never executed always true always false
    1 {-# LANGUAGE DeriveFunctor #-}
    2 {-# LANGUAGE BangPatterns #-}
    3 
    4 -- -----------------------------------------------------------------------------
    5 --
    6 -- (c) The University of Glasgow 1993-2004
    7 --
    8 -- The native code generator's monad.
    9 --
   10 -- -----------------------------------------------------------------------------
   11 
   12 module GHC.CmmToAsm.Monad (
   13         NcgImpl(..),
   14         NatM_State(..), mkNatM_State,
   15 
   16         NatM, -- instance Monad
   17         initNat,
   18         addImportNat,
   19         addNodeBetweenNat,
   20         addImmediateSuccessorNat,
   21         updateCfgNat,
   22         getUniqueNat,
   23         mapAccumLNat,
   24         setDeltaNat,
   25         getConfig,
   26         getPlatform,
   27         getDeltaNat,
   28         getThisModuleNat,
   29         getBlockIdNat,
   30         getNewLabelNat,
   31         getNewRegNat,
   32         getNewRegPairNat,
   33         getPicBaseMaybeNat,
   34         getPicBaseNat,
   35         getCfgWeights,
   36         getModLoc,
   37         getFileId,
   38         getDebugBlock,
   39 
   40         DwarfFiles
   41 )
   42 
   43 where
   44 
   45 import GHC.Prelude
   46 
   47 import GHC.Platform
   48 import GHC.Platform.Reg
   49 import GHC.CmmToAsm.Format
   50 import GHC.CmmToAsm.Reg.Target
   51 import GHC.CmmToAsm.Config
   52 import GHC.CmmToAsm.Types
   53 
   54 import GHC.Cmm.BlockId
   55 import GHC.Cmm.Dataflow.Collections
   56 import GHC.Cmm.Dataflow.Label
   57 import GHC.Cmm.CLabel           ( CLabel )
   58 import GHC.Cmm.DebugBlock
   59 import GHC.Data.FastString      ( FastString )
   60 import GHC.Types.Unique.FM
   61 import GHC.Types.Unique.Supply
   62 import GHC.Types.Unique         ( Unique )
   63 import GHC.Unit.Module
   64 
   65 import Control.Monad    ( ap )
   66 
   67 import GHC.Utils.Outputable (SDoc, ppr)
   68 import GHC.Utils.Panic      (pprPanic)
   69 import GHC.CmmToAsm.CFG
   70 import GHC.CmmToAsm.CFG.Weight
   71 
   72 data NcgImpl statics instr jumpDest = NcgImpl {
   73     ncgConfig                 :: !NCGConfig,
   74     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
   75     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
   76     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
   77     canShortcut               :: instr -> Maybe jumpDest,
   78     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
   79     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
   80     -- | 'Module' is only for printing internal labels. See Note [Internal proc
   81     -- labels] in CLabel.
   82     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
   83     maxSpillSlots             :: Int,
   84     allocatableRegs           :: [RealReg],
   85     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
   86     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
   87                               -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
   88     -- ^ The list of block ids records the redirected jumps to allow us to update
   89     -- the CFG.
   90     ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
   91     extractUnwindPoints       :: [instr] -> [UnwindPoint],
   92     -- ^ given the instruction sequence of a block, produce a list of
   93     -- the block's 'UnwindPoint's
   94     -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
   95     -- and Note [Unwinding information in the NCG] in this module.
   96     invertCondBranches        :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
   97                               -> [NatBasicBlock instr]
   98     -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
   99     -- when possible.
  100     }
  101 
  102 data NatM_State
  103         = NatM_State {
  104                 natm_us          :: UniqSupply,
  105                 natm_delta       :: Int,
  106                 natm_imports     :: [(CLabel)],
  107                 natm_pic         :: Maybe Reg,
  108                 natm_config      :: NCGConfig,
  109                 natm_modloc      :: ModLocation,
  110                 natm_fileid      :: DwarfFiles,
  111                 natm_debug_map   :: LabelMap DebugBlock,
  112                 natm_cfg         :: CFG
  113         -- ^ Having a CFG with additional information is essential for some
  114         -- operations. However we can't reconstruct all information once we
  115         -- generated instructions. So instead we update the CFG as we go.
  116         }
  117 
  118 type DwarfFiles = UniqFM FastString (FastString, Int)
  119 
  120 newtype NatM result = NatM (NatM_State -> (result, NatM_State))
  121     deriving (Functor)
  122 
  123 unNat :: NatM a -> NatM_State -> (a, NatM_State)
  124 unNat (NatM a) = a
  125 
  126 mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation ->
  127                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
  128 mkNatM_State us delta config
  129         = \loc dwf dbg cfg ->
  130                 NatM_State
  131                         { natm_us = us
  132                         , natm_delta = delta
  133                         , natm_imports = []
  134                         , natm_pic = Nothing
  135                         , natm_config = config
  136                         , natm_modloc = loc
  137                         , natm_fileid = dwf
  138                         , natm_debug_map = dbg
  139                         , natm_cfg = cfg
  140                         }
  141 
  142 initNat :: NatM_State -> NatM a -> (a, NatM_State)
  143 initNat init_st m
  144         = case unNat m init_st of { (r,st) -> (r,st) }
  145 
  146 instance Applicative NatM where
  147       pure = returnNat
  148       (<*>) = ap
  149 
  150 instance Monad NatM where
  151   (>>=) = thenNat
  152 
  153 instance MonadUnique NatM where
  154   getUniqueSupplyM = NatM $ \st ->
  155       case splitUniqSupply (natm_us st) of
  156           (us1, us2) -> (us1, st {natm_us = us2})
  157 
  158   getUniqueM = NatM $ \st ->
  159       case takeUniqFromSupply (natm_us st) of
  160           (uniq, us') -> (uniq, st {natm_us = us'})
  161 
  162 thenNat :: NatM a -> (a -> NatM b) -> NatM b
  163 thenNat expr cont
  164         = NatM $ \st -> case unNat expr st of
  165                         (result, st') -> unNat (cont result) st'
  166 
  167 returnNat :: a -> NatM a
  168 returnNat result
  169         = NatM $ \st ->  (result, st)
  170 
  171 mapAccumLNat :: (acc -> x -> NatM (acc, y))
  172                 -> acc
  173                 -> [x]
  174                 -> NatM (acc, [y])
  175 
  176 mapAccumLNat _ b []
  177   = return (b, [])
  178 mapAccumLNat f b (x:xs)
  179   = do (b__2, x__2)  <- f b x
  180        (b__3, xs__2) <- mapAccumLNat f b__2 xs
  181        return (b__3, x__2:xs__2)
  182 
  183 getUniqueNat :: NatM Unique
  184 getUniqueNat = NatM $ \ st ->
  185     case takeUniqFromSupply $ natm_us st of
  186     (uniq, us') -> (uniq, st {natm_us = us'})
  187 
  188 getDeltaNat :: NatM Int
  189 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
  190 
  191 -- | Get CFG edge weights
  192 getCfgWeights :: NatM Weights
  193 getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)
  194 
  195 setDeltaNat :: Int -> NatM ()
  196 setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
  197 
  198 getThisModuleNat :: NatM Module
  199 getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st)
  200 
  201 instance HasModule NatM where
  202   getModule = getThisModuleNat
  203 
  204 addImportNat :: CLabel -> NatM ()
  205 addImportNat imp
  206         = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
  207 
  208 updateCfgNat :: (CFG -> CFG) -> NatM ()
  209 updateCfgNat f
  210         = NatM $ \ st -> let !cfg' = f (natm_cfg st)
  211                          in ((), st { natm_cfg = cfg'})
  212 
  213 -- | Record that we added a block between `from` and `old`.
  214 addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
  215 addNodeBetweenNat from between to
  216  = do   weights <- getCfgWeights
  217         let jmpWeight = fromIntegral (uncondWeight weights)
  218         updateCfgNat (updateCfg jmpWeight from between to)
  219   where
  220     -- When transforming A -> B to A -> A' -> B
  221     -- A -> A' keeps the old edge info while
  222     -- A' -> B gets the info for an unconditional
  223     -- jump.
  224     updateCfg weight from between old m
  225         | Just info <- getEdgeInfo from old m
  226         = addEdge from between info .
  227           addWeightEdge between old weight .
  228           delEdge from old $ m
  229         | otherwise
  230         = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))
  231 
  232 
  233 -- | Place `succ` after `block` and change any edges
  234 --   block -> X to `succ` -> X
  235 addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
  236 addImmediateSuccessorNat block succ = do
  237    weights <- getCfgWeights
  238    updateCfgNat (addImmediateSuccessor weights block succ)
  239 
  240 getBlockIdNat :: NatM BlockId
  241 getBlockIdNat
  242  = do   u <- getUniqueNat
  243         return (mkBlockId u)
  244 
  245 
  246 getNewLabelNat :: NatM CLabel
  247 getNewLabelNat
  248  = blockLbl <$> getBlockIdNat
  249 
  250 
  251 getNewRegNat :: Format -> NatM Reg
  252 getNewRegNat rep
  253  = do u <- getUniqueNat
  254       platform <- getPlatform
  255       return (RegVirtual $ targetMkVirtualReg platform u rep)
  256 
  257 
  258 getNewRegPairNat :: Format -> NatM (Reg,Reg)
  259 getNewRegPairNat rep
  260  = do u <- getUniqueNat
  261       platform <- getPlatform
  262       let vLo = targetMkVirtualReg platform u rep
  263       let lo  = RegVirtual $ targetMkVirtualReg platform u rep
  264       let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
  265       return (lo, hi)
  266 
  267 
  268 getPicBaseMaybeNat :: NatM (Maybe Reg)
  269 getPicBaseMaybeNat
  270         = NatM (\state -> (natm_pic state, state))
  271 
  272 
  273 getPicBaseNat :: Format -> NatM Reg
  274 getPicBaseNat rep
  275  = do   mbPicBase <- getPicBaseMaybeNat
  276         case mbPicBase of
  277                 Just picBase -> return picBase
  278                 Nothing
  279                  -> do
  280                         reg <- getNewRegNat rep
  281                         NatM (\state -> (reg, state { natm_pic = Just reg }))
  282 
  283 getModLoc :: NatM ModLocation
  284 getModLoc
  285         = NatM $ \ st -> (natm_modloc st, st)
  286 
  287 -- | Get native code generator configuration
  288 getConfig :: NatM NCGConfig
  289 getConfig = NatM $ \st -> (natm_config st, st)
  290 
  291 -- | Get target platform from native code generator configuration
  292 getPlatform :: NatM Platform
  293 getPlatform = ncgPlatform <$> getConfig
  294 
  295 getFileId :: FastString -> NatM Int
  296 getFileId f = NatM $ \st ->
  297   case lookupUFM (natm_fileid st) f of
  298     Just (_,n) -> (n, st)
  299     Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
  300                       fids = addToUFM (natm_fileid st) f (f,n)
  301                   in n `seq` fids `seq` (n, st { natm_fileid = fids  })
  302 
  303 getDebugBlock :: Label -> NatM (Maybe DebugBlock)
  304 getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)