-----------------------------------------------------------------------------
--
-- Cmm optimisation
--
-- (c) The University of Glasgow 2006
--
-----------------------------------------------------------------------------
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
module GHC.Cmm.Opt (
        constantFoldNode,
        constantFoldExpr,
        cmmMachOpFold,
        cmmMachOpFoldM,
        Opt, runOpt
 ) where

import GHC.Prelude

import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Utils
import GHC.Cmm
import GHC.Cmm.Config
import GHC.Types.Unique.DSM

import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Platform

import Data.Maybe
import Data.Word
import GHC.Exts (oneShot)
import Control.Monad

constantFoldNode :: CmmNode e x -> Opt (CmmNode e x)
constantFoldNode :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Opt (CmmNode e x)
constantFoldNode (CmmUnsafeForeignCall (PrimTarget CallishMachOp
op) [CmmFormal]
res [CmmActual]
args)
  = (CmmActual -> Opt CmmActual) -> [CmmActual] -> Opt [CmmActual]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CmmActual -> Opt CmmActual
constantFoldExprOpt [CmmActual]
args Opt [CmmActual]
-> ([CmmActual] -> Opt (CmmNode e x)) -> Opt (CmmNode e x)
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CallishMachOp
-> [CmmFormal] -> [CmmActual] -> Opt (CmmNode 'Open 'Open)
cmmCallishMachOpFold CallishMachOp
op [CmmFormal]
res
constantFoldNode CmmNode e x
node
  = (CmmActual -> Opt CmmActual) -> CmmNode e x -> Opt (CmmNode e x)
forall (e :: Extensibility) (x :: Extensibility).
(CmmActual -> Opt CmmActual) -> CmmNode e x -> Opt (CmmNode e x)
mapExpOpt CmmActual -> Opt CmmActual
constantFoldExprOpt CmmNode e x
node

constantFoldExprOpt :: CmmExpr -> Opt CmmExpr
constantFoldExprOpt :: CmmActual -> Opt CmmActual
constantFoldExprOpt CmmActual
e = (CmmActual -> Opt CmmActual) -> CmmActual -> Opt CmmActual
wrapRecExpOpt CmmActual -> Opt CmmActual
f CmmActual
e
  where
    f :: CmmActual -> Opt CmmActual
f (CmmMachOp MachOp
op [CmmActual]
args)
      = do
        cfg <- Opt CmmConfig
getConfig
        case cmmMachOpFold (cmmPlatform cfg) op args of
          CmmMachOp MachOp
op' [CmmActual]
args' -> CmmActual -> Maybe CmmActual -> CmmActual
forall a. a -> Maybe a -> a
fromMaybe (MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
op' [CmmActual]
args') (Maybe CmmActual -> CmmActual)
-> Opt (Maybe CmmActual) -> Opt CmmActual
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmConfig -> MachOp -> [CmmActual] -> Opt (Maybe CmmActual)
cmmMachOpFoldOptM CmmConfig
cfg MachOp
op' [CmmActual]
args'
          CmmActual
e -> CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmActual
e
    f (CmmRegOff CmmReg
r Int
0) = CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmReg -> CmmActual
CmmReg CmmReg
r)
    f (CmmLit (CmmInt Integer
x Width
rep)) = CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowU Width
rep Integer
x) Width
rep)
    f CmmActual
e = CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmActual
e

constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
constantFoldExpr :: Platform -> CmmActual -> CmmActual
constantFoldExpr Platform
platform = (CmmActual -> CmmActual) -> CmmActual -> CmmActual
wrapRecExp CmmActual -> CmmActual
f
  where f :: CmmActual -> CmmActual
f (CmmMachOp MachOp
op [CmmActual]
args) = Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
op [CmmActual]
args
        f (CmmRegOff CmmReg
r Int
0) = CmmReg -> CmmActual
CmmReg CmmReg
r
        f CmmActual
e = CmmActual
e

-- -----------------------------------------------------------------------------
-- MachOp constant folder

-- Now, try to constant-fold the MachOps.  The arguments have already
-- been optimized and folded.

cmmMachOpFold
    :: Platform
    -> MachOp       -- The operation from an CmmMachOp
    -> [CmmExpr]    -- The optimized arguments
    -> CmmExpr

cmmMachOpFold :: Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
op [CmmActual]
args = CmmActual -> Maybe CmmActual -> CmmActual
forall a. a -> Maybe a -> a
fromMaybe (MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
op [CmmActual]
args) (Platform -> MachOp -> [CmmActual] -> Maybe CmmActual
cmmMachOpFoldM Platform
platform MachOp
op [CmmActual]
args)

-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
    :: Platform
    -> MachOp
    -> [CmmExpr]
    -> Maybe CmmExpr
cmmMachOpFoldM :: Platform -> MachOp -> [CmmActual] -> Maybe CmmActual
cmmMachOpFoldM Platform
_ (MO_V_Broadcast Int
lg Width
_w) [CmmActual]
exprs =
  case [CmmActual]
exprs of
    [CmmLit CmmLit
l] -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit ([CmmLit] -> CmmLit
CmmVec ([CmmLit] -> CmmLit) -> [CmmLit] -> CmmLit
forall a b. (a -> b) -> a -> b
$ Int -> CmmLit -> [CmmLit]
forall a. Int -> a -> [a]
replicate Int
lg CmmLit
l)
    [CmmActual]
_ -> Maybe CmmActual
forall a. Maybe a
Nothing
cmmMachOpFoldM Platform
_ (MO_VF_Broadcast Int
lg Width
_w) [CmmActual]
exprs =
  case [CmmActual]
exprs of
    [CmmLit CmmLit
l] -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit ([CmmLit] -> CmmLit
CmmVec ([CmmLit] -> CmmLit) -> [CmmLit] -> CmmLit
forall a b. (a -> b) -> a -> b
$ Int -> CmmLit -> [CmmLit]
forall a. Int -> a -> [a]
replicate Int
lg CmmLit
l)
    [CmmActual]
_ -> Maybe CmmActual
forall a. Maybe a
Nothing
cmmMachOpFoldM Platform
_ MachOp
op [CmmLit (CmmInt Integer
x Width
rep)]
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! case MachOp
op of
      MO_S_Neg Width
_ -> CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowS Width
rep (-Integer
x)) Width
rep)
      MO_Not Width
_   -> CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer -> Integer
forall a. Bits a => a -> a
complement Integer
x) Width
rep)

        -- these are interesting: we must first narrow to the
        -- "from" type, in order to truncate to the correct size.
        -- The final narrow/widen to the destination type
        -- is implicit in the CmmLit.
      MO_SF_Round Width
_frm Width
to -> CmmLit -> CmmActual
CmmLit (Rational -> Width -> CmmLit
CmmFloat (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
x) Width
to)
      MO_SS_Conv  Width
from Width
to -> CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowS Width
from Integer
x) Width
to)
      MO_UU_Conv  Width
from Width
to -> CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowU Width
from Integer
x) Width
to)
      MO_XX_Conv  Width
from Width
to -> CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowS Width
from Integer
x) Width
to)
      MachOp
_ -> String -> CmmActual
forall a. HasCallStack => String -> a
panic (String -> CmmActual) -> String -> CmmActual
forall a b. (a -> b) -> a -> b
$ String
"cmmMachOpFoldM: unknown unary op: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MachOp -> String
forall a. Show a => a -> String
show MachOp
op

-- Eliminate shifts that are wider than the shiftee
cmmMachOpFoldM Platform
_ MachOp
op [CmmActual
_shiftee, CmmLit (CmmInt Integer
shift Width
_)]
  | Just Width
width <- MachOp -> Maybe Width
isShift MachOp
op
  , Integer
shift Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
width)
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
width)
  where
    isShift :: MachOp -> Maybe Width
isShift (MO_Shl   Width
w) = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
    isShift (MO_U_Shr Width
w) = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
    isShift (MO_S_Shr Width
w) = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
    isShift MachOp
_            = Maybe Width
forall a. Maybe a
Nothing

-- Eliminate conversion NOPs
cmmMachOpFoldM Platform
_ (MO_SS_Conv Width
rep1 Width
rep2) [CmmActual
x] | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
cmmMachOpFoldM Platform
_ (MO_UU_Conv Width
rep1 Width
rep2) [CmmActual
x] | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
cmmMachOpFoldM Platform
_ (MO_XX_Conv Width
rep1 Width
rep2) [CmmActual
x] | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x

-- Eliminate nested conversions where possible
cmmMachOpFoldM Platform
platform MachOp
conv_outer [CmmMachOp MachOp
conv_inner [CmmActual
x]]
  | Just (Width
rep1,Width
rep2,Bool
signed1) <- MachOp -> Maybe (Width, Width, Bool)
isIntConversion MachOp
conv_inner,
    Just (Width
_,   Width
rep3,Bool
signed2) <- MachOp -> Maybe (Width, Width, Bool)
isIntConversion MachOp
conv_outer
  = case () of
        -- widen then narrow to the same size is a nop
      ()
_ | Width
rep1 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
rep2 Bool -> Bool -> Bool
&& Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep3 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
        -- Widen then narrow to different size: collapse to single conversion
        -- but remember to use the signedness from the widening, just in case
        -- the final conversion is a widen.
        | Width
rep1 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
rep2 Bool -> Bool -> Bool
&& Width
rep2 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
rep3 ->
            CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Bool -> Width -> Width -> MachOp
intconv Bool
signed1 Width
rep1 Width
rep3) [CmmActual
x]
        -- Nested widenings: collapse if the signedness is the same
        | Width
rep1 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
rep2 Bool -> Bool -> Bool
&& Width
rep2 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
rep3 Bool -> Bool -> Bool
&& Bool
signed1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
signed2 ->
            CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Bool -> Width -> Width -> MachOp
intconv Bool
signed1 Width
rep1 Width
rep3) [CmmActual
x]
        -- Nested narrowings: collapse
        | Width
rep1 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
rep2 Bool -> Bool -> Bool
&& Width
rep2 Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
rep3 ->
            CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> Width -> MachOp
MO_UU_Conv Width
rep1 Width
rep3) [CmmActual
x]
        | Bool
otherwise ->
            Maybe CmmActual
forall a. Maybe a
Nothing
  where
        isIntConversion :: MachOp -> Maybe (Width, Width, Bool)
isIntConversion (MO_UU_Conv Width
rep1 Width
rep2)
          = (Width, Width, Bool) -> Maybe (Width, Width, Bool)
forall a. a -> Maybe a
Just (Width
rep1,Width
rep2,Bool
False)
        isIntConversion (MO_SS_Conv Width
rep1 Width
rep2)
          = (Width, Width, Bool) -> Maybe (Width, Width, Bool)
forall a. a -> Maybe a
Just (Width
rep1,Width
rep2,Bool
True)
        isIntConversion MachOp
_ = Maybe (Width, Width, Bool)
forall a. Maybe a
Nothing

        intconv :: Bool -> Width -> Width -> MachOp
intconv Bool
True  = Width -> Width -> MachOp
MO_SS_Conv
        intconv Bool
False = Width -> Width -> MachOp
MO_UU_Conv

cmmMachOpFoldM Platform
platform MachOp
mop [CmmLit (CmmInt Integer
x Width
xrep), CmmLit (CmmInt Integer
y Width
_)]
  = case MachOp
mop of
        -- for comparisons: don't forget to narrow the arguments before
        -- comparing, since they might be out of range.
        MO_Eq Width
_   -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_Ne Width
_   -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))

        MO_U_Gt Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>  Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_U_Ge Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_U_Lt Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_U_Le Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
y_u then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))

        MO_S_Gt Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>  Integer
y_s then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_S_Ge Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y_s then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_S_Lt Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
y_s then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))
        MO_S_Le Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (if Integer
x_s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
y_s then Integer
1 else Integer
0) (Platform -> Width
wordWidth Platform
platform))

        MO_Add Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowU Width
r (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y) Width
r)
        MO_Sub Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowS Width
r (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y) Width
r)
        MO_Mul Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowU Width
r (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y) Width
r)
        MO_U_Quot Width
r | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_u Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
y_u) Width
r)
        MO_U_Rem  Width
r | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_u Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem`  Integer
y_u) Width
r)
        MO_S_Quot Width
r | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_s Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
y_s) Width
r)
        MO_S_Rem  Width
r | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_s Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem`  Integer
y_s) Width
r)

        MO_And   Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
y) Width
r)
        MO_Or    Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
y) Width
r)
        MO_Xor   Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
y) Width
r)

        MO_Shl   Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Width -> Integer -> Integer
narrowU Width
r (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
x   Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y) Width
r)
        MO_U_Shr Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_u Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y) Width
r)
        MO_S_Shr Width
r -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
x_s Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y) Width
r)

        MachOp
_          -> Maybe CmmActual
forall a. Maybe a
Nothing

   where
        x_u :: Integer
x_u = Width -> Integer -> Integer
narrowU Width
xrep Integer
x
        y_u :: Integer
y_u = Width -> Integer -> Integer
narrowU Width
xrep Integer
y
        x_s :: Integer
x_s = Width -> Integer -> Integer
narrowS Width
xrep Integer
x
        y_s :: Integer
y_s = Width -> Integer -> Integer
narrowS Width
xrep Integer
y


-- When possible, shift the constants to the right-hand side, so that we
-- can match for strength reductions.  Note that the code generator will
-- also assume that constants have been shifted to the right when
-- possible.

cmmMachOpFoldM Platform
platform MachOp
op [x :: CmmActual
x@(CmmLit CmmLit
_), CmmActual
y]
   | Bool -> Bool
not (CmmActual -> Bool
isLit CmmActual
y) Bool -> Bool -> Bool
&& MachOp -> Bool
isCommutableMachOp MachOp
op
   = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
op [CmmActual
y, CmmActual
x])

-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
-- moved to the right, it is more likely that we will find
-- opportunities for constant folding when the expression is
-- right-associated.
--
-- ToDo: this appears to introduce a quadratic behaviour due to the
-- nested cmmMachOpFold.  Can we fix this?
--
-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
-- is also a lit (otherwise arg1 would be on the right).  If we
-- put arg1 on the left of the rearranged expression, we'll get into a
-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
--
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
cmmMachOpFoldM Platform
platform MachOp
mop1 [CmmMachOp MachOp
mop2 [CmmActual
arg1,CmmActual
arg2], CmmActual
arg3]
   | MachOp
mop2 MachOp -> MachOp -> Bool
`associates_with` MachOp
mop1
     Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmActual -> Bool
isLit CmmActual
arg1) Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmActual -> Bool
isPicReg CmmActual
arg1)
   = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
mop2 [CmmActual
arg1, Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
mop1 [CmmActual
arg2,CmmActual
arg3]])
   where
     MO_Add{} associates_with :: MachOp -> MachOp -> Bool
`associates_with` MO_Sub{} = Bool
True
     MachOp
mop1 `associates_with` MachOp
mop2 =
        MachOp
mop1 MachOp -> MachOp -> Bool
forall a. Eq a => a -> a -> Bool
== MachOp
mop2 Bool -> Bool -> Bool
&& MachOp -> Bool
isAssociativeMachOp MachOp
mop1

-- special case: (a - b) + c  ==>  a + (c - b)
cmmMachOpFoldM Platform
platform mop1 :: MachOp
mop1@(MO_Add{}) [CmmMachOp mop2 :: MachOp
mop2@(MO_Sub{}) [CmmActual
arg1,CmmActual
arg2], CmmActual
arg3]
   | Bool -> Bool
not (CmmActual -> Bool
isLit CmmActual
arg1) Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmActual -> Bool
isPicReg CmmActual
arg1)
   = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
mop1 [CmmActual
arg1, Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
mop2 [CmmActual
arg3,CmmActual
arg2]])

-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)
--
-- this is better because lit+N is a single link-time constant (e.g. a
-- CmmLabelOff), so the right-hand expression needs only one
-- instruction, whereas the left needs two.  This happens when pointer
-- tagging gives us label+offset, and PIC turns the label into
-- PicBaseReg + label.
--
cmmMachOpFoldM Platform
_ MO_Add{} [ CmmMachOp op :: MachOp
op@MO_Add{} [CmmActual
pic, CmmLit CmmLit
lit]
                          , CmmLit (CmmInt Integer
n Width
rep) ]
  | CmmActual -> Bool
isPicReg CmmActual
pic
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
op [CmmActual
pic, CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit Int
off ]
  where off :: Int
off = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowS Width
rep Integer
n)

-- Make a RegOff if we can. We don't perform this optimization if rep is greater
-- than the host word size because we use an Int to store the offset. See
-- #24893 and #24700. This should be fixed to ensure that optimizations don't
-- depend on the compiler host platform.
cmmMachOpFoldM Platform
_ (MO_Add Width
_) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmReg -> Int -> CmmActual
cmmRegOff CmmReg
reg (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowS Width
rep Integer
n))
cmmMachOpFoldM Platform
_ (MO_Add Width
_) [CmmRegOff CmmReg
reg Int
off, CmmLit (CmmInt Integer
n Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmReg -> Int -> CmmActual
cmmRegOff CmmReg
reg (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowS Width
rep Integer
n))
cmmMachOpFoldM Platform
_ (MO_Sub Width
_) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmReg -> Int -> CmmActual
cmmRegOff CmmReg
reg (- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowS Width
rep Integer
n))
cmmMachOpFoldM Platform
_ (MO_Sub Width
_) [CmmRegOff CmmReg
reg Int
off, CmmLit (CmmInt Integer
n Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmReg -> Int -> CmmActual
cmmRegOff CmmReg
reg (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowS Width
rep Integer
n))

-- Fold label(+/-)offset into a CmmLit where possible

cmmMachOpFoldM Platform
_ (MO_Add Width
_) [CmmLit CmmLit
lit, CmmLit (CmmInt Integer
i Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowU Width
rep Integer
i)))
cmmMachOpFoldM Platform
_ (MO_Add Width
_) [CmmLit (CmmInt Integer
i Width
rep), CmmLit CmmLit
lit]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Integer -> Integer
narrowU Width
rep Integer
i)))
cmmMachOpFoldM Platform
_ (MO_Sub Width
_) [CmmLit CmmLit
lit, CmmLit (CmmInt Integer
i Width
rep)]
  | Width -> Bool
validOffsetRep Width
rep
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer
forall a. Num a => a -> a
negate (Width -> Integer -> Integer
narrowU Width
rep Integer
i))))


-- Comparison of literal with widened operand: perform the comparison
-- at the smaller width, as long as the literal is within range.

-- We can't do the reverse trick, when the operand is narrowed:
-- narrowing throws away bits from the operand, there's no way to do
-- the same comparison at the larger size.

cmmMachOpFoldM Platform
platform MachOp
cmp [CmmMachOp MachOp
conv [CmmActual
x], CmmLit (CmmInt Integer
i Width
_)]
  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
    Platform -> Arch
platformArch Platform
platform Arch -> [Arch] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arch
ArchX86, Arch
ArchX86_64],
        -- if the operand is widened:
    Just (Width
rep, Bool
signed, Width -> Integer -> Integer
narrow_fn) <- MachOp -> Maybe (Width, Bool, Width -> Integer -> Integer)
maybe_conversion MachOp
conv,
        -- and this is a comparison operation:
    Just MachOp
narrow_cmp <- MachOp -> Width -> Bool -> Maybe MachOp
maybe_comparison MachOp
cmp Width
rep Bool
signed,
        -- and the literal fits in the smaller size:
    Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Width -> Integer -> Integer
narrow_fn Width
rep Integer
i
        -- then we can do the comparison at the smaller size
  = CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform MachOp
narrow_cmp [CmmActual
x, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
i Width
rep)])
 where
    maybe_conversion :: MachOp -> Maybe (Width, Bool, Width -> Integer -> Integer)
maybe_conversion (MO_UU_Conv Width
from Width
to)
        | Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
from
        = (Width, Bool, Width -> Integer -> Integer)
-> Maybe (Width, Bool, Width -> Integer -> Integer)
forall a. a -> Maybe a
Just (Width
from, Bool
False, Width -> Integer -> Integer
narrowU)
    maybe_conversion (MO_SS_Conv Width
from Width
to)
        | Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
from
        = (Width, Bool, Width -> Integer -> Integer)
-> Maybe (Width, Bool, Width -> Integer -> Integer)
forall a. a -> Maybe a
Just (Width
from, Bool
True, Width -> Integer -> Integer
narrowS)

        -- don't attempt to apply this optimisation when the source
        -- is a float; see #1916
    maybe_conversion MachOp
_ = Maybe (Width, Bool, Width -> Integer -> Integer)
forall a. Maybe a
Nothing

        -- careful (#2080): if the original comparison was signed, but
        -- we were doing an unsigned widen, then we must do an
        -- unsigned comparison at the smaller size.
    maybe_comparison :: MachOp -> Width -> Bool -> Maybe MachOp
maybe_comparison (MO_U_Gt Width
_) Width
rep Bool
_     = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Gt Width
rep)
    maybe_comparison (MO_U_Ge Width
_) Width
rep Bool
_     = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Ge Width
rep)
    maybe_comparison (MO_U_Lt Width
_) Width
rep Bool
_     = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Lt Width
rep)
    maybe_comparison (MO_U_Le Width
_) Width
rep Bool
_     = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Le Width
rep)
    maybe_comparison (MO_Eq   Width
_) Width
rep Bool
_     = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_Eq   Width
rep)
    maybe_comparison (MO_S_Gt Width
_) Width
rep Bool
True  = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_S_Gt Width
rep)
    maybe_comparison (MO_S_Ge Width
_) Width
rep Bool
True  = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_S_Ge Width
rep)
    maybe_comparison (MO_S_Lt Width
_) Width
rep Bool
True  = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_S_Lt Width
rep)
    maybe_comparison (MO_S_Le Width
_) Width
rep Bool
True  = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_S_Le Width
rep)
    maybe_comparison (MO_S_Gt Width
_) Width
rep Bool
False = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Gt Width
rep)
    maybe_comparison (MO_S_Ge Width
_) Width
rep Bool
False = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Ge Width
rep)
    maybe_comparison (MO_S_Lt Width
_) Width
rep Bool
False = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Lt Width
rep)
    maybe_comparison (MO_S_Le Width
_) Width
rep Bool
False = MachOp -> Maybe MachOp
forall a. a -> Maybe a
Just (Width -> MachOp
MO_U_Le Width
rep)
    maybe_comparison MachOp
_ Width
_ Bool
_ = Maybe MachOp
forall a. Maybe a
Nothing

-- We can often do something with constants of 0, 1 and (-1) ...
-- See Note [Comparison operators]

cmmMachOpFoldM Platform
platform MachOp
mop [CmmActual
x, y :: CmmActual
y@(CmmLit (CmmInt Integer
0 Width
_))]
  = case MachOp
mop of
        -- Arithmetic
        MO_Add   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- x + 0 = x
        MO_Sub   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- x - 0 = x
        MO_Mul   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
y   -- x * 0 = 0

        -- Logical operations
        MO_And   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
y   -- x &     0 = 0
        MO_Or    Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- x |     0 = x
        MO_Xor   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- x `xor` 0 = x

        -- Shifts
        MO_Shl   Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- x << 0 = x
        MO_S_Shr Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x   -- ditto shift-right
        MO_U_Shr Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x

        -- Comparisons; these ones are trickier
        -- See Note [Comparison operators]
        MO_Ne    Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x                -- (x > y) != 0  =  x > y
        MO_Eq    Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'  -- (x > y) == 0  =  x <= y
        MO_U_Gt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x                -- (x > y) > 0   =  x > y
        MO_S_Gt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x                -- ditto
        MO_U_Lt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
zero             -- (x > y) < 0  =  0
        MO_S_Lt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
zero
        MO_U_Ge  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
one              -- (x > y) >= 0  =  1
        MO_S_Ge  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
one

        MO_U_Le  Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'  -- (x > y) <= 0  =  x <= y
        MO_S_Le  Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'
        MachOp
_ -> Maybe CmmActual
forall a. Maybe a
Nothing
  where
    zero :: CmmActual
zero = CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (Platform -> Width
wordWidth Platform
platform))
    one :: CmmActual
one  = CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
1 (Platform -> Width
wordWidth Platform
platform))

cmmMachOpFoldM Platform
platform MachOp
mop [CmmActual
x, (CmmLit (CmmInt Integer
1 Width
rep))]
  = case MachOp
mop of
        -- Arithmetic: x*1 = x, etc
        MO_Mul    Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
        MO_S_Quot Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
        MO_U_Quot Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
        MO_S_Rem  Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        MO_U_Rem  Width
_ -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)

        -- Comparisons; trickier
        -- See Note [Comparison operators]
        MO_Ne    Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'  -- (x>y) != 1  =  x<=y
        MO_Eq    Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x                -- (x>y) == 1  =  x>y
        MO_U_Lt  Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'  -- (x>y) < 1   =  x<=y
        MO_S_Lt  Width
_ | Just CmmActual
x' <- CmmActual -> Maybe CmmActual
maybeInvertCmmExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x'  -- ditto
        MO_U_Gt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
zero             -- (x>y) > 1   = 0
        MO_S_Gt  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
zero
        MO_U_Le  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
one              -- (x>y) <= 1  = 1
        MO_S_Le  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
one
        MO_U_Ge  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x                -- (x>y) >= 1  = x>y
        MO_S_Ge  Width
_ | CmmActual -> Bool
isComparisonExpr CmmActual
x -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
x
        MachOp
_ -> Maybe CmmActual
forall a. Maybe a
Nothing
  where
    zero :: CmmActual
zero = CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (Platform -> Width
wordWidth Platform
platform))
    one :: CmmActual
one  = CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
1 (Platform -> Width
wordWidth Platform
platform))

-- Now look for multiplication/division by powers of 2 (integers).

cmmMachOpFoldM Platform
platform MachOp
mop [CmmActual
x, (CmmLit (CmmInt Integer
n Width
_))]
  = case MachOp
mop of
        MO_Mul Width
rep
           | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
n ->
                 CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Shl Width
rep) [CmmActual
x, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
p (Width -> CmmLit) -> Width -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform)])
        -- The optimization for division by power of 2 is technically duplicated, but since at least one other part of ghc uses
        -- the pure `constantFoldExpr` this remains
        MO_U_Quot Width
rep
           | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
n ->
                 CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_U_Shr Width
rep) [CmmActual
x, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
p (Width -> CmmLit) -> Width -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform)])
        MO_U_Rem Width
rep
           | Just Integer
_ <- Integer -> Maybe Integer
exactLog2 Integer
n ->
                 CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_And Width
rep) [CmmActual
x, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Width
rep)])
        MO_S_Quot Width
rep
           | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
n,
             CmmReg CmmReg
_ <- CmmActual
x ->
                CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_S_Shr Width
rep)
                  [Platform -> Integer -> CmmActual -> Width -> Integer -> CmmActual
signedQuotRemHelper Platform
platform Integer
n CmmActual
x Width
rep Integer
p, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
p (Width -> CmmLit) -> Width -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform)])
        MO_S_Rem Width
rep
           | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
n,
             CmmReg CmmReg
_ <- CmmActual
x ->
                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
                CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual) -> CmmActual -> Maybe CmmActual
forall a b. (a -> b) -> a -> b
$! (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Sub Width
rep)
                    [CmmActual
x, Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_And Width
rep)
                      [Platform -> Integer -> CmmActual -> Width -> Integer -> CmmActual
signedQuotRemHelper Platform
platform Integer
n CmmActual
x Width
rep Integer
p, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (- Integer
n) Width
rep)]])
        MachOp
_ -> Maybe CmmActual
forall a. Maybe a
Nothing

-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
-- Unfortunately this needs a unique supply because x might not be a
-- register.  See #2253 (program 6) for an example.


-- Anything else is just too hard.

cmmMachOpFoldM Platform
_ MachOp
_ [CmmActual]
_ = Maybe CmmActual
forall a. Maybe a
Nothing

-- | Check that a literal width is compatible with the host word size used to
-- store offsets. This should be fixed properly (using larger types to store
-- literal offsets). See #24893
validOffsetRep :: Width -> Bool
validOffsetRep :: Width -> Bool
validOffsetRep Width
rep = Width -> Int
widthInBits Width
rep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
forall a. HasCallStack => a
undefined :: Int)


{- Note [Comparison operators]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
   CmmCondBranch ((x>#y) == 1) t f
we really want to convert to
   CmmCondBranch (x>#y) t f

That's what the constant-folding operations on comparison operators do above.
-}

-- -----------------------------------------------------------------------------
-- Utils

isPicReg :: CmmExpr -> Bool
isPicReg :: CmmActual -> Bool
isPicReg (CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_))) = Bool
True
isPicReg CmmActual
_ = Bool
False

canOptimizeDivision :: CmmConfig -> Width -> Bool
canOptimizeDivision :: CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep = CmmConfig -> Bool
cmmOptConstDivision CmmConfig
cfg Bool -> Bool -> Bool
&&
  -- we can either widen the arguments to simulate mul2 or use mul2 directly for the platform word size
  (Width
rep Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform Bool -> Bool -> Bool
|| (Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform Bool -> Bool -> Bool
&& CmmConfig -> Bool
cmmAllowMul2 CmmConfig
cfg))
  where platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg

-- -----------------------------------------------------------------------------
-- Folding callish machops

cmmCallishMachOpFold :: CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (CmmNode O O)
cmmCallishMachOpFold :: CallishMachOp
-> [CmmFormal] -> [CmmActual] -> Opt (CmmNode 'Open 'Open)
cmmCallishMachOpFold CallishMachOp
op [CmmFormal]
res [CmmActual]
args =
  CmmNode 'Open 'Open
-> Maybe (CmmNode 'Open 'Open) -> CmmNode 'Open 'Open
forall a. a -> Maybe a -> a
fromMaybe (ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall (CallishMachOp -> ForeignTarget
PrimTarget CallishMachOp
op) [CmmFormal]
res [CmmActual]
args) (Maybe (CmmNode 'Open 'Open) -> CmmNode 'Open 'Open)
-> Opt (Maybe (CmmNode 'Open 'Open)) -> Opt (CmmNode 'Open 'Open)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Opt CmmConfig
getConfig Opt CmmConfig
-> (CmmConfig -> Opt (Maybe (CmmNode 'Open 'Open)))
-> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CmmConfig
cfg -> CmmConfig
-> CallishMachOp
-> [CmmFormal]
-> [CmmActual]
-> Opt (Maybe (CmmNode 'Open 'Open))
cmmCallishMachOpFoldM CmmConfig
cfg CallishMachOp
op [CmmFormal]
res [CmmActual]
args)

cmmCallishMachOpFoldM :: CmmConfig -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Opt (Maybe (CmmNode O O))

-- If possible move the literals to the right, the following cases assume that to be the case
cmmCallishMachOpFoldM :: CmmConfig
-> CallishMachOp
-> [CmmFormal]
-> [CmmActual]
-> Opt (Maybe (CmmNode 'Open 'Open))
cmmCallishMachOpFoldM CmmConfig
cfg CallishMachOp
op [CmmFormal]
res [x :: CmmActual
x@(CmmLit CmmLit
_),CmmActual
y]
  | CallishMachOp -> Bool
isCommutableCallishMachOp CallishMachOp
op Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmActual -> Bool
isLit CmmActual
y) = CmmConfig
-> CallishMachOp
-> [CmmFormal]
-> [CmmActual]
-> Opt (Maybe (CmmNode 'Open 'Open))
cmmCallishMachOpFoldM CmmConfig
cfg CallishMachOp
op [CmmFormal]
res [CmmActual
y,CmmActual
x]

-- Both arguments are literals, replace with the result
cmmCallishMachOpFoldM CmmConfig
_ CallishMachOp
op [CmmFormal]
res [CmmLit (CmmInt Integer
x Width
_), CmmLit (CmmInt Integer
y Width
_)]
  = case CallishMachOp
op of
    MO_S_Mul2 Width
rep
      | [CmmFormal
rHiNeeded,CmmFormal
rHi,CmmFormal
rLo] <- [CmmFormal]
res -> do
          let resSz :: Int
resSz = Width -> Int
widthInBits Width
rep
              resVal :: Integer
resVal = (Width -> Integer -> Integer
narrowS Width
rep Integer
x) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Width -> Integer -> Integer
narrowS Width
rep Integer
y)
              high :: Integer
high = Integer
resVal Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
resSz
              low :: Integer
low = Width -> Integer -> Integer
narrowS Width
rep Integer
resVal
              isHiNeeded :: Bool
isHiNeeded = Integer
high Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
low Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
resSz
              isHiNeededVal :: Integer
isHiNeededVal = if Bool
isHiNeeded then Integer
1 else Integer
0
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHiNeeded) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
isHiNeededVal Width
rep)
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
high Width
rep)
          Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
low Width
rep)
    MO_U_Mul2 Width
rep
      | [CmmFormal
rHi,CmmFormal
rLo] <- [CmmFormal]
res -> do
          let resSz :: Int
resSz = Width -> Int
widthInBits Width
rep
              resVal :: Integer
resVal = (Width -> Integer -> Integer
narrowU Width
rep Integer
x) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Width -> Integer -> Integer
narrowU Width
rep Integer
y)
              high :: Integer
high = Integer
resVal Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
resSz
              low :: Integer
low = Width -> Integer -> Integer
narrowU Width
rep Integer
resVal
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
high Width
rep)
          Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
low Width
rep)
    MO_S_QuotRem Width
rep
      | [CmmFormal
rQuot, CmmFormal
rRem] <- [CmmFormal]
res,
        Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> do
          let (Integer
q,Integer
r) = Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
quotRem (Width -> Integer -> Integer
narrowS Width
rep Integer
x) (Width -> Integer -> Integer
narrowS Width
rep Integer
y)
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
q Width
rep)
          Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
r Width
rep)
    MO_U_QuotRem Width
rep
      | [CmmFormal
rQuot, CmmFormal
rRem] <- [CmmFormal]
res,
        Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> do
          let (Integer
q,Integer
r) = Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
quotRem (Width -> Integer -> Integer
narrowU Width
rep Integer
x) (Width -> Integer -> Integer
narrowU Width
rep Integer
y)
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
q Width
rep)
          Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
r Width
rep)
    CallishMachOp
_ -> Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

-- 0, 1 or -1 as one of the constants

cmmCallishMachOpFoldM CmmConfig
_ CallishMachOp
op [CmmFormal]
res [CmmActual
_, CmmLit (CmmInt Integer
0 Width
_)]
  = case CallishMachOp
op of
    -- x * 0 == 0
    MO_S_Mul2 Width
rep
      | [CmmFormal
rHiNeeded, CmmFormal
rHi, CmmFormal
rLo] <- [CmmFormal]
res -> do
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHiNeeded) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    -- x * 0 == 0
    MO_U_Mul2 Width
rep
      | [CmmFormal
rHi, CmmFormal
rLo] <- [CmmFormal]
res -> do
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    CallishMachOp
_ -> Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

cmmCallishMachOpFoldM CmmConfig
_ CallishMachOp
op [CmmFormal]
res [CmmLit (CmmInt Integer
0 Width
_), CmmActual
_]
  = case CallishMachOp
op of
    -- 0 quotRem d == (0,0)
    MO_S_QuotRem Width
rep
      | [CmmFormal
rQuot, CmmFormal
rRem] <- [CmmFormal]
res -> do
      CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
      Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    -- 0 quotRem d == (0,0)
    MO_U_QuotRem Width
rep
      | [CmmFormal
rQuot,CmmFormal
rRem] <- [CmmFormal]
res -> do
      CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
      Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    CallishMachOp
_ -> Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

cmmCallishMachOpFoldM CmmConfig
cfg CallishMachOp
op [CmmFormal]
res [CmmActual
x, CmmLit (CmmInt Integer
1 Width
_)]
  = case CallishMachOp
op of
    -- x * 1 == x -- Note: The high word needs to be a sign extension of the low word, so we use a sign extending shift
    MO_S_Mul2 Width
rep
      | [CmmFormal
rHiNeeded, CmmFormal
rHi, CmmFormal
rLo] <- [CmmFormal]
res -> do
        let platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
            wordRep :: Width
wordRep = Platform -> Width
wordWidth Platform
platform
            repInBits :: Integer
repInBits = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
rep
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHiNeeded) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_S_Shr Width
rep) [CmmActual
x, CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Integer
repInBits Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Width
wordRep])
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) CmmActual
x
    -- x * 1 == x
    MO_U_Mul2 Width
rep
      | [CmmFormal
rHi, CmmFormal
rLo] <- [CmmFormal]
res -> do
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rHi) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rLo) CmmActual
x
    -- x quotRem 1 == (x, 0)
    MO_S_QuotRem Width
rep
      | [CmmFormal
rQuot, CmmFormal
rRem] <- [CmmFormal]
res -> do
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) CmmActual
x
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    -- x quotRem 1 == (x, 0)
    MO_U_QuotRem Width
rep
      | [CmmFormal
rQuot, CmmFormal
rRem] <- [CmmFormal]
res -> do
        CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) CmmActual
x
        Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
rep)
    CallishMachOp
_ -> Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

-- handle quotRem with a constant divisor

cmmCallishMachOpFoldM CmmConfig
cfg CallishMachOp
op [CmmFormal]
res [CmmActual
n, CmmLit (CmmInt Integer
d' Width
_)]
  = case CallishMachOp
op of
    MO_S_QuotRem Width
rep
      | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
d,
        [CmmFormal
rQuot,CmmFormal
rRem] <- [CmmFormal]
res -> do
          n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
          -- first prepend the optimized division by a power 2
          prependNode $! CmmAssign (CmmLocal rQuot)
            (cmmMachOpFold platform (MO_S_Shr rep)
              [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt p $ wordWidth platform)])
          -- then output an optimized remainder by a power of 2
          pure . Just $! CmmAssign (CmmLocal rRem)
            (cmmMachOpFold platform (MO_Sub rep)
              [n', cmmMachOpFold platform (MO_And rep)
                [signedQuotRemHelper platform d n' rep p, CmmLit (CmmInt (- d) rep)]])
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Integer
1), Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1,
        [CmmFormal
rQuot,CmmFormal
rRem] <- [CmmFormal]
res -> do
          -- we are definitely going to use n multiple times, so put it into a register
          n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
          -- generate an optimized (signed) division of n by d
          q <- generateDivisionBySigned platform cfg rep n' d
          -- we also need the result multiple times to calculate the remainder
          q' <- intoRegister q (cmmBits rep)

          prependNode $! CmmAssign (CmmLocal rQuot) q'
          -- The remainder now becomes n - q * d
          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]
      where
        platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
        d :: Integer
d = Width -> Integer -> Integer
narrowS Width
rep Integer
d'
    MO_U_QuotRem Width
rep
      | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
d,
        [CmmFormal
rQuot,CmmFormal
rRem] <- [CmmFormal]
res -> do
          -- first prepend the optimized division by a power 2
          CmmNode 'Open 'Open -> Opt ()
prependNode (CmmNode 'Open 'Open -> Opt ()) -> CmmNode 'Open 'Open -> Opt ()
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rQuot) (CmmActual -> CmmNode 'Open 'Open)
-> CmmActual -> CmmNode 'Open 'Open
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_U_Shr Width
rep) [CmmActual
n, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
p (Width -> CmmLit) -> Width -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform)]
          -- then output an optimized remainder by a power of 2
          Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open)))
-> (CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open
-> Opt (Maybe (CmmNode 'Open 'Open))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode 'Open 'Open -> Maybe (CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open)))
-> CmmNode 'Open 'Open -> Opt (Maybe (CmmNode 'Open 'Open))
forall a b. (a -> b) -> a -> b
$! CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
rRem) (CmmActual -> CmmNode 'Open 'Open)
-> CmmActual -> CmmNode 'Open 'Open
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_And Width
rep) [CmmActual
n, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Width
rep)]
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1,
        [CmmFormal
rQuot,CmmFormal
rRem] <- [CmmFormal]
res -> do
          -- we are definitely going to use n multiple times, so put it into a register
          n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
          -- generate an optimized (unsigned) division of n by d
          q <- generateDivisionByUnsigned platform cfg rep n' d
          -- we also need the result multiple times to calculate the remainder
          q' <- intoRegister q (cmmBits rep)

          prependNode $! CmmAssign (CmmLocal rQuot) q'
          -- The remainder now becomes n - q * d
          pure . Just $! CmmAssign (CmmLocal rRem) $ CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q', CmmLit $ CmmInt d rep]]
      where
        platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
        d :: Integer
d = Width -> Integer -> Integer
narrowU Width
rep Integer
d'
    CallishMachOp
_ -> Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

cmmCallishMachOpFoldM CmmConfig
_ CallishMachOp
_ [CmmFormal]
_ [CmmActual]
_ = Maybe (CmmNode 'Open 'Open) -> Opt (Maybe (CmmNode 'Open 'Open))
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- Specialized constant folding for MachOps which sometimes need to expand into multiple nodes

cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmExpr] -> Opt (Maybe CmmExpr)

cmmMachOpFoldOptM :: CmmConfig -> MachOp -> [CmmActual] -> Opt (Maybe CmmActual)
cmmMachOpFoldOptM CmmConfig
cfg MachOp
op [CmmActual
n, CmmLit (CmmInt Integer
d' Width
_)] =
  case MachOp
op of
    MO_S_Quot Width
rep
      -- recheck for power of 2 division. This may not be handled by cmmMachOpFoldM if n is not in a register
      | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
d -> do
        n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
        pure . Just $! cmmMachOpFold platform (MO_S_Shr rep)
          [ signedQuotRemHelper platform d n' rep p
          , CmmLit (CmmInt p $ wordWidth platform)
          ]
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Integer
1), Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1 -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual)
-> Opt CmmActual -> Opt (Maybe CmmActual)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Platform
-> CmmConfig -> Width -> CmmActual -> Integer -> Opt CmmActual
generateDivisionBySigned Platform
platform CmmConfig
cfg Width
rep CmmActual
n Integer
d
      where d :: Integer
d = Width -> Integer -> Integer
narrowS Width
rep Integer
d'
    MO_S_Rem Width
rep
      -- recheck for power of 2 remainder. This may not be handled by cmmMachOpFoldM if n is not in a register
      | Just Integer
p <- Integer -> Maybe Integer
exactLog2 Integer
d -> do
        n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
        pure . Just $! cmmMachOpFold platform (MO_Sub rep)
          [ n'
          , cmmMachOpFold platform (MO_And rep)
              [ signedQuotRemHelper platform d n' rep p
              , CmmLit (CmmInt (- d) rep)
              ]
          ]
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Integer
1), Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1 -> do
        n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
        -- first generate the division
        q <- generateDivisionBySigned platform cfg rep n' d
        -- then calculate the remainder by n - q * d
        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]
      where d :: Integer
d = Width -> Integer -> Integer
narrowS Width
rep Integer
d'
    MO_U_Quot Width
rep
      -- No need to recheck power of 2 division because cmmMachOpFoldM always handles that case
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1, Maybe Integer
Nothing <- Integer -> Maybe Integer
exactLog2 Integer
d -> CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just (CmmActual -> Maybe CmmActual)
-> Opt CmmActual -> Opt (Maybe CmmActual)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Platform
-> CmmConfig -> Width -> CmmActual -> Integer -> Opt CmmActual
generateDivisionByUnsigned Platform
platform CmmConfig
cfg Width
rep CmmActual
n Integer
d
      where d :: Integer
d = Width -> Integer -> Integer
narrowU Width
rep Integer
d'
    MO_U_Rem Width
rep
      -- No need to recheck power of 2 remainder because cmmMachOpFoldM always handles that case
      | CmmConfig -> Width -> Bool
canOptimizeDivision CmmConfig
cfg Width
rep,
        Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1, Maybe Integer
Nothing <- Integer -> Maybe Integer
exactLog2 Integer
d -> do
        n' <- CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n (Width -> CmmType
cmmBits Width
rep)
        -- first generate the division
        q <- generateDivisionByUnsigned platform cfg rep n d
        -- then calculate the remainder by n - q * d
        pure . Just $! CmmMachOp (MO_Sub rep) [n', CmmMachOp (MO_Mul rep) [q, CmmLit $ CmmInt d rep]]
      where d :: Integer
d = Width -> Integer -> Integer
narrowU Width
rep Integer
d'
    MachOp
_ -> Maybe CmmActual -> Opt (Maybe CmmActual)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CmmActual
forall a. Maybe a
Nothing
  where platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg

cmmMachOpFoldOptM CmmConfig
_ MachOp
_ [CmmActual]
_ = Maybe CmmActual -> Opt (Maybe CmmActual)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CmmActual
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- Utils for prepending new nodes

-- Move an expression into a register to possibly use it multiple times
intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr
intoRegister :: CmmActual -> CmmType -> Opt CmmActual
intoRegister e :: CmmActual
e@(CmmReg CmmReg
_) CmmType
_ = CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmActual
e
intoRegister CmmActual
expr CmmType
ty = do
  u <- Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
  let reg = Unique -> CmmType -> CmmFormal
LocalReg Unique
u CmmType
ty
  CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr)

prependNode :: CmmNode O O -> Opt ()
prependNode :: CmmNode 'Open 'Open -> Opt ()
prependNode CmmNode 'Open 'Open
n = (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], ()))
-> Opt ()
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], ()))
 -> Opt ())
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], ()))
-> Opt ()
forall a b. (a -> b) -> a -> b
$ \CmmConfig
_ [CmmNode 'Open 'Open]
xs -> ([CmmNode 'Open 'Open], ()) -> UniqDSM ([CmmNode 'Open 'Open], ())
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CmmNode 'Open 'Open]
xs [CmmNode 'Open 'Open]
-> [CmmNode 'Open 'Open] -> [CmmNode 'Open 'Open]
forall a. [a] -> [a] -> [a]
++ [CmmNode 'Open 'Open
n], ())

-- -----------------------------------------------------------------------------
-- Division by constants utils

-- Helper for division by a power of 2
-- In contrast with unsigned integers, for signed ones
-- shift right is not the same as quot, because it rounds
-- to minus infinity, whereas quot rounds toward zero.
-- To fix this up, we add one less than the divisor to the
-- dividend if it is a negative number.
--
-- to avoid a test/jump, we use the following sequence:
--      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
--      x2 = y & (divisor-1)
--      result = x + x2
-- this could be done a bit more simply using conditional moves,
-- but we're processor independent here.
--
-- we optimize the divide by 2 case slightly, generating
--      x1 = x >> word_size-1  (unsigned)
--      return = x + x1
signedQuotRemHelper :: Platform -> Integer -> CmmExpr -> Width -> Integer -> CmmExpr
signedQuotRemHelper :: Platform -> Integer -> CmmActual -> Width -> Integer -> CmmActual
signedQuotRemHelper Platform
platform Integer
n CmmActual
x Width
rep Integer
p = MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
rep) [CmmActual
x, CmmActual
x2]
  where
    bits :: Integer
bits = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
rep) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
    shr :: MachOp
shr = if Integer
p Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then Width -> MachOp
MO_U_Shr Width
rep else Width -> MachOp
MO_S_Shr Width
rep
    x1 :: CmmActual
x1 = MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
shr [CmmActual
x, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
bits (Width -> CmmLit) -> Width -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform)]
    x2 :: CmmActual
x2 = if Integer
p Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then CmmActual
x1 else
          MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_And Width
rep) [CmmActual
x1, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Width
rep)]

{- Note: [Division by constants]

Integer division is floor(n / d), the goal is to find m,p
such that floor((m * n) / 2^p) = floor(n / d).

The idea being: n/d = n * (1/d). But we cannot store 1/d in an integer without
some error, so we choose some 2^p / d such that the error ends up small and
thus vanishes when we divide by 2^p again.

The algorithm below to generate these numbers is taken from Hacker's Delight
Second Edition Chapter 10 "Integer division by constants". The chapter also
contains proof that this method does indeed produce correct results.

However this is a much more literal interpretation of the algorithm,
which we can use because of the unbounded Integer type. Hacker's Delight
also provides a much more complex algorithm which computes these numbers
without the need to exceed the word size, but that is not necessary here.
-}

generateDivisionBySigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr

-- Sanity checks, division will generate incorrect results or undesirable code for these cases
-- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!
generateDivisionBySigned :: Platform
-> CmmConfig -> Width -> CmmActual -> Integer -> Opt CmmActual
generateDivisionBySigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
0 = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic String
"generate signed division with 0"
generateDivisionBySigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
1 = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic String
"generate signed division with 1"
generateDivisionBySigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ (-1) = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic String
"generate signed division with -1"
generateDivisionBySigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
d | Just Integer
_ <- Integer -> Maybe Integer
exactLog2 Integer
d = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic (String -> Opt CmmActual) -> String -> Opt CmmActual
forall a b. (a -> b) -> a -> b
$ String
"generate signed division with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
d

generateDivisionBySigned Platform
platform CmmConfig
_cfg Width
rep CmmActual
n Integer
divisor = do
  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register
  n' <- if Integer
sign Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmActual
n else CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n CmmType
resRep

  -- Set up mul2
  (shift', qExpr) <- mul2 n'

  -- add/subtract n if necessary
  let qExpr' = case Integer
sign of
        Integer
1  -> MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
rep) [CmmActual
qExpr, CmmActual
n']
        -1 -> MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Sub Width
rep) [CmmActual
qExpr, CmmActual
n']
        Integer
_  -> CmmActual
qExpr

  qExpr'' <- intoRegister (cmmMachOpFold platform (MO_S_Shr rep) [qExpr', CmmLit $ CmmInt shift' wordRep]) resRep

  -- Lastly add the sign of the quotient to correct for negative results
  pure $! cmmMachOpFold platform
    (MO_Add rep) [qExpr'', cmmMachOpFold platform (MO_U_Shr rep) [qExpr'', CmmLit $ CmmInt (toInteger $ widthInBits rep - 1) wordRep]]
  where
    resRep :: CmmType
resRep = Width -> CmmType
cmmBits Width
rep
    wordRep :: Width
wordRep = Platform -> Width
wordWidth Platform
platform
    (Integer
magic, Integer
sign, Integer
shift) = Width -> Integer -> (Integer, Integer, Integer)
divisionMagicS Width
rep Integer
divisor
    -- generate the multiply with the magic number
    mul2 :: CmmActual -> Opt (Integer, CmmActual)
mul2 CmmActual
n
      -- Using mul2 for sub-word sizes regresses for signed integers only
      | Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = do
        (r1, r2, r3) <- (,,) (Unique -> Unique -> Unique -> (Unique, Unique, Unique))
-> Opt Unique -> Opt (Unique -> Unique -> (Unique, Unique, Unique))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM Opt (Unique -> Unique -> (Unique, Unique, Unique))
-> Opt Unique -> Opt (Unique -> (Unique, Unique, Unique))
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM Opt (Unique -> (Unique, Unique, Unique))
-> Opt Unique -> Opt (Unique, Unique, Unique)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
        let rg1    = Unique -> CmmType -> CmmFormal
LocalReg Unique
r1 CmmType
resRep
            resReg = Unique -> CmmType -> CmmFormal
LocalReg Unique
r2 CmmType
resRep
            rg3    = Unique -> CmmType -> CmmFormal
LocalReg Unique
r3 CmmType
resRep
        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_S_Mul2 rep)) [rg1, resReg, rg3] [n, CmmLit $ CmmInt magic rep])
        pure (shift, res)
      -- widen the register and multiply without the MUL2 instruction
      -- if we don't need an additional add after this we can combine the shifts
      | Bool
otherwise = (Integer, CmmActual) -> Opt (Integer, CmmActual)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Integer
sign Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Integer
0 else Integer
shift, CmmActual
res)
          where
            wordRep :: Width
wordRep = Platform -> Width
wordWidth Platform
platform
            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow
            res :: CmmActual
res = Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> Width -> MachOp
MO_SS_Conv Width
wordRep Width
rep)
                    [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_S_Shr Width
wordRep)
                      [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Mul Width
wordRep)
                        [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> Width -> MachOp
MO_SS_Conv Width
rep Width
wordRep) [CmmActual
n]
                        , CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
magic Width
wordRep
                        ]
                      -- Check if we need to generate an add/subtract later. If not we can combine this with the postshift
                      , CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt ((if Integer
sign Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
shift else Integer
0) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
rep)) Width
wordRep
                      ]
                    ]

-- See hackers delight for how and why this works (chapter in note [Division by constants])
divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer)
divisionMagicS :: Width -> Integer -> (Integer, Integer, Integer)
divisionMagicS Width
rep Integer
divisor = (Integer
magic, Integer
sign, Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wSz)
  where
    sign :: Integer
sign = if Integer
divisor Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
      then if Integer
magic Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer
1 else Integer
0
      else if Integer
magic Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer
0 else -Integer
1
    wSz :: Int
wSz = Width -> Int
widthInBits Width
rep
    ad :: Integer
ad = Integer -> Integer
forall a. Num a => a -> a
abs Integer
divisor
    t :: Integer
t = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
wSz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ if Integer
divisor Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then Integer
0 else Integer
1
    anc :: Integer
anc = Integer
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem Integer
t Integer
ad
    go :: Int -> Int
go Int
p'
      | Integer
twoP Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
anc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
ad Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem Integer
twoP Integer
ad) = Int
p'
      | Bool
otherwise = Int -> Int
go (Int
p' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      where twoP :: Integer
twoP = Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p'
    p :: Int
p = Int -> Int
go Int
wSz
    am :: Integer
am = (Integer
twoP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
ad Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem Integer
twoP Integer
ad) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
ad
      where twoP :: Integer
twoP = Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p
    magic :: Integer
magic = Width -> Integer -> Integer
narrowS Width
rep (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ if Integer
divisor Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then Integer
am else -Integer
am

generateDivisionByUnsigned :: Platform -> CmmConfig -> Width -> CmmExpr -> Integer -> Opt CmmExpr
-- Sanity checks, division will generate incorrect results or undesirable code for these cases
-- cmmMachOpFoldM and cmmMachOpFoldOptM should have already handled these cases!
generateDivisionByUnsigned :: Platform
-> CmmConfig -> Width -> CmmActual -> Integer -> Opt CmmActual
generateDivisionByUnsigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
0 = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic String
"generate signed division with 0"
generateDivisionByUnsigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
1 = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic String
"generate signed division with 1"
generateDivisionByUnsigned Platform
_ CmmConfig
_ Width
_ CmmActual
_ Integer
d | Just Integer
_ <- Integer -> Maybe Integer
exactLog2 Integer
d = String -> Opt CmmActual
forall a. HasCallStack => String -> a
panic (String -> Opt CmmActual) -> String -> Opt CmmActual
forall a b. (a -> b) -> a -> b
$ String
"generate signed division with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
d

generateDivisionByUnsigned Platform
platform CmmConfig
cfg Width
rep CmmActual
n Integer
divisor = do
  -- We only duplicate n' if we actually need to add/subtract it, so we may not need it in a register
  n' <- if Bool -> Bool
not Bool
needsAdd -- Invariant: We also never preshift if we need an add, thus we don't need n in a register
    then CmmActual -> Opt CmmActual
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmActual -> Opt CmmActual) -> CmmActual -> Opt CmmActual
forall a b. (a -> b) -> a -> b
$! Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_U_Shr Width
rep) [CmmActual
n, CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
preShift Width
wordRep]
    else CmmActual -> CmmType -> Opt CmmActual
intoRegister CmmActual
n CmmType
resRep

  -- Set up mul2
  (postShift', qExpr) <- mul2 n'

  -- add/subtract n if necessary
  let qExpr' = if Bool
needsAdd
        -- This is qExpr + (n - qExpr) / 2 = (qExpr + n) / 2 but with a guarantee that it'll not overflow
        then Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Add Width
rep)
          [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_U_Shr Width
rep)
            [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Sub Width
rep) [CmmActual
n', CmmActual
qExpr]
            , CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
1 Width
wordRep
            ]
          , CmmActual
qExpr
          ]
        else CmmActual
qExpr
      -- If we already divided by 2 in the add, remember to shift one bit less
      -- Hacker's Delight, Edition 2 Page 234: postShift > 0 if we needed an add, except if the divisor
      -- is 1, which we checked for above
      finalShift = if Bool
needsAdd then Integer
postShift' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 else Integer
postShift'

  -- apply the final postShift
  pure $! cmmMachOpFold platform (MO_U_Shr rep) [qExpr', CmmLit $ CmmInt finalShift wordRep]
  where
    resRep :: CmmType
resRep = Width -> CmmType
cmmBits Width
rep
    wordRep :: Width
wordRep = Platform -> Width
wordWidth Platform
platform
    (Integer
preShift, Integer
magic, Bool
needsAdd, Integer
postShift) =
        let withPre :: (Integer, Integer, Bool, Integer)
withPre = Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)
divisionMagicU Width
rep Bool
True  Integer
divisor
            noPre :: (Integer, Integer, Bool, Integer)
noPre   = Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)
divisionMagicU Width
rep Bool
False Integer
divisor
        in case ((Integer, Integer, Bool, Integer)
withPre, (Integer, Integer, Bool, Integer)
noPre) of
          -- Use whatever does not cause us to take the expensive case
          ((Integer
_, Integer
_, Bool
False, Integer
_), (Integer
_, Integer
_, Bool
True, Integer
_)) -> (Integer, Integer, Bool, Integer)
withPre
          -- If we cannot avoid the expensive case, don't bother with the pre shift
          ((Integer, Integer, Bool, Integer),
 (Integer, Integer, Bool, Integer))
_ -> (Integer, Integer, Bool, Integer)
noPre
    -- generate the multiply with the magic number
    mul2 :: CmmActual -> Opt (Integer, CmmActual)
mul2 CmmActual
n
      | Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform Bool -> Bool -> Bool
|| (CmmConfig -> Bool
cmmAllowMul2 CmmConfig
cfg Bool -> Bool -> Bool
&& Bool
needsAdd) = do
        (r1, r2) <- (,) (Unique -> Unique -> (Unique, Unique))
-> Opt Unique -> Opt (Unique -> (Unique, Unique))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM Opt (Unique -> (Unique, Unique))
-> Opt Unique -> Opt (Unique, Unique)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Opt Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
        let rg1    = Unique -> CmmType -> CmmFormal
LocalReg Unique
r1 CmmType
resRep
            resReg = Unique -> CmmType -> CmmFormal
LocalReg Unique
r2 CmmType
resRep
        res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep])
        pure (postShift, res)
      | Bool
otherwise = do
        (Integer, CmmActual) -> Opt (Integer, CmmActual)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Bool
needsAdd then Integer
postShift else Integer
0, CmmActual
res)
          where
            wordRep :: Width
wordRep = Platform -> Width
wordWidth Platform
platform
            -- (n * magic) >> widthInBits + (if sign == 0 then shift else 0) -- With conversion in between to not overflow
            res :: CmmActual
res = Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> Width -> MachOp
MO_UU_Conv Width
wordRep Width
rep)
              [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_U_Shr Width
wordRep)
                [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Mul Width
wordRep)
                  [ Platform -> MachOp -> [CmmActual] -> CmmActual
cmmMachOpFold Platform
platform (Width -> Width -> MachOp
MO_UU_Conv Width
rep Width
wordRep) [CmmActual
n]
                  , CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
magic Width
wordRep
                  ]
                -- Check if we need to generate an add later. If not we can combine this with the postshift
                , CmmLit -> CmmActual
CmmLit (CmmLit -> CmmActual) -> CmmLit -> CmmActual
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt ((if Bool
needsAdd then Integer
0 else Integer
postShift) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
rep)) Width
wordRep
                ]
              ]

-- See hackers delight for how and why this works (chapter in note [Division by constants])
-- The preshift isn't described there, but the idea is:
-- If a divisor d has n trailing zeros, then d is a multiple of 2^n. Since we want to divide x by d
-- we can also calculate (x / 2^n) / (d / 2^n) which may then not require an extra addition.
--
-- The addition performs: quotient + dividend, but we need to avoid overflows, so we actually need to
-- calculate: quotient + (dividend - quotient) / 2 = (quotient + dividend) / 2
-- Thus if the preshift can avoid all of this, we have 1 operation in place of 3.
--
-- The decision to use the preshift is made somewhere else, here we only report if the addition is needed
divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)
divisionMagicU :: Width -> Bool -> Integer -> (Integer, Integer, Bool, Integer)
divisionMagicU Width
rep Bool
doPreShift Integer
divisor = (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
zeros, Integer
magic, Bool
needsAdd, Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wSz)
  where
    wSz :: Int
wSz = Width -> Int
widthInBits Width
rep
    zeros :: Int
zeros = if Bool
doPreShift then Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger @Word64 Integer
divisor else Int
0
    d :: Integer
d = Integer
divisor Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
zeros
    ones :: Integer
ones = ((Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
wSz) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
zeros
    nc :: Integer
nc = Integer
ones Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem (Integer
ones Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
d) Integer
d
    go :: Int -> Int
go Int
p'
      | Integer
twoP Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
nc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem (Integer
twoP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer
d) = Int
p'
      | Bool
otherwise = Int -> Int
go (Int
p' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      where twoP :: Integer
twoP = Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p'
    p :: Int
p = Int -> Int
go Int
wSz
    m :: Integer
m = (Integer
twoP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem (Integer
twoP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer
d) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
d
      where twoP :: Integer
twoP = Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p
    needsAdd :: Bool
needsAdd = Integer
d Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wSz)
    magic :: Integer
magic = if Bool
needsAdd then Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
ones Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) else Integer
m

-- -----------------------------------------------------------------------------
-- Opt monad

newtype Opt a = OptI { forall a.
Opt a
-> CmmConfig
-> [CmmNode 'Open 'Open]
-> UniqDSM ([CmmNode 'Open 'Open], a)
runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) }

-- | Pattern synonym for 'Opt', as described in Note [The one-shot state
-- monad trick].
pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a
pattern $mOpt :: forall {r} {a}.
Opt a
-> ((CmmConfig
     -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
    -> r)
-> ((# #) -> r)
-> r
$bOpt :: forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt f <- OptI f
  where Opt CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
f = (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
OptI ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
 -> Opt a)
-> ((CmmConfig
     -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
    -> CmmConfig
    -> [CmmNode 'Open 'Open]
    -> UniqDSM ([CmmNode 'Open 'Open], a))
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> CmmConfig
-> [CmmNode 'Open 'Open]
-> UniqDSM ([CmmNode 'Open 'Open], a)
forall a b. (a -> b) -> a -> b
oneShot ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
 -> Opt a)
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
forall a b. (a -> b) -> a -> b
$ \CmmConfig
cfg -> ([CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
forall a b. (a -> b) -> a -> b
oneShot (([CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> ([CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> [CmmNode 'Open 'Open]
-> UniqDSM ([CmmNode 'Open 'Open], a)
forall a b. (a -> b) -> a -> b
$ \[CmmNode 'Open 'Open]
out -> CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
f CmmConfig
cfg [CmmNode 'Open 'Open]
out
{-# COMPLETE Opt #-}

runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a)
runOpt :: forall a. CmmConfig -> Opt a -> UniqDSM ([CmmNode 'Open 'Open], a)
runOpt CmmConfig
cf (Opt CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g) = CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g CmmConfig
cf []

getConfig :: Opt CmmConfig
getConfig :: Opt CmmConfig
getConfig = (CmmConfig
 -> [CmmNode 'Open 'Open]
 -> UniqDSM ([CmmNode 'Open 'Open], CmmConfig))
-> Opt CmmConfig
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open]
  -> UniqDSM ([CmmNode 'Open 'Open], CmmConfig))
 -> Opt CmmConfig)
-> (CmmConfig
    -> [CmmNode 'Open 'Open]
    -> UniqDSM ([CmmNode 'Open 'Open], CmmConfig))
-> Opt CmmConfig
forall a b. (a -> b) -> a -> b
$ \CmmConfig
cf [CmmNode 'Open 'Open]
xs -> ([CmmNode 'Open 'Open], CmmConfig)
-> UniqDSM ([CmmNode 'Open 'Open], CmmConfig)
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CmmNode 'Open 'Open]
xs, CmmConfig
cf)

instance Functor Opt where
  fmap :: forall a b. (a -> b) -> Opt a -> Opt b
fmap a -> b
f (Opt CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g) = (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
-> Opt b
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
 -> Opt b)
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
-> Opt b
forall a b. (a -> b) -> a -> b
$ \CmmConfig
cf [CmmNode 'Open 'Open]
xs -> (([CmmNode 'Open 'Open], a) -> ([CmmNode 'Open 'Open], b))
-> UniqDSM ([CmmNode 'Open 'Open], a)
-> UniqDSM ([CmmNode 'Open 'Open], b)
forall a b. (a -> b) -> UniqDSM a -> UniqDSM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b)
-> ([CmmNode 'Open 'Open], a) -> ([CmmNode 'Open 'Open], b)
forall a b.
(a -> b)
-> ([CmmNode 'Open 'Open], a) -> ([CmmNode 'Open 'Open], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g CmmConfig
cf [CmmNode 'Open 'Open]
xs)

instance Applicative Opt where
  pure :: forall a. a -> Opt a
pure a
a = (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
 -> Opt a)
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
forall a b. (a -> b) -> a -> b
$ \CmmConfig
_ [CmmNode 'Open 'Open]
xs -> ([CmmNode 'Open 'Open], a) -> UniqDSM ([CmmNode 'Open 'Open], a)
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CmmNode 'Open 'Open]
xs, a
a)
  Opt (a -> b)
ff <*> :: forall a b. Opt (a -> b) -> Opt a -> Opt b
<*> Opt a
fa = do
    f <- Opt (a -> b)
ff
    f <$> fa

instance Monad Opt where
  Opt CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g >>= :: forall a b. Opt a -> (a -> Opt b) -> Opt b
>>= a -> Opt b
f = (CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
-> Opt b
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
 -> Opt b)
-> (CmmConfig
    -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], b))
-> Opt b
forall a b. (a -> b) -> a -> b
$ \CmmConfig
cf [CmmNode 'Open 'Open]
xs -> do
    (ys, a) <- CmmConfig
-> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a)
g CmmConfig
cf [CmmNode 'Open 'Open]
xs
    runOptI (f a) cf ys

instance MonadGetUnique Opt where
  getUniqueM :: Opt Unique
getUniqueM = (CmmConfig
 -> [CmmNode 'Open 'Open]
 -> UniqDSM ([CmmNode 'Open 'Open], Unique))
-> Opt Unique
forall a.
(CmmConfig
 -> [CmmNode 'Open 'Open] -> UniqDSM ([CmmNode 'Open 'Open], a))
-> Opt a
Opt ((CmmConfig
  -> [CmmNode 'Open 'Open]
  -> UniqDSM ([CmmNode 'Open 'Open], Unique))
 -> Opt Unique)
-> (CmmConfig
    -> [CmmNode 'Open 'Open]
    -> UniqDSM ([CmmNode 'Open 'Open], Unique))
-> Opt Unique
forall a b. (a -> b) -> a -> b
$ \CmmConfig
_ [CmmNode 'Open 'Open]
xs -> ([CmmNode 'Open 'Open]
xs,) (Unique -> ([CmmNode 'Open 'Open], Unique))
-> UniqDSM Unique -> UniqDSM ([CmmNode 'Open 'Open], Unique)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqDSM Unique
getUniqueDSM

mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget
mapForeignTargetOpt :: (CmmActual -> Opt CmmActual) -> ForeignTarget -> Opt ForeignTarget
mapForeignTargetOpt CmmActual -> Opt CmmActual
exp   (ForeignTarget CmmActual
e ForeignConvention
c) = (CmmActual -> ForeignConvention -> ForeignTarget)
-> ForeignConvention -> CmmActual -> ForeignTarget
forall a b c. (a -> b -> c) -> b -> a -> c
flip CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget ForeignConvention
c (CmmActual -> ForeignTarget) -> Opt CmmActual -> Opt ForeignTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmActual -> Opt CmmActual
exp CmmActual
e
mapForeignTargetOpt CmmActual -> Opt CmmActual
_   m :: ForeignTarget
m@(PrimTarget CallishMachOp
_)      = ForeignTarget -> Opt ForeignTarget
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignTarget
m

wrapRecExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmExpr -> Opt CmmExpr
wrapRecExpOpt :: (CmmActual -> Opt CmmActual) -> CmmActual -> Opt CmmActual
wrapRecExpOpt CmmActual -> Opt CmmActual
f (CmmMachOp MachOp
op [CmmActual]
es)       = (CmmActual -> Opt CmmActual) -> [CmmActual] -> Opt [CmmActual]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((CmmActual -> Opt CmmActual) -> CmmActual -> Opt CmmActual
wrapRecExpOpt CmmActual -> Opt CmmActual
f) [CmmActual]
es Opt [CmmActual] -> ([CmmActual] -> Opt CmmActual) -> Opt CmmActual
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CmmActual -> Opt CmmActual
f (CmmActual -> Opt CmmActual)
-> ([CmmActual] -> CmmActual) -> [CmmActual] -> Opt CmmActual
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
op
wrapRecExpOpt CmmActual -> Opt CmmActual
f (CmmLoad CmmActual
addr CmmType
ty AlignmentSpec
align) = (CmmActual -> Opt CmmActual) -> CmmActual -> Opt CmmActual
wrapRecExpOpt CmmActual -> Opt CmmActual
f CmmActual
addr Opt CmmActual -> (CmmActual -> Opt CmmActual) -> Opt CmmActual
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CmmActual
newAddr -> CmmActual -> Opt CmmActual
f (CmmActual -> CmmType -> AlignmentSpec -> CmmActual
CmmLoad CmmActual
newAddr CmmType
ty AlignmentSpec
align)
wrapRecExpOpt CmmActual -> Opt CmmActual
f CmmActual
e                       = CmmActual -> Opt CmmActual
f CmmActual
e

mapExpOpt :: (CmmExpr -> Opt CmmExpr) -> CmmNode e x -> Opt (CmmNode e x)
mapExpOpt :: forall (e :: Extensibility) (x :: Extensibility).
(CmmActual -> Opt CmmActual) -> CmmNode e x -> Opt (CmmNode e x)
mapExpOpt CmmActual -> Opt CmmActual
_ f :: CmmNode e x
f@(CmmEntry{})                          = CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmNode e x
f
mapExpOpt CmmActual -> Opt CmmActual
_ m :: CmmNode e x
m@(CmmComment FastString
_)                        = CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmNode e x
m
mapExpOpt CmmActual -> Opt CmmActual
_ m :: CmmNode e x
m@(CmmTick CmmTickish
_)                           = CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmNode e x
m
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmUnwind [(GlobalReg, Maybe CmmActual)]
regs)                      = [(GlobalReg, Maybe CmmActual)] -> CmmNode e x
[(GlobalReg, Maybe CmmActual)] -> CmmNode 'Open 'Open
CmmUnwind ([(GlobalReg, Maybe CmmActual)] -> CmmNode e x)
-> Opt [(GlobalReg, Maybe CmmActual)] -> Opt (CmmNode e x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((GlobalReg, Maybe CmmActual) -> Opt (GlobalReg, Maybe CmmActual))
-> [(GlobalReg, Maybe CmmActual)]
-> Opt [(GlobalReg, Maybe CmmActual)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Maybe CmmActual -> Opt (Maybe CmmActual))
-> (GlobalReg, Maybe CmmActual) -> Opt (GlobalReg, Maybe CmmActual)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (GlobalReg, a) -> f (GlobalReg, b)
traverse ((CmmActual -> Opt CmmActual)
-> Maybe CmmActual -> Opt (Maybe CmmActual)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse CmmActual -> Opt CmmActual
f)) [(GlobalReg, Maybe CmmActual)]
regs
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmAssign CmmReg
r CmmActual
e)                       = CmmReg -> CmmActual -> CmmNode 'Open 'Open
CmmAssign CmmReg
r (CmmActual -> CmmNode e x) -> Opt CmmActual -> Opt (CmmNode e x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmActual -> Opt CmmActual
f CmmActual
e
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmStore CmmActual
addr CmmActual
e AlignmentSpec
align)               = CmmActual -> CmmActual -> AlignmentSpec -> CmmNode e x
CmmActual -> CmmActual -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore (CmmActual -> CmmActual -> AlignmentSpec -> CmmNode e x)
-> Opt CmmActual -> Opt (CmmActual -> AlignmentSpec -> CmmNode e x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmActual -> Opt CmmActual
f CmmActual
addr Opt (CmmActual -> AlignmentSpec -> CmmNode e x)
-> Opt CmmActual -> Opt (AlignmentSpec -> CmmNode e x)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CmmActual -> Opt CmmActual
f CmmActual
e Opt (AlignmentSpec -> CmmNode e x)
-> Opt AlignmentSpec -> Opt (CmmNode e x)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AlignmentSpec -> Opt AlignmentSpec
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AlignmentSpec
align
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmActual]
as)      = ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode e x
ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall (ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode e x)
-> Opt ForeignTarget
-> Opt ([CmmFormal] -> [CmmActual] -> CmmNode e x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CmmActual -> Opt CmmActual) -> ForeignTarget -> Opt ForeignTarget
mapForeignTargetOpt CmmActual -> Opt CmmActual
f ForeignTarget
tgt Opt ([CmmFormal] -> [CmmActual] -> CmmNode e x)
-> Opt [CmmFormal] -> Opt ([CmmActual] -> CmmNode e x)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CmmFormal] -> Opt [CmmFormal]
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CmmFormal]
fs Opt ([CmmActual] -> CmmNode e x)
-> Opt [CmmActual] -> Opt (CmmNode e x)
forall a b. Opt (a -> b) -> Opt a -> Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CmmActual -> Opt CmmActual) -> [CmmActual] -> Opt [CmmActual]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CmmActual -> Opt CmmActual
f [CmmActual]
as
mapExpOpt CmmActual -> Opt CmmActual
_ l :: CmmNode e x
l@(CmmBranch Label
_)                         = CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmNode e x
l
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmCondBranch CmmActual
e Label
ti Label
fi Maybe Bool
l)             = CmmActual -> Opt CmmActual
f CmmActual
e Opt CmmActual
-> (CmmActual -> Opt (CmmNode e x)) -> Opt (CmmNode e x)
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CmmActual
newE -> CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmActual -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmActual
newE Label
ti Label
fi Maybe Bool
l)
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmSwitch CmmActual
e SwitchTargets
ids)                     = (CmmActual -> SwitchTargets -> CmmNode e x)
-> SwitchTargets -> CmmActual -> CmmNode e x
forall a b c. (a -> b -> c) -> b -> a -> c
flip CmmActual -> SwitchTargets -> CmmNode e x
CmmActual -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch SwitchTargets
ids (CmmActual -> CmmNode e x) -> Opt CmmActual -> Opt (CmmNode e x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmActual -> Opt CmmActual
f CmmActual
e
mapExpOpt CmmActual -> Opt CmmActual
f   n :: CmmNode e x
n@CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmActual
cml_target=CmmActual
tgt}            = CmmActual -> Opt CmmActual
f CmmActual
tgt Opt CmmActual
-> (CmmActual -> Opt (CmmNode e x)) -> Opt (CmmNode e x)
forall a b. Opt a -> (a -> Opt b) -> Opt b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CmmActual
newTgt -> CmmNode e x -> Opt (CmmNode e x)
forall a. a -> Opt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmNode e x
n{cml_target = newTgt}
mapExpOpt CmmActual -> Opt CmmActual
f   (CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmActual]
as Label
succ Int
ret_args Int
updfr Bool
intrbl)
                                                    = do
                                                      newTgt <- (CmmActual -> Opt CmmActual) -> ForeignTarget -> Opt ForeignTarget
mapForeignTargetOpt CmmActual -> Opt CmmActual
f ForeignTarget
tgt
                                                      newAs <- traverse f as
                                                      pure $ CmmForeignCall newTgt fs newAs succ ret_args updfr intrbl