{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}

-- CmmNode type for representation using Hoopl graphs.

module GHC.Cmm.Node (
     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
     UpdFrameOffset, Convention(..),
     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
     CmmReturnInfo(..),
     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,

     -- * Tick scopes
     CmmTickScope(..), isTickSubScope, combineTickScopes,
  ) where

import GHC.Prelude hiding (succ)

import GHC.Platform.Regs
import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Cmm.Switch
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Types.ForeignCall
import GHC.Utils.Outputable
import GHC.Runtime.Heap.Layout
import GHC.Types.Tickish (CmmTickish)
import qualified GHC.Types.Unique as U
import GHC.Types.Basic (FunctionOrData(..))

import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import Data.Foldable (toList)
import Data.Functor.Classes (liftCompare)
import Data.Maybe
import Data.List (tails,sortBy)
import GHC.Types.Unique (nonDetCmpUnique)
import GHC.Utils.Constants (debugIsOn)


------------------------
-- CmmNode

#define ULabel {-# UNPACK #-} !Label

data CmmNode e x where
  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O

  CmmComment :: FastString -> CmmNode O O

    -- Tick annotation, covering Cmm code in our tick scope. We only
    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
    -- See Note [CmmTick scoping details]
  CmmTick :: !CmmTickish -> CmmNode O O

    -- Unwind pseudo-instruction, encoding stack unwinding
    -- instructions for a debugger. This describes how to reconstruct
    -- the "old" value of a register if we want to navigate the stack
    -- up one frame. Having unwind information for @Sp@ will allow the
    -- debugger to "walk" the stack.
    --
    -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O

  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
    -- Assign to register

  CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O
    -- Assign to memory location.  Size is
    -- given by cmmExprType of the rhs.

  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
                                -- see Note [Foreign calls]
                                -- Like a "fat machine instruction"; can occur
                                -- in the middle of a block
      ForeignTarget ->          -- call target
      [CmmFormal] ->            -- zero or more results
      [CmmActual] ->            -- zero or more arguments
      CmmNode O O
      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
      -- See Note [Unsafe foreign calls clobber caller-save registers]
      --
      -- Invariant: the arguments and the ForeignTarget must not
      -- mention any registers for which GHC.Platform.callerSaves
      -- is True.  See Note [Register parameter passing].

  CmmBranch :: ULabel -> CmmNode O C
                                   -- Goto another block in the same procedure

  CmmCondBranch :: {                 -- conditional branch
      CmmNode 'Open 'Closed -> CmmExpr
cml_pred :: CmmExpr,
      CmmNode 'Open 'Closed -> Label
cml_true, CmmNode 'Open 'Closed -> Label
cml_false :: ULabel,
      CmmNode 'Open 'Closed -> Maybe Bool
cml_likely :: Maybe Bool       -- likely result of the conditional,
                                     -- if known
  } -> CmmNode O C

  CmmSwitch
    :: CmmExpr       -- Scrutinee, of some integral type
    -> SwitchTargets -- Cases. See Note [SwitchTargets]
    -> CmmNode O C

  CmmCall :: {                -- A native call or tail call
      CmmNode 'Open 'Closed -> CmmExpr
cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

      CmmNode 'Open 'Closed -> Maybe Label
cml_cont :: Maybe Label,
          -- Label of continuation (Nothing for return or tail call)
          --
          -- Note [Continuation BlockIds]
          -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          -- These BlockIds are called
          -- Continuation BlockIds, and are the only BlockIds that can
          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
          -- (CmmStackSlot (Young b) _).

      CmmNode 'Open 'Closed -> [GlobalRegUse]
cml_args_regs :: [GlobalRegUse],
          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
          -- to the call.  This is essential information for the
          -- native code generator's register allocator; without
          -- knowing which GlobalRegs are live it has to assume that
          -- they are all live.  This list should only include
          -- GlobalRegs that are mapped to real machine registers on
          -- the target platform.

      CmmNode 'Open 'Closed -> ByteOff
cml_args :: ByteOff,
          -- Byte offset, from the *old* end of the Area associated with
          -- the Label (if cml_cont = Nothing, then Old area), of
          -- youngest outgoing arg.  Set the stack pointer to this before
          -- transferring control.
          -- (NB: an update frame might also have been stored in the Old
          --      area, but it'll be in an older part than the args.)

      CmmNode 'Open 'Closed -> ByteOff
cml_ret_args :: ByteOff,
          -- For calls *only*, the byte offset for youngest returned value
          -- This is really needed at the *return* point rather than here
          -- at the call, but in practice it's convenient to record it here.

      CmmNode 'Open 'Closed -> ByteOff
cml_ret_off :: ByteOff
        -- For calls *only*, the byte offset of the base of the frame that
        -- must be described by the info table for the return point.
        -- The older words are an update frames, which have their own
        -- info-table and layout information

        -- From a liveness point of view, the stack words older than
        -- cml_ret_off are treated as live, even if the sequel of
        -- the call goes into a loop.
  } -> CmmNode O C

  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
                                -- Always the last node of a block
      CmmNode 'Open 'Closed -> ForeignTarget
tgt   :: ForeignTarget,   -- call target and convention
      CmmNode 'Open 'Closed -> [CmmFormal]
res   :: [CmmFormal],     -- zero or more results
      CmmNode 'Open 'Closed -> [CmmExpr]
args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
      CmmNode 'Open 'Closed -> Label
succ  :: ULabel,          -- Label of continuation
      CmmNode 'Open 'Closed -> ByteOff
ret_args :: ByteOff,      -- same as cml_ret_args
      CmmNode 'Open 'Closed -> ByteOff
ret_off :: ByteOff,       -- same as cml_ret_off
      CmmNode 'Open 'Closed -> Bool
intrbl:: Bool             -- whether or not the call is interruptible
  } -> CmmNode O C

instance OutputableP Platform (CmmNode e x) where
    pdoc :: Platform -> CmmNode e x -> SDoc
pdoc = Platform -> CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode

pprNode :: Platform -> CmmNode e x -> SDoc
pprNode :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode Platform
platform CmmNode e x
node = SDoc
pp_node SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_debug
  where
    pp_node :: SDoc
    pp_node :: SDoc
pp_node = case CmmNode e x
node of
      -- label:
      CmmEntry Label
id CmmTickScope
tscope ->
         ((SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressUniques ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
            Bool
True  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_lbl_"
            Bool
False -> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id
         )
         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
tscope)

      -- // text
      CmmComment FastString
s -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s

      -- //tick bla<...>
      CmmTick CmmTickish
t -> (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"//tick" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickish
t)

      -- unwind reg = expr;
      CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs ->
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unwind "
          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SDoc] -> SDoc
commafy (((GlobalReg, Maybe CmmExpr) -> SDoc)
-> [(GlobalReg, Maybe CmmExpr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(GlobalReg
r,Maybe CmmExpr
e) -> GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'=' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> Maybe CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe CmmExpr
e) [(GlobalReg, Maybe CmmExpr)]
regs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

      -- reg = expr;
      CmmAssign CmmReg
reg CmmExpr
expr -> CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

      -- rep[lv] = expr;
      CmmStore CmmExpr
lv CmmExpr
expr AlignmentSpec
align -> SDoc
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
align_mark SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
lv) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
          where
            align_mark :: SDoc
align_mark = case AlignmentSpec
align of
                           AlignmentSpec
Unaligned -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"^"
                           AlignmentSpec
NaturallyAligned -> SDoc
forall doc. IsOutput doc => doc
empty
            rep :: SDoc
rep = CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ( Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr )

      -- call "ccall" foo(x, y)[r1, r2];
      -- ToDo ppr volatile
      CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
results [CmmExpr]
args ->
          [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless ([CmmFormal] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmFormal]
results) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmFormal -> SDoc) -> [CmmFormal] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
results) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals,
                 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"call",
                 Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
target SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CmmExpr]
args) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi]

      -- goto label;
      CmmBranch Label
ident -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
ident SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

      -- if (expr) goto t; else goto f;
      CmmCondBranch CmmExpr
expr Label
t Label
f Maybe Bool
l ->
          [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"if"
               , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
               , case Maybe Bool
l of
                   Maybe Bool
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
                   Just Bool
b -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"likely:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b)
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto"
               , Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"else goto"
               , Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
f SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
               ]

      CmmSwitch CmmExpr
expr SwitchTargets
ids ->
          SDoc -> ByteOff -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"switch"
                     , SDoc
range
                     , if CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
expr
                       then Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr
                       else SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
                     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{"
                     ])
             ByteOff
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((NonEmpty Integer, Label) -> SDoc)
-> [(NonEmpty Integer, Label)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty Integer, Label) -> SDoc
forall {t :: * -> *} {a}.
(Foldable t, Functor t, Outputable a) =>
(t Integer, a) -> SDoc
ppCase [(NonEmpty Integer, Label)]
cases) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
def) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
forall doc. IsLine doc => doc
rbrace
          where
            ([(NonEmpty Integer, Label)]
cases, Maybe Label
mbdef) = SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label)
switchTargetsFallThrough SwitchTargets
ids
            ppCase :: (t Integer, a) -> SDoc
ppCase (t Integer
is,a
l) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                            [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case"
                            , [SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ t SDoc -> [SDoc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t SDoc -> [SDoc]) -> t SDoc -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (Integer -> SDoc) -> t Integer -> t SDoc
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer t Integer
is
                            , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": goto"
                            , a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
                            ]
            def :: SDoc
def | Just Label
l <- Maybe Label
mbdef = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                            [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default:"
                            , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi)
                            ]
                | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty

            range :: SDoc
range = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
lo, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..", Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
hi]
              where (Integer
lo,Integer
hi) = SwitchTargets -> (Integer, Integer)
switchTargetsRange SwitchTargets
ids

      CmmCall CmmExpr
tgt Maybe Label
k [GlobalRegUse]
regs ByteOff
out ByteOff
res ByteOff
updfr_off ->
          [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"call", SDoc
forall doc. IsLine doc => doc
space
               , CmmExpr -> SDoc
pprFun CmmExpr
tgt, SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([GlobalRegUse] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [GlobalRegUse]
regs), SDoc
forall doc. IsLine doc => doc
space
               , SDoc
returns SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
out SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"res: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
res SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"upd: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
updfr_off
               , SDoc
forall doc. IsLine doc => doc
semi ]
          where pprFun :: CmmExpr -> SDoc
pprFun f :: CmmExpr
f@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f
                pprFun CmmExpr
f = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f)

                returns :: SDoc
returns
                  | Just Label
r <- Maybe Label
k = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"returns to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                  | Bool
otherwise   = SDoc
forall doc. IsOutput doc => doc
empty

      CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
t, res :: CmmNode 'Open 'Closed -> [CmmFormal]
res=[CmmFormal]
rs, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
as, succ :: CmmNode 'Open 'Closed -> Label
succ=Label
s, ret_args :: CmmNode 'Open 'Closed -> ByteOff
ret_args=ByteOff
a, ret_off :: CmmNode 'Open 'Closed -> ByteOff
ret_off=ByteOff
u, intrbl :: CmmNode 'Open 'Closed -> Bool
intrbl=Bool
i} ->
          [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
i then [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"interruptible", SDoc
forall doc. IsLine doc => doc
space] else [] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
               [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"foreign call", SDoc
forall doc. IsLine doc => doc
space
               , Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
t, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(...)", SDoc
forall doc. IsLine doc => doc
space
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"returns to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
s
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> [CmmExpr] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CmmExpr]
as)
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ress:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([CmmFormal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
rs)
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ret_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
a
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ret_off:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
u
               , SDoc
forall doc. IsLine doc => doc
semi ]

    pp_debug :: SDoc
    pp_debug :: SDoc
pp_debug =
      if Bool -> Bool
not Bool
debugIsOn then SDoc
forall doc. IsOutput doc => doc
empty
      else case CmmNode e x
node of
             CmmEntry {}             -> SDoc
forall doc. IsOutput doc => doc
empty -- Looks terrible with text "  // CmmEntry"
             CmmComment {}           -> SDoc
forall doc. IsOutput doc => doc
empty -- Looks also terrible with text "  // CmmComment"
             CmmTick {}              -> SDoc
forall doc. IsOutput doc => doc
empty
             CmmUnwind {}            -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmUnwind"
             CmmAssign {}            -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmAssign"
             CmmStore {}             -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmStore"
             CmmUnsafeForeignCall {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmUnsafeForeignCall"
             CmmBranch {}            -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmBranch"
             CmmCondBranch {}        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmCondBranch"
             CmmSwitch {}            -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmSwitch"
             CmmCall {}              -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmCall"
             CmmForeignCall {}       -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  // CmmForeignCall"

    commafy :: [SDoc] -> SDoc
    commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
xs

instance OutputableP Platform (Block CmmNode C C) where
    pdoc :: Platform -> Block CmmNode 'Closed 'Closed -> SDoc
pdoc = Platform -> Block CmmNode 'Closed 'Closed -> SDoc
Platform
-> Block CmmNode 'Closed 'Closed -> IndexedCO 'Closed SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode C O) where
    pdoc :: Platform -> Block CmmNode 'Closed 'Open -> SDoc
pdoc = Platform -> Block CmmNode 'Closed 'Open -> SDoc
Platform
-> Block CmmNode 'Closed 'Open -> IndexedCO 'Closed SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O C) where
    pdoc :: Platform -> Block CmmNode 'Open 'Closed -> SDoc
pdoc = Platform -> Block CmmNode 'Open 'Closed -> SDoc
Platform
-> Block CmmNode 'Open 'Closed -> IndexedCO 'Open SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O O) where
    pdoc :: Platform -> Block CmmNode 'Open 'Open -> SDoc
pdoc = Platform -> Block CmmNode 'Open 'Open -> SDoc
Platform -> Block CmmNode 'Open 'Open -> IndexedCO 'Open SDoc SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock

instance OutputableP Platform (Graph CmmNode e x) where
    pdoc :: Platform -> Graph CmmNode e x -> SDoc
pdoc = Platform -> Graph CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph

pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock :: forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock Platform
platform Block CmmNode e x
block
    = (CmmNode 'Closed 'Open -> SDoc -> SDoc,
 CmmNode 'Open 'Open -> SDoc -> SDoc,
 CmmNode 'Open 'Closed -> SDoc -> SDoc)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block CmmNode e x -> IndexedCO x SDoc SDoc -> IndexedCO e SDoc SDoc
forall (n :: Extensibility -> Extensibility -> *) a b c.
(n 'Closed 'Open -> b -> c, n 'Open 'Open -> b -> b,
 n 'Open 'Closed -> a -> b)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO x a b -> IndexedCO e c b
foldBlockNodesB3 ( SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Closed 'Open -> SDoc)
-> CmmNode 'Closed 'Open
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Closed 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       , SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Open 'Open -> SDoc)
-> CmmNode 'Open 'Open
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc)
-> (CmmNode 'Open 'Open -> SDoc) -> CmmNode 'Open 'Open -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Open 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       , SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode 'Open 'Closed -> SDoc)
-> CmmNode 'Open 'Closed
-> SDoc
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc)
-> (CmmNode 'Open 'Closed -> SDoc) -> CmmNode 'Open 'Closed -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode 'Open 'Closed -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       )
                       Block CmmNode e x
block
                       SDoc
IndexedCO x SDoc SDoc
forall doc. IsOutput doc => doc
empty

pprGraph :: Platform -> Graph CmmNode e x -> SDoc
pprGraph :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph Platform
platform = \case
   Graph CmmNode e x
GNil                  -> SDoc
forall doc. IsOutput doc => doc
empty
   GUnit Block CmmNode 'Open 'Open
block           -> Platform -> Block CmmNode 'Open 'Open -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode 'Open 'Open
block
   GMany MaybeO e (Block CmmNode 'Open 'Closed)
entry Body' LabelMap Block CmmNode
body MaybeO x (Block CmmNode 'Closed 'Open)
exit ->
         String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{"
      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ByteOff -> SDoc -> SDoc
nest ByteOff
2 (MaybeO e (Block CmmNode 'Open 'Closed) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO e (Block CmmNode 'Open 'Closed)
entry SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Block CmmNode 'Closed 'Closed -> SDoc)
-> [Block CmmNode 'Closed 'Closed] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Block CmmNode 'Closed 'Closed -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) ([Block CmmNode 'Closed 'Closed] -> [SDoc])
-> [Block CmmNode 'Closed 'Closed] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Body' LabelMap Block CmmNode -> [Block CmmNode 'Closed 'Closed]
forall (n :: Extensibility -> Extensibility -> *).
Body LabelMap n -> [Block n 'Closed 'Closed]
bodyToBlockList Body' LabelMap Block CmmNode
body) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ MaybeO x (Block CmmNode 'Closed 'Open) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO x (Block CmmNode 'Closed 'Open)
exit)
      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}"
      where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
                      => MaybeO ex (Block CmmNode e x) -> SDoc
            pprMaybeO :: forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO ex (Block CmmNode e x)
NothingO = SDoc
forall doc. IsOutput doc => doc
empty
            pprMaybeO (JustO Block CmmNode e x
block) = Platform -> Block CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode e x
block

{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
a CmmForeignCall call is used for *safe* foreign calls.

Unsafe ones are mostly easy: think of them as a "fat machine
instruction".  In particular, they do *not* kill all live registers,
just the registers they return to (there was a bit of code in GHC that
conservatively assumed otherwise.)  However, see [Register parameter passing].

Safe ones are trickier.  A safe foreign call
     r = f(x)
ultimately expands to
     push "return address"      -- Never used to return to;
                                -- just points an info table
     save registers into TSO
     call suspendThread
     r = f(x)                   -- Make the call
     call resumeThread
     restore registers
     pop "return address"
We cannot "lower" a safe foreign call to this sequence of Cmms, because
after we've saved Sp all the Cmm optimiser's assumptions are broken.

Note that a safe foreign call needs an info table.

So Safe Foreign Calls must remain as last nodes until the stack is
made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above
sequence.
-}

{- Note [Unsafe foreign calls clobber caller-save registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A foreign call is defined to clobber any GlobalRegs that are mapped to
caller-saves machine registers (according to the prevailing C ABI).
GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.

This is a design choice that makes it easier to generate code later.
We could instead choose to say that foreign calls do *not* clobber
caller-saves regs, but then we would have to figure out which regs
were live across the call later and insert some saves/restores.

Furthermore when we generate code we never have any GlobalRegs live
across a call, because they are always copied-in to LocalRegs and
copied-out again before making a call/jump.  So all we have to do is
avoid any code motion that would make a caller-saves GlobalReg live
across a foreign call during subsequent optimisations.
-}

{- Note [Register parameter passing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On certain architectures, some registers are utilized for parameter
passing in the C calling convention.  For example, in x86-64 Linux
convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
argument passing.  These are registers R3-R6, which our generated
code may also be using; as a result, it's necessary to save these
values before doing a foreign call.  This is done during initial
code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.

However, one result of doing this is that the contents of these registers may
mysteriously change if referenced inside the arguments.  This is dangerous, so
you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink
currently.  We should fix this!
-}

---------------------------------------------
-- Eq instance of CmmNode

deriving instance Eq (CmmNode e x)

----------------------------------------------
-- Hoopl instances of CmmNode

instance NonLocal CmmNode where
  entryLabel :: forall (x :: Extensibility). CmmNode 'Closed x -> Label
entryLabel (CmmEntry Label
l CmmTickScope
_) = Label
l

  successors :: forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
successors (CmmBranch Label
l) = [Label
l]
  successors (CmmCondBranch {cml_true :: CmmNode 'Open 'Closed -> Label
cml_true=Label
t, cml_false :: CmmNode 'Open 'Closed -> Label
cml_false=Label
f}) = [Label
f, Label
t] -- meets layout constraint
  successors (CmmSwitch CmmExpr
_ SwitchTargets
ids) = SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids
  successors (CmmCall {cml_cont :: CmmNode 'Open 'Closed -> Maybe Label
cml_cont=Maybe Label
l}) = Maybe Label -> [Label]
forall a. Maybe a -> [a]
maybeToList Maybe Label
l
  successors (CmmForeignCall {succ :: CmmNode 'Open 'Closed -> Label
succ=Label
l}) = [Label
l]


--------------------------------------------------
-- Various helper types

type CmmActual = CmmExpr
type CmmFormal = LocalReg

type UpdFrameOffset = ByteOff

-- | A convention maps a list of values (function arguments or return
-- values) to registers or stack locations.
data Convention
  = NativeDirectCall
       -- ^ top-level Haskell functions use @NativeDirectCall@, which
       -- maps arguments to registers starting with R2, according to
       -- how many registers are available on the platform.  This
       -- convention ignores R1, because for a top-level function call
       -- the function closure is implicit, and doesn't need to be passed.
  | NativeNodeCall
       -- ^ non-top-level Haskell functions, which pass the address of
       -- the function closure in R1 (regardless of whether R1 is a
       -- real register or not), and the rest of the arguments in
       -- registers or on the stack.
  | NativeReturn
       -- ^ a native return.  The convention for returns depends on
       -- how many values are returned: for just one value returned,
       -- the appropriate register is used (R1, F1, etc.). regardless
       -- of whether it is a real register or not.  For multiple
       -- values returned, they are mapped to registers or the stack.
  | Slow
       -- ^ Slow entry points: all args pushed on the stack
  | GC
       -- ^ Entry to the garbage collector: uses the node reg!
       -- (TODO: I don't think we need this --SDM)
  deriving( Convention -> Convention -> Bool
(Convention -> Convention -> Bool)
-> (Convention -> Convention -> Bool) -> Eq Convention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Convention -> Convention -> Bool
== :: Convention -> Convention -> Bool
$c/= :: Convention -> Convention -> Bool
/= :: Convention -> Convention -> Bool
Eq )

data ForeignConvention
  = ForeignConvention
        CCallConv               -- Which foreign-call convention
        [ForeignHint]           -- Extra info about the args
        [ForeignHint]           -- Extra info about the result
        CmmReturnInfo
  deriving ForeignConvention -> ForeignConvention -> Bool
(ForeignConvention -> ForeignConvention -> Bool)
-> (ForeignConvention -> ForeignConvention -> Bool)
-> Eq ForeignConvention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForeignConvention -> ForeignConvention -> Bool
== :: ForeignConvention -> ForeignConvention -> Bool
$c/= :: ForeignConvention -> ForeignConvention -> Bool
/= :: ForeignConvention -> ForeignConvention -> Bool
Eq

instance Outputable ForeignConvention where
    ppr :: ForeignConvention -> SDoc
ppr = ForeignConvention -> SDoc
pprForeignConvention

pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention CCallConv
c [ForeignHint]
args [ForeignHint]
res CmmReturnInfo
ret) =
    SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (CCallConv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CCallConv
c) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg hints: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" result hints: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
res SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmReturnInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReturnInfo
ret

data CmmReturnInfo
  = CmmMayReturn
  | CmmNeverReturns
  deriving ( CmmReturnInfo -> CmmReturnInfo -> Bool
(CmmReturnInfo -> CmmReturnInfo -> Bool)
-> (CmmReturnInfo -> CmmReturnInfo -> Bool) -> Eq CmmReturnInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CmmReturnInfo -> CmmReturnInfo -> Bool
== :: CmmReturnInfo -> CmmReturnInfo -> Bool
$c/= :: CmmReturnInfo -> CmmReturnInfo -> Bool
/= :: CmmReturnInfo -> CmmReturnInfo -> Bool
Eq )

instance Outputable CmmReturnInfo where
    ppr :: CmmReturnInfo -> SDoc
ppr = CmmReturnInfo -> SDoc
pprReturnInfo

pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo CmmReturnInfo
CmmMayReturn = SDoc
forall doc. IsOutput doc => doc
empty
pprReturnInfo CmmReturnInfo
CmmNeverReturns = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"never returns"

data ForeignTarget        -- The target of a foreign call
  = ForeignTarget                -- A foreign procedure
        CmmExpr                  -- Its address
        ForeignConvention        -- Its calling convention
  | PrimTarget            -- A possibly-side-effecting machine operation
        CallishMachOp            -- Which one
  deriving ForeignTarget -> ForeignTarget -> Bool
(ForeignTarget -> ForeignTarget -> Bool)
-> (ForeignTarget -> ForeignTarget -> Bool) -> Eq ForeignTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForeignTarget -> ForeignTarget -> Bool
== :: ForeignTarget -> ForeignTarget -> Bool
$c/= :: ForeignTarget -> ForeignTarget -> Bool
/= :: ForeignTarget -> ForeignTarget -> Bool
Eq

instance OutputableP Platform ForeignTarget where
    pdoc :: Platform -> ForeignTarget -> SDoc
pdoc = Platform -> ForeignTarget -> SDoc
pprForeignTarget

pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget Platform
platform (ForeignTarget CmmExpr
fn ForeignConvention
c) =
    ForeignConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignConvention
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmExpr -> SDoc
ppr_target CmmExpr
fn
  where
    ppr_target :: CmmExpr -> SDoc
    ppr_target :: CmmExpr -> SDoc
ppr_target t :: CmmExpr
t@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
t
    ppr_target CmmExpr
fn'          = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fn')
pprForeignTarget Platform
platform (PrimTarget CallishMachOp
op)
 -- HACK: We're just using a ForeignLabel to get this printed, the label
 --       might not really be foreign.
 = Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
               (FastString -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel
                          (String -> FastString
mkFastString (CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
op))
                          ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction)

instance Outputable Convention where
  ppr :: Convention -> SDoc
ppr = Convention -> SDoc
pprConvention

pprConvention :: Convention -> SDoc
pprConvention :: Convention -> SDoc
pprConvention (NativeNodeCall   {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-node-call-convention>"
pprConvention (NativeDirectCall {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-direct-call-convention>"
pprConvention (NativeReturn {})     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<native-ret-convention>"
pprConvention  Convention
Slow                 = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<slow-convention>"
pprConvention  Convention
GC                   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<gc-convention>"


foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
  = ( [ForeignHint]
res_hints [ForeignHint] -> [ForeignHint] -> [ForeignHint]
forall a. [a] -> [a] -> [a]
++ ForeignHint -> [ForeignHint]
forall a. a -> [a]
repeat ForeignHint
NoHint
    , [ForeignHint]
arg_hints [ForeignHint] -> [ForeignHint] -> [ForeignHint]
forall a. [a] -> [a] -> [a]
++ ForeignHint -> [ForeignHint]
forall a. a -> [a]
repeat ForeignHint
NoHint )
  where
    ([ForeignHint]
res_hints, [ForeignHint]
arg_hints) =
       case ForeignTarget
target of
          PrimTarget CallishMachOp
op -> CallishMachOp -> ([ForeignHint], [ForeignHint])
callishMachOpHints CallishMachOp
op
          ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
_ [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
_) ->
             ([ForeignHint]
res_hints, [ForeignHint]
arg_hints)

--------------------------------------------------
-- Instances of register and slot users / definers

instance UserOfRegs LocalReg (CmmNode e x) where
  {-# INLINEABLE foldRegsUsed #-}
  foldRegsUsed :: forall b.
Platform -> (b -> CmmFormal -> b) -> b -> CmmNode e x -> b
foldRegsUsed Platform
platform b -> CmmFormal -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
    CmmAssign CmmReg
_ CmmExpr
expr -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
    CmmStore CmmExpr
addr CmmExpr
rval AlignmentSpec
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
addr) CmmExpr
rval
    CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
args -> (b -> CmmFormal -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z ForeignTarget
t) [CmmExpr]
args
    CmmCondBranch CmmExpr
expr Label
_ Label
_ Maybe Bool
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
    CmmSwitch CmmExpr
expr SwitchTargets
_ -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
expr
    CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt} -> (b -> CmmFormal -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmExpr
tgt
    CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args} -> (b -> CmmFormal -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f ((b -> CmmFormal -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z ForeignTarget
tgt) [CmmExpr]
args
    CmmNode e x
_ -> b
z
    where fold :: forall a b. UserOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold :: forall a b.
UserOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z a
n = Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall b. Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> CmmFormal -> b
f b
z a
n

instance UserOfRegs GlobalRegUse (CmmNode e x) where
  {-# INLINEABLE foldRegsUsed #-}
  foldRegsUsed :: forall b.
Platform -> (b -> GlobalRegUse -> b) -> b -> CmmNode e x -> b
foldRegsUsed Platform
platform b -> GlobalRegUse -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
    CmmAssign CmmReg
_ CmmExpr
expr -> (b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z CmmExpr
expr
    CmmStore CmmExpr
addr CmmExpr
rval AlignmentSpec
_ -> (b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f ((b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z CmmExpr
addr) CmmExpr
rval
    CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
args -> (b -> GlobalRegUse -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f ((b -> GlobalRegUse -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z ForeignTarget
t) [CmmExpr]
args
    CmmCondBranch CmmExpr
expr Label
_ Label
_ Maybe Bool
_ -> (b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z CmmExpr
expr
    CmmSwitch CmmExpr
expr SwitchTargets
_ -> (b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z CmmExpr
expr
    CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt, cml_args_regs :: CmmNode 'Open 'Closed -> [GlobalRegUse]
cml_args_regs=[GlobalRegUse]
args} -> (b -> GlobalRegUse -> b) -> b -> CmmExpr -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f ((b -> GlobalRegUse -> b) -> b -> [GlobalRegUse] -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z [GlobalRegUse]
args) CmmExpr
tgt
    CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args} -> (b -> GlobalRegUse -> b) -> b -> [CmmExpr] -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f ((b -> GlobalRegUse -> b) -> b -> ForeignTarget -> b
forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z ForeignTarget
tgt) [CmmExpr]
args
    CmmNode e x
_ -> b
z
    where fold :: forall a b.  UserOfRegs GlobalRegUse a
               => (b -> GlobalRegUse -> b) -> b -> a -> b
          fold :: forall a b.
UserOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z a
n = Platform -> (b -> GlobalRegUse -> b) -> b -> a -> b
forall b. Platform -> (b -> GlobalRegUse -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> GlobalRegUse -> b
f b
z a
n
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
  -- The (Ord r) in the context is necessary here
  -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
  {-# INLINEABLE foldRegsUsed #-}
  foldRegsUsed :: forall b. Platform -> (b -> r -> b) -> b -> ForeignTarget -> b
foldRegsUsed Platform
_        b -> r -> b
_ !b
z (PrimTarget CallishMachOp
_)      = b
z
  foldRegsUsed Platform
platform b -> r -> b
f !b
z (ForeignTarget CmmExpr
e ForeignConvention
_) = Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall b. Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z CmmExpr
e

instance DefinerOfRegs LocalReg (CmmNode e x) where
  {-# INLINEABLE foldRegsDefd #-}
  foldRegsDefd :: forall b.
Platform -> (b -> CmmFormal -> b) -> b -> CmmNode e x -> b
foldRegsDefd Platform
platform b -> CmmFormal -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
    CmmAssign CmmReg
lhs CmmExpr
_ -> (b -> CmmFormal -> b) -> b -> CmmReg -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z CmmReg
lhs
    CmmUnsafeForeignCall ForeignTarget
_ [CmmFormal]
fs [CmmExpr]
_ -> (b -> CmmFormal -> b) -> b -> [CmmFormal] -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z [CmmFormal]
fs
    CmmForeignCall {res :: CmmNode 'Open 'Closed -> [CmmFormal]
res=[CmmFormal]
res} -> (b -> CmmFormal -> b) -> b -> [CmmFormal] -> b
forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z [CmmFormal]
res
    CmmNode e x
_ -> b
z
    where fold :: forall a b. DefinerOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold :: forall a b.
DefinerOfRegs CmmFormal a =>
(b -> CmmFormal -> b) -> b -> a -> b
fold b -> CmmFormal -> b
f b
z a
n = Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall b. Platform -> (b -> CmmFormal -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform b -> CmmFormal -> b
f b
z a
n

instance DefinerOfRegs GlobalRegUse (CmmNode e x) where
  {-# INLINEABLE foldRegsDefd #-}
  foldRegsDefd :: forall b.
Platform -> (b -> GlobalRegUse -> b) -> b -> CmmNode e x -> b
foldRegsDefd Platform
platform b -> GlobalRegUse -> b
f !b
z CmmNode e x
n = case CmmNode e x
n of
    CmmAssign CmmReg
lhs CmmExpr
_ -> (b -> GlobalRegUse -> b) -> b -> CmmReg -> b
forall a b.
DefinerOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z CmmReg
lhs
    CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
_ [CmmExpr]
_  -> (b -> GlobalRegUse -> b) -> b -> [GlobalRegUse] -> b
forall a b.
DefinerOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z (ForeignTarget -> [GlobalRegUse]
foreignTargetRegs ForeignTarget
tgt)
    CmmCall        {} -> (b -> GlobalRegUse -> b) -> b -> [GlobalRegUse] -> b
forall a b.
DefinerOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z [GlobalRegUse]
activeRegs
    CmmForeignCall {} -> (b -> GlobalRegUse -> b) -> b -> [GlobalRegUse] -> b
forall a b.
DefinerOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z [GlobalRegUse]
activeRegs
                      -- See Note [Safe foreign calls clobber STG registers]
    CmmNode e x
_ -> b
z
    where fold :: forall a b. DefinerOfRegs GlobalRegUse a
               => (b -> GlobalRegUse -> b) -> b -> a -> b
          fold :: forall a b.
DefinerOfRegs GlobalRegUse a =>
(b -> GlobalRegUse -> b) -> b -> a -> b
fold b -> GlobalRegUse -> b
f b
z a
n = Platform -> (b -> GlobalRegUse -> b) -> b -> a -> b
forall b. Platform -> (b -> GlobalRegUse -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform b -> GlobalRegUse -> b
f b
z a
n

          activeRegs :: [GlobalRegUse]
          activeRegs :: [GlobalRegUse]
activeRegs = (GlobalReg -> GlobalRegUse) -> [GlobalReg] -> [GlobalRegUse]
forall a b. (a -> b) -> [a] -> [b]
map (\ GlobalReg
r -> GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
r (Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
r)) ([GlobalReg] -> [GlobalRegUse]) -> [GlobalReg] -> [GlobalRegUse]
forall a b. (a -> b) -> a -> b
$ Platform -> [GlobalReg]
activeStgRegs Platform
platform
          activeCallerSavesRegs :: [GlobalRegUse]
activeCallerSavesRegs = (GlobalRegUse -> Bool) -> [GlobalRegUse] -> [GlobalRegUse]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform (GlobalReg -> Bool)
-> (GlobalRegUse -> GlobalReg) -> GlobalRegUse -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRegUse -> GlobalReg
globalRegUse_reg) [GlobalRegUse]
activeRegs

          foreignTargetRegs :: ForeignTarget -> [GlobalRegUse]
foreignTargetRegs (ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
_ [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
CmmNeverReturns)) = []
          foreignTargetRegs ForeignTarget
_ = [GlobalRegUse]
activeCallerSavesRegs

-- Note [Safe foreign calls clobber STG registers]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- During stack layout phase every safe foreign call is expanded into a block
-- that contains unsafe foreign call (instead of safe foreign call) and ends
-- with a normal call (See Note [Foreign calls]). This means that we must
-- treat safe foreign call as if it was a normal call (because eventually it
-- will be). This is important if we try to run sinking pass before stack
-- layout phase. Consider this example of what might go wrong (this is cmm
-- code from stablename001 test). Here is code after common block elimination
-- (before stack layout):
--
--  c1q6:
--      _s1pf::P64 = R1;
--      _c1q8::I64 = performMajorGC;
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- If we run sinking pass now (still before stack layout) we will get this:
--
--  c1q6:
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
-- safe call to performMajorGC will be turned into:
--
--  c1q6:
--      _s1pc::P64 = P64[Sp + 8];
--      I64[Sp - 8] = c1q9;
--      Sp = Sp - 8;
--      I64[I64[CurrentTSO + 24] + 16] = Sp;
--      P64[CurrentNursery + 8] = Hp + 8;
--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
--      BaseReg = _u1qJ::I64;
--      _u1qK::P64 = CurrentTSO;
--      _u1qL::P64 = I64[_u1qK::P64 + 24];
--      Sp = I64[_u1qL::P64 + 16];
--      SpLim = _u1qL::P64 + 192;
--      HpAlloc = 0;
--      Hp = I64[CurrentNursery + 8] - 8;
--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ INCORRECT!
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
-- call is clearly incorrect. This is what would happen if we assumed that
-- safe foreign call has the same semantics as unsafe foreign call. To prevent
-- this we need to treat safe foreign call as if was normal call.

-----------------------------------
-- mapping Expr in GHC.Cmm.Node

mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
exp   (ForeignTarget CmmExpr
e ForeignConvention
c) = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (CmmExpr -> CmmExpr
exp CmmExpr
e) ForeignConvention
c
mapForeignTarget CmmExpr -> CmmExpr
_   m :: ForeignTarget
m@(PrimTarget CallishMachOp
_)      = ForeignTarget
m

wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-- Take a transformer on expressions and apply it recursively.
-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
--                  then  uses f to rewrite the resulting expression
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f (CmmMachOp MachOp
op [CmmExpr]
es)       = CmmExpr -> CmmExpr
f (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
op ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> CmmExpr
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f) [CmmExpr]
es)
wrapRecExp CmmExpr -> CmmExpr
f (CmmLoad CmmExpr
addr CmmType
ty AlignmentSpec
align) = CmmExpr -> CmmExpr
f (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad ((CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f CmmExpr
addr) CmmType
ty AlignmentSpec
align)
wrapRecExp CmmExpr -> CmmExpr
f CmmExpr
e                       = CmmExpr -> CmmExpr
f CmmExpr
e

mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp CmmExpr -> CmmExpr
_ f :: CmmNode e x
f@(CmmEntry{})                          = CmmNode e x
f
mapExp CmmExpr -> CmmExpr
_ m :: CmmNode e x
m@(CmmComment FastString
_)                        = CmmNode e x
m
mapExp CmmExpr -> CmmExpr
_ m :: CmmNode e x
m@(CmmTick CmmTickish
_)                           = CmmNode e x
m
mapExp CmmExpr -> CmmExpr
f   (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs)                      = [(GlobalReg, Maybe CmmExpr)] -> CmmNode 'Open 'Open
CmmUnwind (((GlobalReg, Maybe CmmExpr) -> (GlobalReg, Maybe CmmExpr))
-> [(GlobalReg, Maybe CmmExpr)] -> [(GlobalReg, Maybe CmmExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe CmmExpr -> Maybe CmmExpr)
-> (GlobalReg, Maybe CmmExpr) -> (GlobalReg, Maybe CmmExpr)
forall a b. (a -> b) -> (GlobalReg, a) -> (GlobalReg, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CmmExpr -> CmmExpr) -> Maybe CmmExpr -> Maybe CmmExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmExpr -> CmmExpr
f)) [(GlobalReg, Maybe CmmExpr)]
regs)
mapExp CmmExpr -> CmmExpr
f   (CmmAssign CmmReg
r CmmExpr
e)                       = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
r (CmmExpr -> CmmExpr
f CmmExpr
e)
mapExp CmmExpr -> CmmExpr
f   (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
align)               = CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore (CmmExpr -> CmmExpr
f CmmExpr
addr) (CmmExpr -> CmmExpr
f CmmExpr
e) AlignmentSpec
align
mapExp CmmExpr -> CmmExpr
f   (CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as)      = ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ((CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
f ForeignTarget
tgt) [CmmFormal]
fs ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
f [CmmExpr]
as)
mapExp CmmExpr -> CmmExpr
_ l :: CmmNode e x
l@(CmmBranch Label
_)                         = CmmNode e x
l
mapExp CmmExpr -> CmmExpr
f   (CmmCondBranch CmmExpr
e Label
ti Label
fi Maybe Bool
l)             = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch (CmmExpr -> CmmExpr
f CmmExpr
e) Label
ti Label
fi Maybe Bool
l
mapExp CmmExpr -> CmmExpr
f   (CmmSwitch CmmExpr
e SwitchTargets
ids)                     = CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch (CmmExpr -> CmmExpr
f CmmExpr
e) SwitchTargets
ids
mapExp CmmExpr -> CmmExpr
f   n :: CmmNode e x
n@CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt}            = CmmNode e x
n{cml_target = f tgt}
mapExp CmmExpr -> CmmExpr
f   (CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl) = ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ((CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget CmmExpr -> CmmExpr
f ForeignTarget
tgt) [CmmFormal]
fs ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
f [CmmExpr]
as) Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl

mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
f = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp ((CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x)
-> (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
wrapRecExp CmmExpr -> CmmExpr
f

------------------------------------------------------------------------
-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes

mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f (ForeignTarget CmmExpr
e ForeignConvention
c) = (\CmmExpr
x -> CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
x ForeignConvention
c) (CmmExpr -> ForeignTarget) -> Maybe CmmExpr -> Maybe ForeignTarget
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapForeignTargetM CmmExpr -> Maybe CmmExpr
_ (PrimTarget CallishMachOp
_)      = Maybe ForeignTarget
forall a. Maybe a
Nothing

wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
--                   then  gives f a chance to rewrite the resulting expression
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f n :: CmmExpr
n@(CmmMachOp MachOp
op [CmmExpr]
es)       = Maybe CmmExpr
-> ([CmmExpr] -> Maybe CmmExpr) -> Maybe [CmmExpr] -> Maybe CmmExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CmmExpr -> Maybe CmmExpr
f CmmExpr
n) (CmmExpr -> Maybe CmmExpr
f (CmmExpr -> Maybe CmmExpr)
-> ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> Maybe CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
op)    ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM ((CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f) [CmmExpr]
es)
wrapRecExpM CmmExpr -> Maybe CmmExpr
f n :: CmmExpr
n@(CmmLoad CmmExpr
addr CmmType
ty AlignmentSpec
align) = Maybe CmmExpr
-> (CmmExpr -> Maybe CmmExpr) -> Maybe CmmExpr -> Maybe CmmExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CmmExpr -> Maybe CmmExpr
f CmmExpr
n) (\CmmExpr
addr' -> CmmExpr -> Maybe CmmExpr
f (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
addr' CmmType
ty AlignmentSpec
align) ((CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f CmmExpr
addr)
wrapRecExpM CmmExpr -> Maybe CmmExpr
f CmmExpr
e                         = CmmExpr -> Maybe CmmExpr
f CmmExpr
e

mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmEntry{})              = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmComment FastString
_)            = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmTick CmmTickish
_)               = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs)          = [(GlobalReg, Maybe CmmExpr)] -> CmmNode e x
[(GlobalReg, Maybe CmmExpr)] -> CmmNode 'Open 'Open
CmmUnwind ([(GlobalReg, Maybe CmmExpr)] -> CmmNode e x)
-> Maybe [(GlobalReg, Maybe CmmExpr)] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((GlobalReg, Maybe CmmExpr) -> Maybe (GlobalReg, Maybe CmmExpr))
-> [(GlobalReg, Maybe CmmExpr)]
-> Maybe [(GlobalReg, Maybe CmmExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(GlobalReg
r,Maybe CmmExpr
e) -> (CmmExpr -> Maybe CmmExpr)
-> Maybe CmmExpr -> Maybe (Maybe CmmExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM CmmExpr -> Maybe CmmExpr
f Maybe CmmExpr
e Maybe (Maybe CmmExpr)
-> (Maybe CmmExpr -> Maybe (GlobalReg, Maybe CmmExpr))
-> Maybe (GlobalReg, Maybe CmmExpr)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe CmmExpr
e' -> (GlobalReg, Maybe CmmExpr) -> Maybe (GlobalReg, Maybe CmmExpr)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalReg
r,Maybe CmmExpr
e')) [(GlobalReg, Maybe CmmExpr)]
regs
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmAssign CmmReg
r CmmExpr
e)           = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
r (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
align)   = (\ (Pair CmmExpr
addr' CmmExpr
e') -> CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore CmmExpr
addr' CmmExpr
e' AlignmentSpec
align) (Pair CmmExpr -> CmmNode e x)
-> Maybe (Pair CmmExpr) -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> Pair CmmExpr -> Maybe (Pair CmmExpr)
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) -> Pair a -> f (Pair b)
traverse CmmExpr -> Maybe CmmExpr
f (CmmExpr -> CmmExpr -> Pair CmmExpr
forall a. a -> a -> Pair a
Pair CmmExpr
addr CmmExpr
e)
mapExpM CmmExpr -> Maybe CmmExpr
_ (CmmBranch Label
_)             = Maybe (CmmNode e x)
forall a. Maybe a
Nothing
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmCondBranch CmmExpr
e Label
ti Label
fi Maybe Bool
l) = (\CmmExpr
x -> CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
x Label
ti Label
fi Maybe Bool
l) (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmSwitch CmmExpr
e SwitchTargets
tbl)         = (\CmmExpr
x -> CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
x SwitchTargets
tbl)       (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
e
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmCall CmmExpr
tgt Maybe Label
mb_id [GlobalRegUse]
r ByteOff
o ByteOff
i ByteOff
s) = (\CmmExpr
x -> CmmExpr
-> Maybe Label
-> [GlobalRegUse]
-> ByteOff
-> ByteOff
-> ByteOff
-> CmmNode 'Open 'Closed
CmmCall CmmExpr
x Maybe Label
mb_id [GlobalRegUse]
r ByteOff
o ByteOff
i ByteOff
s) (CmmExpr -> CmmNode e x) -> Maybe CmmExpr -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> Maybe CmmExpr
f CmmExpr
tgt
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as)
    = case (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f ForeignTarget
tgt of
        Just ForeignTarget
tgt' -> CmmNode e x -> Maybe (CmmNode e x)
forall a. a -> Maybe a
Just (ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
tgt' [CmmFormal]
fs ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as))
        Maybe ForeignTarget
Nothing   -> (\[CmmExpr]
xs -> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
xs) ([CmmExpr] -> CmmNode e x)
-> Maybe [CmmExpr] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as
mapExpM CmmExpr -> Maybe CmmExpr
f (CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
as Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl)
    = case (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM CmmExpr -> Maybe CmmExpr
f ForeignTarget
tgt of
        Just ForeignTarget
tgt' -> CmmNode e x -> Maybe (CmmNode e x)
forall a. a -> Maybe a
Just (ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ForeignTarget
tgt' [CmmFormal]
fs ((CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as) Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl)
        Maybe ForeignTarget
Nothing   -> (\[CmmExpr]
xs -> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> ByteOff
-> ByteOff
-> Bool
-> CmmNode 'Open 'Closed
CmmForeignCall ForeignTarget
tgt [CmmFormal]
fs [CmmExpr]
xs Label
succ ByteOff
ret_args ByteOff
updfr Bool
intrbl) ([CmmExpr] -> CmmNode e x)
-> Maybe [CmmExpr] -> Maybe (CmmNode e x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (CmmExpr -> Maybe CmmExpr) -> [CmmExpr] -> Maybe [CmmExpr]
forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM CmmExpr -> Maybe CmmExpr
f [CmmExpr]
as

-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
mapListM :: forall a. (a -> Maybe a) -> [a] -> Maybe [a]
mapListM a -> Maybe a
f [a]
xs = let (Bool
b, [a]
r) = (a -> Maybe a) -> [a] -> (Bool, [a])
forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs
                in if Bool
b then [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
r else Maybe [a]
forall a. Maybe a
Nothing

mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ :: forall a. (a -> Maybe a) -> [a] -> [a]
mapListJ a -> Maybe a
f [a]
xs = (Bool, [a]) -> [a]
forall a b. (a, b) -> b
snd ((a -> Maybe a) -> [a] -> (Bool, [a])
forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs)

mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT :: forall a. (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT a -> Maybe a
f [a]
xs = (([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a]))
-> (Bool, [a]) -> [([a], a, Maybe a)] -> (Bool, [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
forall {a}. ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
g (Bool
False, []) ([[a]] -> [a] -> [Maybe a] -> [([a], a, Maybe a)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs) [a]
xs ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
f [a]
xs))
    where g :: ([a], a, Maybe a) -> (Bool, [a]) -> (Bool, [a])
g ([a]
_,   a
y, Maybe a
Nothing) (Bool
True, [a]
ys)  = (Bool
True,  a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
          g ([a]
_,   a
_, Just a
y)  (Bool
True, [a]
ys)  = (Bool
True,  a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
          g ([a]
ys', a
_, Maybe a
Nothing) (Bool
False, [a]
_)  = (Bool
False, [a]
ys')
          g ([a]
_,   a
_, Just a
y)  (Bool
False, [a]
ys) = (Bool
True,  a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)

mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM :: forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM CmmExpr -> Maybe CmmExpr
f = (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM ((CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x))
-> (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
wrapRecExpM CmmExpr -> Maybe CmmExpr
f

-----------------------------------
-- folding Expr in GHC.Cmm.Node

foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget :: forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
exp (ForeignTarget CmmExpr
e ForeignConvention
_) z
z = CmmExpr -> z -> z
exp CmmExpr
e z
z
foldExpForeignTarget CmmExpr -> z -> z
_   (PrimTarget CallishMachOp
_)      z
z = z
z

-- Take a folder on expressions and apply it recursively.
-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
-- itself, delegating all the other CmmExpr forms to 'f'.
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf :: forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f e :: CmmExpr
e@(CmmMachOp MachOp
_ [CmmExpr]
es)   z
z = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f) (CmmExpr -> z -> z
f CmmExpr
e z
z) [CmmExpr]
es
wrapRecExpf CmmExpr -> z -> z
f e :: CmmExpr
e@(CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_) z
z = (CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f CmmExpr
addr (CmmExpr -> z -> z
f CmmExpr
e z
z)
wrapRecExpf CmmExpr -> z -> z
f CmmExpr
e                    z
z = CmmExpr -> z -> z
f CmmExpr
e z
z

foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp :: forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp CmmExpr -> z -> z
_ (CmmEntry {}) z
z                         = z
z
foldExp CmmExpr -> z -> z
_ (CmmComment {}) z
z                       = z
z
foldExp CmmExpr -> z -> z
_ (CmmTick {}) z
z                          = z
z
foldExp CmmExpr -> z -> z
f (CmmUnwind [(GlobalReg, Maybe CmmExpr)]
xs) z
z                        = (Maybe CmmExpr -> z -> z) -> z -> [Maybe CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((z -> z) -> (CmmExpr -> z -> z) -> Maybe CmmExpr -> z -> z
forall b a. b -> (a -> b) -> Maybe a -> b
maybe z -> z
forall a. a -> a
id CmmExpr -> z -> z
f) z
z (((GlobalReg, Maybe CmmExpr) -> Maybe CmmExpr)
-> [(GlobalReg, Maybe CmmExpr)] -> [Maybe CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Maybe CmmExpr) -> Maybe CmmExpr
forall a b. (a, b) -> b
snd [(GlobalReg, Maybe CmmExpr)]
xs)
foldExp CmmExpr -> z -> z
f (CmmAssign CmmReg
_ CmmExpr
e) z
z                       = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmStore CmmExpr
addr CmmExpr
e AlignmentSpec
_) z
z                   = CmmExpr -> z -> z
f CmmExpr
addr (z -> z) -> z -> z
forall a b. (a -> b) -> a -> b
$ CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
_ [CmmExpr]
as) z
z         = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmExpr -> z -> z
f ((CmmExpr -> z -> z) -> ForeignTarget -> z -> z
forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
f ForeignTarget
t z
z) [CmmExpr]
as
foldExp CmmExpr -> z -> z
_ (CmmBranch Label
_) z
z                         = z
z
foldExp CmmExpr -> z -> z
f (CmmCondBranch CmmExpr
e Label
_ Label
_ Maybe Bool
_) z
z               = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmSwitch CmmExpr
e SwitchTargets
_) z
z                       = CmmExpr -> z -> z
f CmmExpr
e z
z
foldExp CmmExpr -> z -> z
f (CmmCall {cml_target :: CmmNode 'Open 'Closed -> CmmExpr
cml_target=CmmExpr
tgt}) z
z            = CmmExpr -> z -> z
f CmmExpr
tgt z
z
foldExp CmmExpr -> z -> z
f (CmmForeignCall {tgt :: CmmNode 'Open 'Closed -> ForeignTarget
tgt=ForeignTarget
tgt, args :: CmmNode 'Open 'Closed -> [CmmExpr]
args=[CmmExpr]
args}) z
z = (CmmExpr -> z -> z) -> z -> [CmmExpr] -> z
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmExpr -> z -> z
f ((CmmExpr -> z -> z) -> ForeignTarget -> z -> z
forall z. (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget CmmExpr -> z -> z
f ForeignTarget
tgt z
z) [CmmExpr]
args

foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep :: forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep CmmExpr -> z -> z
f = (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp ((CmmExpr -> z -> z) -> CmmExpr -> z -> z
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> z -> z
f)

-- -----------------------------------------------------------------------------

mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors :: (Label -> Label) -> CmmNode 'Open 'Closed -> CmmNode 'Open 'Closed
mapSuccessors Label -> Label
f (CmmBranch Label
bid)         = Label -> CmmNode 'Open 'Closed
CmmBranch (Label -> Label
f Label
bid)
mapSuccessors Label -> Label
f (CmmCondBranch CmmExpr
p Label
y Label
n Maybe Bool
l) = CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
p (Label -> Label
f Label
y) (Label -> Label
f Label
n) Maybe Bool
l
mapSuccessors Label -> Label
f (CmmSwitch CmmExpr
e SwitchTargets
ids)       = CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
e ((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets Label -> Label
f SwitchTargets
ids)
mapSuccessors Label -> Label
_ CmmNode 'Open 'Closed
n = CmmNode 'Open 'Closed
n

mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
                     -> (CmmNode O C, [a])
mapCollectSuccessors :: forall a.
(Label -> (Label, a))
-> CmmNode 'Open 'Closed -> (CmmNode 'Open 'Closed, [a])
mapCollectSuccessors Label -> (Label, a)
f (CmmBranch Label
bid)
  = let (Label
bid', a
acc) = Label -> (Label, a)
f Label
bid in (Label -> CmmNode 'Open 'Closed
CmmBranch Label
bid', [a
acc])
mapCollectSuccessors Label -> (Label, a)
f (CmmCondBranch CmmExpr
p Label
y Label
n Maybe Bool
l)
  = let (Label
bidt, a
acct) = Label -> (Label, a)
f Label
y
        (Label
bidf, a
accf) = Label -> (Label, a)
f Label
n
    in  (CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
p Label
bidt Label
bidf Maybe Bool
l, [a
accf, a
acct])
mapCollectSuccessors Label -> (Label, a)
f (CmmSwitch CmmExpr
e SwitchTargets
ids)
  = let lbls :: [Label]
lbls = SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
ids :: [Label]
        lblMap :: LabelMap (Label, a)
lblMap = [(Label, (Label, a))] -> LabelMap (Label, a)
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, (Label, a))] -> LabelMap (Label, a))
-> [(Label, (Label, a))] -> LabelMap (Label, a)
forall a b. (a -> b) -> a -> b
$ [Label] -> [(Label, a)] -> [(Label, (Label, a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
lbls ((Label -> (Label, a)) -> [Label] -> [(Label, a)]
forall a b. (a -> b) -> [a] -> [b]
map Label -> (Label, a)
f [Label]
lbls) :: LabelMap (Label, a)
    in ( CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
e
          ((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets
            (\Label
l -> (Label, a) -> Label
forall a b. (a, b) -> a
fst ((Label, a) -> Label) -> (Label, a) -> Label
forall a b. (a -> b) -> a -> b
$ (Label, a) -> Label -> LabelMap (Label, a) -> (Label, a)
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault (String -> (Label, a)
forall a. HasCallStack => String -> a
error String
"impossible") Label
l LabelMap (Label, a)
lblMap) SwitchTargets
ids)
          , ((Label, a) -> a) -> [(Label, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Label, a) -> a
forall a b. (a, b) -> b
snd (LabelMap (Label, a) -> [(Label, a)]
forall a. LabelMap a -> [a]
mapElems LabelMap (Label, a)
lblMap)
        )
mapCollectSuccessors Label -> (Label, a)
_ CmmNode 'Open 'Closed
n = (CmmNode 'Open 'Closed
n, [])

-- -----------------------------------------------------------------------------

-- | Tick scope identifier, allowing us to reason about what
-- annotations in a Cmm block should scope over. We especially take
-- care to allow optimisations to reorganise blocks without losing
-- tick association in the process.
data CmmTickScope
  = GlobalScope
    -- ^ The global scope is the "root" of the scope graph. Every
    -- scope is a sub-scope of the global scope. It doesn't make sense
    -- to add ticks to this scope. On the other hand, this means that
    -- setting this scope on a block means no ticks apply to it.

  | SubScope !U.Unique CmmTickScope
    -- ^ Constructs a new sub-scope to an existing scope. This allows
    -- us to translate Core-style scoping rules (see @tickishScoped@)
    -- into the Cmm world. Suppose the following code:
    --
    --   tick<1> case ... of
    --             A -> tick<2> ...
    --             B -> tick<3> ...
    --
    -- We want the top-level tick annotation to apply to blocks
    -- generated for the A and B alternatives. We can achieve that by
    -- generating tick<1> into a block with scope a, while the code
    -- for alternatives A and B gets generated into sub-scopes a/b and
    -- a/c respectively.

  | CombinedScope CmmTickScope CmmTickScope
    -- ^ A combined scope scopes over everything that the two given
    -- scopes cover. It is therefore a sub-scope of either scope. This
    -- is required for optimisations. Consider common block elimination:
    --
    --   A -> tick<2> case ... of
    --     C -> [common]
    --   B -> tick<3> case ... of
    --     D -> [common]
    --
    -- We will generate code for the C and D alternatives, and figure
    -- out afterwards that it's actually common code. Scoping rules
    -- dictate that the resulting common block needs to be covered by
    -- both tick<2> and tick<3>, therefore we need to construct a
    -- scope that is a child to *both* scope. Now we can do that - if
    -- we assign the scopes a/c and b/d to the common-ed up blocks,
    -- the new block could have a combined tick scope a/c+b/d, which
    -- both tick<2> and tick<3> apply to.

-- Note [CmmTick scoping details]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
-- same block. Note that as a result of this, optimisations making
-- tick scopes more specific can *reduce* the amount of code a tick
-- scopes over. Fixing this would require a separate @CmmTickScope@
-- field for @CmmTick@. Right now we do not do this simply because I
-- couldn't find an example where it actually mattered -- multiple
-- blocks within the same scope generally jump to each other, which
-- prevents common block elimination from happening in the first
-- place. But this is no strong reason, so if Cmm optimisations become
-- more involved in future this might have to be revisited.

-- | Output all scope paths.
scopeToPaths :: CmmTickScope -> [[U.Unique]]
scopeToPaths :: CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
GlobalScope           = [[]]
scopeToPaths (SubScope Unique
u CmmTickScope
s)        = ([Unique] -> [Unique]) -> [[Unique]] -> [[Unique]]
forall a b. (a -> b) -> [a] -> [b]
map (Unique
uUnique -> [Unique] -> [Unique]
forall a. a -> [a] -> [a]
:) (CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s)
scopeToPaths (CombinedScope CmmTickScope
s1 CmmTickScope
s2) = CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s1 [[Unique]] -> [[Unique]] -> [[Unique]]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
s2

-- | Returns the head uniques of the scopes. This is based on the
-- assumption that the @Unique@ of @SubScope@ identifies the
-- underlying super-scope. Used for efficient equality and comparison,
-- see below.
scopeUniques :: CmmTickScope -> [U.Unique]
scopeUniques :: CmmTickScope -> [Unique]
scopeUniques CmmTickScope
GlobalScope           = []
scopeUniques (SubScope Unique
u CmmTickScope
_)        = [Unique
u]
scopeUniques (CombinedScope CmmTickScope
s1 CmmTickScope
s2) = CmmTickScope -> [Unique]
scopeUniques CmmTickScope
s1 [Unique] -> [Unique] -> [Unique]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
s2

-- Equality and order is based on the head uniques defined above. We
-- take care to short-cut the (extremely) common cases.
instance Eq CmmTickScope where
  CmmTickScope
GlobalScope    == :: CmmTickScope -> CmmTickScope -> Bool
== CmmTickScope
GlobalScope     = Bool
True
  CmmTickScope
GlobalScope    == CmmTickScope
_               = Bool
False
  CmmTickScope
_              == CmmTickScope
GlobalScope     = Bool
False
  (SubScope Unique
u CmmTickScope
_) == (SubScope Unique
u' CmmTickScope
_) = Unique
u Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
u'
  (SubScope Unique
_ CmmTickScope
_) == CmmTickScope
_               = Bool
False
  CmmTickScope
_              == (SubScope Unique
_ CmmTickScope
_)  = Bool
False
  CmmTickScope
scope          == CmmTickScope
scope'          =
    (Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique (CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope) [Unique] -> [Unique] -> Bool
forall a. Eq a => a -> a -> Bool
==
    (Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique (CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope')
    -- This is still deterministic because
    -- the order is the same for equal lists

-- This is non-deterministic but we do not currently support deterministic
-- code-generation. See Note [Unique Determinism and code generation]
-- See Note [No Ord for Unique]
instance Ord CmmTickScope where
  compare :: CmmTickScope -> CmmTickScope -> Ordering
compare CmmTickScope
GlobalScope    CmmTickScope
GlobalScope     = Ordering
EQ
  compare CmmTickScope
GlobalScope    CmmTickScope
_               = Ordering
LT
  compare CmmTickScope
_              CmmTickScope
GlobalScope     = Ordering
GT
  compare (SubScope Unique
u CmmTickScope
_) (SubScope Unique
u' CmmTickScope
_) = Unique -> Unique -> Ordering
nonDetCmpUnique Unique
u Unique
u'
  compare CmmTickScope
scope CmmTickScope
scope'                   = (Unique -> Unique -> Ordering) -> [Unique] -> [Unique] -> Ordering
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare Unique -> Unique -> Ordering
nonDetCmpUnique
     ((Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique ([Unique] -> [Unique]) -> [Unique] -> [Unique]
forall a b. (a -> b) -> a -> b
$ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope)
     ((Unique -> Unique -> Ordering) -> [Unique] -> [Unique]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Unique -> Unique -> Ordering
nonDetCmpUnique ([Unique] -> [Unique]) -> [Unique] -> [Unique]
forall a b. (a -> b) -> a -> b
$ CmmTickScope -> [Unique]
scopeUniques CmmTickScope
scope')

instance Outputable CmmTickScope where
  ppr :: CmmTickScope -> SDoc
ppr CmmTickScope
GlobalScope     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"global"
  ppr (SubScope Unique
us CmmTickScope
GlobalScope)
                      = Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
us
  ppr (SubScope Unique
us CmmTickScope
s) = CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
s SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
us
  ppr CmmTickScope
combined        = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+') ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        ([Unique] -> SDoc) -> [[Unique]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> ([Unique] -> [SDoc]) -> [Unique] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/') ([SDoc] -> [SDoc]) -> ([Unique] -> [SDoc]) -> [Unique] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique -> SDoc) -> [Unique] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Unique] -> [SDoc])
-> ([Unique] -> [Unique]) -> [Unique] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Unique] -> [Unique]
forall a. [a] -> [a]
reverse) ([[Unique]] -> [SDoc]) -> [[Unique]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        CmmTickScope -> [[Unique]]
scopeToPaths CmmTickScope
combined

-- | Checks whether two tick scopes are sub-scopes of each other. True
-- if the two scopes are equal.
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope = CmmTickScope -> CmmTickScope -> Bool
cmp
  where cmp :: CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
_              CmmTickScope
GlobalScope             = Bool
True
        cmp CmmTickScope
GlobalScope    CmmTickScope
_                       = Bool
False
        cmp (CombinedScope CmmTickScope
s1 CmmTickScope
s2) CmmTickScope
s'               = CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s1 CmmTickScope
s' Bool -> Bool -> Bool
&& CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s2 CmmTickScope
s'
        cmp CmmTickScope
s              (CombinedScope CmmTickScope
s1' CmmTickScope
s2') = CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s1' Bool -> Bool -> Bool
|| CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s2'
        cmp (SubScope Unique
u CmmTickScope
s) s' :: CmmTickScope
s'@(SubScope Unique
u' CmmTickScope
_)      = Unique
u Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
u' Bool -> Bool -> Bool
|| CmmTickScope -> CmmTickScope -> Bool
cmp CmmTickScope
s CmmTickScope
s'

-- | Combine two tick scopes. The new scope should be sub-scope of
-- both parameters. We simplify automatically if one tick scope is a
-- sub-scope of the other already.
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
s1 CmmTickScope
s2
  | CmmTickScope
s1 CmmTickScope -> CmmTickScope -> Bool
`isTickSubScope` CmmTickScope
s2 = CmmTickScope
s1
  | CmmTickScope
s2 CmmTickScope -> CmmTickScope -> Bool
`isTickSubScope` CmmTickScope
s1 = CmmTickScope
s2
  | Bool
otherwise              = CmmTickScope -> CmmTickScope -> CmmTickScope
CombinedScope CmmTickScope
s1 CmmTickScope
s2