{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- CmmNode type for representation using Hoopl graphs.

module CmmNode (
     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 GhcPrelude hiding (succ)

import CodeGen.Platform
import CmmExpr
import CmmSwitch
import DynFlags
import FastString
import ForeignCall
import Outputable
import SMRep
import CoreSyn (Tickish)
import qualified Unique as U

import Hoopl.Block
import Hoopl.Graph
import Hoopl.Collections
import Hoopl.Label
import Data.Maybe
import Data.List (tails,sortBy)
import Unique (nonDetCmpUnique)
import Util

------------------------
-- 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 Debug
  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O

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

  CmmStore :: !CmmExpr -> !CmmExpr -> 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 CodeGen.Platform.callerSaves
      -- is True.  See Note [Register Parameter Passing].

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

  CmmCondBranch :: {                 -- conditional branch
      cml_pred :: CmmExpr,
      cml_true, cml_false :: ULabel,
      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
      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

      cml_cont :: Maybe Label,
          -- Label of continuation (Nothing for return or tail call)
          --
          -- Note [Continuation BlockId]: 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) _).

      cml_args_regs :: [GlobalReg],
          -- 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.

      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.)

      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.

      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
      tgt   :: ForeignTarget,   -- call target and convention
      res   :: [CmmFormal],     -- zero or more results
      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
      succ  :: ULabel,          -- Label of continuation
      ret_args :: ByteOff,      -- same as cml_ret_args
      ret_off :: ByteOff,       -- same as cml_ret_off
      intrbl:: Bool             -- whether or not the call is interruptible
  } -> CmmNode O C

{- 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 CmmLayoutStack, 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).
StgCmmUtils.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 StgCmmUtils.hs.  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 cmm/CmmOpt.hs currently.  We should fix this!
-}

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

deriving instance Eq (CmmNode e x)

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

instance NonLocal CmmNode where
  entryLabel (CmmEntry l _) = l

  successors (CmmBranch l) = [l]
  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
  successors (CmmSwitch _ ids) = switchTargetsToList ids
  successors (CmmCall {cml_cont=l}) = maybeToList l
  successors (CmmForeignCall {succ=l}) = [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( Eq )

data ForeignConvention
  = ForeignConvention
        CCallConv               -- Which foreign-call convention
        [ForeignHint]           -- Extra info about the args
        [ForeignHint]           -- Extra info about the result
        CmmReturnInfo
  deriving Eq

data CmmReturnInfo
  = CmmMayReturn
  | CmmNeverReturns
  deriving ( Eq )

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 Eq

foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
  = ( res_hints ++ repeat NoHint
    , arg_hints ++ repeat NoHint )
  where
    (res_hints, arg_hints) =
       case target of
          PrimTarget op -> callishMachOpHints op
          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
             (res_hints, arg_hints)

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

instance UserOfRegs LocalReg (CmmNode e x) where
  foldRegsUsed dflags f !z n = case n of
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt} -> fold f z tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b. UserOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold f z n = foldRegsUsed dflags f z n

instance UserOfRegs GlobalReg (CmmNode e x) where
  foldRegsUsed dflags f !z n = case n of
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b.  UserOfRegs GlobalReg a
               => (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsUsed dflags f z 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 TcInstDcls
  foldRegsUsed _      _ !z (PrimTarget _)      = z
  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e

instance DefinerOfRegs LocalReg (CmmNode e x) where
  foldRegsDefd dflags f !z n = case n of
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall _ fs _ -> fold f z fs
    CmmForeignCall {res=res} -> fold f z res
    _ -> z
    where fold :: forall a b. DefinerOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold f z n = foldRegsDefd dflags f z n

instance DefinerOfRegs GlobalReg (CmmNode e x) where
  foldRegsDefd dflags f !z n = case n of
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
    CmmCall        {} -> fold f z activeRegs
    CmmForeignCall {} -> fold f z activeRegs
                      -- See Note [Safe foreign calls clobber STG registers]
    _ -> z
    where fold :: forall a b. DefinerOfRegs GlobalReg a
               => (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsDefd dflags f z n

          platform = targetPlatform dflags
          activeRegs = activeStgRegs platform
          activeCallerSavesRegs = filter (callerSaves platform) activeRegs

          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
          foreignTargetRegs _ = 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 CmmNode

mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _   m@(PrimTarget _)      = 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 f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e                    = f e

mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry{})                          = f
mapExp _ m@(CmmComment _)                        = m
mapExp _ m@(CmmTick _)                           = m
mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
mapExp _ l@(CmmBranch _)                         = l
mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids
mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl

mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f

------------------------------------------------------------------------
-- mapping Expr in CmmNode, but not performing allocation if no changes

mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _)      = 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 f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e                    = f e

mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry{})              = Nothing
mapExpM _ (CmmComment _)            = Nothing
mapExpM _ (CmmTick _)               = Nothing
mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
mapExpM _ (CmmBranch _)             = Nothing
mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
mapExpM f (CmmUnsafeForeignCall tgt fs as)
    = case mapForeignTargetM f tgt of
        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
    = case mapForeignTargetM f tgt of
        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as

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

mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ f xs = snd (mapListT f xs)

mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
          g (ys', _, Nothing) (False, _)  = (False, ys')
          g (_,   _, Just y)  (False, ys) = (True,  y:ys)

mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM f = mapExpM $ wrapRecExpM f

-----------------------------------
-- folding Expr in CmmNode

foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget _   (PrimTarget _)      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 f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
wrapRecExpf f e                  z = f e z

foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp _ (CmmEntry {}) z                         = z
foldExp _ (CmmComment {}) z                       = z
foldExp _ (CmmTick {}) z                          = z
foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
foldExp f (CmmAssign _ e) z                       = f e z
foldExp f (CmmStore addr e) z                     = f addr $ f e z
foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
foldExp _ (CmmBranch _) z                         = z
foldExp f (CmmCondBranch e _ _ _) z               = f e z
foldExp f (CmmSwitch e _) z                       = f e z
foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args

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

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

mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
mapSuccessors _ n = n

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

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

-- | Tickish in Cmm context (annotations only)
type CmmTickish = Tickish ()

-- | 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 GlobalScope           = [[]]
scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths 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 GlobalScope           = []
scopeUniques (SubScope u _)        = [u]
scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2

-- Equality and order is based on the head uniques defined above. We
-- take care to short-cut the (extremly) common cases.
instance Eq CmmTickScope where
  GlobalScope    == GlobalScope     = True
  GlobalScope    == _               = False
  _              == GlobalScope     = False
  (SubScope u _) == (SubScope u' _) = u == u'
  (SubScope _ _) == _               = False
  _              == (SubScope _ _)  = False
  scope          == scope'          =
    sortBy nonDetCmpUnique (scopeUniques scope) ==
    sortBy nonDetCmpUnique (scopeUniques 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 GlobalScope    GlobalScope     = EQ
  compare GlobalScope    _               = LT
  compare _              GlobalScope     = GT
  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
  compare scope scope'                   = cmpList nonDetCmpUnique
     (sortBy nonDetCmpUnique $ scopeUniques scope)
     (sortBy nonDetCmpUnique $ scopeUniques scope')

instance Outputable CmmTickScope where
  ppr GlobalScope     = text "global"
  ppr (SubScope us GlobalScope)
                      = ppr us
  ppr (SubScope us s) = ppr s <> char '/' <> ppr us
  ppr combined        = parens $ hcat $ punctuate (char '+') $
                        map (hcat . punctuate (char '/') . map ppr . reverse) $
                        scopeToPaths combined

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

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


-- The default iteration limit is a bit too low for the definitions
-- in this module.
{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}

-----------------------------------------------------------------------------
--
-- Cmm optimisation
--
-- (c) The University of Glasgow 2006
--
-----------------------------------------------------------------------------

module CmmOpt (
        constantFoldNode,
        constantFoldExpr,
        cmmMachOpFold,
        cmmMachOpFoldM
 ) where

import GhcPrelude

import CmmUtils
import Cmm
import DynFlags
import Util

import Outputable
import Platform

import Data.Bits
import Data.Maybe

constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
constantFoldNode dflags = mapExp (constantFoldExpr dflags)

constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
constantFoldExpr dflags = wrapRecExp f
  where f (CmmMachOp op args) = cmmMachOpFold dflags op args
        f (CmmRegOff r 0) = CmmReg r
        f e = e

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

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

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

cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)

-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
    :: DynFlags
    -> MachOp
    -> [CmmExpr]
    -> Maybe CmmExpr

cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
  = Just $ case op of
      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)
      MO_Not _   -> CmmLit (CmmInt (complement x) rep)

        -- these are interesting: we must first narrow to the
        -- "from" type, in order to truncate to the correct size.
        -- The final narrow/widen to the destination type
        -- is implicit in the CmmLit.
      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)
      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)

      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op

-- Eliminate conversion NOPs
cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x

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

        intconv True  = MO_SS_Conv
        intconv False = MO_UU_Conv

-- ToDo: a narrow of a load can be collapsed into a narrow load, right?
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?

cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
  = case mop of
        -- for comparisons: don't forget to narrow the arguments before
        -- comparing, since they might be out of range.
        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))

        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))
        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))
        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))

        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))
        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))
        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))

        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)
        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)
        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)
        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)
        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)

        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)
        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)
        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)

        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)

        _          -> Nothing

   where
        x_u = narrowU xrep x
        y_u = narrowU xrep y
        x_s = narrowS xrep x
        y_s = narrowS xrep y

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

cmmMachOpFoldM dflags op [x@(CmmLit _), y]
   | not (isLit y) && isCommutableMachOp op
   = Just (cmmMachOpFold dflags op [y, x])

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

-- special case: (a - b) + c  ==>  a + (c - b)
cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
   | not (isLit arg1) && not (isPicReg arg1)
   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])

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

-- Make a RegOff if we can
cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))
cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))
cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))
cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))

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

cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]
  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]
  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))

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

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

cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
        -- if the operand is widened:
    Just (rep, signed, narrow_fn) <- maybe_conversion conv,
        -- and this is a comparison operation:
    Just narrow_cmp <- maybe_comparison cmp rep signed,
        -- and the literal fits in the smaller size:
    i == narrow_fn rep i
        -- then we can do the comparison at the smaller size
  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
 where
    maybe_conversion (MO_UU_Conv from to)
        | to > from
        = Just (from, False, narrowU)
    maybe_conversion (MO_SS_Conv from to)
        | to > from
        = Just (from, True, narrowS)

        -- don't attempt to apply this optimisation when the source
        -- is a float; see #1916
    maybe_conversion _ = Nothing

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

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

cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
  = case mop of
        -- Arithmetic
        MO_Add   _ -> Just x   -- x + 0 = x
        MO_Sub   _ -> Just x   -- x - 0 = x
        MO_Mul   _ -> Just y   -- x * 0 = 0

        -- Logical operations
        MO_And   _ -> Just y   -- x &     0 = 0
        MO_Or    _ -> Just x   -- x |     0 = x
        MO_Xor   _ -> Just x   -- x `xor` 0 = x

        -- Shifts
        MO_Shl   _ -> Just x   -- x << 0 = x
        MO_S_Shr _ -> Just x   -- ditto shift-right
        MO_U_Shr _ -> Just x

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

        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y
        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'
        _ -> Nothing
  where
    zero = CmmLit (CmmInt 0 (wordWidth dflags))
    one  = CmmLit (CmmInt 1 (wordWidth dflags))

cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
  = case mop of
        -- Arithmetic: x*1 = x, etc
        MO_Mul    _ -> Just x
        MO_S_Quot _ -> Just x
        MO_U_Quot _ -> Just x
        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)

        -- Comparisons; trickier
        -- See Note [Comparison operators]
        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y
        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y
        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y
        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto
        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0
        MO_S_Gt  _ | isComparisonExpr x -> Just zero
        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1
        MO_S_Le  _ | isComparisonExpr x -> Just one
        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y
        MO_S_Ge  _ | isComparisonExpr x -> Just x
        _ -> Nothing
  where
    zero = CmmLit (CmmInt 0 (wordWidth dflags))
    one  = CmmLit (CmmInt 1 (wordWidth dflags))

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

cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
  = case mop of
        MO_Mul rep
           | Just p <- exactLog2 n ->
                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
        MO_U_Quot rep
           | Just p <- exactLog2 n ->
                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
        MO_U_Rem rep
           | Just _ <- exactLog2 n ->
                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
        MO_S_Quot rep
           | Just p <- exactLog2 n,
             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
                                -- it is a reg.  FIXME: remove this restriction.
                Just (cmmMachOpFold dflags (MO_S_Shr rep)
                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
        MO_S_Rem rep
           | Just p <- exactLog2 n,
             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
                                -- it is a reg.  FIXME: remove this restriction.
                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
                Just (cmmMachOpFold dflags (MO_Sub rep)
                    [x, cmmMachOpFold dflags (MO_And rep)
                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
        _ -> Nothing
  where
    -- In contrast with unsigned integers, for signed ones
    -- shift right is not the same as quot, because it rounds
    -- to minus infinity, whereas quot rounds toward zero.
    -- To fix this up, we add one less than the divisor to the
    -- dividend if it is a negative number.
    --
    -- to avoid a test/jump, we use the following sequence:
    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
    --      x2 = y & (divisor-1)
    --      result = x + x2
    -- this could be done a bit more simply using conditional moves,
    -- but we're processor independent here.
    --
    -- we optimise the divide by 2 case slightly, generating
    --      x1 = x >> word_size-1  (unsigned)
    --      return = x + x1
    signedQuotRemHelper :: Width -> Integer -> CmmExpr
    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
      where
        bits = fromIntegral (widthInBits rep) - 1
        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
        x2 = if p == 1 then x1 else
             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]

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

-- Anything else is just too hard.

cmmMachOpFoldM _ _ _ = Nothing

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

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

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

isPicReg :: CmmExpr -> Bool
isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
isPicReg _ = False


{-# LANGUAGE BangPatterns #-}

module CmmPipeline (
  -- | Converts C-- with an implicit stack and native C-- calls into
  -- optimized, CPS converted and native-call-less C--.  The latter
  -- C-- can be used to generate assembly.
  cmmPipeline
) where

import GhcPrelude

import Cmm
import CmmLint
import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmImplementSwitchPlans
import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
import CmmSink
import Hoopl.Collections

import UniqSupply
import DynFlags
import ErrUtils
import HscTypes
import Control.Monad
import Outputable
import Platform

-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
-----------------------------------------------------------------------------

cmmPipeline
 :: HscEnv -- Compilation env including
           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
 -> ModuleSRTInfo        -- Info about SRTs generated so far
 -> CmmGroup             -- Input C-- with Procedures
 -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--

cmmPipeline hsc_env srtInfo prog =
  do let dflags = hsc_dflags hsc_env

     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog

     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)

     return (srtInfo, cmms)

cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
cpsTop hsc_env proc =
    do
       ----------- Control-flow optimisations ----------------------------------

       -- The first round of control-flow optimisation speeds up the
       -- later passes by removing lots of empty blocks, so we do it
       -- even when optimisation isn't turned on.
       --
       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
            return $ cmmCfgOptsProc splitting_proc_points proc
       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g

       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
                                          , do_layout = do_layout }} = h

       ----------- Eliminate common blocks -------------------------------------
       g <- {-# SCC "elimCommonBlocks" #-}
            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
                          Opt_D_dump_cmm_cbe "Post common block elimination"

       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks

       g <- {-# SCC "createSwitchPlans" #-}
            runUniqSM $ cmmImplementSwitchPlans dflags g
       dump Opt_D_dump_cmm_switch "Post switch plan" g

       ----------- Proc points -------------------------------------------------
       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
       proc_points <-
          if splitting_proc_points
             then do
               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
                  minimalProcPointSet (targetPlatform dflags) call_pps g
               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
                     (ppr l $$ ppr pp $$ ppr g)
               return pp
             else
               return call_pps

       ----------- Layout the stack and manifest Sp ----------------------------
       (g, stackmaps) <-
            {-# SCC "layoutStack" #-}
            if do_layout
               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
               else return (g, mapEmpty)
       dump Opt_D_dump_cmm_sp "Layout Stack" g

       ----------- Sink and inline assignments  --------------------------------
       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
            condPass Opt_CmmSink (cmmSink dflags) g
                     Opt_D_dump_cmm_sink "Sink assignments"

       ------------- CAF analysis ----------------------------------------------
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)

       g <- if splitting_proc_points
            then do
               ------------- Split into separate procedures -----------------------
               let pp_map = {-# SCC "procPointAnalysis" #-}
                            procPointAnalysis proc_points g
               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
                    ppr pp_map
               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
                    splitAtProcPoints dflags l call_pps proc_points pp_map
                                      (CmmProc h l v g)
               dumps Opt_D_dump_cmm_split "Post splitting" g
               return g
             else do
               -- attach info tables to return points
               return $ [attachContInfoTables call_pps (CmmProc h l v g)]

       ------------- Populate info tables with stack info -----------------
       g <- {-# SCC "setInfoTableStackMap" #-}
            return $ map (setInfoTableStackMap dflags stackmaps) g
       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g

       ----------- Control-flow optimisations -----------------------------
       g <- {-# SCC "cmmCfgOpts(2)" #-}
            return $ if optLevel dflags >= 1
                     then map (cmmCfgOptsProc splitting_proc_points) g
                     else g
       g <- return (map removeUnreachableBlocksProc g)
            -- See Note [unreachable blocks]
       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g

       return (cafEnv, g)

  where dflags = hsc_dflags hsc_env
        platform = targetPlatform dflags
        dump = dumpGraph dflags

        dumps flag name
           = mapM_ (dumpWith dflags flag name . ppr)

        condPass flag pass g dumpflag dumpname =
            if gopt flag dflags
               then do
                    g <- return $ pass g
                    dump dumpflag dumpname g
                    return g
               else return g

        -- we don't need to split proc points for the NCG, unless
        -- tablesNextToCode is off.  The latter is because we have no
        -- label to put on info tables for basic blocks that are not
        -- the entry point.
        splitting_proc_points = hscTarget dflags /= HscAsm
                             || not (tablesNextToCode dflags)
                             || -- Note [inconsistent-pic-reg]
                                usingInconsistentPicReg
        usingInconsistentPicReg
           = case (platformArch platform, platformOS platform, positionIndependent dflags)
             of   (ArchX86, OSDarwin, pic) -> pic
                  _                        -> False

-- Note [Sinking after stack layout]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In the past we considered running sinking pass also before stack
-- layout, but after making some measurements we realized that:
--
--   a) running sinking only before stack layout produces slower
--      code than running sinking only before stack layout
--
--   b) running sinking both before and after stack layout produces
--      code that has the same performance as when running sinking
--      only after stack layout.
--
-- In other words sinking before stack layout doesn't buy as anything.
--
-- An interesting question is "why is it better to run sinking after
-- stack layout"? It seems that the major reason are stores and loads
-- generated by stack layout. Consider this code before stack layout:
--
--  c1E:
--      _c1C::P64 = R3;
--      _c1B::P64 = R2;
--      _c1A::P64 = R1;
--      I64[(young<c1D> + 8)] = c1D;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      R3 = _c1C::P64;
--      R2 = _c1B::P64;
--      R1 = _c1A::P64;
--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- Stack layout pass will save all local variables live across a call
-- (_c1C, _c1B and _c1A in this example) on the stack just before
-- making a call and reload them from the stack after returning from a
-- call:
--
--  c1E:
--      _c1C::P64 = R3;
--      _c1B::P64 = R2;
--      _c1A::P64 = R1;
--      I64[Sp - 32] = c1D;
--      P64[Sp - 24] = _c1A::P64;
--      P64[Sp - 16] = _c1B::P64;
--      P64[Sp - 8] = _c1C::P64;
--      Sp = Sp - 32;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      _c1A::P64 = P64[Sp + 8];
--      _c1B::P64 = P64[Sp + 16];
--      _c1C::P64 = P64[Sp + 24];
--      R3 = _c1C::P64;
--      R2 = _c1B::P64;
--      R1 = _c1A::P64;
--      Sp = Sp + 32;
--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- If we don't run sinking pass after stack layout we are basically
-- left with such code. However, running sinking on this code can lead
-- to significant improvements:
--
--  c1E:
--      I64[Sp - 32] = c1D;
--      P64[Sp - 24] = R1;
--      P64[Sp - 16] = R2;
--      P64[Sp - 8] = R3;
--      Sp = Sp - 32;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      R3 = P64[Sp + 24];
--      R2 = P64[Sp + 16];
--      R1 = P64[Sp + 8];
--      Sp = Sp + 32;
--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- Now we only have 9 assignments instead of 15.
--
-- There is one case when running sinking before stack layout could
-- be beneficial. Consider this:
--
--   L1:
--      x = y
--      call f() returns L2
--   L2: ...x...y...
--
-- Since both x and y are live across a call to f, they will be stored
-- on the stack during stack layout and restored after the call:
--
--   L1:
--      x = y
--      P64[Sp - 24] = L2
--      P64[Sp - 16] = x
--      P64[Sp - 8]  = y
--      Sp = Sp - 24
--      call f() returns L2
--   L2:
--      y = P64[Sp + 16]
--      x = P64[Sp + 8]
--      Sp = Sp + 24
--      ...x...y...
--
-- However, if we run sinking before stack layout we would propagate x
-- to its usage place (both x and y must be local register for this to
-- be possible - global registers cannot be floated past a call):
--
--   L1:
--      x = y
--      call f() returns L2
--   L2: ...y...y...
--
-- Thus making x dead at the call to f(). If we ran stack layout now
-- we would generate less stores and loads:
--
--   L1:
--      x = y
--      P64[Sp - 16] = L2
--      P64[Sp - 8]  = y
--      Sp = Sp - 16
--      call f() returns L2
--   L2:
--      y = P64[Sp + 8]
--      Sp = Sp + 16
--      ...y...y...
--
-- But since we don't see any benefits from running sinking befroe stack
-- layout, this situation probably doesn't arise too often in practice.
--

{- Note [inconsistent-pic-reg]

On x86/Darwin, PIC is implemented by inserting a sequence like

    call 1f
 1: popl %reg

at the proc entry point, and then referring to labels as offsets from
%reg.  If we don't split proc points, then we could have many entry
points in a proc that would need this sequence, and each entry point
would then get a different value for %reg.  If there are any join
points, then at the join point we don't have a consistent value for
%reg, so we don't know how to refer to labels.

Hence, on x86/Darwin, we have to split proc points, and then each proc
point will get its own PIC initialisation sequence.

This isn't an issue on x86/ELF, where the sequence is

    call 1f
 1: popl %reg
    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg

so %reg always has a consistent value: the address of
_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.

-}

{- Note [unreachable blocks]

The control-flow optimiser sometimes leaves unreachable blocks behind
containing junk code.  These aren't necessarily a problem, but
removing them is good because it might save time in the native code
generator later.

-}

runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)

dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
  when (gopt Opt_DoCmmLinting dflags) $ do_lint g
  dumpWith dflags flag name (ppr g)
 where
  do_lint g = case cmmLintGraph dflags g of
                 Just err -> do { fatalErrorMsg dflags err
                                ; ghcExit dflags 1
                                }
                 Nothing  -> return ()

dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith dflags flag txt sdoc = do
         -- ToDo: No easy way of say "dump all the cmm, *and* split
         -- them into files."  Also, -ddump-cmm-verbose doesn't play
         -- nicely with -ddump-to-file, since the headers get omitted.
   dumpIfSet_dyn dflags flag txt sdoc
   when (not (dopt flag dflags)) $
      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc


{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}

module CmmProcPoint
    ( ProcPointSet, Status(..)
    , callProcPoints, minimalProcPointSet
    , splitAtProcPoints, procPointAnalysis
    , attachContInfoTables
    )
where

import GhcPrelude hiding (last, unzip, succ, zip)

import DynFlags
import BlockId
import CLabel
import Cmm
import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive
import CmmSwitch
import Data.List (sortBy)
import Maybes
import Control.Monad
import Outputable
import Platform
import UniqSupply
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Dataflow
import Hoopl.Graph
import Hoopl.Label

-- Compute a minimal set of proc points for a control-flow graph.

-- Determine a protocol for each proc point (which live variables will
-- be passed as arguments and which will be on the stack).

{-
A proc point is a basic block that, after CPS transformation, will
start a new function.  The entry block of the original function is a
proc point, as is the continuation of each function call.
A third kind of proc point arises if we want to avoid copying code.
Suppose we have code like the following:

  f() {
    if (...) { ..1..; call foo(); ..2..}
    else     { ..3..; call bar(); ..4..}
    x = y + z;
    return x;
  }

The statement 'x = y + z' can be reached from two different proc
points: the continuations of foo() and bar().  We would prefer not to
put a copy in each continuation; instead we would like 'x = y + z' to
be the start of a new procedure to which the continuations can jump:

  f_cps () {
    if (...) { ..1..; push k_foo; jump foo_cps(); }
    else     { ..3..; push k_bar; jump bar_cps(); }
  }
  k_foo() { ..2..; jump k_join(y, z); }
  k_bar() { ..4..; jump k_join(y, z); }
  k_join(y, z) { x = y + z; return x; }

You might think then that a criterion to make a node a proc point is
that it is directly reached by two distinct proc points.  (Note
[Direct reachability].)  But this criterion is a bit too simple; for
example, 'return x' is also reached by two proc points, yet there is
no point in pulling it out of k_join.  A good criterion would be to
say that a node should be made a proc point if it is reached by a set
of proc points that is different than its immediate dominator.  NR
believes this criterion can be shown to produce a minimum set of proc
points, and given a dominator tree, the proc points can be chosen in
time linear in the number of blocks.  Lacking a dominator analysis,
however, we turn instead to an iterative solution, starting with no
proc points and adding them according to these rules:

  1. The entry block is a proc point.
  2. The continuation of a call is a proc point.
  3. A node is a proc point if it is directly reached by more proc
     points than one of its predecessors.

Because we don't understand the problem very well, we apply rule 3 at
most once per iteration, then recompute the reachability information.
(See Note [No simple dataflow].)  The choice of the new proc point is
arbitrary, and I don't know if the choice affects the final solution,
so I don't know if the number of proc points chosen is the
minimum---but the set will be minimal.

Note [Proc-point analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~

Given a specified set of proc-points (a set of block-ids), "proc-point
analysis" figures out, for every block, which proc-point it belongs to.
All the blocks belonging to proc-point P will constitute a single
top-level C procedure.

A non-proc-point block B "belongs to" a proc-point P iff B is
reachable from P without going through another proc-point.

Invariant: a block B should belong to at most one proc-point; if it
belongs to two, that's a bug.

Note [Non-existing proc-points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

On some architectures it might happen that the list of proc-points
computed before stack layout pass will be invalidated by the stack
layout. This will happen if stack layout removes from the graph
blocks that were determined to be proc-points. Later on in the pipeline
we use list of proc-points to perform [Proc-point analysis], but
if a proc-point does not exist anymore then we will get compiler panic.
See #8205.
-}

type ProcPointSet = LabelSet

data Status
  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
  | ProcPoint               -- this block is itself a proc point

instance Outputable Status where
  ppr (ReachedBy ps)
      | setNull ps = text "<not-reached>"
      | otherwise = text "reached by" <+>
                    (hsep $ punctuate comma $ map ppr $ setElems ps)
  ppr ProcPoint = text "<procpt>"

--------------------------------------------------
-- Proc point analysis

-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
-- See Note [Proc-point analysis]
procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
  where
    initProcPoints =
        mkFactBase
            procPointLattice
            [ (id, ProcPoint)
            | id <- setElems procPoints
            -- See Note [Non-existing proc-points]
            , id `setMember` labelsInGraph
            ]
    labelsInGraph = labelsDefined graph

procPointTransfer :: TransferFun Status
procPointTransfer block facts =
    let label = entryLabel block
        !fact = case getFact procPointLattice label facts of
            ProcPoint -> ReachedBy $! setSingleton label
            f -> f
        result = map (\id -> (id, fact)) (successors block)
    in mkFactBase procPointLattice result

procPointLattice :: DataflowLattice Status
procPointLattice = DataflowLattice unreached add_to
  where
    unreached = ReachedBy setEmpty
    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
        | setSize union > setSize p = Changed (ReachedBy union)
        | otherwise = NotChanged (ReachedBy p)
      where
        union = setUnion p' p

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

-- It is worth distinguishing two sets of proc points: those that are
-- induced by calls in the original graph and those that are
-- introduced because they're reachable from multiple proc points.
--
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints      :: CmmGraph -> ProcPointSet
callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
  where add :: LabelSet -> CmmBlock -> LabelSet
        add set b = case lastNode b of
                      CmmCall {cml_cont = Just k} -> setInsert k set
                      CmmForeignCall {succ=k}     -> setInsert k set
                      _ -> set

minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
                    -> UniqSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
minimalProcPointSet platform callProcPoints g
  = extendPPSet platform g (revPostorder g) callProcPoints

extendPPSet
    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet platform g blocks procPoints =
    let env = procPointAnalysis procPoints g
        add pps block = let id = entryLabel block
                        in  case mapLookup id env of
                              Just ProcPoint -> setInsert id pps
                              _ -> pps
        procPoints' = foldlGraphBlocks add setEmpty g
        newPoints = mapMaybe ppSuccessor blocks
        newPoint  = listToMaybe newPoints
        ppSuccessor b =
            let nreached id = case mapLookup id env `orElse`
                                    pprPanic "no ppt" (ppr id <+> ppr b) of
                                ProcPoint -> 1
                                ReachedBy ps -> setSize ps
                block_procpoints = nreached (entryLabel b)
                -- | Looking for a successor of b that is reached by
                -- more proc points than b and is not already a proc
                -- point.  If found, it can become a proc point.
                newId succ_id = not (setMember succ_id procPoints') &&
                                nreached succ_id > block_procpoints
            in  listToMaybe $ filter newId $ successors b

    in case newPoint of
         Just id ->
             if setMember id procPoints'
                then panic "added old proc pt"
                else extendPPSet platform g blocks (setInsert id procPoints')
         Nothing -> return procPoints'

-- At this point, we have found a set of procpoints, each of which should be
-- the entry point of a procedure.
-- Now, we create the procedure for each proc point,
-- which requires that we:
-- 1. build a map from proc points to the blocks reachable from the proc point
-- 2. turn each branch to a proc point into a jump
-- 3. turn calls and returns into jumps
-- 4. build info tables for the procedures -- and update the info table for
--    the SRTs in the entry procedure as well.
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
                     CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints dflags entry_label callPPs procPoints procMap
                  (CmmProc (TopInfo {info_tbls = info_tbls})
                           top_l _ g@(CmmGraph {g_entry=entry})) =
  do -- Build a map from procpoints to the blocks they reach
     let add_block
             :: LabelMap (LabelMap CmmBlock)
             -> CmmBlock
             -> LabelMap (LabelMap CmmBlock)
         add_block graphEnv b =
           case mapLookup bid procMap of
             Just ProcPoint -> add graphEnv bid bid b
             Just (ReachedBy set) ->
               case setElems set of
                 []   -> graphEnv
                 [id] -> add graphEnv id bid b
                 _    -> panic "Each block should be reachable from only one ProcPoint"
             Nothing -> graphEnv
           where bid = entryLabel b
         add graphEnv procId bid b = mapInsert procId graph' graphEnv
               where graph  = mapLookup procId graphEnv `orElse` mapEmpty
                     graph' = mapInsert bid b graph

     let liveness = cmmGlobalLiveness dflags g
     let ppLiveness pp = filter isArgReg $
                         regSetToList $
                         expectJust "ppLiveness" $ mapLookup pp liveness

     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g

     -- Build a map from proc point BlockId to pairs of:
     --  * Labels for their new procedures
     --  * Labels for the info tables of their new procedures (only if
     --    the proc point is a callPP)
     -- Due to common blockification, we may overestimate the set of procpoints.
     let add_label map pp = mapInsert pp lbls map
           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
                                                    Just info_table_lbl)
                      where block_lbl      = blockLbl pp
                            info_table_lbl = infoTblLbl pp

         procLabels :: LabelMap (CLabel, Maybe CLabel)
         procLabels = foldl' add_label mapEmpty
                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))

     -- In each new graph, add blocks jumping off to the new procedures,
     -- and replace branches to procpoints with branches to the jump-off blocks
     let add_jump_block
             :: (LabelMap Label, [CmmBlock])
             -> (Label, CLabel)
             -> UniqSM (LabelMap Label, [CmmBlock])
         add_jump_block (env, bs) (pp, l) =
           do bid <- liftM mkBlockId getUniqueM
              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
                  live = ppLiveness pp
                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
              return (mapInsert pp bid env, b : bs)

         add_jumps
             :: LabelMap CmmGraph
             -> (Label, LabelMap CmmBlock)
             -> UniqSM (LabelMap CmmGraph)
         add_jumps newGraphEnv (ppId, blockEnv) =
           do let needed_jumps = -- find which procpoints we currently branch to
                    mapFoldr add_if_branch_to_pp [] blockEnv
                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
                  add_if_branch_to_pp block rst =
                    case lastNode block of
                      CmmBranch id          -> add_if_pp id rst
                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids
                      _                     -> rst

                  -- when jumping to a PP that has an info table, if
                  -- tablesNextToCode is off we must jump to the entry
                  -- label instead.
                  jump_label (Just info_lbl) _
                             | tablesNextToCode dflags = info_lbl
                             | otherwise               = toEntryLbl info_lbl
                  jump_label Nothing         block_lbl = block_lbl

                  add_if_pp id rst = case mapLookup id procLabels of
                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
                                       Nothing                 -> rst
              (jumpEnv, jumpBlocks) <-
                 foldM add_jump_block (mapEmpty, []) needed_jumps
                  -- update the entry block
              let b = expectJust "block in env" $ mapLookup ppId blockEnv
                  blockEnv' = mapInsert ppId b blockEnv
                  -- replace branches to procpoints with branches to jumps
                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
                  -- add the jump blocks to the graph
                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
              let g' = ofBlockMap ppId blockEnv'''
              -- pprTrace "g' pre jumps" (ppr g') $ do
              return (mapInsert ppId g' newGraphEnv)

     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv

     let to_proc (bid, g)
             | bid == entry
             =  CmmProc (TopInfo {info_tbls  = info_tbls,
                                  stack_info = stack_info})
                        top_l live g'
             | otherwise
             = case expectJust "pp label" $ mapLookup bid procLabels of
                 (lbl, Just info_lbl)
                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
                                        , stack_info=stack_info})
                               lbl live g'
                 (lbl, Nothing)
                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
                               lbl live g'
                where
                 g' = replacePPIds g
                 live = ppLiveness (g_entry g')
                 stack_info = StackInfo { arg_space = 0
                                        , updfr_space =  Nothing
                                        , do_layout = True }
                               -- cannot use panic, this is printed by -ddump-cmm

         -- References to procpoint IDs can now be replaced with the
         -- infotable's label
         replacePPIds g = {-# SCC "replacePPIds" #-}
                          mapGraphNodes (id, mapExp repl, mapExp repl) g
           where repl e@(CmmLit (CmmBlock bid)) =
                   case mapLookup bid procLabels of
                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
                     _ -> e
                 repl e = e

     -- The C back end expects to see return continuations before the
     -- call sites.  Here, we sort them in reverse order -- it gets
     -- reversed later.
     let (_, block_order) =
             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
                   (revPostorder g)
         add_block_num (i, map) block =
           (i + 1, mapInsert (entryLabel block) i map)
         sort_fn (bid, _) (bid', _) =
           compare (expectJust "block_order" $ mapLookup bid  block_order)
                   (expectJust "block_order" $ mapLookup bid' block_order)
     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
     return -- pprTrace "procLabels" (ppr procLabels)
            -- pprTrace "splitting graphs" (ppr procs)
            procs
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]

-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches env cmmg
  = {-# SCC "replaceBranches" #-}
    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
  where
    f block = replaceLastNode block $ last (lastNode block)

    last :: CmmNode O C -> CmmNode O C
    last (CmmBranch id)          = CmmBranch (lookup id)
    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)
    last l@(CmmCall {})          = l { cml_cont = Nothing }
            -- NB. remove the continuation of a CmmCall, since this
            -- label will now be in a different CmmProc.  Not only
            -- is this tidier, it stops CmmLint from complaining.
    last l@(CmmForeignCall {})   = l
    lookup id = fmap lookup (mapLookup id env) `orElse` id
            -- XXX: this is a recursive lookup, it follows chains
            -- until the lookup returns Nothing, at which point we
            -- return the last BlockId

-- --------------------------------------------------------------
-- Not splitting proc points: add info tables for continuations

attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
 = CmmProc top_info{info_tbls = info_tbls'} top_l live g
 where
   info_tbls' = mapUnion (info_tbls top_info) $
                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
                            | l <- setElems call_proc_points
                            , l /= g_entry g ]
attachContInfoTables _ other_decl
 = other_decl

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

{-
Note [Direct reachability]

Block B is directly reachable from proc point P iff control can flow
from P to B without passing through an intervening proc point.
-}

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

{-
Note [No simple dataflow]

Sadly, it seems impossible to compute the proc points using a single
dataflow pass.  One might attempt to use this simple lattice:

  data Location = Unknown
                | InProc BlockId -- node is in procedure headed by the named proc point
                | ProcPoint      -- node is itself a proc point

At a join, a node in two different blocks becomes a proc point.
The difficulty is that the change of information during iterative
computation may promote a node prematurely.  Here's a program that
illustrates the difficulty:

  f () {
  entry:
    ....
  L1:
    if (...) { ... }
    else { ... }

  L2: if (...) { g(); goto L1; }
      return x + y;
  }

The only proc-point needed (besides the entry) is L1.  But in an
iterative analysis, consider what happens to L2.  On the first pass
through, it rises from Unknown to 'InProc entry', but when L1 is
promoted to a proc point (because it's the successor of g()), L1's
successors will be promoted to 'InProc L1'.  The problem hits when the
new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
The join operation makes it a proc point when in fact it needn't be,
because its immediate dominator L1 is already a proc point and there
are no other proc points that directly reach L2.
-}

{- Note [Separate Adams optimization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It may be worthwhile to attempt the Adams optimization by rewriting
the graph before the assignment of proc-point protocols.  Here are a
couple of rules:

  g() returns to k;                    g() returns to L;
  k: CopyIn c ress; goto L:
   ...                        ==>        ...
  L: // no CopyIn node here            L: CopyIn c ress;

And when c == c' and ress == ress', this also:

  g() returns to k;                    g() returns to L;
  k: CopyIn c ress; goto L:
   ...                        ==>        ...
  L: CopyIn c' ress'                   L: CopyIn c' ress' ;

In both cases the goal is to eliminate k.
-}