Zubin pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Cmm/Config.hs
    ... ... @@ -24,8 +24,6 @@ data CmmConfig = CmmConfig
    24 24 
       , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries
    25 25 
       , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements
    26 26 
       , cmmSplitProcPoints     :: !Bool    -- ^ Should Cmm split proc points or not
    27 
    -  , cmmAllowMul2           :: !Bool    -- ^ Does this platform support mul2
    28 
    -  , cmmOptConstDivision    :: !Bool    -- ^ Should we optimize constant divisors
    29 27 
       }
    30 28
    31 29 
     -- | retrieve the target Cmm platform

  • compiler/GHC/Cmm/MachOp.hs
    ... ... @@ -7,7 +7,6 @@ module GHC.Cmm.MachOp
    7 7 
         , pprMachOp, isCommutableMachOp, isAssociativeMachOp
    8 8 
         , isComparisonMachOp, maybeIntComparison, machOpResultType
    9 9 
         , machOpArgReps, maybeInvertComparison, isFloatComparison
    10 
    -    , isCommutableCallishMachOp
    11 10
    12 11 
         -- MachOp builders
    13 12 
         , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
    ... ... @@ -846,17 +845,3 @@ machOpMemcpyishAlign op = case op of
    846 845 
       MO_Memmove align -> Just align
    847 846 
       MO_Memcmp  align -> Just align
    848 847 
       _                -> Nothing
    849 
    -
    850 
    -isCommutableCallishMachOp :: CallishMachOp -> Bool
    851 
    -isCommutableCallishMachOp op =
    852 
    -  case op of
    853 
    -    MO_x64_Add  -> True
    854 
    -    MO_x64_Mul  -> True
    855 
    -    MO_x64_Eq   -> True
    856 
    -    MO_x64_Ne   -> True
    857 
    -    MO_x64_And  -> True
    858 
    -    MO_x64_Or   -> True
    859 
    -    MO_x64_Xor  -> True
    860 
    -    MO_S_Mul2 _ -> True
    861 
    -    MO_U_Mul2 _ -> True
    862 
    -    _ -> False

  • compiler/GHC/Cmm/Opt.hs
    ... ... @@ -5,53 +5,29 @@
    5 5 
     -- (c) The University of Glasgow 2006
    6 6 
     --
    7 7 
     -----------------------------------------------------------------------------
    8 
    -{-# LANGUAGE TupleSections #-}
    9 
    -{-# LANGUAGE TypeApplications #-}
    10 
    -{-# LANGUAGE PatternSynonyms #-}
    11 8 
     module GHC.Cmm.Opt (
    12 9 
             constantFoldNode,
    13 10 
             constantFoldExpr,
    14 11 
             cmmMachOpFold,
    15 
    -        cmmMachOpFoldM,
    16 
    -        Opt, runOpt
    12 
    +        cmmMachOpFoldM
    17 13 
      ) where
    18 14
    19 15 
     import GHC.Prelude
    20 16
    21 
    -import GHC.Cmm.Dataflow.Block
    22 17 
     import GHC.Cmm.Utils
    23 18 
     import GHC.Cmm
    24 
    -import GHC.Cmm.Config
    25 
    -import GHC.Types.Unique.DSM
    26 
    -
    27 19 
     import GHC.Utils.Misc
    20 
    +
    28 21 
     import GHC.Utils.Panic
    29 22 
     import GHC.Utils.Outputable
    30 23 
     import GHC.Platform
    31 24
    32 25 
     import Data.Maybe
    33 26 
     import GHC.Float
    34 
    -import Data.Word
    35 
    -import GHC.Exts (oneShot)
    36 
    -import Control.Monad
    37 
    -
    38 
    -constantFoldNode :: CmmNode e x -> Opt (CmmNode e x)
    39 
    -constantFoldNode (CmmUnsafeForeignCall (PrimTarget op) res args)
    40 
    -  = traverse constantFoldExprOpt args >>= cmmCallishMachOpFold op res
    41 
    -constantFoldNode node
    42 
    -  = mapExpOpt constantFoldExprOpt node
    43 
    -
    44 
    -constantFoldExprOpt :: CmmExpr -> Opt CmmExpr
    45 
    -constantFoldExprOpt e = wrapRecExpOpt f e
    46 
    -  where
    47 
    -    f (CmmMachOp op args)
    48 
    -      = do
    49 
    -        cfg <- getConfig
    50 
    -        case cmmMachOpFold (cmmPlatform cfg) op args of
    51 
    -          CmmMachOp op' args' -> fromMaybe (CmmMachOp op' args') <$> cmmMachOpFoldOptM cfg op' args'
    52 
    -          e -> pure e
    53 
    -    f (CmmRegOff r 0) = pure (CmmReg r)
    54 
    -    f e = pure e
    27 
    +
    28 
    +
    29 
    +constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
    30 
    +constantFoldNode platform = mapExp (constantFoldExpr platform)
    55 31
    56 32 
     constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
    57 33 
     constantFoldExpr platform = wrapRecExp f
    ... ... @@ -354,7 +330,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
    354 330 
         maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
    355 331 
         maybe_comparison _ _ _ = Nothing
    356 332
    357 
    --- We can often do something with constants of 0, 1 and (-1) ...
    333 
    +-- We can often do something with constants of 0 and 1 ...
    358 334 
     -- See Note [Comparison operators]
    359 335
    360 336 
     cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]
    ... ... @@ -425,8 +401,6 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
    425 401 
             MO_Mul rep
    426 402 
                | Just p <- exactLog2 n ->
    427 403 
                      Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
    428 
    -        -- The optimization for division by power of 2 is technically duplicated, but since at least one other part of ghc uses
    429 
    -        -- the pure `constantFoldExpr` this remains
    430 404 
             MO_U_Quot rep
    431 405 
                | Just p <- exactLog2 n ->
    432 406 
                      Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
    ... ... @@ -435,19 +409,46 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
    435 409 
                      Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
    436 410 
             MO_S_Quot rep
    437 411 
                | Just p <- exactLog2 n,
    438 
    -             CmmReg _ <- x ->
    412 
    +             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
    413 
    +                                -- it is a reg.  FIXME: remove this restriction.
    439 414 
                     Just $! (cmmMachOpFold platform (MO_S_Shr rep)
    440 
    -                  [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt p $ wordWidth platform)])
    415 
    +                  [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])
    441 416 
             MO_S_Rem rep
    442 417 
                | Just p <- exactLog2 n,
    443 
    -             CmmReg _ <- x ->
    418 
    +             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
    419 
    +                                -- it is a reg.  FIXME: remove this restriction.
    444 420 
                     -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
    445 421 
                     -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
    446 422 
                     -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
    447 423 
                     Just $! (cmmMachOpFold platform (MO_Sub rep)
    448 424 
                         [x, cmmMachOpFold platform (MO_And rep)
    449 
    -                      [signedQuotRemHelper platform n x rep p, CmmLit (CmmInt (- n) rep)]])
    425 
    +                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
    450 426 
             _ -> Nothing
    427 
    +  where
    428 
    +    -- In contrast with unsigned integers, for signed ones
    429 
    +    -- shift right is not the same as quot, because it rounds
    430 
    +    -- to minus infinity, whereas quot rounds toward zero.
    431 
    +    -- To fix this up, we add one less than the divisor to the
    432 
    +    -- dividend if it is a negative number.
    433 
    +    --
    434 
    +    -- to avoid a test/jump, we use the following sequence:
    435 
    +    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
    436 
    +    --      x2 = y & (divisor-1)
    437 
    +    --      result = x + x2
    438 
    +    -- this could be done a bit more simply using conditional moves,
    439 
    +    -- but we're processor independent here.
    440 
    +    --
    441 
    +    -- we optimise the divide by 2 case slightly, generating
    442 
    +    --      x1 = x >> word_size-1  (unsigned)
    443 
    +    --      return = x + x1
    444 
    +    signedQuotRemHelper :: Width -> Integer -> CmmExpr
    445 
    +    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
    446 
    +      where
    447 
    +        bits = fromIntegral (widthInBits rep) - 1
    448 
    +        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
    449 
    +        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]
    450 
    +        x2 = if p == 1 then x1 else
    451 
    +             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
    451 452
    452 453 
     -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
    453 454 
     -- Unfortunately this needs a unique supply because x might not be a
    ... ... @@ -481,533 +482,3 @@ That's what the constant-folding operations on comparison operators do above.
    481 482 
     isPicReg :: CmmExpr -> Bool
    482 483 
     isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True
    483 484 
     isPicReg _ = False
    484 
    -
    485 
    -canOptimizeDivision :: CmmConfig -> Width -> Bool
    486 
    -canOptimizeDivision cfg rep = cmmOptConstDivision cfg &&
    487 
    -  -- we can either widen the arguments to simulate mul2 or use mul2 directly for the platform word size
    488 
    -  (rep < wordWidth platform || (rep == wordWidth platform && cmmAllowMul2 cfg))
    489 
    -  where platform = cmmPlatform cfg
    490 
    -
    491 
    --- -----------------------------------------------------------------------------
    492 
    --- Folding callish machops
    493 
    -
    494 
    -cmmCallishMachOpFold :: CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (CmmNode O O)
    495 
    -cmmCallishMachOpFold op res args =
    496 
    -  fromMaybe (CmmUnsafeForeignCall (PrimTarget op) res args) <$> (getConfig >>= \cfg -> cmmCallishMachOpFoldM cfg op res args)
    497 
    -
    498 
    -cmmCallishMachOpFoldM :: CmmConfig -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (Maybe (CmmNode O O))
    499 
    -
    500 
    --- If possible move the literals to the right, the following cases assume that to be the case
    501 
    -cmmCallishMachOpFoldM cfg op res [x@(CmmLit _),y]
    502 
    -  | isCommutableCallishMachOp op && not (isLit y) = cmmCallishMachOpFoldM cfg op res [y,x]
    503 
    -
    504 
    --- Both arguments are literals, replace with the result
    505 
    -cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt x _), CmmLit (CmmInt y _)]
    506 
    -  = case op of
    507 
    -    MO_S_Mul2 rep
    508 
    -      | [rHiNeeded,rHi,rLo] <- res -> do
    509 
    -          let resSz = widthInBits rep
    510 
    -              resVal = (narrowS rep x) * (narrowS rep y)
    511 
    -              high = resVal `shiftR` resSz
    512 
    -              low = narrowS rep resVal
    513 
    -              isHiNeeded = high /= low `shiftR` resSz
    514 
    -              isHiNeededVal = if isHiNeeded then 1 else 0
    515 
    -          prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt isHiNeededVal rep)
    516 
    -          prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)
    517 
    -          pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)
    518 
    -    MO_U_Mul2 rep
    519 
    -      | [rHi,rLo] <- res -> do
    520 
    -          let resSz = widthInBits rep
    521 
    -              resVal = (narrowU rep x) * (narrowU rep y)
    522 
    -              high = resVal `shiftR` resSz
    523 
    -              low = narrowU rep resVal
    524 
    -          prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt high rep)
    525 
    -          pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt low rep)
    526 
    -    MO_S_QuotRem rep
    527 
    -      | [rQuot, rRem] <- res,
    528 
    -        y /= 0 -> do
    529 
    -          let (q,r) = quotRem (narrowS rep x) (narrowS rep y)
    530 
    -          prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)
    531 
    -          pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)
    532 
    -    MO_U_QuotRem rep
    533 
    -      | [rQuot, rRem] <- res,
    534 
    -        y /= 0 -> do
    535 
    -          let (q,r) = quotRem (narrowU rep x) (narrowU rep y)
    536 
    -          prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt q rep)
    537 
    -          pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt r rep)
    538 
    -    _ -> pure Nothing
    539 
    -
    540 
    --- 0, 1 or -1 as one of the constants
    541 
    -
    542 
    -cmmCallishMachOpFoldM _ op res [_, CmmLit (CmmInt 0 _)]
    543 
    -  = case op of
    544 
    -    -- x * 0 == 0
    545 
    -    MO_S_Mul2 rep
    546 
    -      | [rHiNeeded, rHi, rLo] <- res -> do
    547 
    -        prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)
    548 
    -        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)
    549 
    -        pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)
    550 
    -    -- x * 0 == 0
    551 
    -    MO_U_Mul2 rep
    552 
    -      | [rHi, rLo] <- res -> do
    553 
    -        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)
    554 
    -        pure . Just $! CmmAssign (CmmLocal rLo) (CmmLit $ CmmInt 0 rep)
    555 
    -    _ -> pure Nothing
    556 
    -
    557 
    -cmmCallishMachOpFoldM _ op res [CmmLit (CmmInt 0 _), _]
    558 
    -  = case op of
    559 
    -    -- 0 quotRem d == (0,0)
    560 
    -    MO_S_QuotRem rep
    561 
    -      | [rQuot, rRem] <- res -> do
    562 
    -      prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)
    563 
    -      pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)
    564 
    -    -- 0 quotRem d == (0,0)
    565 
    -    MO_U_QuotRem rep
    566 
    -      | [rQuot,rRem] <- res -> do
    567 
    -      prependNode $! CmmAssign (CmmLocal rQuot) (CmmLit $ CmmInt 0 rep)
    568 
    -      pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)
    569 
    -    _ -> pure Nothing
    570 
    -
    571 
    -cmmCallishMachOpFoldM cfg op res [x, CmmLit (CmmInt 1 _)]
    572 
    -  = case op of
    573 
    -    -- x * 1 == x -- Note: The high word needs to be a sign extension of the low word, so we use a sign extending shift
    574 
    -    MO_S_Mul2 rep
    575 
    -      | [rHiNeeded, rHi, rLo] <- res -> do
    576 
    -        let platform = cmmPlatform cfg
    577 
    -            wordRep = wordWidth platform
    578 
    -            repInBits = toInteger $ widthInBits rep
    579 
    -        prependNode $! CmmAssign (CmmLocal rHiNeeded) (CmmLit $ CmmInt 0 rep)
    580 
    -        prependNode $! CmmAssign (CmmLocal rHi) (cmmMachOpFold platform (MO_S_Shr rep) [x, CmmLit $ CmmInt (repInBits - 1) wordRep])
    581 
    -        pure . Just $! CmmAssign (CmmLocal rLo) x
    582 
    -    -- x * 1 == x
    583 
    -    MO_U_Mul2 rep
    584 
    -      | [rHi, rLo] <- res -> do
    585 
    -        prependNode $! CmmAssign (CmmLocal rHi) (CmmLit $ CmmInt 0 rep)
    586 
    -        pure . Just $! CmmAssign (CmmLocal rLo) x
    587 
    -    -- x quotRem 1 == (x, 0)
    588 
    -    MO_S_QuotRem rep
    589 
    -      | [rQuot, rRem] <- res -> do
    590 
    -        prependNode $! CmmAssign (CmmLocal rQuot) x
    591 
    -        pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)
    592 
    -    -- x quotRem 1 == (x, 0)
    593 
    -    MO_U_QuotRem rep
    594 
    -      | [rQuot, rRem] <- res -> do
    595 
    -        prependNode $! CmmAssign (CmmLocal rQuot) x
    596 
    -        pure . Just $! CmmAssign (CmmLocal rRem) (CmmLit $ CmmInt 0 rep)
    597 
    -    _ -> pure Nothing
    598 
    -
    599 
    --- handle quotRem with a constant divisor
    600 
    -
    601 
    -cmmCallishMachOpFoldM cfg op res [n, CmmLit (CmmInt d' _)]
    602 
    -  = case op of
    603 
    -    MO_S_QuotRem rep
    604 
    -      | Just p <- exactLog2 d,
    605 
    -        [rQuot,rRem] <- res -> do
    606 
    -          n' <- intoRegister n (cmmBits rep)
    607 
    -          -- first prepend the optimized division by a power 2
    608 
    -          prependNode $! CmmAssign (CmmLocal rQuot)
    609 
    -            (cmmMachOpFold platform (MO_S_Shr rep)
    610 
    -              [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt p $ wordWidth platform)])
    611 
    -          -- then output an optimized remainder by a power of 2
    612 
    -          pure . Just $! CmmAssign (CmmLocal rRem)
    613 
    -            (cmmMachOpFold platform (MO_Sub rep)
    614 
    -              [n', cmmMachOpFold platform (MO_And rep)
    615 
    -                [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt (- d) rep)]])
    616 
    -      | canOptimizeDivision cfg rep,
    617 
    -        d /= (-1), d /= 0, d /= 1,
    618 
    -        [rQuot,rRem] <- res -> do
    619 
    -          -- we are definitely going to use n multiple times, so put it into a register
    620 
    -          n' <- intoRegister n (cmmBits rep)
    621 
    -          -- generate an optimized (signed) division of n by d
    622 
    -          q <- generateDivisionBySigned platform cfg rep n' d
    623 
    -          -- we also need the result multiple times to calculate the remainder
    624 
    -          q' <- intoRegister q (cmmBits rep)
    625 
    -
    626 
    -          prependNode $! CmmAssign (CmmLocal rQuot) q'
    627 
    -          -- The remainder now becomes n - q * d
    628 
    -          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]
    629 
    -      where
    630 
    -        platform = cmmPlatform cfg
    631 
    -        d = narrowS rep d'
    632 
    -    MO_U_QuotRem rep
    633 
    -      | Just p <- exactLog2 d,
    634 
    -        [rQuot,rRem] <- res -> do
    635 
    -          -- first prepend the optimized division by a power 2
    636 
    -          prependNode $! CmmAssign (CmmLocal rQuot) $ CmmMachOp (MO_U_Shr rep) [n, CmmLit (CmmInt p $ wordWidth platform)]
    637 
    -          -- then output an optimized remainder by a power of 2
    638 
    -          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_And rep) [n, CmmLit (CmmInt (d - 1) rep)]
    639 
    -      | canOptimizeDivision cfg rep,
    640 
    -        d /= 0, d /= 1,
    641 
    -        [rQuot,rRem] <- res -> do
    642 
    -          -- we are definitely going to use n multiple times, so put it into a register
    643 
    -          n' <- intoRegister n (cmmBits rep)
    644 
    -          -- generate an optimized (unsigned) division of n by d
    645 
    -          q <- generateDivisionByUnsigned platform cfg rep n' d
    646 
    -          -- we also need the result multiple times to calculate the remainder
    647 
    -          q' <- intoRegister q (cmmBits rep)
    648 
    -
    649 
    -          prependNode $! CmmAssign (CmmLocal rQuot) q'
    650 
    -          -- The remainder now becomes n - q * d
    651 
    -          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]
    652 
    -      where
    653 
    -        platform = cmmPlatform cfg
    654 
    -        d = narrowU rep d'
    655 
    -    _ -> pure Nothing
    656 
    -
    657 
    -cmmCallishMachOpFoldM _ _ _ _ = pure Nothing
    658 
    -
    659 
    --- -----------------------------------------------------------------------------
    660 
    --- Specialized constant folding for MachOps which sometimes need to expand into multiple nodes
    661 
    -
    662 
    -cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmExpr] -> Opt (Maybe CmmExpr)
    663 
    -
    664 
    -cmmMachOpFoldOptM cfg op [n, CmmLit (CmmInt d' _)] =
    665 
    -  case op of
    666 
    -    MO_S_Quot rep
    667 
    -      -- recheck for power of 2 division. This may not be handled by cmmMachOpFoldM if n is not in a register
    668 
    -      | Just p <- exactLog2 d -> do
    669 
    -        n' <- intoRegister n (cmmBits rep)
    670 
    -        pure . Just $! cmmMachOpFold platform (MO_S_Shr rep)
    671 
    -          [ signedQuotRemHelper platform d n' rep p
    672 
    -          , CmmLit (CmmInt p $ wordWidth platform)
    673 
    -          ]
    674 
    -      | canOptimizeDivision cfg rep,
    675 
    -        d /= (-1), d /= 0, d /= 1 -> Just <$!> generateDivisionBySigned platform cfg rep n d
    676 
    -      where d = narrowS rep d'
    677 
    -    MO_S_Rem rep
    678 
    -      -- recheck for power of 2 remainder. This may not be handled by cmmMachOpFoldM if n is not in a register
    679 
    -      | Just p <- exactLog2 d -> do
    680 
    -        n' <- intoRegister n (cmmBits rep)
    681 
    -        pure . Just $! cmmMachOpFold platform (MO_Sub rep)
    682 
    -          [ n'
    683 
    -          , cmmMachOpFold platform (MO_And rep)
    684 
    -              [ signedQuotRemHelper platform d n' rep p
    685 
    -              , CmmLit (CmmInt (- d) rep)
    686 
    -              ]
    687 
    -          ]
    688 
    -      | canOptimizeDivision cfg rep,
    689 
    -        d /= (-1), d /= 0, d /= 1 -> do
    690 
    -        n' <- intoRegister n (cmmBits rep)
    691 
    -        -- first generate the division
    692 
    -        q <- generateDivisionBySigned platform cfg rep n' d
    693 
    -        -- then calculate the remainder by n - q * d
    694 
    -        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]
    695 
    -      where d = narrowS rep d'
    696 
    -    MO_U_Quot rep
    697 
    -      -- No need to recheck power of 2 division because cmmMachOpFoldM always handles that case
    698 
    -      | canOptimizeDivision cfg rep,
    699 
    -        d /= 0, d /= 1, Nothing <- exactLog2 d -> Just <$!> generateDivisionByUnsigned platform cfg rep n d
    700 
    -      where d = narrowU rep d'
    701 
    -    MO_U_Rem rep
    702 
    -      -- No need to recheck power of 2 remainder because cmmMachOpFoldM always handles that case
    703 
    -      | canOptimizeDivision cfg rep,
    704 
    -        d /= 0, d /= 1, Nothing <- exactLog2 d -> do
    705 
    -        n' <- intoRegister n (cmmBits rep)
    706 
    -        -- first generate the division
    707 
    -        q <- generateDivisionByUnsigned platform cfg rep n d
    708 
    -        -- then calculate the remainder by n - q * d
    709 
    -        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]
    710 
    -      where d = narrowU rep d'
    711 
    -    _ -> pure Nothing
    712 
    -  where platform = cmmPlatform cfg
    713 
    -
    714 
    -cmmMachOpFoldOptM _ _ _ = pure Nothing
    715 
    -
    716 
    --- -----------------------------------------------------------------------------
    717 
    --- Utils for prepending new nodes
    718 
    -
    719 
    --- Move an expression into a register to possibly use it multiple times
    720 
    -intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr
    721 
    -intoRegister e@(CmmReg _) _ = pure e
    722 
    -intoRegister expr ty = do
    723 
    -  u <- getUniqueM
    724 
    -  let reg = LocalReg u ty
    725 
    -  CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr)
    726 
    -
    727 
    -prependNode :: CmmNode O O -> Opt ()
    728 
    -prependNode n = Opt $ \_ xs -> pure (xs ++ [n], ())
    729 
    -
    730 
    --- -----------------------------------------------------------------------------
    731 
    --- Division by constants utils
    732 
    -
    733 
    --- Helper for division by a power of 2
    734 
    --- In contrast with unsigned integers, for signed ones
    735 
    --- shift right is not the same as quot, because it rounds
    736 
    --- to minus infinity, whereas quot rounds toward zero.
    737 
    --- To fix this up, we add one less than the divisor to the
    738 
    --- dividend if it is a negative number.
    739 
    ---
    740 
    --- to avoid a test/jump, we use the following sequence:
    741 
    ---      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
    742 
    ---      x2 = y & (divisor-1)
    743 
    ---      result = x + x2
    744 
    --- this could be done a bit more simply using conditional moves,
    745 
    --- but we're processor independent here.
    746 
    ---
    747 
    --- we optimize the divide by 2 case slightly, generating
    748 
    ---      x1 = x >> word_size-1  (unsigned)
    749 
    ---      return = x + x1
    750 
    -signedQuotRemHelper :: Platform -> Integer -> CmmExpr -> Width -> Integer -> CmmExpr
    751 
    -signedQuotRemHelper platform n x rep p = CmmMachOp (MO_Add rep) [x, x2]
    752 
    -  where
    753 
    -    bits = fromIntegral (widthInBits rep) - 1
    754 
    -    shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
    755 
    -    x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]
    756 
    -    x2 = if p == 1 then x1 else
    757 
    -          CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
    758 
    -
    759 
    -{- Note: [Division by constants]
    760 
    -
    761 
    -Integer division is floor(n / d), the goal is to find m,p
    762 
    -such that floor((m * n) / 2^p) = floor(n / d).
    763 
    -
    764 
    -The idea being: n/d = n * (1/d). But we cannot store 1/d in an integer without
    765 
    -some error, so we choose some 2^p / d such that the error ends up small and
    766 
    -thus vanishes when we divide by 2^p again.
    767 
    -
    768 
    -The algorithm below to generate these numbers is taken from Hacker's Delight
    769 
    -Second Edition Chapter 10 "Integer division by constants". The chapter also
    770 
    -contains proof that this method does indeed produce correct results.
    771 
    -
    772 
    -However this is a much more literal interpretation of the algorithm,
    773 
    -which we can use because of the unbounded Integer type. Hacker's Delight
    774 
    -also provides a much more complex algorithm which computes these numbers
    775 
    -without the need to exceed the word size, but that is not necessary here.
    776 
    --}
    777 
    -
    778 
    -generateDivisionBySigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr
    779 
    -
    780 
    --- Sanity checks, division will generate incorrect results or undesirable code for these cases
    781 
    --- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!
    782 
    -generateDivisionBySigned _ _ _ _ 0 = panic "generate signed division with 0"
    783 
    -generateDivisionBySigned _ _ _ _ 1 = panic "generate signed division with 1"
    784 
    -generateDivisionBySigned _ _ _ _ (-1) = panic "generate signed division with -1"
    785 
    -generateDivisionBySigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d
    786 
    -
    787 
    -generateDivisionBySigned platform _cfg rep n divisor = do
    788 
    -  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register
    789 
    -  n' <- if sign == 0 then pure n else intoRegister n resRep
    790 
    -
    791 
    -  -- Set up mul2
    792 
    -  (shift', qExpr) <- mul2 n'
    793 
    -
    794 
    -  -- add/subtract n if necessary
    795 
    -  let qExpr' = case sign of
    796 
    -        1  -> CmmMachOp (MO_Add rep) [qExpr, n']
    797 
    -        -1 -> CmmMachOp (MO_Sub rep) [qExpr, n']
    798 
    -        _  -> qExpr
    799 
    -
    800 
    -  qExpr'' <- intoRegister (cmmMachOpFold platform (MO_S_Shr rep) [qExpr', CmmLit $ CmmInt shift' wordRep]) resRep
    801 
    -
    802 
    -  -- Lastly add the sign of the quotient to correct for negative results
    803 
    -  pure $! cmmMachOpFold platform
    804 
    -    (MO_Add rep) [qExpr'', cmmMachOpFold platform (MO_U_Shr rep) [qExpr'', CmmLit $ CmmInt (toInteger $ widthInBits rep - 1) wordRep]]
    805 
    -  where
    806 
    -    resRep = cmmBits rep
    807 
    -    wordRep = wordWidth platform
    808 
    -    (magic, sign, shift) = divisionMagicS rep divisor
    809 
    -    -- generate the multiply with the magic number
    810 
    -    mul2 n
    811 
    -      -- Using mul2 for sub-word sizes regresses for signed integers only
    812 
    -      | rep == wordWidth platform = do
    813 
    -        (r1, r2, r3) <- (,,) <$> getUniqueM <*> getUniqueM <*> getUniqueM
    814 
    -        let rg1    = LocalReg r1 resRep
    815 
    -            resReg = LocalReg r2 resRep
    816 
    -            rg3    = LocalReg r3 resRep
    817 
    -        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_S_Mul2 rep)) [rg1, resReg, rg3] [n, CmmLit $ CmmInt magic rep])
    818 
    -        pure (shift, res)
    819 
    -      -- widen the register and multiply without the MUL2 instruction
    820 
    -      -- if we don't need an additional add after this we can combine the shifts
    821 
    -      | otherwise = pure (if sign == 0 then 0 else shift, res)
    822 
    -          where
    823 
    -            wordRep = wordWidth platform
    824 
    -            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow
    825 
    -            res = cmmMachOpFold platform (MO_SS_Conv wordRep rep)
    826 
    -                    [ cmmMachOpFold platform (MO_S_Shr wordRep)
    827 
    -                      [ cmmMachOpFold platform (MO_Mul wordRep)
    828 
    -                        [ cmmMachOpFold platform (MO_SS_Conv rep wordRep) [n]
    829 
    -                        , CmmLit $ CmmInt magic wordRep
    830 
    -                        ]
    831 
    -                      -- Check if we need to generate an add/subtract later. If not we can combine this with the postshift
    832 
    -                      , CmmLit $ CmmInt ((if sign == 0 then toInteger shift else 0) + (toInteger $ widthInBits rep)) wordRep
    833 
    -                      ]
    834 
    -                    ]
    835 
    -
    836 
    --- See hackers delight for how and why this works (chapter in note [Division by constants])
    837 
    -divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer)
    838 
    -divisionMagicS rep divisor = (magic, sign, toInteger $ p - wSz)
    839 
    -  where
    840 
    -    sign = if divisor > 0
    841 
    -      then if magic < 0 then 1 else 0
    842 
    -      else if magic < 0 then 0 else -1
    843 
    -    wSz = widthInBits rep
    844 
    -    ad = abs divisor
    845 
    -    t = (1 `shiftL` (wSz - 1)) + if divisor > 0 then 0 else 1
    846 
    -    anc = t - 1 - rem t ad
    847 
    -    go p'
    848 
    -      | twoP > anc * (ad - rem twoP ad) = p'
    849 
    -      | otherwise = go (p' + 1)
    850 
    -      where twoP = 1 `shiftL` p'
    851 
    -    p = go wSz
    852 
    -    am = (twoP + ad - rem twoP ad) `quot` ad
    853 
    -      where twoP = 1 `shiftL` p
    854 
    -    magic = narrowS rep $ if divisor > 0 then am else -am
    855 
    -
    856 
    -generateDivisionByUnsigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr
    857 
    --- Sanity checks, division will generate incorrect results or undesirable code for these cases
    858 
    --- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!
    859 
    -generateDivisionByUnsigned _ _ _ _ 0 = panic "generate signed division with 0"
    860 
    -generateDivisionByUnsigned _ _ _ _ 1 = panic "generate signed division with 1"
    861 
    -generateDivisionByUnsigned _ _ _ _ d | Just _ <- exactLog2 d = panic $ "generate signed division with " ++ show d
    862 
    -
    863 
    -generateDivisionByUnsigned platform cfg rep n divisor = do
    864 
    -  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register
    865 
    -  n' <- if not needsAdd -- Invariant: We also never preshift if we need an add, thus we don't need n in a register
    866 
    -    then pure $! cmmMachOpFold platform (MO_U_Shr rep) [n, CmmLit $ CmmInt preShift wordRep]
    867 
    -    else intoRegister n resRep
    868 
    -
    869 
    -  -- Set up mul2
    870 
    -  (postShift', qExpr) <- mul2 n'
    871 
    -
    872 
    -  -- add/subtract n if necessary
    873 
    -  let qExpr' = if needsAdd
    874 
    -        -- This is qExpr + (n - qExpr) / 2 = (qExpr + n) / 2 but with a guarantee that it'll not overflow
    875 
    -        then cmmMachOpFold platform (MO_Add rep)
    876 
    -          [ cmmMachOpFold platform (MO_U_Shr rep)
    877 
    -            [ cmmMachOpFold platform (MO_Sub rep) [n', qExpr]
    878 
    -            , CmmLit $ CmmInt 1 wordRep
    879 
    -            ]
    880 
    -          , qExpr
    881 
    -          ]
    882 
    -        else qExpr
    883 
    -      -- If we already divided by 2 in the add, remember to shift one bit less
    884 
    -      -- Hacker's Delight, Edition 2 Page 234: postShift > 0 if we needed an add, except if the divisor
    885 
    -      -- is 1, which we checked for above
    886 
    -      finalShift = if needsAdd then postShift' - 1 else postShift'
    887 
    -
    888 
    -  -- apply the final postShift
    889 
    -  pure $! cmmMachOpFold platform (MO_U_Shr rep) [qExpr', CmmLit $ CmmInt finalShift wordRep]
    890 
    -  where
    891 
    -    resRep = cmmBits rep
    892 
    -    wordRep = wordWidth platform
    893 
    -    (preShift, magic, needsAdd, postShift) =
    894 
    -        let withPre = divisionMagicU rep True  divisor
    895 
    -            noPre   = divisionMagicU rep False divisor
    896 
    -        in case (withPre, noPre) of
    897 
    -          -- Use whatever does not cause us to take the expensive case
    898 
    -          ((_, _, False, _), (_, _, True, _)) -> withPre
    899 
    -          -- If we cannot avoid the expensive case, don't bother with the pre shift
    900 
    -          _ -> noPre
    901 
    -    -- generate the multiply with the magic number
    902 
    -    mul2 n
    903 
    -      | rep == wordWidth platform || (cmmAllowMul2 cfg && needsAdd) = do
    904 
    -        (r1, r2) <- (,) <$> getUniqueM <*> getUniqueM
    905 
    -        let rg1    = LocalReg r1 resRep
    906 
    -            resReg = LocalReg r2 resRep
    907 
    -        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep])
    908 
    -        pure (postShift, res)
    909 
    -      | otherwise = do
    910 
    -        pure (if needsAdd then postShift else 0, res)
    911 
    -          where
    912 
    -            wordRep = wordWidth platform
    913 
    -            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow
    914 
    -            res = cmmMachOpFold platform (MO_UU_Conv wordRep rep)
    915 
    -              [ cmmMachOpFold platform (MO_U_Shr wordRep)
    916 
    -                [ cmmMachOpFold platform (MO_Mul wordRep)
    917 
    -                  [ cmmMachOpFold platform (MO_UU_Conv rep wordRep) [n]
    918 
    -                  , CmmLit $ CmmInt magic wordRep
    919 
    -                  ]
    920 
    -                -- Check if we need to generate an add later. If not we can combine this with the postshift
    921 
    -                , CmmLit $ CmmInt ((if needsAdd then 0 else postShift) + (toInteger $ widthInBits rep)) wordRep
    922 
    -                ]
    923 
    -              ]
    924 
    -
    925 
    --- See hackers delight for how and why this works (chapter in note [Division by constants])
    926 
    --- The preshift isn't described there, but the idea is:
    927 
    --- If a divisor d has n trailing zeros, then d is a multiple of 2^n. Since we want to divide x by d
    928 
    --- we can also calculate (x / 2^n) / (d / 2^n) which may then not require an extra addition.
    929 
    ---
    930 
    --- The addition performs: quotient + dividend, but we need to avoid overflows, so we actually need to
    931 
    --- calculate: quotient + (dividend - quotient) / 2 = (quotient + dividend) / 2
    932 
    --- Thus if the preshift can avoid all of this, we have 1 operation in place of 3.
    933 
    ---
    934 
    --- The decision to use the preshift is made somewhere else, here we only report if the addition is needed
    935 
    -divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)
    936 
    -divisionMagicU rep doPreShift divisor = (toInteger zeros, magic, needsAdd, toInteger $ p - wSz)
    937 
    -  where
    938 
    -    wSz = widthInBits rep
    939 
    -    zeros = if doPreShift then countTrailingZeros $ fromInteger @Word64 divisor else 0
    940 
    -    d = divisor `shiftR` zeros
    941 
    -    ones = ((1 `shiftL` wSz) - 1) `shiftR` zeros
    942 
    -    nc = ones - rem (ones - d) d
    943 
    -    go p'
    944 
    -      | twoP > nc * (d - 1 - rem (twoP - 1) d) = p'
    945 
    -      | otherwise = go (p' + 1)
    946 
    -      where twoP = 1 `shiftL` p'
    947 
    -    p = go wSz
    948 
    -    m = (twoP + d - 1 - rem (twoP - 1) d) `quot` d
    949 
    -      where twoP = 1 `shiftL` p
    950 
    -    needsAdd = d < 1 `shiftL` (p - wSz)
    951 
    -    magic = if needsAdd then m - (ones + 1) else m
    952 
    -
    953 
    --- -----------------------------------------------------------------------------
    954 
    --- Opt monad
    955 
    -
    956 
    -newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) }
    957 
    -
    958 
    --- | Pattern synonym for 'Opt', as described in Note [The one-shot state
    959 
    --- monad trick].
    960 
    -pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a
    961 
    -pattern Opt f <- OptI f
    962 
    -  where Opt f = OptI . oneShot $ \cfg -> oneShot $ \out -> f cfg out
    963 
    -{-# COMPLETE Opt #-}
    964 
    -
    965 
    -runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a)
    966 
    -runOpt cf (Opt g) = g cf []
    967 
    -
    968 
    -getConfig :: Opt CmmConfig
    969 
    -getConfig = Opt $ \cf xs -> pure (xs, cf)
    970 
    -
    971 
    -instance Functor Opt where
    972 
    -  fmap f (Opt g) = Opt $ \cf xs -> fmap (fmap f) (g cf xs)
    973 
    -
    974 
    -instance Applicative Opt where
    975 
    -  pure a = Opt $ \_ xs -> pure (xs, a)
    976 
    -  ff <*> fa = do
    977 
    -    f <- ff
    978 
    -    f <$> fa
    979 
    -
    980 
    -instance Monad Opt where
    981 
    -  Opt g >>= f = Opt $ \cf xs -> do
    982 
    -    (ys, a) <- g cf xs
    983 
    -    runOptI (f a) cf ys
    984 
    -
    985 
    -instance MonadGetUnique Opt where
    986 
    -  getUniqueM = Opt $ \_ xs -> (xs,) <$> getUniqueDSM
    987 
    -
    988 
    -mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget
    989 
    -mapForeignTargetOpt exp   (ForeignTarget e c) = flip ForeignTarget c <$> exp e
    990 
    -mapForeignTargetOpt _   m@(PrimTarget _)      = pure m
    991 
    -
    992 
    -wrapRecExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmExpr -> Opt CmmExpr
    993 
    -wrapRecExpOpt f (CmmMachOp op es)       = traverse (wrapRecExpOpt f) es >>= f . CmmMachOp op
    994 
    -wrapRecExpOpt f (CmmLoad addr ty align) = wrapRecExpOpt f addr >>= \newAddr -> f (CmmLoad newAddr ty align)
    995 
    -wrapRecExpOpt f e                       = f e
    996 
    -
    997 
    -mapExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmNode e x -> Opt (CmmNode e x)
    998 
    -mapExpOpt _ f@(CmmEntry{})                          = pure f
    999 
    -mapExpOpt _ m@(CmmComment _)                        = pure m
    1000 
    -mapExpOpt _ m@(CmmTick _)                           = pure m
    1001 
    -mapExpOpt f   (CmmUnwind regs)                      = CmmUnwind <$> traverse (traverse (traverse f)) regs
    1002 
    -mapExpOpt f   (CmmAssign r e)                       = CmmAssign r <$> f e
    1003 
    -mapExpOpt f   (CmmStore addr e align)               = CmmStore <$> f addr <*> f e <*> pure align
    1004 
    -mapExpOpt f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall <$> mapForeignTargetOpt f tgt <*> pure fs <*> traverse f as
    1005 
    -mapExpOpt _ l@(CmmBranch _)                         = pure l
    1006 
    -mapExpOpt f   (CmmCondBranch e ti fi l)             = f e >>= \newE -> pure (CmmCondBranch newE ti fi l)
    1007 
    -mapExpOpt f   (CmmSwitch e ids)                     = flip CmmSwitch ids <$> f e
    1008 
    -mapExpOpt f   n@CmmCall {cml_target=tgt}            = f tgt >>= \newTgt -> pure n{cml_target = newTgt}
    1009 
    -mapExpOpt f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
    1010 
    -                                                    = do
    1011 
    -                                                      newTgt <- mapForeignTargetOpt f tgt
    1012 
    -                                                      newAs <- traverse f as
    1013 
    -                                                      pure $ CmmForeignCall newTgt fs newAs succ ret_args updfr intrbl

  • compiler/GHC/Cmm/Pipeline.hs
    ... ... @@ -137,12 +137,9 @@ cpsTop logger platform cfg dus proc =
    137 137 
           dump Opt_D_dump_cmm_sp "Layout Stack" g
    138 138
    139 139 
           ----------- Sink and inline assignments  --------------------------------
    140 
    -      (g, dus) <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
    141 
    -           if cmmOptSink cfg
    142 
    -              then pure $ runUniqueDSM dus $ cmmSink cfg g
    143 
    -              else return (g, dus)
    144 
    -      dump Opt_D_dump_cmm_sink "Sink assignments" g
    145 
    -
    140 
    +      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
    141 
    +           condPass (cmmOptSink cfg) (cmmSink platform) g
    142 
    +                    Opt_D_dump_cmm_sink "Sink assignments"
    146 143
    147 144 
           ------------- CAF analysis ----------------------------------------------
    148 145 
           let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g

  • compiler/GHC/Cmm/Sink.hs
    ... ... @@ -20,8 +20,6 @@ import GHC.Platform.Regs
    20 20
    21 21 
     import GHC.Platform
    22 22 
     import GHC.Types.Unique.FM
    23 
    -import GHC.Types.Unique.DSM
    24 
    -import GHC.Cmm.Config
    25 23
    26 24 
     import Data.List (partition)
    27 25 
     import Data.Maybe
    ... ... @@ -152,10 +150,9 @@ type Assignments = [Assignment]
    152 150 
       --     y = e2
    153 151 
       --     x = e1
    154 152
    155 
    -cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph
    156 
    -cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
    153 
    +cmmSink :: Platform -> CmmGraph -> CmmGraph
    154 
    +cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
    157 155 
       where
    158 
    -  platform = cmmPlatform cfg
    159 156 
       liveness = cmmLocalLivenessL platform graph
    160 157 
       getLive l = mapFindWithDefault emptyLRegSet l liveness
    161 158
    ... ... @@ -163,41 +160,11 @@ cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
    163 160
    164 161 
       join_pts = findJoinPoints blocks
    165 162
    166 
    -  sink :: LabelMap Assignments -> [CmmBlock] -> UniqDSM [CmmBlock]
    167 
    -  sink _ [] = pure []
    168 
    -  sink sunk (b:bs) = do
    169 
    -    -- Now sink and inline in this block
    170 
    -    (prepend, last_fold) <- runOpt cfg $ constantFoldNode last
    171 
    -
    172 
    -    (middle', assigs) <- walk cfg (ann_middles ++ annotate platform live_middle prepend) (mapFindWithDefault [] lbl sunk)
    173 
    -
    174 
    -    let (final_last, assigs') = tryToInline platform live last_fold assigs
    175 
    -        -- Now, drop any assignments that we will not sink any further.
    176 
    -        (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'
    177 
    -        drop_if :: (LocalReg, CmmExpr, AbsMem)
    178 
    -                      -> [LRegSet] -> (Bool, [LRegSet])
    179 
    -        drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
    180 
    -            where
    181 
    -              should_drop =  conflicts platform a final_last
    182 
    -                          || not (isTrivial platform rhs) && live_in_multi live_sets r
    183 
    -                          || r `elemLRegSet` live_in_joins
    184 
    -
    185 
    -              live_sets' | should_drop = live_sets
    186 
    -                        | otherwise   = map upd live_sets
    187 
    -
    188 
    -              upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs
    189 
    -                      | otherwise           = set
    190 
    -
    191 
    -              live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs
    192 
    -
    193 
    -        final_middle = foldl' blockSnoc middle' dropped_last
    194 
    -
    195 
    -        sunk' = mapUnion sunk $
    196 
    -                  mapFromList [ (l, filterAssignments platform (getLive l) assigs'')
    197 
    -                              | l <- succs ]
    198 
    -
    199 
    -    (blockJoin first final_middle final_last :) <$> sink sunk' bs
    200 
    -
    163 
    +  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
    164 
    +  sink _ [] = []
    165 
    +  sink sunk (b:bs) =
    166 
    +    -- pprTrace "sink" (ppr lbl) $
    167 
    +    blockJoin first final_middle final_last : sink sunk' bs
    201 168 
         where
    202 169 
           lbl = entryLabel b
    203 170 
           (first, middle, last) = blockSplit b
    ... ... @@ -211,6 +178,11 @@ cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
    211 178 
           live_middle = gen_killL platform last live
    212 179 
           ann_middles = annotate platform live_middle (blockToList middle)
    213 180
    181 
    +      -- Now sink and inline in this block
    182 
    +      (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk)
    183 
    +      fold_last = constantFoldNode platform last
    184 
    +      (final_last, assigs') = tryToInline platform live fold_last assigs
    185 
    +
    214 186 
           -- We cannot sink into join points (successors with more than
    215 187 
           -- one predecessor), so identify the join points and the set
    216 188 
           -- of registers live in them.
    ... ... @@ -228,6 +200,31 @@ cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
    228 200 
                (_one:_two:_) -> True
    229 201 
                _ -> False
    230 202
    203 
    +      -- Now, drop any assignments that we will not sink any further.
    204 
    +      (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'
    205 
    +
    206 
    +      drop_if :: (LocalReg, CmmExpr, AbsMem)
    207 
    +                      -> [LRegSet] -> (Bool, [LRegSet])
    208 
    +      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
    209 
    +          where
    210 
    +            should_drop =  conflicts platform a final_last
    211 
    +                        || not (isTrivial platform rhs) && live_in_multi live_sets r
    212 
    +                        || r `elemLRegSet` live_in_joins
    213 
    +
    214 
    +            live_sets' | should_drop = live_sets
    215 
    +                       | otherwise   = map upd live_sets
    216 
    +
    217 
    +            upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs
    218 
    +                    | otherwise          = set
    219 
    +
    220 
    +            live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs
    221 
    +
    222 
    +      final_middle = foldl' blockSnoc middle' dropped_last
    223 
    +
    224 
    +      sunk' = mapUnion sunk $
    225 
    +                 mapFromList [ (l, filterAssignments platform (getLive l) assigs'')
    226 
    +                             | l <- succs ]
    227 
    +
    231 228 
     {- TODO: enable this later, when we have some good tests in place to
    232 229 
        measure the effect and tune it.
    233 230
    ... ... @@ -302,7 +299,7 @@ filterAssignments platform live assigs = reverse (go assigs [])
    302 299 
     --    * a list of assignments that will be placed *after* that block.
    303 300 
     --
    304 301
    305 
    -walk :: CmmConfig
    302 
    +walk :: Platform
    306 303 
          -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with
    307 304 
                                             -- the set of registers live *after*
    308 305 
                                             -- this node.
    ... ... @@ -312,39 +309,36 @@ walk :: CmmConfig
    312 309 
                                             -- Earlier assignments may refer
    313 310 
                                             -- to later ones.
    314 311
    315 
    -     -> UniqDSM ( Block CmmNode O O             -- The new block
    316 
    -               , Assignments                   -- Assignments to sink further
    317 
    -               )
    312 
    +     -> ( Block CmmNode O O             -- The new block
    313 
    +        , Assignments                   -- Assignments to sink further
    314 
    +        )
    318 315
    319 
    -walk cfg nodes assigs = go nodes emptyBlock assigs
    316 
    +walk platform nodes assigs = go nodes emptyBlock assigs
    320 317 
      where
    321 
    -   platform = cmmPlatform cfg
    322 
    -   go []               block as = pure (block, as)
    318 
    +   go []               block as = (block, as)
    323 319 
        go ((live,node):ns) block as
    324 320 
         -- discard nodes representing dead assignment
    325 321 
         | shouldDiscard node live             = go ns block as
    326 
    -    | otherwise = do
    327 
    -      (prepend, node1) <- runOpt cfg $ constantFoldNode node
    328 
    -      if not (null prepend)
    329 
    -        then go (annotate platform live (prepend ++ [node1]) ++ ns) block as
    330 
    -        else do
    331 
    -          let -- Inline assignments
    332 
    -              (node2, as1) = tryToInline platform live node1 as
    333 
    -              -- Drop any earlier assignments conflicting with node2
    334 
    -              (dropped, as') = dropAssignmentsSimple platform
    335 
    -                                (\a -> conflicts platform a node2) as1
    336 
    -              -- Walk over the rest of the block. Includes dropped assignments
    337 
    -              block' = foldl' blockSnoc block dropped `blockSnoc` node2
    338 
    -
    339 
    -          (prepend2, node3) <- runOpt cfg $ constantFoldNode node2
    340 
    -          if | not (null prepend2)                 -> go (annotate platform live (prepend2 ++ [node3]) ++ ns) block as
    341 
    -             -- sometimes only after simplification we can tell we can discard the node.
    342 
    -             -- See Note [Discard simplified nodes]
    343 
    -             | noOpAssignment node3                -> go ns block as
    344 
    -             -- Pick up interesting assignments
    345 
    -             | Just a <- shouldSink platform node3 -> go ns block (a : as1)
    346 
    -             -- Try inlining, drop assignments and move on
    347 
    -             | otherwise                           -> go ns block' as'
    322 
    +    -- sometimes only after simplification we can tell we can discard the node.
    323 
    +    -- See Note [Discard simplified nodes]
    324 
    +    | noOpAssignment node2                = go ns block as
    325 
    +    -- Pick up interesting assignments
    326 
    +    | Just a <- shouldSink platform node2 = go ns block (a : as1)
    327 
    +    -- Try inlining, drop assignments and move on
    328 
    +    | otherwise                           = go ns block' as'
    329 
    +    where
    330 
    +      -- Simplify node
    331 
    +      node1 = constantFoldNode platform node
    332 
    +
    333 
    +      -- Inline assignments
    334 
    +      (node2, as1) = tryToInline platform live node1 as
    335 
    +
    336 
    +      -- Drop any earlier assignments conflicting with node2
    337 
    +      (dropped, as') = dropAssignmentsSimple platform
    338 
    +                          (\a -> conflicts platform a node2) as1
    339 
    +
    340 
    +      -- Walk over the rest of the block. Includes dropped assignments
    341 
    +      block' = foldl' blockSnoc block dropped `blockSnoc` node2
    348 342
    349 343 
     {- Note [Discard simplified nodes]
    350 344 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • compiler/GHC/Driver/Config/Cmm.hs
    ... ... @@ -24,17 +24,5 @@ initCmmConfig dflags = CmmConfig
    24 24 
       , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))
    25 25 
       , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))
    26 26 
                                  || not (platformTablesNextToCode platform)
    27 
    -  , cmmAllowMul2           = (ncg && x86ish) || llvm
    28 
    -  , cmmOptConstDivision    = not llvm
    29 27 
       }
    30 28 
       where platform                = targetPlatform dflags
    31 
    -        -- Copied from StgToCmm
    32 
    -        (ncg, llvm) = case backendPrimitiveImplementation (backend dflags) of
    33 
    -                          GenericPrimitives -> (False, False)
    34 
    -                          NcgPrimitives -> (True, False)
    35 
    -                          LlvmPrimitives -> (False, True)
    36 
    -                          JSPrimitives -> (False, False)
    37 
    -        x86ish  = case platformArch platform of
    38 
    -                    ArchX86    -> True
    39 
    -                    ArchX86_64 -> True
    40 
    -                    _          -> False

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -1571,28 +1571,28 @@ emitPrimOp cfg primop =
    1571 1571 
       CastDoubleToWord64Op -> translateBitcasts (MO_FW_Bitcast W64)
    1572 1572 
       CastWord64ToDoubleOp -> translateBitcasts (MO_WF_Bitcast W64)
    1573 1573
    1574 
    -  IntQuotRemOp -> opCallishHandledLater $
    1575 
    -    if allowQuotRem
    1574 
    +  IntQuotRemOp -> \args -> flip opCallishHandledLater args $
    1575 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1576 1576 
         then Left (MO_S_QuotRem  (wordWidth platform))
    1577 1577 
         else Right (genericIntQuotRemOp (wordWidth platform))
    1578 1578
    1579 
    -  Int8QuotRemOp -> opCallishHandledLater $
    1580 
    -    if allowQuotRem
    1579 
    +  Int8QuotRemOp -> \args -> flip opCallishHandledLater args $
    1580 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1581 1581 
         then Left (MO_S_QuotRem W8)
    1582 1582 
         else Right (genericIntQuotRemOp W8)
    1583 1583
    1584 
    -  Int16QuotRemOp -> opCallishHandledLater $
    1585 
    -    if allowQuotRem
    1584 
    +  Int16QuotRemOp -> \args -> flip opCallishHandledLater args $
    1585 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1586 1586 
         then Left (MO_S_QuotRem W16)
    1587 1587 
         else Right (genericIntQuotRemOp W16)
    1588 1588
    1589 
    -  Int32QuotRemOp -> opCallishHandledLater $
    1590 
    -    if allowQuotRem
    1589 
    +  Int32QuotRemOp -> \args -> flip opCallishHandledLater args $
    1590 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1591 1591 
         then Left (MO_S_QuotRem W32)
    1592 1592 
         else Right (genericIntQuotRemOp W32)
    1593 1593
    1594 
    -  WordQuotRemOp -> opCallishHandledLater $
    1595 
    -    if allowQuotRem
    1594 
    +  WordQuotRemOp -> \args -> flip opCallishHandledLater args $
    1595 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1596 1596 
         then Left (MO_U_QuotRem  (wordWidth platform))
    1597 1597 
         else Right (genericWordQuotRemOp (wordWidth platform))
    1598 1598
    ... ... @@ -1601,18 +1601,18 @@ emitPrimOp cfg primop =
    1601 1601 
         then Left (MO_U_QuotRem2 (wordWidth platform))
    1602 1602 
         else Right (genericWordQuotRem2Op platform)
    1603 1603
    1604 
    -  Word8QuotRemOp -> opCallishHandledLater $
    1605 
    -    if allowQuotRem
    1604 
    +  Word8QuotRemOp -> \args -> flip opCallishHandledLater args $
    1605 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1606 1606 
         then Left (MO_U_QuotRem W8)
    1607 1607 
         else Right (genericWordQuotRemOp W8)
    1608 1608
    1609 
    -  Word16QuotRemOp -> opCallishHandledLater $
    1610 
    -    if allowQuotRem
    1609 
    +  Word16QuotRemOp -> \args -> flip opCallishHandledLater args $
    1610 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1611 1611 
         then Left (MO_U_QuotRem W16)
    1612 1612 
         else Right (genericWordQuotRemOp W16)
    1613 1613
    1614 
    -  Word32QuotRemOp -> opCallishHandledLater $
    1615 
    -    if allowQuotRem
    1614 
    +  Word32QuotRemOp -> \args -> flip opCallishHandledLater args $
    1615 
    +    if allowQuotRem && not (quotRemCanBeOptimized args)
    1616 1616 
         then Left (MO_U_QuotRem W32)
    1617 1617 
         else Right (genericWordQuotRemOp W32)
    1618 1618
    ... ... @@ -1835,6 +1835,23 @@ emitPrimOp cfg primop =
    1835 1835 
         pure $ map (CmmReg . CmmLocal) regs
    1836 1836
    1837 1837 
       alwaysExternal = \_ -> PrimopCmmEmit_External
    1838 
    +  -- Note [QuotRem optimization]
    1839 
    +  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1840 
    +  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops
    1841 
    +  -- (shift, .&.).
    1842 
    +  --
    1843 
    +  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the
    1844 
    +  -- constant is a power of 2. #9041 tracks the implementation of the general
    1845 
    +  -- optimization.
    1846 
    +  --
    1847 
    +  -- `quotRem` can be optimized in the same way. However as it returns two values,
    1848 
    +  -- it is implemented as a "callish" primop which is harder to match and
    1849 
    +  -- to transform later on. For simplicity, the current implementation detects cases
    1850 
    +  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem
    1851 
    +  -- primop into two CMM quot and rem primops.
    1852 
    +  quotRemCanBeOptimized = \case
    1853 
    +    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)
    1854 
    +    _                         -> False
    1838 1855
    1839 1856 
       allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg
    1840 1857 
       allowQuotRem2 = stgToCmmAllowQuotRem2             cfg

  • testsuite/tests/numeric/should_run/all.T
    ... ... @@ -3,6 +3,10 @@
    3 3 
     #	extra run flags
    4 4 
     #	expected process return value, if not zero
    5 5
    6 
    +# some bugs only surface with -O, omitting optasm may cause them to
    7 
    +# slip into releases! (e.g. #26711)
    8 
    +setTestOpts(when(have_ncg(), extra_ways(['optasm'])))
    9 
    +
    6 10 
     test('arith001', normal, compile_and_run, [''])
    7 11 
     test('arith002', normal, compile_and_run, [''])
    8 12 
     test('arith003', normal, compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help