Andreas Klebinger pushed to branch wip/andreask/cfg-fix at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/CmmToAsm/BlockLayout.hs
    ... ... @@ -66,6 +66,11 @@ import GHC.Types.Unique.DSM (UniqDSM)
    66 66 
       * Feed this CFG into the block layout code (`sequenceTop`) in this
    67 67 
         module. Which will then produce a code layout based on the input weights.
    68 68
    69 
    +  It's worth mentioning that instead of maintaining a CFG in the backend we
    70 
    +  could re-create one from the assembly. But a naive version of this would lose
    71 
    +  some essential information, like weither or not a branch is known to be
    72 
    +  likely/unlikely. But we could get a similar effect by encoding the relevant
    73 
    +  information directly in the instruction stream as meta instructions or similar.
    69 74
    70 75 
       Note [Chain based CFG serialization]
    71 76 
       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • compiler/GHC/CmmToAsm/Monad.hs
    ... ... @@ -19,7 +19,14 @@ module GHC.CmmToAsm.Monad (
    19 19 
             addImportNat,
    20 20 
             addNodeBetweenNat,
    21 21 
             addImmediateSuccessorNat,
    22 
    -        updateCfgNat,
    22 
    +        getCurrentBlock,
    23 
    +        setCurrentBlock,
    24 
    +        currentBlock,
    25 
    +        continueInNewBlock,
    26 
    +        addDiamondFlow,
    27 
    +        addCondBlock,
    28 
    +        addColdSelfLoop,
    29 
    +        increaseEdgeWeight,
    23 30 
             getUniqueNat,
    24 31 
             setDeltaNat,
    25 32 
             getConfig,
    ... ... @@ -66,11 +73,12 @@ import GHC.Types.Unique ( Unique )
    66 73 
     import GHC.Unit.Module
    67 74
    68 75 
     import GHC.Utils.Outputable (SDoc, HDoc, ppr)
    69 
    -import GHC.Utils.Panic      (pprPanic)
    76 
    +import GHC.Utils.Panic      (panic, pprPanic)
    70 77 
     import GHC.Utils.Monad.State.Strict (State (..), runState, state)
    71 78 
     import GHC.Utils.Misc
    72 79 
     import GHC.CmmToAsm.CFG
    73 80 
     import GHC.CmmToAsm.CFG.Weight
    81 
    +import GHC.Data.Unboxed (MaybeUB (..))
    74 82
    75 83 
     -- | A Native Code Generator implementation is parametrised over
    76 84 
     -- * The type of static data (typically related to 'CmmStatics')
    ... ... @@ -184,10 +192,13 @@ data NatM_State
    184 192 
                     natm_config      :: NCGConfig,
    185 193 
                     natm_fileid      :: DwarfFiles,
    186 194 
                     natm_debug_map   :: LabelMap DebugBlock,
    187 
    -                natm_cfg         :: CFG
    195 
    +                natm_cfg         :: CFG,
    188 196 
             -- ^ Having a CFG with additional information is essential for some
    189 197 
             -- operations. However we can't reconstruct all information once we
    190 198 
             -- generated instructions. So instead we update the CFG as we go.
    199 
    +                natm_cur_block   :: !(MaybeUB BlockId)
    200 
    +        -- ^ Keep track of the current block during code generation for
    201 
    +        -- CFG updates. Only used by backends using the CFG for code layout.
    191 202 
             }
    192 203
    193 204 
     type DwarfFiles = UniqFM FastString (FastString, Int)
    ... ... @@ -217,6 +228,7 @@ mkNatM_State us delta config
    217 228 
                             , natm_fileid = dwf
    218 229 
                             , natm_debug_map = dbg
    219 230 
                             , natm_cfg = cfg
    231 
    +                        , natm_cur_block = NothingUB
    220 232 
                             }
    221 233
    222 234 
     initNat :: NatM_State -> NatM a -> (a, NatM_State)
    ... ... @@ -255,6 +267,167 @@ updateCfgNat f
    255 267 
             = NatM $ \ st -> let !cfg' = f (natm_cfg st)
    256 268 
                              in ((), st { natm_cfg = cfg'})
    257 269
    270 
    +setCurrentBlock :: BlockId -> NatM ()
    271 
    +setCurrentBlock bid = NatM $ \ st -> ((), st { natm_cur_block = JustUB bid })
    272 
    +
    273 
    +getCurrentBlock :: NatM (Maybe BlockId)
    274 
    +getCurrentBlock = NatM $ \ st ->
    275 
    +  let !cbid = case natm_cur_block st of
    276 
    +        JustUB bid -> Just bid
    277 
    +        NothingUB  -> Nothing
    278 
    +  in
    279 
    +  ( cbid, st )
    280 
    +
    281 
    +{- Note [Updating the CFG during CodeGen]
    282 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    283 
    +At the CMM level life is simple:
    284 
    +Blocks consist of a sequence of statements.
    285 
    +Control flow exists only between blocks.
    286 
    +
    287 
    +We are not so lucky for CodeGen. There we may introduce
    288 
    +intra-block control flow. For example we might turn a
    289 
    +simple ´MO_Ctz width arg` into branching code like this:
    290 
    +
    291 
    +       arg_block
    292 
    +        ╱     ╲
    293 
    +    left       right
    294 
    +        ╲     ╱
    295 
    +          cont
    296 
    +
    297 
    +We update the CFG to account for this. (See also Note [CFG based code layout]).
    298 
    +To do so we generally:
    299 
    +* Keep track of the current block in the NatM state.
    300 
    +* Compute code for all dependencies (arg in this case)
    301 
    +* Then generate the instructions for the MachOp at hand.
    302 
    +  + If that involves branching control flow we call update the CFG
    303 
    +    by calling one of continueInNewBlock, addCondBlock or addDiamondFlow,
    304 
    +    which will adjust the CFG
    305 
    +    and update the current block.
    306 
    +* We then return our generated instructions, and the parent expression
    307 
    +  can use the update CFG/currentBlock to generate it's own code.
    308 
    +-}
    309 
    +
    310 
    +-- | The block instructions are currently being generated for.
    311 
    +--
    312 
    +-- Panics if the current block isn't being tracked, which is a code generator
    313 
    +-- bug: any backend using the CFG based operations below must set the current
    314 
    +-- block for each basic block it starts to generate code for.
    315 
    +currentBlock :: HasDebugCallStack => NatM BlockId
    316 
    +currentBlock = NatM $ \ st ->
    317 
    +  case natm_cur_block st of
    318 
    +    JustUB bid -> (bid, st)
    319 
    +    NothingUB  -> panic "currentBlock: current block not tracked"
    320 
    +
    321 
    +-- | Continue/extend the current block under a new label.
    322 
    +--
    323 
    +-- >   Before:  cur -> S       After:  cur -> cont -> S
    324 
    +--
    325 
    +-- All cur->S edges get rewritten to cont->S.
    326 
    +-- @cont@ becomes the current block.
    327 
    +-- Returns @cur@ (the old current block).
    328 
    +--
    329 
    +-- Use for example for self loops. See also Note [Updating the CFG during CodeGen]
    330 
    +continueInNewBlock :: HasDebugCallStack => BlockId -> NatM BlockId
    331 
    +continueInNewBlock cont = do
    332 
    +    cur <- currentBlock
    333 
    +    addImmediateSuccessorNat cur cont
    334 
    +    setCurrentBlock cont
    335 
    +    return cur
    336 
    +
    337 
    +-- | Register diamond shaped control flow.
    338 
    +--
    339 
    +-- >     Before:            After:
    340 
    +-- >
    341 
    +-- >       cur                cur
    342 
    +-- >        │                ╱   ╲
    343 
    +-- >        │          likely     unlikely
    344 
    +-- >        │                ╲   ╱
    345 
    +-- >        │                 cont
    346 
    +-- >        ▼                  │
    347 
    +-- >        S                  ▼
    348 
    +-- >                           S
    349 
    +--
    350 
    +-- * All cur->S edges get rewritten to cont->S.
    351 
    +-- * @cont becomes the current block.
    352 
    +--
    353 
    +-- See also Note [Updating the CFG during CodeGen]
    354 
    +addDiamondFlow :: HasDebugCallStack
    355 
    +               => BlockId -- ^ the arm we expect to be taken
    356 
    +               -> BlockId -- ^ the arm we expect not to be taken
    357 
    +               -> BlockId -- ^ the block both arms converge on
    358 
    +               -> NatM ()
    359 
    +addDiamondFlow likely unlikely cont = do
    360 
    +    weights <- getCfgWeights
    361 
    +    cur <- continueInNewBlock cont
    362 
    +    -- Both arms end in an unconditional jump to cont. Control never passes
    363 
    +    -- from cur to cont directly, so we drop the edge continueInNewBlock added.
    364 
    +    updateCfgNat ( addWeightEdge cur likely    (fromIntegral $ likelyCondWeight weights)
    365 
    +                 . addWeightEdge cur unlikely  (fromIntegral $ unlikelyCondWeight weights)
    366 
    +                 . addWeightEdge likely   cont (fromIntegral $ uncondWeight weights)
    367 
    +                 . addWeightEdge unlikely cont (fromIntegral $ uncondWeight weights)
    368 
    +                 . delEdge cur cont )
    369 
    +
    370 
    +-- | Register a conditional block that converges again on the same path.
    371 
    +--
    372 
    +-- >     Before:            After:
    373 
    +-- >
    374 
    +-- >       cur                cur ────╮
    375 
    +-- >        │                  │      │
    376 
    +-- >        │                  │  cond_block
    377 
    +-- >        │                  │      │
    378 
    +-- >        │                 cont ◀─╯
    379 
    +-- >        ▼                  │
    380 
    +-- >        S                  ▼
    381 
    +-- >                           S
    382 
    +--
    383 
    +-- Takes a bool @is_likely@ that indicates if the new block is the likely code
    384 
    +-- path or not.
    385 
    +--
    386 
    +-- @cont@ takes over the successors of the current block and becomes the
    387 
    +-- current block.
    388 
    +--
    389 
    +-- See also Note [Updating the CFG during CodeGen]
    390 
    +addCondBlock :: HasDebugCallStack
    391 
    +             => BlockId -- ^ the new code block
    392 
    +             -> Bool    -- ^ Is the newly given block the likely code path?
    393 
    +             -> BlockId -- ^ the block control flow converges on
    394 
    +             -> NatM ()
    395 
    +addCondBlock cond_block is_likely cont = do
    396 
    +    weights <- getCfgWeights
    397 
    +    cur <- continueInNewBlock cont
    398 
    +    let likely   = fromIntegral (likelyCondWeight weights)
    399 
    +        unlikely = fromIntegral (unlikelyCondWeight weights)
    400 
    +        (w_cond, w_skip) | is_likely = (likely, unlikely)
    401 
    +                         | otherwise = (unlikely, likely)
    402 
    +    -- This overwrites the cur -> cont edge added by continueInNewBlock, which
    403 
    +    -- is no longer an unconditional jump now that cond_block can be taken.
    404 
    +    updateCfgNat ( addWeightEdge cur cond_block w_cond
    405 
    +                 . addWeightEdge cur cont       w_skip
    406 
    +                 . addWeightEdge cond_block cont (fromIntegral $ uncondWeight weights) )
    407 
    +
    408 
    +-- | Register a self loop on the given block, e.g. the retry loop of a
    409 
    +-- cmpxchg based sequence.
    410 
    +--
    411 
    +-- >   bid ──╮
    412 
    +-- >    ▲    │
    413 
    +-- >    ╰────╯
    414 
    +--
    415 
    +-- The edge gets a weight of zero, which keeps it irrelevant for layout:
    416 
    +-- 'optimizeCFG' deliberately does not apply its back edge bonus to zero weight
    417 
    +-- edges, so @bid@ is not treated as the head of a hot loop.
    418 
    +--
    419 
    +-- See also Note [Updating the CFG during CodeGen]
    420 
    +-- See also Note [Introducing cfg edges inside basic blocks] for some wrinkles around
    421 
    +-- self loops in particular.
    422 
    +addColdSelfLoop :: BlockId -> NatM ()
    423 
    +addColdSelfLoop bid = updateCfgNat (addWeightEdge bid bid 0)
    424 
    +
    425 
    +-- | Allows us to bias layout towards a specific edge.
    426 
    +increaseEdgeWeight :: HasDebugCallStack => BlockId -> EdgeWeight -> NatM ()
    427 
    +increaseEdgeWeight target bonus = do
    428 
    +    cur <- currentBlock
    429 
    +    updateCfgNat (\cfg -> adjustEdgeWeight cfg (+ bonus) cur target)
    430 
    +
    258 431 
     -- | Record that we added a block between `from` and `old`.
    259 432 
     addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
    260 433 
     addNodeBetweenNat from between to

  • compiler/GHC/CmmToAsm/X86/CodeGen.hs
    ... ... @@ -47,8 +47,10 @@ import GHC.CmmToAsm.Monad
    47 47 
        , getDeltaNat, getBlockIdNat, getPicBaseNat
    48 48 
        , Reg64(..), RegCode64(..), getNewReg64, localReg64
    49 49 
        , getPicBaseMaybeNat, getDebugBlock, getFileId
    50 
    -   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform
    51 
    -   , getCfgWeights
    50 
    +   , getConfig, getPlatform
    51 
    +   , setCurrentBlock, getCurrentBlock, currentBlock
    52 
    +   , continueInNewBlock, addDiamondFlow, addCondBlock
    53 
    +   , addColdSelfLoop, increaseEdgeWeight
    52 54 
        )
    53 55 
     import GHC.CmmToAsm.CFG
    54 56 
     import GHC.CmmToAsm.Format
    ... ... @@ -216,6 +218,7 @@ basicBlockCodeGen block = do
    216 218 
       let (_, nodes, tail)  = blockSplit block
    217 219 
           id = entryLabel block
    218 220 
           stmts = blockToList nodes
    221 
    +  setCurrentBlock id
    219 222 
       -- Generate location directive
    220 223 
       dbg <- getDebugBlock (entryLabel block)
    221 224 
       loc_instrs <- case dblSourceTick =<< dbg of
    ... ... @@ -224,8 +227,8 @@ basicBlockCodeGen block = do
    224 227 
                 let line = srcSpanStartLine span; col = srcSpanStartCol span
    225 228 
                 return $ unitOL $ LOCATION fileId line col (unpackFS name)
    226 229 
         _ -> return nilOL
    227 
    -  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
    228 
    -  (!tail_instrs,_) <- stmtToInstrs mid_bid tail
    230 
    +  mid_instrs <- stmtsToInstrs stmts
    231 
    +  !tail_instrs <- stmtToInstrs tail
    229 232 
       let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
    230 233 
       platform <- getPlatform
    231 234 
       return $! verifyBasicBlock platform (fromOL instrs)
    ... ... @@ -301,55 +304,41 @@ This resulted in two new basic blocks being inserted:
    301 304 
                     jmp _c3B1
    302 305 
             ...
    303 306
    304 
    -Based on the Cmm we called stmtToInstrs we translated both atomic operations under
    305 
    -the assumption they would be placed into their Cmm basic block `c3Bf`.
    306 
    -However for the retry loop we introduce new labels, so this is not the case
    307 
    -for the second statement.
    308 
    -This resulted in a desync between the explicit control flow graph
    309 
    -we construct as a separate data type and the actual control flow graph in the code.
    307 
    +This is a relatively common occurance for a number of MachOps. And is, in fact,
    308 
    +not limited to statements but can also happen for Cmm expressions in general.
    309 
    +To ensure we always the basic block info around with which we can update the CFG
    310 
    +whenever we split up the control flow graph we keep track of that information
    311 
    +in the NatM state via setCurrentBlock.
    310 312
    311 
    -Instead we now return the new basic block if a statement causes a change
    312 
    -in the current block and use the block for all following statements.
    313 
    -
    314 
    -For this reason genForeignCall is also split into two parts.  One for calls which
    315 
    -*won't* change the basic blocks in which successive instructions will be
    316 
    -placed (since they only evaluate CmmExpr, which can only contain MachOps, which
    317 
    -cannot introduce basic blocks in their lowerings).  A different one for calls
    318 
    -which *are* known to change the basic block.
    313 
    +This works because ultimately the control flow of those expressions and statements *does*
    314 
    +converge. So every expression, and every statement that wasn't a conditional branch at
    315 
    +the CMM level must converge in a single block. And whenver we are done generating the code
    316 
    +for one of those we can record the block in which it did so using setCurrentBlock.
    319 317
    318 
    +While we could go all out and take this one step further and hoist the CFG updates fully
    319 
    +into NatM with combinators like `withDiamond (\left right cont -> ...)` for now we use
    320 
    +explicit CFG updates.
    320 321 
     -}
    321 322
    322 
    --- See Note [Keeping track of the current block] for why
    323 
    --- we pass the BlockId.
    324 
    -stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
    325 
    -              -> [CmmNode O O] -- ^ Cmm Statement
    326 
    -              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
    327 
    -stmtsToInstrs bid stmts =
    328 
    -    go bid stmts nilOL
    323 
    +stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements
    324 
    +              -> NatM InstrBlock -- ^ Resulting instructions
    325 
    +stmtsToInstrs stmts =
    326 
    +    go stmts nilOL
    329 327 
       where
    330 
    -    go bid  []        instrs = return (instrs,bid)
    331 
    -    go bid (s:stmts)  instrs = do
    332 
    -      (instrs',bid') <- stmtToInstrs bid s
    333 
    -      -- If the statement introduced a new block, we use that one
    334 
    -      let !newBid = fromMaybe bid bid'
    335 
    -      go newBid stmts (instrs `appOL` instrs')
    336 
    -
    337 
    --- | `bid` refers to the current block and is used to update the CFG
    338 
    ---   if new blocks are inserted in the control flow.
    339 
    --- See Note [Keeping track of the current block] for more details.
    340 
    -stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
    341 
    -             -> CmmNode e x
    342 
    -             -> NatM (InstrBlock, Maybe BlockId)
    343 
    -             -- ^ Instructions, and bid of new block if successive
    344 
    -             -- statements are placed in a different basic block.
    345 
    -stmtToInstrs bid stmt = do
    328 
    +    go []        instrs = return instrs
    329 
    +    go (s:stmts) instrs = do
    330 
    +      instrs' <- stmtToInstrs s
    331 
    +      go stmts (instrs `appOL` instrs')
    332 
    +
    333 
    +stmtToInstrs :: CmmNode e x
    334 
    +             -> NatM InstrBlock
    335 
    +stmtToInstrs stmt = do
    346 336 
       is32Bit <- is32BitPlatform
    347 337 
       platform <- getPlatform
    348 338 
       case stmt of
    349 
    -    CmmUnsafeForeignCall target result_regs args
    350 
    -       -> genForeignCall target result_regs args bid
    339 
    +      CmmUnsafeForeignCall target result_regs args
    340 
    +                     -> genForeignCall target result_regs args
    351 341
    352 
    -    _ -> (,Nothing) <$> case stmt of
    353 342 
           CmmComment s   -> return (unitOL (COMMENT s))
    354 343 
           CmmTick {}     -> return nilOL
    355 344
    ... ... @@ -381,8 +370,8 @@ stmtToInstrs bid stmt = do
    381 370
    382 371 
           --We try to arrange blocks such that the likely branch is the fallthrough
    383 372 
           --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
    384 
    -      CmmCondBranch arg true false _ -> genCondBranch bid true false arg
    385 
    -      CmmSwitch arg ids -> genSwitch arg ids bid
    373 
    +      CmmCondBranch arg true false _ -> genCondBranch true false arg
    374 
    +      CmmSwitch arg ids -> genSwitch arg ids
    386 375 
           CmmCall { cml_target = arg
    387 376 
                   , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
    388 377 
           _ ->
    ... ... @@ -734,6 +723,8 @@ iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do
    734 723 
        Reg64 rhi rlo <- getNewReg64
    735 724 
        lbl1 <- newBlockId
    736 725 
        lbl2 <- newBlockId
    726 
    +   -- See Note [Updating the CFG during CodeGen]
    727 
    +   addCondBlock lbl1 False lbl2
    737 728 
        let
    738 729 
             code =  code1 `appOL`
    739 730 
                     code2 ecx `appOL`
    ... ... @@ -764,6 +755,8 @@ iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do
    764 755 
        Reg64 rhi rlo <- getNewReg64
    765 756 
        lbl1 <- newBlockId
    766 757 
        lbl2 <- newBlockId
    758 
    +   -- See Note [Updating the CFG during CodeGen]
    759 
    +   addCondBlock lbl1 False lbl2
    767 760 
        let
    768 761 
             code =  code1 `appOL`
    769 762 
                     code2 `appOL`
    ... ... @@ -791,6 +784,8 @@ iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do
    791 784 
        Reg64 rhi rlo <- getNewReg64
    792 785 
        lbl1 <- newBlockId
    793 786 
        lbl2 <- newBlockId
    787 
    +   -- See Note [Updating the CFG during CodeGen]
    788 
    +   addCondBlock lbl1 False lbl2
    794 789 
        let
    795 790 
             code =  code1 `appOL`
    796 791 
                     code2 `appOL`
    ... ... @@ -4151,21 +4146,20 @@ codes are set according to the supplied comparison operation.
    4151 4146 
     -}
    4152 4147
    4153 4148 
     genCondBranch
    4154 
    -    :: BlockId      -- the source of the jump
    4155 
    -    -> BlockId      -- the true branch target
    4149 
    +    :: BlockId      -- the true branch target
    4156 4150 
         -> BlockId      -- the false branch target
    4157 4151 
         -> CmmExpr      -- the condition on which to branch
    4158 4152 
         -> NatM InstrBlock -- Instructions
    4159 4153
    4160 
    -genCondBranch bid id false expr = do
    4154 
    +genCondBranch id false expr = do
    4161 4155 
       is32Bit <- is32BitPlatform
    4162 
    -  genCondBranch' is32Bit bid id false expr
    4156 
    +  genCondBranch' is32Bit id false expr
    4163 4157
    4164 4158 
     -- | We return the instructions generated.
    4165 
    -genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
    4159 
    +genCondBranch' :: Bool -> BlockId -> BlockId -> CmmExpr
    4166 4160 
                    -> NatM InstrBlock
    4167 4161
    4168 
    -genCondBranch' _ bid id false bool = do
    4162 
    +genCondBranch' _ id false bool = do
    4169 4163 
       CondCode is_float cond cond_code <- getCondCode bool
    4170 4164 
       if not is_float
    4171 4165 
         then
    ... ... @@ -4200,7 +4194,11 @@ genCondBranch' _ bid id false bool = do
    4200 4194 
                       JXX cond id,
    4201 4195 
                       JXX ALWAYS false
    4202 4196 
                     ]
    4203 
    -        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)
    4197 
    +
    4198 
    +        -- We can fall through the false branch. Which makes it
    4199 
    +        -- beneficial to bias code layout towards placing the
    4200 
    +        -- false target after the jump.
    4201 
    +        increaseEdgeWeight false 3
    4204 4202 
             return (cond_code `appOL` code)
    4205 4203
    4206 4204 
     {-  Note [Introducing cfg edges inside basic blocks]
    ... ... @@ -4315,147 +4313,129 @@ genCondBranch' _ bid id false bool = do
    4315 4313 
     --
    4316 4314 
     -- (If applicable) Do not fill the delay slots here; you will confuse the
    4317 4315 
     -- register allocator.
    4318 
    ---
    4319 
    --- See Note [Keeping track of the current block] for information why we need
    4320 
    --- to take/return a block id.
    4321 4316
    4322 4317 
     genForeignCall
    4323 4318 
         :: ForeignTarget -- ^ function to call
    4324 4319 
         -> [CmmFormal]   -- ^ where to put the result
    4325 4320 
         -> [CmmActual]   -- ^ arguments (of mixed type)
    4326 
    -    -> BlockId       -- ^ The block we are in
    4327 
    -    -> NatM (InstrBlock, Maybe BlockId)
    4321 
    +    -> NatM InstrBlock
    4328 4322
    4329 
    -genForeignCall target dst args bid = do
    4323 
    +genForeignCall target dst args = do
    4330 4324 
       case target of
    4331 
    -    PrimTarget prim         -> genPrim bid prim dst args
    4332 
    -    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args
    4325 
    +    PrimTarget prim         -> genPrim prim dst args
    4326 
    +    ForeignTarget addr conv -> genCCall addr conv dst args
    4333 4327
    4334 4328 
     genPrim
    4335 
    -    :: BlockId       -- ^ The block we are in
    4336 
    -    -> CallishMachOp -- ^ MachOp
    4337 
    -    -> [CmmFormal]   -- ^ where to put the result
    4338 
    -    -> [CmmActual]   -- ^ arguments (of mixed type)
    4339 
    -    -> NatM (InstrBlock, Maybe BlockId)
    4340 
    -
    4341 
    --- First we deal with cases which might introduce new blocks in the stream.
    4342 
    -genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]
    4343 
    -  = genAtomicRMW bid width amop dst addr n
    4344 
    -genPrim bid (MO_Ctz width) [dst] [src]
    4345 
    -  = genCtz bid width dst src
    4346 
    -genPrim bid (MO_UF_Conv width) [dst] [src]
    4347 
    -  = genWordToFloat bid width dst src
    4348 
    -
    4349 
    --- Then we deal with cases which not introducing new blocks in the stream.
    4350 
    -genPrim bid prim dst args
    4351 
    -  = (,Nothing) <$> genSimplePrim bid prim dst args
    4352 
    -
    4353 
    -genSimplePrim
    4354 
    -    :: BlockId       -- ^ the block we are in
    4355 
    -    -> CallishMachOp -- ^ MachOp
    4329 
    +    :: CallishMachOp -- ^ MachOp
    4356 4330 
         -> [CmmFormal]   -- ^ where to put the result
    4357 4331 
         -> [CmmActual]   -- ^ arguments (of mixed type)
    4358 4332 
         -> NatM InstrBlock
    4359 
    -genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n
    4360 
    -genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n
    4361 
    -genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n
    4362 
    -genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n
    4363 
    -genSimplePrim _   MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;
    4364 
    -genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.
    4365 
    -genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE
    4366 
    -genSimplePrim _   MO_Touch             []      [_]            = return nilOL
    4367 
    -genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src
    4368 
    -genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src
    4369 
    -genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src
    4370 
    -genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src
    4371 
    -genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask
    4372 
    -genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask
    4373 
    -genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src
    4374 
    -genSimplePrim _   (MO_AtomicRead w mo)  [dst]  [addr]         = genAtomicRead w mo dst addr
    4375 
    -genSimplePrim _   (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo addr val
    4376 
    -genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new
    4377 
    -genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value
    4378 
    -genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y
    4379 
    -genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y
    4380 
    -genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y
    4381 
    -genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y
    4382 
    -genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y
    4383 
    -genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y
    4384 
    -genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y
    4385 
    -genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y
    4386 
    -genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y
    4387 
    -genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y
    4388 
    -genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src
    4389 
    -genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src
    4390 
    -genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src
    4391 
    -genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src
    4392 
    -genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]
    4393 
    -genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]
    4394 
    -genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]
    4395 
    -genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]
    4396 
    -genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]
    4397 
    -genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]
    4398 
    -genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]
    4399 
    -genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]
    4400 
    -genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]
    4401 
    -genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]
    4402 
    -genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]
    4403 
    -genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]
    4404 
    -genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]
    4405 
    -genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]
    4406 
    -genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]
    4407 
    -genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]
    4408 
    -genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]
    4409 
    -genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]
    4410 
    -genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]
    4411 
    -genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]
    4412 
    -genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]
    4413 
    -genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]
    4414 
    -genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]
    4415 
    -genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]
    4416 
    -genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]
    4417 
    -genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]
    4418 
    -genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]
    4419 
    -genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]
    4420 
    -genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]
    4421 
    -genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]
    4422 
    -genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]
    4423 
    -genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]
    4424 
    -genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]
    4425 
    -genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]
    4426 
    -genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]
    4427 
    -genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]
    4428 
    -genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]
    4429 
    -genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]
    4430 
    -genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]
    4431 
    -genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]
    4432 
    -genSimplePrim bid (MO_VS_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y]
    4433 
    -genSimplePrim bid (MO_VS_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y]
    4434 
    -genSimplePrim bid (MO_VS_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y]
    4435 
    -genSimplePrim bid (MO_VS_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y]
    4436 
    -genSimplePrim _   op@(MO_VS_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4437 
    -genSimplePrim bid (MO_VS_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y]
    4438 
    -genSimplePrim bid (MO_VS_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y]
    4439 
    -genSimplePrim bid (MO_VS_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y]
    4440 
    -genSimplePrim bid (MO_VS_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y]
    4441 
    -genSimplePrim _   op@(MO_VS_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4442 
    -genSimplePrim bid (MO_VU_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y]
    4443 
    -genSimplePrim bid (MO_VU_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y]
    4444 
    -genSimplePrim bid (MO_VU_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y]
    4445 
    -genSimplePrim bid (MO_VU_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y]
    4446 
    -genSimplePrim _   op@(MO_VU_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4447 
    -genSimplePrim bid (MO_VU_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y]
    4448 
    -genSimplePrim bid (MO_VU_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y]
    4449 
    -genSimplePrim bid (MO_VU_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y]
    4450 
    -genSimplePrim bid (MO_VU_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y]
    4451 
    -genSimplePrim _   op@(MO_VU_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4452 
    -genSimplePrim bid MO_I64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y]
    4453 
    -genSimplePrim bid MO_I64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y]
    4454 
    -genSimplePrim bid MO_W64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y]
    4455 
    -genSimplePrim bid MO_W64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y]
    4456 
    -genSimplePrim _   op                   dst     args           = do
    4333 
    +genPrim (MO_AtomicRMW width amop) [dst] [addr, n]
    4334 
    +  = genAtomicRMW width amop dst addr n
    4335 
    +genPrim (MO_Ctz width) [dst] [src]
    4336 
    +  = genCtz width dst src
    4337 
    +genPrim (MO_UF_Conv width) [dst] [src]
    4338 
    +  = genWordToFloat width dst src
    4339 
    +genPrim (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  align dst src n
    4340 
    +genPrim (MO_Memmove align)   []      [dst,src,n]    = genMemMove align dst src n
    4341 
    +genPrim (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  align res dst src n
    4342 
    +genPrim (MO_Memset align)    []      [dst,c,n]      = genMemSet  align dst c n
    4343 
    +genPrim MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;
    4344 
    +genPrim MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.
    4345 
    +genPrim MO_SeqCstFence       []      []             = return $ unitOL MFENCE
    4346 
    +genPrim MO_Touch             []      [_]            = return nilOL
    4347 
    +genPrim (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src
    4348 
    +genPrim (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src
    4349 
    +genPrim (MO_BRev width)      [dst]   [src]          = genBitRev width dst src
    4350 
    +genPrim (MO_PopCnt width)    [dst]   [src]          = genPopCnt width dst src
    4351 
    +genPrim (MO_Pdep width)      [dst]   [src,mask]     = genPdep width dst src mask
    4352 
    +genPrim (MO_Pext width)      [dst]   [src,mask]     = genPext width dst src mask
    4353 
    +genPrim (MO_Clz width)       [dst]   [src]          = genClz width dst src
    4354 
    +genPrim (MO_AtomicRead w mo)  [dst]  [addr]         = genAtomicRead w mo dst addr
    4355 
    +genPrim (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo addr val
    4356 
    +genPrim (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg width dst addr old new
    4357 
    +genPrim (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value
    4358 
    +genPrim (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y
    4359 
    +genPrim (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y
    4360 
    +genPrim (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y
    4361 
    +genPrim (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y
    4362 
    +genPrim (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y
    4363 
    +genPrim (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y
    4364 
    +genPrim (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y
    4365 
    +genPrim (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y
    4366 
    +genPrim (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y
    4367 
    +genPrim (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y
    4368 
    +genPrim MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src
    4369 
    +genPrim MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src
    4370 
    +genPrim MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src
    4371 
    +genPrim MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src
    4372 
    +genPrim MO_F32_Sin           [dst]   [src]          = genLibCCall (fsLit "sinf") [dst] [src]
    4373 
    +genPrim MO_F32_Cos           [dst]   [src]          = genLibCCall (fsLit "cosf") [dst] [src]
    4374 
    +genPrim MO_F32_Tan           [dst]   [src]          = genLibCCall (fsLit "tanf") [dst] [src]
    4375 
    +genPrim MO_F32_Exp           [dst]   [src]          = genLibCCall (fsLit "expf") [dst] [src]
    4376 
    +genPrim MO_F32_ExpM1         [dst]   [src]          = genLibCCall (fsLit "expm1f") [dst] [src]
    4377 
    +genPrim MO_F32_Log           [dst]   [src]          = genLibCCall (fsLit "logf") [dst] [src]
    4378 
    +genPrim MO_F32_Log1P         [dst]   [src]          = genLibCCall (fsLit "log1pf") [dst] [src]
    4379 
    +genPrim MO_F32_Asin          [dst]   [src]          = genLibCCall (fsLit "asinf") [dst] [src]
    4380 
    +genPrim MO_F32_Acos          [dst]   [src]          = genLibCCall (fsLit "acosf") [dst] [src]
    4381 
    +genPrim MO_F32_Atan          [dst]   [src]          = genLibCCall (fsLit "atanf") [dst] [src]
    4382 
    +genPrim MO_F32_Sinh          [dst]   [src]          = genLibCCall (fsLit "sinhf") [dst] [src]
    4383 
    +genPrim MO_F32_Cosh          [dst]   [src]          = genLibCCall (fsLit "coshf") [dst] [src]
    4384 
    +genPrim MO_F32_Tanh          [dst]   [src]          = genLibCCall (fsLit "tanhf") [dst] [src]
    4385 
    +genPrim MO_F32_Pwr           [dst]   [x,y]          = genLibCCall (fsLit "powf")  [dst] [x,y]
    4386 
    +genPrim MO_F32_Asinh         [dst]   [src]          = genLibCCall (fsLit "asinhf") [dst] [src]
    4387 
    +genPrim MO_F32_Acosh         [dst]   [src]          = genLibCCall (fsLit "acoshf") [dst] [src]
    4388 
    +genPrim MO_F32_Atanh         [dst]   [src]          = genLibCCall (fsLit "atanhf") [dst] [src]
    4389 
    +genPrim MO_F64_Sin           [dst]   [src]          = genLibCCall (fsLit "sin") [dst] [src]
    4390 
    +genPrim MO_F64_Cos           [dst]   [src]          = genLibCCall (fsLit "cos") [dst] [src]
    4391 
    +genPrim MO_F64_Tan           [dst]   [src]          = genLibCCall (fsLit "tan") [dst] [src]
    4392 
    +genPrim MO_F64_Exp           [dst]   [src]          = genLibCCall (fsLit "exp") [dst] [src]
    4393 
    +genPrim MO_F64_ExpM1         [dst]   [src]          = genLibCCall (fsLit "expm1") [dst] [src]
    4394 
    +genPrim MO_F64_Log           [dst]   [src]          = genLibCCall (fsLit "log") [dst] [src]
    4395 
    +genPrim MO_F64_Log1P         [dst]   [src]          = genLibCCall (fsLit "log1p") [dst] [src]
    4396 
    +genPrim MO_F64_Asin          [dst]   [src]          = genLibCCall (fsLit "asin") [dst] [src]
    4397 
    +genPrim MO_F64_Acos          [dst]   [src]          = genLibCCall (fsLit "acos") [dst] [src]
    4398 
    +genPrim MO_F64_Atan          [dst]   [src]          = genLibCCall (fsLit "atan") [dst] [src]
    4399 
    +genPrim MO_F64_Sinh          [dst]   [src]          = genLibCCall (fsLit "sinh") [dst] [src]
    4400 
    +genPrim MO_F64_Cosh          [dst]   [src]          = genLibCCall (fsLit "cosh") [dst] [src]
    4401 
    +genPrim MO_F64_Tanh          [dst]   [src]          = genLibCCall (fsLit "tanh") [dst] [src]
    4402 
    +genPrim MO_F64_Pwr           [dst]   [x,y]          = genLibCCall (fsLit "pow")  [dst] [x,y]
    4403 
    +genPrim MO_F64_Asinh         [dst]   [src]          = genLibCCall (fsLit "asinh") [dst] [src]
    4404 
    +genPrim MO_F64_Acosh         [dst]   [src]          = genLibCCall (fsLit "acosh") [dst] [src]
    4405 
    +genPrim MO_F64_Atanh         [dst]   [src]          = genLibCCall (fsLit "atanh") [dst] [src]
    4406 
    +genPrim MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall (fsLit "suspendThread") [tok] [rs,i]
    4407 
    +genPrim MO_ResumeThread      [rs]    [tok]          = genRTSCCall (fsLit "resumeThread") [rs] [tok]
    4408 
    +genPrim MO_I64_Quot          [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotInt64") [dst] [x,y]
    4409 
    +genPrim MO_I64_Rem           [dst]   [x,y]          = genPrimCCall (fsLit "hs_remInt64") [dst] [x,y]
    4410 
    +genPrim MO_W64_Quot          [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotWord64") [dst] [x,y]
    4411 
    +genPrim MO_W64_Rem           [dst]   [x,y]          = genPrimCCall (fsLit "hs_remWord64") [dst] [x,y]
    4412 
    +genPrim (MO_VS_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotInt8X16") [dst] [x,y]
    4413 
    +genPrim (MO_VS_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotInt16X8") [dst] [x,y]
    4414 
    +genPrim (MO_VS_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotInt32X4") [dst] [x,y]
    4415 
    +genPrim (MO_VS_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotInt64X2") [dst] [x,y]
    4416 
    +genPrim op@(MO_VS_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4417 
    +genPrim (MO_VS_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remInt8X16") [dst] [x,y]
    4418 
    +genPrim (MO_VS_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remInt16X8") [dst] [x,y]
    4419 
    +genPrim (MO_VS_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remInt32X4") [dst] [x,y]
    4420 
    +genPrim (MO_VS_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remInt64X2") [dst] [x,y]
    4421 
    +genPrim op@(MO_VS_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4422 
    +genPrim (MO_VU_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotWord8X16") [dst] [x,y]
    4423 
    +genPrim (MO_VU_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotWord16X8") [dst] [x,y]
    4424 
    +genPrim (MO_VU_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotWord32X4") [dst] [x,y]
    4425 
    +genPrim (MO_VU_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall (fsLit "hs_quotWord64X2") [dst] [x,y]
    4426 
    +genPrim op@(MO_VU_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4427 
    +genPrim (MO_VU_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remWord8X16") [dst] [x,y]
    4428 
    +genPrim (MO_VU_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remWord16X8") [dst] [x,y]
    4429 
    +genPrim (MO_VU_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remWord32X4") [dst] [x,y]
    4430 
    +genPrim (MO_VU_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall (fsLit "hs_remWord64X2") [dst] [x,y]
    4431 
    +genPrim op@(MO_VU_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)
    4432 
    +genPrim MO_I64X2_Min         [dst]   [x,y]          = genPrimCCall (fsLit "hs_minInt64X2") [dst] [x,y]
    4433 
    +genPrim MO_I64X2_Max         [dst]   [x,y]          = genPrimCCall (fsLit "hs_maxInt64X2") [dst] [x,y]
    4434 
    +genPrim MO_W64X2_Min         [dst]   [x,y]          = genPrimCCall (fsLit "hs_minWord64X2") [dst] [x,y]
    4435 
    +genPrim MO_W64X2_Max         [dst]   [x,y]          = genPrimCCall (fsLit "hs_maxWord64X2") [dst] [x,y]
    4436 
    +genPrim op                   dst     args           = do
    4457 4437 
       platform <- ncgPlatform <$> getConfig
    4458 
    -  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))
    4438 
    +  pprPanic "genPrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))
    4459 4439
    4460 4440 
     {- Note [Evaluate C-call arguments before placing in destination registers]
    4461 4441 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -4507,8 +4487,8 @@ genForeignCall{32,64}.
    4507 4487 
     -}
    4508 4488
    4509 4489 
     -- | See Note [Evaluate C-call arguments before placing in destination registers]
    4510 
    -evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
    4511 
    -evalArgs bid actuals
    4490 
    +evalArgs :: [CmmActual] -> NatM (InstrBlock, [CmmActual])
    4491 
    +evalArgs actuals
    4512 4492 
       | any loadIntoRegMightClobberOtherReg actuals = do
    4513 4493 
           regs_blks <- mapM evalArg actuals
    4514 4494 
           return (concatOL $ map fst regs_blks, map snd regs_blks)
    ... ... @@ -4519,9 +4499,11 @@ evalArgs bid actuals
    4519 4499 
         evalArg actual = do
    4520 4500 
             platform <- getPlatform
    4521 4501 
             lreg <- newLocalReg $ cmmExprType platform actual
    4522 
    -        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
    4502 
    +        cur <- getCurrentBlock
    4503 
    +        instrs <- stmtToInstrs $ CmmAssign (CmmLocal lreg) actual
    4523 4504 
             -- The above assignment shouldn't change the current block
    4524 
    -        massert (isNothing bid1)
    4505 
    +        cur' <- getCurrentBlock
    4506 
    +        massert (cur == cur')
    4525 4507 
             return (instrs, CmmReg $ CmmLocal lreg)
    4526 4508
    4527 4509 
         newLocalReg :: CmmType -> NatM LocalReg
    ... ... @@ -4556,27 +4538,25 @@ loadIntoRegMightClobberOtherReg _ = True
    4556 4538
    4557 4539 
     -- | Generate C call to the given function in ghc-prim
    4558 4540 
     genPrimCCall
    4559 
    -  :: BlockId
    4560 
    -  -> FastString
    4541 
    +  :: FastString
    4561 4542 
       -> [CmmFormal]
    4562 4543 
       -> [CmmActual]
    4563 4544 
       -> NatM InstrBlock
    4564 
    -genPrimCCall bid lbl_txt dsts args = do
    4545 
    +genPrimCCall lbl_txt dsts args = do
    4565 4546 
       config <- getConfig
    4566 4547 
       -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel
    4567 4548 
       let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt
    4568 4549 
       addr <- cmmMakeDynamicReference config CallReference lbl
    4569 4550 
       let conv = ForeignConvention CCallConv [] [] CmmMayReturn
    4570 
    -  genCCall bid addr conv dsts args
    4551 
    +  genCCall addr conv dsts args
    4571 4552
    4572 4553 
     -- | Generate C call to the given function in libc
    4573 4554 
     genLibCCall
    4574 
    -  :: BlockId
    4575 
    -  -> FastString
    4555 
    +  :: FastString
    4576 4556 
       -> [CmmFormal]
    4577 4557 
       -> [CmmActual]
    4578 4558 
       -> NatM InstrBlock
    4579 
    -genLibCCall bid lbl_txt dsts args = do
    4559 
    +genLibCCall lbl_txt dsts args = do
    4580 4560 
       config <- getConfig
    4581 4561 
       -- Assume we can call these functions directly, and that they're not in a dynamic library.
    4582 4562 
       -- TODO: Why is this ok? Under linux this code will be in libm.so
    ... ... @@ -4584,37 +4564,35 @@ genLibCCall bid lbl_txt dsts args = do
    4584 4564 
       let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction
    4585 4565 
       addr <- cmmMakeDynamicReference config CallReference lbl
    4586 4566 
       let conv = ForeignConvention CCallConv [] [] CmmMayReturn
    4587 
    -  genCCall bid addr conv dsts args
    4567 
    +  genCCall addr conv dsts args
    4588 4568
    4589 4569 
     -- | Generate C call to the given function in the RTS
    4590 4570 
     genRTSCCall
    4591 
    -  :: BlockId
    4592 
    -  -> FastString
    4571 
    +  :: FastString
    4593 4572 
       -> [CmmFormal]
    4594 4573 
       -> [CmmActual]
    4595 4574 
       -> NatM InstrBlock
    4596 
    -genRTSCCall bid lbl_txt dsts args = do
    4575 
    +genRTSCCall lbl_txt dsts args = do
    4597 4576 
       config <- getConfig
    4598 4577 
       -- Assume we can call these functions directly, and that they're not in a dynamic library.
    4599 4578 
       let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction
    4600 4579 
       addr <- cmmMakeDynamicReference config CallReference lbl
    4601 4580 
       let conv = ForeignConvention CCallConv [] [] CmmMayReturn
    4602 
    -  genCCall bid addr conv dsts args
    4581 
    +  genCCall addr conv dsts args
    4603 4582
    4604 4583 
     -- | Generate a real C call to the given address with the given convention
    4605 4584 
     genCCall
    4606 
    -  :: BlockId
    4607 
    -  -> CmmExpr
    4585 
    +  :: CmmExpr
    4608 4586 
       -> ForeignConvention
    4609 4587 
       -> [CmmFormal]
    4610 4588 
       -> [CmmActual]
    4611 4589 
       -> NatM InstrBlock
    4612 
    -genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do
    4590 
    +genCCall addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do
    4613 4591 
       platform <- getPlatform
    4614 4592 
       is32Bit <- is32BitPlatform
    4615 4593 
       let args_hints = zip args (argHints ++ repeat NoHint)
    4616 4594 
           prom_args = map (maybePromoteCArgToW32 platform) args_hints
    4617 
    -  (instrs0, args') <- evalArgs bid prom_args
    4595 
    +  (instrs0, args') <- evalArgs prom_args
    4618 4596 
       instrs1 <- if is32Bit
    4619 4597 
         then genCCall32 addr conv dest_regs args'
    4620 4598 
         else genCCall64 addr conv dest_regs args'
    ... ... @@ -5575,8 +5553,8 @@ read the table and to compute the target address. However:
    5575 5553 
     -- | Generate a JMP_TBL instruction
    5576 5554 
     --
    5577 5555 
     -- See Note [Jump tables]
    5578 
    -genSwitch :: CmmExpr -> SwitchTargets -> BlockId -> NatM InstrBlock
    5579 
    -genSwitch expr targets bid = do
    5556 
    +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
    5557 
    +genSwitch expr targets = do
    5580 5558 
       config <- getConfig
    5581 5559 
       let platform = ncgPlatform config
    5582 5560 
           expr_w = cmmExprWidth platform expr
    ... ... @@ -5595,7 +5573,6 @@ genSwitch expr targets bid = do
    5595 5573 
           fmt = archWordFormat is32bit
    5596 5574
    5597 5575 
       table_lbl <- getNewLabelNat
    5598 
    -  let bid_lbl = blockLbl bid
    5599 5576 
       let table_section = Section ReadOnlyData table_lbl
    5600 5577
    5601 5578 
       -- see Note [Jump tables] for a description of the following 3 variants.
    ... ... @@ -5607,6 +5584,9 @@ genSwitch expr targets bid = do
    5607 5584 
           -- way (via cmmMakeDynamicReference).
    5608 5585 
           (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code and j_code
    5609 5586 
           (tableReg,t_code) <- getNonClobberedReg =<< cmmMakeDynamicReference config DataReference table_lbl
    5587 
    +      -- We make the jump table entries relative to the current block to ensure we don't
    5588 
    +      -- overflow.
    5589 
    +      bid_lbl <- blockLbl <$> currentBlock
    5610 5590 
           (targetReg,j_code) <- getSomeReg =<< cmmMakeDynamicReference config DataReference bid_lbl
    5611 5591 
           pure $ e_code `appOL` t_code `appOL` j_code `appOL` toOL
    5612 5592 
                 [ ADD fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)))
    ... ... @@ -6124,14 +6104,13 @@ invertCondBranches (Just cfg) keep bs =
    6124 6104 
         invert [] = []
    6125 6105
    6126 6106 
     genAtomicRMW
    6127 
    -  :: BlockId
    6128 
    -  -> Width
    6107 
    +  :: Width
    6129 6108 
       -> AtomicMachOp
    6130 6109 
       -> LocalReg
    6131 6110 
       -> CmmExpr
    6132 6111 
       -> CmmExpr
    6133 
    -  -> NatM (InstrBlock, Maybe BlockId)
    6134 
    -genAtomicRMW bid width amop dst addr n = do
    6112 
    +  -> NatM InstrBlock
    6113 
    +genAtomicRMW width amop dst addr n = do
    6135 6114 
         Amode amode addr_code <-
    6136 6115 
             if amop `elem` [AMO_Add, AMO_Sub]
    6137 6116 
             then getAmode addr
    ... ... @@ -6141,28 +6120,28 @@ genAtomicRMW bid width amop dst addr n = do
    6141 6120 
         platform <- ncgPlatform <$> getConfig
    6142 6121
    6143 6122 
         let dst_r    = getRegisterReg platform  (CmmLocal dst)
    6144 
    -    (code, lbl) <- op_code dst_r arg amode
    6145 
    -    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)
    6123 
    +    code <- op_code dst_r arg amode
    6124 
    +    return (addr_code `appOL` arg_code arg `appOL` code)
    6146 6125 
       where
    6147 6126 
         -- Code for the operation
    6148 6127 
         op_code :: Reg       -- Destination reg
    6149 6128 
                 -> Reg       -- Register containing argument
    6150 6129 
                 -> AddrMode  -- Address of location to mutate
    6151 
    -            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId
    6130 
    +            -> NatM (OrdList Instr)
    6152 6131 
         op_code dst_r arg amode = do
    6153 6132 
             case amop of
    6154 6133 
               -- In the common case where dst_r is a virtual register the
    6155 6134 
               -- final move should go away, because it's the last use of arg
    6156 6135 
               -- and the first use of dst_r.
    6157 
    -          AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))
    6158 
    -                                     , MOV format (OpReg arg) (OpReg dst_r)
    6159 
    -                                     ], bid)
    6160 
    -          AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)
    6161 
    -                                     , LOCK (XADD format (OpReg arg) (OpAddr amode))
    6162 
    -                                     , MOV format (OpReg arg) (OpReg dst_r)
    6163 
    -                                     ], bid)
    6164 
    -          -- In these cases we need a new block id, and have to return it so
    6165 
    -          -- that later instruction selection can reference it.
    6136 
    +          AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))
    6137 
    +                                    , MOV format (OpReg arg) (OpReg dst_r)
    6138 
    +                                    ]
    6139 
    +          AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)
    6140 
    +                                    , LOCK (XADD format (OpReg arg) (OpAddr amode))
    6141 
    +                                    , MOV format (OpReg arg) (OpReg dst_r)
    6142 
    +                                    ]
    6143 
    +          -- In these cases we need a new block id, and set it as current block
    6144 
    +          -- so that later instruction selection can reference it.
    6166 6145 
               AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)
    6167 6146 
               AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst
    6168 6147 
                                                           , NOT format dst
    ... ... @@ -6173,7 +6152,7 @@ genAtomicRMW bid width amop dst addr n = do
    6173 6152 
             -- Simulate operation that lacks a dedicated instruction using
    6174 6153 
             -- cmpxchg.
    6175 6154 
             cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
    6176 
    -                     -> NatM (OrdList Instr, BlockId)
    6155 
    +                     -> NatM (OrdList Instr)
    6177 6156 
             cmpxchg_code instrs = do
    6178 6157 
                 lbl1 <- getBlockIdNat
    6179 6158 
                 lbl2 <- getBlockIdNat
    ... ... @@ -6182,11 +6161,12 @@ genAtomicRMW bid width amop dst addr n = do
    6182 6161 
                 --Record inserted blocks
    6183 6162 
                 --  We turn A -> B into A -> A' -> A'' -> B
    6184 6163 
                 --  with a self loop on A'.
    6185 
    -            addImmediateSuccessorNat bid lbl1
    6186 
    -            addImmediateSuccessorNat lbl1 lbl2
    6187 
    -            updateCfgNat (addWeightEdge lbl1 lbl1 0)
    6164 
    +            -- See Note [Introducing cfg edges inside basic blocks]
    6165 
    +            _ <- continueInNewBlock lbl1
    6166 
    +            _ <- continueInNewBlock lbl2
    6167 
    +            addColdSelfLoop lbl1
    6188 6168
    6189 
    -            return $ (toOL
    6169 
    +            return $ toOL
    6190 6170 
                     [ MOV format (OpAddr amode) (OpReg eax)
    6191 6171 
                     , JXX ALWAYS lbl1
    6192 6172 
                     , NEWBLOCK lbl1
    ... ... @@ -6201,27 +6181,25 @@ genAtomicRMW bid width amop dst addr n = do
    6201 6181 
                     -- why this basic block is required.
    6202 6182 
                     , JXX ALWAYS lbl2
    6203 6183 
                     , NEWBLOCK lbl2
    6204 
    -                ],
    6205 
    -                lbl2)
    6184 
    +                ]
    6206 6185 
         format = intFormat width
    6207 6186
    6208 6187 
     -- | Count trailing zeroes
    6209 
    -genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)
    6210 
    -genCtz bid width dst src = do
    6188 
    +genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
    6189 
    +genCtz width dst src = do
    6211 6190 
       is32Bit <- is32BitPlatform
    6212 6191 
       if is32Bit && width == W64
    6213 
    -    then genCtz64_32 bid dst src
    6214 
    -    else (,Nothing) <$> genCtzGeneric width dst src
    6192 
    +    then genCtz64_32 dst src
    6193 
    +    else genCtzGeneric width dst src
    6215 6194
    6216 6195 
     -- | Count trailing zeroes
    6217 6196 
     --
    6218 6197 
     -- 64-bit width on 32-bit architecture
    6219 6198 
     genCtz64_32
    6220 
    -  :: BlockId
    6221 
    -  -> LocalReg
    6199 
    +  :: LocalReg
    6222 6200 
       -> CmmExpr
    6223 
    -  -> NatM (InstrBlock, Maybe BlockId)
    6224 
    -genCtz64_32 bid dst src = do
    6201 
    +  -> NatM InstrBlock
    6202 
    +genCtz64_32 dst src = do
    6225 6203 
       RegCode64 vcode rhi rlo <- iselExpr64 src
    6226 6204 
       let dst_r = getLocalRegReg dst
    6227 6205 
       lbl1 <- getBlockIdNat
    ... ... @@ -6229,13 +6207,12 @@ genCtz64_32 bid dst src = do
    6229 6207 
       tmp_r <- getNewRegNat II64
    6230 6208
    6231 6209 
       -- New CFG Edges:
    6232 
    -  --  bid -> lbl2
    6233 
    -  --  bid -> lbl1 -> lbl2
    6234 
    -  --  We also changes edges originating at bid to start at lbl2 instead.
    6235 
    -  weights <- getCfgWeights
    6236 
    -  updateCfgNat (addWeightEdge bid lbl1 110 .
    6237 
    -                addWeightEdge lbl1 lbl2 110 .
    6238 
    -                addImmediateSuccessor weights bid lbl2)
    6210 
    +  --  cur -> lbl2
    6211 
    +  --  cur -> lbl1 -> lbl2
    6212 
    +  --  We also change edges originating at the current block to start at lbl2
    6213 
    +  --  instead.
    6214 
    +  --  lbl1 is only skipped when src is zero, so it is the likely branch here.
    6215 
    +  addCondBlock lbl1 True lbl2
    6239 6216
    6240 6217 
       -- The following instruction sequence corresponds to the pseudo-code
    6241 6218 
       --
    ... ... @@ -6260,7 +6237,7 @@ genCtz64_32 bid dst src = do
    6260 6237
    6261 6238 
                 , NEWBLOCK   lbl2
    6262 6239 
                 ])
    6263 
    -  return (instrs, Just lbl2)
    6240 
    +  return instrs
    6264 6241
    6265 6242 
     -- | Count trailing zeroes
    6266 6243 
     --
    ... ... @@ -6308,15 +6285,14 @@ genCtzGeneric width dst src = do
    6308 6285 
     -- Unroll memcpy calls if the number of bytes to copy isn't too large (cf
    6309 6286 
     -- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.
    6310 6287 
     genMemCpy
    6311 
    -  :: BlockId
    6312 
    -  -> Int
    6288 
    +  :: Int
    6313 6289 
       -> CmmExpr
    6314 6290 
       -> CmmExpr
    6315 6291 
       -> CmmExpr
    6316 6292 
       -> NatM InstrBlock
    6317 
    -genMemCpy bid align dst src arg_n = do
    6293 
    +genMemCpy align dst src arg_n = do
    6318 6294
    6319 
    -  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]
    6295 
    +  let libc_memcpy = genLibCCall (fsLit "memcpy") [] [dst,src,arg_n]
    6320 6296
    6321 6297 
       case arg_n of
    6322 6298 
         CmmLit (CmmInt n _) -> do
    ... ... @@ -6399,15 +6375,14 @@ genMemCpyInlineMaybe align dst src n = do
    6399 6375 
     -- Unroll memset calls if the number of bytes to copy isn't too large (cf
    6400 6376 
     -- ncgInlineThresholdMemset).  Otherwise, call C's memset.
    6401 6377 
     genMemSet
    6402 
    -  :: BlockId
    6403 
    -  -> Int
    6378 
    +  :: Int
    6404 6379 
       -> CmmExpr
    6405 6380 
       -> CmmExpr
    6406 6381 
       -> CmmExpr
    6407 6382 
       -> NatM InstrBlock
    6408 
    -genMemSet bid align dst arg_c arg_n = do
    6383 
    +genMemSet align dst arg_c arg_n = do
    6409 6384
    6410 
    -  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]
    6385 
    +  let libc_memset = genLibCCall (fsLit "memset") [] [dst,arg_c,arg_n]
    6411 6386
    6412 6387 
       case (arg_c,arg_n) of
    6413 6388 
         (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do
    ... ... @@ -6503,17 +6478,17 @@ genMemSetInlineMaybe align dst c n = do
    6503 6478 
                                   go4 dst_r (fromInteger n)
    6504 6479
    6505 6480
    6506 
    -genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
    6507 
    -genMemMove bid _align dst src n = do
    6481 
    +genMemMove :: p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
    6482 
    +genMemMove _align dst src n = do
    6508 6483 
       -- TODO: generate inline assembly when under a given threshold (similarly to
    6509 6484 
       -- memcpy and memset)
    6510 
    -  genLibCCall bid (fsLit "memmove") [] [dst,src,n]
    6485 
    +  genLibCCall (fsLit "memmove") [] [dst,src,n]
    6511 6486
    6512 
    -genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
    6513 
    -genMemCmp bid _align res dst src n = do
    6487 
    +genMemCmp :: p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
    6488 
    +genMemCmp _align res dst src n = do
    6514 6489 
       -- TODO: generate inline assembly when under a given threshold (similarly to
    6515 6490 
       -- memcpy and memset)
    6516 
    -  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]
    6491 
    +  genLibCCall (fsLit "memcmp") [res] [dst,src,n]
    6517 6492
    6518 6493 
     genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)
    6519 6494 
     genPrefetchData n src = do
    ... ... @@ -6575,14 +6550,14 @@ genByteSwap width dst src = do
    6575 6550 
             code_src <- getAnyReg src
    6576 6551 
             return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)
    6577 6552
    6578 
    -genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
    6579 
    -genBitRev bid width dst src = do
    6553 
    +genBitRev :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock
    6554 
    +genBitRev width dst src = do
    6580 6555 
       -- Here the C implementation (hs_bitrevN) is used as there is no x86
    6581 6556 
       -- instruction to reverse a word's bit order.
    6582 
    -  genPrimCCall bid (bRevLabel width) [dst] [src]
    6557 
    +  genPrimCCall (bRevLabel width) [dst] [src]
    6583 6558
    6584 
    -genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock
    6585 
    -genPopCnt bid width dst src = do
    6559 
    +genPopCnt :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
    6560 
    +genPopCnt width dst src = do
    6586 6561 
       config <- getConfig
    6587 6562 
       let
    6588 6563 
         platform = ncgPlatform config
    ... ... @@ -6611,11 +6586,11 @@ genPopCnt bid width dst src = do
    6611 6586 
           -- generate C call to hs_popcntN in ghc-prim
    6612 6587 
           -- TODO: we could directly generate the assembly to index popcount_tab
    6613 6588 
           -- here instead of doing it by calling a C function
    6614 
    -      genPrimCCall bid (popCntLabel width) [dst] [src]
    6589 
    +      genPrimCCall (popCntLabel width) [dst] [src]
    6615 6590
    6616 6591
    6617 
    -genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
    6618 
    -genPdep bid width dst src mask = do
    6592 
    +genPdep :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
    6593 
    +genPdep width dst src mask = do
    6619 6594 
       config <- getConfig
    6620 6595 
       let
    6621 6596 
         platform = ncgPlatform config
    ... ... @@ -6642,11 +6617,11 @@ genPdep bid width dst src mask = do
    6642 6617 
               )
    6643 6618 
         else
    6644 6619 
           -- generate C call to hs_pdepN in ghc-prim
    6645 
    -      genPrimCCall bid (pdepLabel width) [dst] [src,mask]
    6620 
    +      genPrimCCall (pdepLabel width) [dst] [src,mask]
    6646 6621
    6647 6622
    6648 
    -genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
    6649 
    -genPext bid width dst src mask = do
    6623 
    +genPext :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
    6624 
    +genPext width dst src mask = do
    6650 6625 
       config <- getConfig
    6651 6626 
       if ncgBmiVersion config >= Just BMI2
    6652 6627 
         then do
    ... ... @@ -6670,17 +6645,17 @@ genPext bid width dst src mask = do
    6670 6645 
               )
    6671 6646 
         else
    6672 6647 
           -- generate C call to hs_pextN in ghc-prim
    6673 
    -      genPrimCCall bid (pextLabel width) [dst] [src,mask]
    6648 
    +      genPrimCCall (pextLabel width) [dst] [src,mask]
    6674 6649
    6675 
    -genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
    6676 
    -genClz bid width dst src = do
    6650 
    +genClz :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock
    6651 
    +genClz width dst src = do
    6677 6652 
       is32Bit <- is32BitPlatform
    6678 6653 
       config <- getConfig
    6679 6654 
       if is32Bit && width == W64
    6680 6655
    6681 6656 
         then
    6682 6657 
           -- Fallback to `hs_clz64` on i386
    6683 
    -      genPrimCCall bid (clzLabel width) [dst] [src]
    6658 
    +      genPrimCCall (clzLabel width) [dst] [src]
    6684 6659
    6685 6660 
         else do
    6686 6661 
           code_src <- getAnyReg src
    ... ... @@ -6777,8 +6752,8 @@ The constant 65536.0 (= 0x47800000 in float32 bit-pattern) is loaded
    6777 6752 
     via a MOV + MOVD, avoiding a memory load.
    6778 6753 
     -}
    6779 6754
    6780 
    -genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM (InstrBlock, Maybe BlockId)
    6781 
    -genWordToFloat bid width dst src = do
    6755 
    +genWordToFloat :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock
    6756 
    +genWordToFloat width dst src = do
    6782 6757 
       is32Bit <- is32BitPlatform
    6783 6758 
       platform <- getPlatform
    6784 6759
    ... ... @@ -6837,7 +6812,7 @@ genWordToFloat bid width dst src = do
    6837 6812 
                     , ADD dstFormat (OpReg tmp_v) (OpReg dst_r)        -- dst_r = float(high)*65536.0 + float(low)
    6838 6813 
                     ]
    6839 6814 
                 _           -> panic ("genWordToFloat: unsupported source operand format: " ++ show srcFormat)
    6840 
    -      pure (code, Nothing)
    6815 
    +      pure code
    6841 6816 
         else do
    6842 6817 
           -- See Note [Word-to-float conversion on x86-64]
    6843 6818 
           half_r  <- getNewRegNat srcFormat
    ... ... @@ -6847,19 +6822,9 @@ genWordToFloat bid width dst src = do
    6847 6822 
           lblSmall  <- getBlockIdNat
    6848 6823 
           lblAfter  <- getBlockIdNat
    6849 6824
    6850 
    -      -- We're building a diamond CFG:
    6851 
    -      --   bid -> lblSmall -> lblAfter -> origSucc
    6852 
    -      --       \-> lblLarge ->/
    6853 
    -      -- addImmediateSuccessorNat moves bid's original successor to lblAfter,
    6854 
    -      -- then we fix up the other edges.
    6855 
    -      addImmediateSuccessorNat bid lblAfter
    6856 6825 
           -- Small values (MSB clear, i.e. < 2^63) are assumed more common in
    6857 
    -      -- practice, hence the higher weight on the lblSmall edge.
    6858 
    -      updateCfgNat ( addWeightEdge bid     lblSmall  100
    6859 
    -                   . addWeightEdge bid     lblLarge   50
    6860 
    -                   . addWeightEdge lblSmall lblAfter   1
    6861 
    -                   . addWeightEdge lblLarge lblAfter   1
    6862 
    -                   . delEdge bid lblAfter )
    6826 
    +      -- practice, making lblSmall the likely branch of the diamond.
    6827 
    +      addDiamondFlow lblSmall lblLarge lblAfter
    6863 6828
    6864 6829 
           let code = appOL (code_src)
    6865 6830 
                 $ toOL
    ... ... @@ -6882,7 +6847,7 @@ genWordToFloat bid width dst src = do
    6882 6847 
                 , JXX ALWAYS lblAfter
    6883 6848 
                 , NEWBLOCK lblAfter
    6884 6849 
                 ]
    6885 
    -      return (code, Just lblAfter)
    6850 
    +      return code
    6886 6851
    6887 6852 
     genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock
    6888 6853 
     genAtomicRead width _mord dst addr = do
    ... ... @@ -6901,14 +6866,13 @@ genAtomicWrite width mord addr val = do
    6901 6866 
       return $ if needs_fence then code `snocOL` MFENCE else code
    6902 6867
    6903 6868 
     genCmpXchg
    6904 
    -  :: BlockId
    6905 
    -  -> Width
    6869 
    +  :: Width
    6906 6870 
       -> LocalReg
    6907 6871 
       -> CmmExpr
    6908 6872 
       -> CmmExpr
    6909 6873 
       -> CmmExpr
    6910 6874 
       -> NatM InstrBlock
    6911 
    -genCmpXchg bid width dst addr old new = do
    6875 
    +genCmpXchg width dst addr old new = do
    6912 6876 
       is32Bit <- is32BitPlatform
    6913 6877 
       -- On x86 we don't have enough registers to use cmpxchg with a
    6914 6878 
       -- complicated addressing mode, so on that architecture we
    ... ... @@ -6932,7 +6896,7 @@ genCmpXchg bid width dst addr old new = do
    6932 6896 
               `appOL` code
    6933 6897 
         else
    6934 6898 
           -- generate C call to hs_cmpxchgN in ghc-prim
    6935 
    -      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]
    6899 
    +      genPrimCCall (cmpxchgLabel width) [dst] [addr,old,new]
    6936 6900 
           -- TODO: implement cmpxchg8b instruction
    6937 6901
    6938 6902 
     genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/a8d57da7c14594a6a29a869e10437c2bc5aa6a83...a0e60edd9f2967972bf3ab7bdba8ba4709e02580 at 1787921008