{-# LANGUAGE CPP #-}

--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--

--------------------------------------------------------------
-- Converting Core to STG Syntax
--------------------------------------------------------------

-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.

module CoreToStg ( coreToStg ) where

#include "HsVersions.h"

import GhcPrelude

import CoreSyn
import CoreUtils        ( exprType, findDefault, isJoinBind
                        , exprIsTickedString_maybe )
import CoreArity        ( manifestArity )
import StgSyn

import Type
import RepType
import TyCon
import MkId             ( coercionTokenId )
import Id
import IdInfo
import DataCon
import CostCentre
import VarEnv
import Module
import Name             ( isExternalName, nameOccName, nameModule_maybe )
import OccName          ( occNameFS )
import BasicTypes       ( Arity )
import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
import Literal
import Outputable
import MonadUtils
import FastString
import Util
import DynFlags
import ForeignCall
import Demand           ( isUsedOnce )
import PrimOp           ( PrimCall(..) )
import SrcLoc           ( mkGeneralSrcSpan )

import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe    (fromMaybe)
import Control.Monad (liftM, ap)

-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
-- The two are not the same. Liveness is an operational property rather
-- than a semantic one. A variable is live at a particular execution
-- point if it can be referred to directly again. In particular, a dead
-- variable's stack slot (if it has one):
--
--           - should be stubbed to avoid space leaks, and
--           - may be reused for something else.
--
-- There ought to be a better way to say this. Here are some examples:
--
--         let v = [q] \[x] -> e
--         in
--         ...v...  (but no q's)
--
-- Just after the `in', v is live, but q is dead. If the whole of that
-- let expression was enclosed in a case expression, thus:
--
--         case (let v = [q] \[x] -> e in ...v...) of
--                 alts[...q...]
--
-- (ie `alts' mention `q'), then `q' is live even after the `in'; because
-- we'll return later to the `alts' and need it.
--
-- Let-no-escapes make this a bit more interesting:
--
--         let-no-escape v = [q] \ [x] -> e
--         in
--         ...v...
--
-- Here, `q' is still live at the `in', because `v' is represented not by
-- a closure but by the current stack state.  In other words, if `v' is
-- live then so is `q'. Furthermore, if `e' mentions an enclosing
-- let-no-escaped variable, then its free variables are also live if `v' is.

-- Note [What are these SRTs all about?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider the Core program,
--
--     fibs = go 1 1
--       where go a b = let c = a + c
--                      in c : go b c
--     add x = map (\y -> x*y) fibs
--
-- In this case we have a CAF, 'fibs', which is quite large after evaluation and
-- has only one possible user, 'add'. Consequently, we want to ensure that when
-- all references to 'add' die we can garbage collect any bit of 'fibs' that we
-- have evaluated.
--
-- However, how do we know whether there are any references to 'fibs' still
-- around? Afterall, the only reference to it is buried in the code generated
-- for 'add'. The answer is that we record the CAFs referred to by a definition
-- in its info table, namely a part of it known as the Static Reference Table
-- (SRT).
--
-- Since SRTs are so common, we use a special compact encoding for them in: we
-- produce one table containing a list of CAFs in a module and then include a
-- bitmap in each info table describing which entries of this table the closure
-- references.
--
-- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki.

-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- NB: Nowadays this is recognized by the occurrence analyser by turning a
-- "non-escaping let" into a join point. The following is then an operational
-- account of join points.
--
-- Consider:
--
--     let x = fvs \ args -> e
--     in
--         if ... then x else
--            if ... then x else ...
--
-- `x' is used twice (so we probably can't unfold it), but when it is
-- entered, the stack is deeper than it was when the definition of `x'
-- happened.  Specifically, if instead of allocating a closure for `x',
-- we saved all `x's fvs on the stack, and remembered the stack depth at
-- that moment, then whenever we enter `x' we can simply set the stack
-- pointer(s) to these remembered (compile-time-fixed) values, and jump
-- to the code for `x'.
--
-- All of this is provided x is:
--   1. non-updatable;
--   2. guaranteed to be entered before the stack retreats -- ie x is not
--      buried in a heap-allocated closure, or passed as an argument to
--      something;
--   3. all the enters have exactly the right number of arguments,
--      no more no less;
--   4. all the enters are tail calls; that is, they return to the
--      caller enclosing the definition of `x'.
--
-- Under these circumstances we say that `x' is non-escaping.
--
-- An example of when (4) does not hold:
--
--     let x = ...
--     in case x of ...alts...
--
-- Here, `x' is certainly entered only when the stack is deeper than when
-- `x' is defined, but here it must return to ...alts... So we can't just
-- adjust the stack down to `x''s recalled points, because that would lost
-- alts' context.
--
-- Things can get a little more complicated.  Consider:
--
--     let y = ...
--     in let x = fvs \ args -> ...y...
--     in ...x...
--
-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
-- non-escaping way in ...y..., then `y' is non-escaping.
--
-- `x' can even be recursive!  Eg:
--
--     letrec x = [y] \ [v] -> if v then x True else ...
--     in
--         ...(x b)...

-- Note [Cost-centre initialization plan]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
-- We now initialize these correctly. The initialization works like this:
--
--   - For non-top level bindings always use `currentCCS`.
--
--   - For top-level bindings, check if the binding is a CAF
--
--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
--                 and use it. Note that these new cost centres need to be
--                 collected to be able to generate cost centre initialization
--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
--
--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
--
--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
--                 do we set CCCS from it; so we just slam in
--                 dontCareCostCentre.

-- --------------------------------------------------------------
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------

coreToStg :: DynFlags -> Module -> CoreProgram
          -> ([StgTopBinding], CollectedCCs)
coreToStg dflags this_mod pgm
  = (pgm', final_ccs)
  where
    (_, (local_ccs, local_cc_stacks), pgm')
      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm

    prof = WayProf `elem` ways dflags

    final_ccs
      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
      | prof
      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
      | otherwise
      = emptyCollectedCCs

    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod

coreTopBindsToStg
    :: DynFlags
    -> Module
    -> IdEnv HowBound           -- environment for the bindings
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])

coreTopBindsToStg _      _        env ccs []
  = (env, ccs, [])
coreTopBindsToStg dflags this_mod env ccs (b:bs)
  = (env2, ccs2, b':bs')
  where
        (env1, ccs1, b' ) =
          coreTopBindToStg dflags this_mod env ccs b
        (env2, ccs2, bs') =
          coreTopBindsToStg dflags this_mod env1 ccs1 bs

coreTopBindToStg
        :: DynFlags
        -> Module
        -> IdEnv HowBound
        -> CollectedCCs
        -> CoreBind
        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)

coreTopBindToStg _ _ env ccs (NonRec id e)
  | Just str <- exprIsTickedString_maybe e
  -- top-level string literal
  -- See Note [CoreSyn top-level string literals] in CoreSyn
  = let
        env' = extendVarEnv env id how_bound
        how_bound = LetBound TopLet 0
    in (env', ccs, StgTopStringLit id str)

coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs

        (stg_rhs, ccs') =
            initCts env $
              coreToTopStgRhs dflags ccs this_mod (id,rhs)

        bind = StgTopLifted $ StgNonRec id stg_rhs
    in
    ASSERT2(consistentCafInfo id bind, ppr id )
      -- NB: previously the assertion printed 'rhs' and 'bind'
      --     as well as 'id', but that led to a black hole
      --     where printing the assertion error tripped the
      --     assertion again!
    (env', ccs', bind)

coreTopBindToStg dflags this_mod env ccs (Rec pairs)
  = ASSERT( not (null pairs) )
    let
        binders = map fst pairs

        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'

        -- generate StgTopBindings and CAF cost centres created for CAFs
        (ccs', stg_rhss)
          = initCts env' $ do
               mapAccumLM (\ccs rhs -> do
                            (rhs', ccs') <-
                              coreToTopStgRhs dflags ccs this_mod rhs
                            return (ccs', rhs'))
                          ccs
                          pairs

        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
    in
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
    (env', ccs', bind)

-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT.  The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> StgTopBinding -> Bool
consistentCafInfo id bind
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
    safe
  where
    safe  = id_marked_caffy || not binding_is_caffy
    exact = id_marked_caffy == binding_is_caffy
    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
    binding_is_caffy = topStgBindHasCafRefs bind
    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"

coreToTopStgRhs
        :: DynFlags
        -> CollectedCCs
        -> Module
        -> (Id,CoreExpr)
        -> CtsM (StgRhs, CollectedCCs)

coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
  = do { new_rhs <- coreToStgExpr rhs

       ; let (stg_rhs, ccs') =
               mkTopStgRhs dflags this_mod ccs bndr new_rhs
             stg_arity =
               stgRhsArity stg_rhs

       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
                 ccs') }
  where
        -- It's vital that the arity on a top-level Id matches
        -- the arity of the generated STG binding, else an importing
        -- module will use the wrong calling convention
        --      (Trac #2844 was an example where this happened)
        -- NB1: we can't move the assertion further out without
        --      blocking the "knot" tied in coreTopBindsToStg
        -- NB2: the arity check is only needed for Ids with External
        --      Names, because they are externally visible.  The CorePrep
        --      pass introduces "sat" things with Local Names and does
        --      not bother to set their Arity info, so don't fail for those
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
       | otherwise                    = True
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
        = vcat [ppr bndr,
                text "Id arity:" <+> ppr id_arity,
                text "STG arity:" <+> ppr stg_arity]

-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------

coreToStgExpr
        :: CoreExpr
        -> CtsM StgExpr

-- The second and third components can be derived in a simple bottom up pass, not
-- dependent on any decisions about which variables will be let-no-escaped or
-- not.  The first component, that is, the decorated expression, may then depend
-- on these components, but it in turn is not scrutinised as the basis for any
-- decisions.  Hence no black holes.

-- No LitInteger's or LitNatural's should be left by the time this is called.
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
coreToStgExpr (Lit l)      = return (StgLit l)
coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
  -- a STG to Cmm pass.
  = coreToStgExpr (Var unitDataConId)
coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []

coreToStgExpr expr@(App _ _)
  = coreToStgApp Nothing f args ticks
  where
    (f, args, ticks) = myCollectArgs expr

coreToStgExpr expr@(Lam _ _)
  = let
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
    in
    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
    body' <- coreToStgExpr body
    let
        result_expr = case nonEmpty args' of
          Nothing     -> body'
          Just args'' -> StgLam args'' body'

    return result_expr

coreToStgExpr (Tick tick expr)
  = do case tick of
         HpcTick{}    -> return ()
         ProfNote{}   -> return ()
         SourceNote{} -> return ()
         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
       expr2 <- coreToStgExpr expr
       return (StgTick tick expr2)

coreToStgExpr (Cast expr _)
  = coreToStgExpr expr

-- Cases require a little more real work.

coreToStgExpr (Case scrut _ _ [])
  = coreToStgExpr scrut
    -- See Note [Empty case alternatives] in CoreSyn If the case
    -- alternatives are empty, the scrutinee must diverge or raise an
    -- exception, so we can just dive into it.
    --
    -- Of course this may seg-fault if the scrutinee *does* return.  A
    -- belt-and-braces approach would be to move this case into the
    -- code generator, and put a return point anyway that calls a
    -- runtime system error function.

coreToStgExpr (Case scrut bndr _ alts) = do
    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
    scrut2 <- coreToStgExpr scrut
    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
  where
    vars_alt (con, binders, rhs)
      | DataAlt c <- con, c == unboxedUnitDataCon
      = -- This case is a bit smelly.
        -- See Note [Nullary unboxed tuple] in Type.hs
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { rhs2 <- coreToStgExpr rhs
           ; return (DEFAULT, [], rhs2)  }
      | otherwise
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
        rhs2 <- coreToStgExpr rhs
        return (con, binders', rhs2)

coreToStgExpr (Let bind body) = do
    coreToStgLet bind body

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)

mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType bndr alts
  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples

  | otherwise
  = case prim_reps of
      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
        Just tc
          | isAbstractTyCon tc -> look_for_better_tycon
          | isAlgTyCon tc      -> AlgAlt tc
          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                  PolyAlt
        Nothing                -> PolyAlt
      [unlifted] -> PrimAlt unlifted
      not_unary  -> MultiValAlt (length not_unary)
  where
   bndr_ty   = idType bndr
   prim_reps = typePrimRep bndr_ty

   _is_poly_alt_tycon tc
        =  isFunTyCon tc
        || isPrimTyCon tc   -- "Any" is lifted but primitive
        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
                            -- function application where argument has a
                            -- type-family type

   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
   -- grabbing the one from a constructor alternative
   -- if one exists.
   look_for_better_tycon
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts

-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

coreToStgApp
         :: Maybe UpdateFlag            -- Just upd <=> this application is
                                        -- the rhs of a thunk binding
                                        --      x = [...] \upd [] -> the_app
                                        -- with specified update flag
        -> Id                           -- Function
        -> [CoreArg]                    -- Arguments
        -> [Tickish Id]                 -- Debug ticks
        -> CtsM StgExpr

coreToStgApp _ f args ticks = do
    (args', ticks') <- coreToStgArgs args
    how_bound <- lookupVarCts f

    let
        n_val_args       = valArgCount args

        -- Mostly, the arity info of a function is in the fn's IdInfo
        -- But new bindings introduced by CoreSat may not have no
        -- arity info; it would do us no good anyway.  For example:
        --      let f = \ab -> e in f
        -- No point in having correct arity info for f!
        -- Hence the hasArity stuff below.
        -- NB: f_arity is only consulted for LetBound things
        f_arity   = stgArity f how_bound
        saturated = f_arity <= n_val_args

        res_ty = exprType (mkApps (Var f) args)
        app = case idDetails f of
                DataConWorkId dc
                  | saturated    -> StgConApp dc args'
                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))

                -- Some primitive operator that might be implemented as a library call.
                PrimOpId op      -> ASSERT( saturated )
                                    StgOpApp (StgPrimOp op) args' res_ty

                -- A call to some primitive Cmm function.
                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
                                          PrimCallConv _))
                                 -> ASSERT( saturated )
                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty

                -- A regular foreign call.
                FCallId call     -> ASSERT( saturated )
                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty

                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
                _other           -> StgApp f args'

        tapp = foldr StgTick app (ticks ++ ticks')

    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
    app `seq` return tapp

-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs []
  = return ([], [])

coreToStgArgs (Type _ : args) = do     -- Type argument
    (args', ts) <- coreToStgArgs args
    return (args', ts)

coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
  = do { (args', ts) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', ts) }

coreToStgArgs (Tick t e : args)
  = ASSERT( not (tickishIsCode t) )
    do { (args', ts) <- coreToStgArgs (e : args)
       ; return (args', t:ts) }

coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, ticks) <- coreToStgArgs args
    arg' <- coreToStgExpr arg
    let
        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
        stg_arg = case arg'' of
                       StgApp v []        -> StgVarArg v
                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
                       StgLit lit         -> StgLitArg lit
                       _                  -> pprPanic "coreToStgArgs" (ppr arg)

        -- WARNING: what if we have an argument like (v `cast` co)
        --          where 'co' changes the representation type?
        --          (This really only happens if co is unsafe.)
        -- Then all the getArgAmode stuff in CgBindery will set the
        -- cg_rep of the CgIdInfo based on the type of v, rather
        -- than the type of 'co'.
        -- This matters particularly when the function is a primop
        -- or foreign call.
        -- Wanted: a better solution than this hacky warning
    let
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
        -- we can treat an unlifted value as lifted.  But the other way round
        -- we complain.
        -- We also want to check if a pointer is cast to a non-ptr etc

    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
     return (stg_arg : stg_args, ticks ++ aticks)

-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
         :: CoreBind     -- bindings
         -> CoreExpr     -- body
         -> CtsM StgExpr -- new let

coreToStgLet bind body = do
    (bind2, body2)
       <- do

          ( bind2, env_ext)
                <- vars_bind bind

          -- Do the body
          extendVarEnvCts env_ext $ do
             body2 <- coreToStgExpr body

             return (bind2, body2)

        -- Compute the new let-expression
    let
        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2
                | otherwise       = StgLet noExtSilent bind2 body2

    return new_let
  where
    mk_binding binder rhs
        = (binder, LetBound NestedLet (manifestArity rhs))

    vars_bind :: CoreBind
              -> CtsM (StgBinding,
                       [(Id, HowBound)])  -- extension to environment

    vars_bind (NonRec binder rhs) = do
        rhs2 <- coreToStgRhs (binder,rhs)
        let
            env_ext_item = mk_binding binder rhs

        return (StgNonRec binder rhs2, [env_ext_item])

    vars_bind (Rec pairs)
      =    let
                binders = map fst pairs
                env_ext = [ mk_binding b rhs
                          | (b,rhs) <- pairs ]
           in
           extendVarEnvCts env_ext $ do
              rhss2 <- mapM coreToStgRhs pairs
              return (StgRec (binders `zip` rhss2), env_ext)

coreToStgRhs :: (Id,CoreExpr)
             -> CtsM StgRhs

coreToStgRhs (bndr, rhs) = do
    new_rhs <- coreToStgExpr rhs
    return (mkStgRhs bndr new_rhs)

-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
            -> Id -> StgExpr -> (StgRhs, CollectedCCs)

mkTopStgRhs dflags this_mod ccs bndr rhs
  | StgLam bndrs body <- rhs
  = -- StgLam can't have empty arguments, so not CAF
    ( StgRhsClosure noExtSilent
                    dontCareCCS
                    ReEntrant
                    (toList bndrs) body
    , ccs )

  | StgConApp con args _ <- unticked_rhs
  , -- Dynamic StgConApps are updatable
    not (isDllConApp dflags this_mod con args)
  = -- CorePrep does this right, but just to make sure
    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
           , ppr bndr $$ ppr con $$ ppr args)
    ( StgRhsCon dontCareCCS con args, ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | gopt Opt_AutoSccsOnIndividualCafs dflags
  = ( StgRhsClosure noExtSilent
                    caf_ccs
                    upd_flag [] rhs
    , collectCC caf_cc caf_ccs ccs )

  | otherwise
  = ( StgRhsClosure noExtSilent
                    all_cafs_ccs
                    upd_flag [] rhs
    , ccs )

  where
    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs

    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable

    -- CAF cost centres generated for -fcaf-all
    caf_cc = mkAutoCC bndr modl
    caf_ccs = mkSingletonCCS caf_cc
           -- careful: the binder might be :Main.main,
           -- which doesn't belong to module mod_name.
           -- bug #249, tests prof001, prof002
    modl | Just m <- nameModule_maybe (idName bndr) = m
         | otherwise = this_mod

    -- default CAF cost centre
    (_, all_cafs_ccs) = getAllCAFsCC this_mod

-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialzation plan].
mkStgRhs :: Id -> StgExpr -> StgRhs
mkStgRhs bndr rhs
  | StgLam bndrs body <- rhs
  = StgRhsClosure noExtSilent
                  currentCCS
                  ReEntrant
                  (toList bndrs) body

  | isJoinId bndr -- must be a nullary join point
  = ASSERT(idJoinArity bndr == 0)
    StgRhsClosure noExtSilent
                  currentCCS
                  ReEntrant -- ignored for LNE
                  [] rhs

  | StgConApp con args _ <- unticked_rhs
  = StgRhsCon currentCCS con args

  | otherwise
  = StgRhsClosure noExtSilent
                  currentCCS
                  upd_flag [] rhs
  where
    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs

    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable

  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

    upd_flag | isPAP env rhs  = ReEntrant
             | otherwise      = Updatable

-- Detect thunks which will reduce immediately to PAPs, and make them
-- non-updatable.  This has several advantages:
--
--         - the non-updatable thunk behaves exactly like the PAP,
--
--         - the thunk is more efficient to enter, because it is
--           specialised to the task.
--
--         - we save one update frame, one stg_update_PAP, one update
--           and lots of PAP_enters.
--
--         - in the case where the thunk is top-level, we save building
--           a black hole and furthermore the thunk isn't considered to
--           be a CAF any more, so it doesn't appear in any SRTs.
--
-- We do it here, because the arity information is accurate, and we need
-- to do it before the SRT pass to save the SRT entries associated with
-- any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
                              where
                                 arity = stgArity f (lookupBinding env f)
isPAP env _               = False

-}

{- ToDo:
          upd = if isOnceDem dem
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
                     Updatable)
                else Updatable
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

-- ---------------------------------------------------------------------------
-- A monad for the core-to-STG pass
-- ---------------------------------------------------------------------------

-- There's a lot of stuff to pass around, so we use this CtsM
-- ("core-to-STG monad") monad to help.  All the stuff here is only passed
-- *down*.

newtype CtsM a = CtsM
    { unCtsM :: IdEnv HowBound
             -> a
    }

data HowBound
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)

  | LetBound            -- A let(rec) in this module
        LetInfo         -- Whether top level or nested
        Arity           -- Its arity (local Ids don't have arity info at this point)

  | LambdaBound         -- Used for both lambda and case
  deriving (Eq)

data LetInfo
  = TopLet              -- top level things
  | NestedLet
  deriving (Eq)

-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
-- variables that are live if x is live.  This LiveInfo comprises
--         (a) dynamic live variables (ones with a non-top-level binding)
--         (b) static live variabes (CAFs or things that refer to CAFs)
--
-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
-- variable then x is represented by a code pointer and a stack pointer
-- (well, one for each stack).  So all of the variables needed in the
-- execution of x are live if x is, and are therefore recorded in the
-- LetBound constructor; x itself *is* included.
--
-- The set of dynamic live variables is guaranteed ot have no further
-- let-no-escaped variables in it.

-- The std monad functions:

initCts :: IdEnv HowBound -> CtsM a -> a
initCts env m = unCtsM m env

{-# INLINE thenCts #-}
{-# INLINE returnCts #-}

returnCts :: a -> CtsM a
returnCts e = CtsM $ \_ -> e

thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts m k = CtsM $ \env
  -> unCtsM (k (unCtsM m env)) env

instance Functor CtsM where
    fmap = liftM

instance Applicative CtsM where
    pure = returnCts
    (<*>) = ap

instance Monad CtsM where
    (>>=)  = thenCts

-- Functions specific to this monad:

extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts ids_w_howbound expr
   =    CtsM $   \env
   -> unCtsM expr (extendVarEnvList env ids_w_howbound)

lookupVarCts :: Id -> CtsM HowBound
lookupVarCts v = CtsM $ \env -> lookupBinding env v

lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound

getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
    let
      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
      all_cafs_cc  = mkAllCafsCC this_mod span
      all_cafs_ccs = mkSingletonCCS all_cafs_cc
    in
      (all_cafs_cc, all_cafs_ccs)

-- Misc.

filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs = filter isId bndrs

myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders expr
  = go [] expr
  where
    go bs (Lam b e)          = go (b:bs) e
    go bs (Cast e _)         = go bs e
    go bs e                  = (reverse bs, e)

-- | Precondition: argument expression is an 'App', and there is a 'Var' at the
-- head of the 'App' chain.
myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
myCollectArgs expr
  = go expr [] []
  where
    go (Var v)          as ts = (v, as, ts)
    go (App f a)        as ts = go f (a:as) ts
    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
                                go e as (t:ts) -- ticks can appear in type apps
    go (Cast e _)       as ts = go e as ts
    go (Lam b e)        as ts
       | isTyVar b            = go e as ts -- Note [Collect args]
    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)

-- Note [Collect args]
-- ~~~~~~~~~~~~~~~~~~~
--
-- This big-lambda case occurred following a rather obscure eta expansion.
-- It all seems a bit yukky to me.

stgArity :: Id -> HowBound -> Arity
stgArity _ (LetBound _ arity) = arity
stgArity f ImportBound        = idArity f
stgArity _ LambdaBound        = 0


-- | Free variable analysis on STG terms.
module StgFVs (
    annTopBindingsFreeVars,
    annBindingFreeVars
  ) where

import GhcPrelude

import StgSyn
import Id
import VarSet
import CoreSyn    ( Tickish(Breakpoint) )
import Outputable
import Util

import Data.Maybe ( mapMaybe )

newtype Env
  = Env
  { locals :: IdSet
  }

emptyEnv :: Env
emptyEnv = Env emptyVarSet

addLocals :: [Id] -> Env -> Env
addLocals bndrs env
  = env { locals = extendVarSetList (locals env) bndrs }

-- | Annotates a top-level STG binding group with its free variables.
annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
annTopBindingsFreeVars = map go
  where
    go (StgTopStringLit id bs) = StgTopStringLit id bs
    go (StgTopLifted bind)
      = StgTopLifted (annBindingFreeVars bind)

-- | Annotates an STG binding with its free variables.
annBindingFreeVars :: StgBinding -> CgStgBinding
annBindingFreeVars = fst . binding emptyEnv emptyDVarSet

boundIds :: StgBinding -> [Id]
boundIds (StgNonRec b _) = [b]
boundIds (StgRec pairs)  = map fst pairs

-- Note [Tracking local binders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- 'locals' contains non-toplevel, non-imported binders.
-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only
-- places where new local binders are introduced.
-- Why do it there rather than in 'binding'? Two reasons:
--
--   1. We call 'binding' from 'annTopBindingsFreeVars', which would
--      add top-level bindings to the 'locals' set.
--   2. In the let(-no-escape) case, we need to extend the environment
--      prior to analysing the body, but we also need the fvs from the
--      body to analyse the RHSs. No way to do this without some
--      knot-tying.

-- | This makes sure that only local, non-global free vars make it into the set.
mkFreeVarSet :: Env -> [Id] -> DIdSet
mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)

args :: Env -> [StgArg] -> DIdSet
args env = mkFreeVarSet env . mapMaybe f
  where
    f (StgVarArg occ) = Just occ
    f _               = Nothing

binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)
binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
  where
    -- See Note [Tacking local binders]
    (r', rhs_fvs) = rhs env r
    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
  where
    -- See Note [Tacking local binders]
    bndrs = map fst pairs
    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
    pairs' = zip bndrs rhss
    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs

expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)
expr env = go
  where
    go (StgApp occ as)
      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))
    go (StgLit lit) = (StgLit lit, emptyDVarSet)
    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
    go StgLam{} = pprPanic "StgFVs: StgLam" empty
    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
      where
        (scrut', scrut_fvs) = go scrut
        -- See Note [Tacking local binders]
        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
        alt_fvs = unionDVarSets alt_fvss
        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
    go (StgLet ext bind body) = go_bind (StgLet ext) bind body
    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
    go (StgTick tick e) = (StgTick tick e', fvs')
      where
        (e', fvs) = go e
        fvs' = unionDVarSet (tickish tick) fvs
        tickish (Breakpoint _ ids) = mkDVarSet ids
        tickish _                  = emptyDVarSet

    go_bind dc bind body = (dc bind' body', fvs)
      where
        -- See Note [Tacking local binders]
        env' = addLocals (boundIds bind) env
        (body', body_fvs) = expr env' body
        (bind', fvs) = binding env' body_fvs bind

rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)
rhs env (StgRhsClosure _ ccs uf bndrs body)
  = (StgRhsClosure fvs ccs uf bndrs body', fvs)
  where
    -- See Note [Tacking local binders]
    (body', body_fvs) = expr (addLocals bndrs env) body
    fvs = delDVarSetList body_fvs bndrs
rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)

alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
  where
    -- See Note [Tacking local binders]
    (e', rhs_fvs) = expr (addLocals bndrs env) e
    fvs = delDVarSetList rhs_fvs bndrs


{- |
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

A lint pass to check basic STG invariants:

- Variables should be defined before used.

- Let bindings should not have unboxed types (unboxed bindings should only
  appear in case), except when they're join points (see Note [CoreSyn let/app
  invariant] and #14117).

- If linting after unarisation, invariants listed in Note [Post-unarisation
  invariants].

Because we don't have types and coercions in STG we can't really check types
here.

Some history:

StgLint used to check types, but it never worked and so it was disabled in 2000
with this note:

    WARNING:
    ~~~~~~~~

    This module has suffered bit-rot; it is likely to yield lint errors
    for Stg code that is currently perfectly acceptable for code
    generation.  Solution: don't use it!  (KSW 2000-05).

Since then there were some attempts at enabling it again, as summarised in
#14787. It's finally decided that we remove all type checking and only look for
basic properties listed above.
-}

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}

module StgLint ( lintStgTopBindings ) where

import GhcPrelude

import StgSyn

import DynFlags
import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import BasicTypes       ( TopLevelFlag(..), isTopLevel )
import CostCentre       ( isCurrentCCS )
import Id               ( Id, idType, isJoinId, idName )
import VarSet
import DataCon
import CoreSyn          ( AltCon(..) )
import Name             ( getSrcLoc, nameIsLocalOrFrom )
import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
import Type
import RepType
import SrcLoc
import Outputable
import Module           ( Module )
import qualified ErrUtils as Err
import Control.Applicative ((<|>))
import Control.Monad

lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                   => DynFlags
                   -> Module -- ^ module being compiled
                   -> Bool   -- ^ have we run Unarise yet?
                   -> String -- ^ who produced the STG?
                   -> [GenStgTopBinding a]
                   -> IO ()

lintStgTopBindings dflags this_mod unarised whodunnit binds
  = {-# SCC "StgLint" #-}
    case initL this_mod unarised top_level_binds (lint_binds binds) of
      Nothing  ->
        return ()
      Just msg -> do
        putLogMsg dflags NoReason Err.SevDump noSrcSpan
          (defaultDumpStyle dflags)
          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
                        text whodunnit <+> text "***",
                  msg,
                  text "*** Offending Program ***",
                  pprGenStgTopBindings binds,
                  text "*** End of Offense ***"])
        Err.ghcExit dflags 1
  where
    -- Bring all top-level binds into scope because CoreToStg does not generate
    -- bindings in dependency order (so we may see a use before its definition).
    top_level_binds = mkVarSet (bindersOfTopBinds binds)

    lint_binds :: [GenStgTopBinding a] -> LintM ()

    lint_binds [] = return ()
    lint_binds (bind:binds) = do
        binders <- lint_bind bind
        addInScopeVars binders $
            lint_binds binds

    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
    lint_bind (StgTopStringLit v _) = return [v]

lintStgArg :: StgArg -> LintM ()
lintStgArg (StgLitArg _) = return ()
lintStgArg (StgVarArg v) = lintStgVar v

lintStgVar :: Id -> LintM ()
lintStgVar id = checkInScope id

lintStgBinds
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
lintStgBinds top_lvl (StgNonRec binder rhs) = do
    lint_binds_help top_lvl (binder,rhs)
    return [binder]

lintStgBinds top_lvl (StgRec pairs)
  = addInScopeVars binders $ do
        mapM_ (lint_binds_help top_lvl) pairs
        return binders
  where
    binders = [b | (b,_) <- pairs]

lint_binds_help
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag
    -> (Id, GenStgRhs a)
    -> LintM ()
lint_binds_help top_lvl (binder, rhs)
  = addLoc (RhsOf binder) $ do
        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
        lintStgRhs rhs
        -- Check binder doesn't have unlifted type or it's a join point
        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
               (mkUnliftedTyMsg binder rhs)

-- | Top-level bindings can't inherit the cost centre stack from their
-- (static) allocation site.
checkNoCurrentCCS
    :: (OutputablePass a, BinderP a ~ Id)
    => GenStgRhs a
    -> LintM ()
checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
  | isCurrentCCS ccs
  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
  | isCurrentCCS ccs
  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
checkNoCurrentCCS _
  = return ()

lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()

lintStgRhs (StgRhsClosure _ _ _ [] expr)
  = lintStgExpr expr

lintStgRhs (StgRhsClosure _ _ _ binders expr)
  = addLoc (LambdaBodyOf binders) $
      addInScopeVars binders $
        lintStgExpr expr

lintStgRhs rhs@(StgRhsCon _ con args) = do
    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
               ppr rhs)
    mapM_ lintStgArg args
    mapM_ checkPostUnariseConArg args

lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()

lintStgExpr (StgLit _) = return ()

lintStgExpr (StgApp fun args) = do
    lintStgVar fun
    mapM_ lintStgArg args

lintStgExpr app@(StgConApp con args _arg_tys) = do
    -- unboxed sums should vanish during unarise
    lf <- getLintFlags
    when (lf_unarised lf && isUnboxedSumCon con) $
      addErrL (text "Unboxed sum after unarise:" $$
               ppr app)
    mapM_ lintStgArg args
    mapM_ checkPostUnariseConArg args

lintStgExpr (StgOpApp _ args _) =
    mapM_ lintStgArg args

lintStgExpr lam@(StgLam _ _) =
    addErrL (text "Unexpected StgLam" <+> ppr lam)

lintStgExpr (StgLet _ binds body) = do
    binders <- lintStgBinds NotTopLevel binds
    addLoc (BodyOfLetRec binders) $
      addInScopeVars binders $
        lintStgExpr body

lintStgExpr (StgLetNoEscape _ binds body) = do
    binders <- lintStgBinds NotTopLevel binds
    addLoc (BodyOfLetRec binders) $
      addInScopeVars binders $
        lintStgExpr body

lintStgExpr (StgTick _ expr) = lintStgExpr expr

lintStgExpr (StgCase scrut bndr alts_type alts) = do
    lintStgExpr scrut

    lf <- getLintFlags
    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)

    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)

lintAlt
    :: (OutputablePass a, BinderP a ~ Id)
    => (AltCon, [Id], GenStgExpr a) -> LintM ()

lintAlt (DEFAULT, _, rhs) =
    lintStgExpr rhs

lintAlt (LitAlt _, _, rhs) =
    lintStgExpr rhs

lintAlt (DataAlt _, bndrs, rhs) = do
    mapM_ checkPostUnariseBndr bndrs
    addInScopeVars bndrs (lintStgExpr rhs)

{-
************************************************************************
*                                                                      *
Utilities
*                                                                      *
************************************************************************
-}

bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
bindersOf (StgNonRec binder _) = [binder]
bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]

bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
bindersOfTop (StgTopLifted bind) = bindersOf bind
bindersOfTop (StgTopStringLit binder _) = [binder]

bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
bindersOfTopBinds = foldr ((++) . bindersOfTop) []

{-
************************************************************************
*                                                                      *
The Lint monad
*                                                                      *
************************************************************************
-}

newtype LintM a = LintM
    { unLintM :: Module
              -> LintFlags
              -> [LintLocInfo]     -- Locations
              -> IdSet             -- Local vars in scope
              -> Bag MsgDoc        -- Error messages so far
              -> (a, Bag MsgDoc)   -- Result and error messages (if any)
    }

data LintFlags = LintFlags { lf_unarised :: !Bool
                             -- ^ have we run the unariser yet?
                           }

data LintLocInfo
  = RhsOf Id            -- The variable bound
  | LambdaBodyOf [Id]   -- The lambda-binder
  | BodyOfLetRec [Id]   -- One of the binders

dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf v) =
  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
dumpLoc (LambdaBodyOf bs) =
  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )

dumpLoc (BodyOfLetRec bs) =
  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )

pp_binders :: [Id] -> SDoc
pp_binders bs
  = sep (punctuate comma (map pp_binder bs))
  where
    pp_binder b
      = hsep [ppr b, dcolon, ppr (idType b)]

initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
initL this_mod unarised locals (LintM m) = do
  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
  if isEmptyBag errs then
      Nothing
  else
      Just (vcat (punctuate blankLine (bagToList errs)))

instance Functor LintM where
      fmap = liftM

instance Applicative LintM where
      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
      (<*>) = ap
      (*>)  = thenL_

instance Monad LintM where
    (>>=) = thenL
    (>>)  = (*>)

thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k = LintM $ \mod lf loc scope errs
  -> case unLintM m mod lf loc scope errs of
      (r, errs') -> unLintM (k r) mod lf loc scope errs'

thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k = LintM $ \mod lf loc scope errs
  -> case unLintM m mod lf loc scope errs of
      (_, errs') -> unLintM k mod lf loc scope errs'

checkL :: Bool -> MsgDoc -> LintM ()
checkL True  _   = return ()
checkL False msg = addErrL msg

-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr bndr = do
    lf <- getLintFlags
    when (lf_unarised lf) $
      forM_ (checkPostUnariseId bndr) $ \unexpected ->
        addErrL $
          text "After unarisation, binder " <>
          ppr bndr <> text " has " <> text unexpected <> text " type " <>
          ppr (idType bndr)

-- Arguments shouldn't have sum, tuple, or void types.
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg arg = case arg of
    StgLitArg _ ->
      return ()
    StgVarArg id -> do
      lf <- getLintFlags
      when (lf_unarised lf) $
        forM_ (checkPostUnariseId id) $ \unexpected ->
          addErrL $
            text "After unarisation, arg " <>
            ppr id <> text " has " <> text unexpected <> text " type " <>
            ppr (idType id)

-- Post-unarisation args and case alt binders should not have unboxed tuple,
-- unboxed sum, or void types. Return what the binder is if it is one of these.
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId id =
    let
      id_ty = idType id
      is_sum, is_tuple, is_void :: Maybe String
      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
      is_void = guard (isVoidTy id_ty) >> return "void"
    in
      is_sum <|> is_tuple <|> is_void

addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)

addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr errs_so_far msg locs
  = errs_so_far `snocBag` mk_msg locs
  where
    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
                     in  mkLocMessage SevWarning l (hdr $$ msg)
    mk_msg []      = msg

addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m = LintM $ \mod lf loc scope errs
   -> unLintM m mod lf (extra_loc:loc) scope errs

addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars ids m = LintM $ \mod lf loc scope errs
 -> let
        new_set = mkVarSet ids
    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs

getLintFlags :: LintM LintFlags
getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)

checkInScope :: Id -> LintM ()
checkInScope id = LintM $ \mod _lf loc scope errs
 -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
                                text "is out of scope"]) loc)
    else
        ((), errs)

mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg binder rhs
  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
     text "has unlifted type" <+> quotes (ppr (idType binder)))
    $$
    (text "RHS:" <+> ppr rhs)


{-# LANGUAGE CPP #-}

module StgSubst where

#include "HsVersions.h"

import GhcPrelude

import Id
import VarEnv
import Control.Monad.Trans.State.Strict
import Outputable
import Util

-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
-- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but
-- with the domain being 'Id's instead of entire 'CoreExpr'.
data Subst = Subst InScopeSet IdSubstEnv

type IdSubstEnv = IdEnv Id

-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@
emptySubst :: Subst
emptySubst = mkEmptySubst emptyInScopeSet

-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'
-- are in scope.
mkEmptySubst :: InScopeSet -> Subst
mkEmptySubst in_scope = Subst in_scope emptyVarEnv

-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way
-- that avoids shadowing the 'InScopeSet', returning the result and an updated
-- 'Subst' that should be used by subsequent substitutions.
substBndr :: Id -> Subst -> (Id, Subst)
substBndr id (Subst in_scope env)
  = (new_id, Subst new_in_scope new_env)
  where
    new_id = uniqAway in_scope id
    no_change = new_id == id -- in case nothing shadowed
    new_in_scope = in_scope `extendInScopeSet` new_id
    new_env
      | no_change = delVarEnv env id
      | otherwise = extendVarEnv env id new_id

-- | @substBndrs = runState . traverse (state . substBndr)@
substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)
substBndrs = runState . traverse (state . substBndr)

-- | Substitutes an occurrence of an identifier for its counterpart recorded
-- in the 'Subst'.
lookupIdSubst :: HasCallStack => Id -> Subst -> Id
lookupIdSubst id (Subst in_scope env)
  | not (isLocalId id) = id
  | Just id' <- lookupVarEnv env id = id'
  | Just id' <- lookupInScope in_scope id = id'
  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)
                id

-- | Substitutes an occurrence of an identifier for its counterpart recorded
-- in the 'Subst'. Does not generate a debug warning if the identifier to
-- to substitute wasn't in scope.
noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
noWarnLookupIdSubst id (Subst in_scope env)
  | not (isLocalId id) = id
  | Just id' <- lookupVarEnv env id = id'
  | Just id' <- lookupInScope in_scope id = id'
  | otherwise = id

-- | Add the 'Id' to the in-scope set and remove any existing substitutions for
-- it.
extendInScope :: Id -> Subst -> Subst
extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env

-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the
-- in-scope set is such that TyCORep Note [The substitution invariant]
-- holds after extending the substitution like this.
extendSubst :: Id -> Id -> Subst -> Subst
extendSubst id new_id (Subst in_scope env)
  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )
    Subst in_scope (extendVarEnv env id new_id)


{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}

This data type represents programs just before code generation (conversion to
@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
being one that happens to be ideally suited to spineless tagless code
generation.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}

module StgSyn (
        StgArg(..),

        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
        GenStgAlt, AltType(..),

        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
        NoExtSilent, noExtSilent,
        OutputablePass,

        UpdateFlag(..), isUpdatable,

        -- a set of synonyms for the vanilla parameterisation
        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,

        -- a set of synonyms for the code gen parameterisation
        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,

        -- a set of synonyms for the lambda lifting parameterisation
        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,

        -- a set of synonyms to distinguish in- and out variants
        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,

        -- StgOp
        StgOp(..),

        -- utils
        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
        isDllConApp,
        stgArgType,
        stripStgTicksTop,
        stgCaseBndrInScope,

        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
    ) where

#include "HsVersions.h"

import GhcPrelude

import CoreSyn     ( AltCon, Tickish )
import CostCentre  ( CostCentreStack )
import Data.ByteString ( ByteString )
import Data.Data   ( Data )
import Data.List   ( intersperse )
import DataCon
import DynFlags
import FastString
import ForeignCall ( ForeignCall )
import Id
import IdInfo      ( mayHaveCafRefs )
import VarSet
import Literal     ( Literal, literalType )
import Module      ( Module )
import Outputable
import Packages    ( isDllName )
import Platform
import PprCore     ( {- instances -} )
import PrimOp      ( PrimOp, PrimCall )
import TyCon       ( PrimRep(..), TyCon )
import Type        ( Type )
import RepType     ( typePrimRep1 )
import Unique      ( Unique )
import Util

import Data.List.NonEmpty ( NonEmpty, toList )

{-
************************************************************************
*                                                                      *
\subsection{@GenStgBinding@}
*                                                                      *
************************************************************************

As usual, expressions are interesting; other things are boring. Here
are the boring things [except note the @GenStgRhs@], parameterised
with respect to binder and occurrence information (just as in
@CoreSyn@):
-}

-- | A top-level binding.
data GenStgTopBinding pass
-- See Note [CoreSyn top-level string literals]
  = StgTopLifted (GenStgBinding pass)
  | StgTopStringLit Id ByteString

data GenStgBinding pass
  = StgNonRec (BinderP pass) (GenStgRhs pass)
  | StgRec    [(BinderP pass, GenStgRhs pass)]

{-
************************************************************************
*                                                                      *
\subsection{@StgArg@}
*                                                                      *
************************************************************************
-}

data StgArg
  = StgVarArg  Id
  | StgLitArg  Literal

-- | Does this constructor application refer to
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags this_mod con args
 | platformOS (targetPlatform dflags) == OSMinGW32
    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args
 | otherwise = False
  where
    -- NB: typePrimRep1 is legit because any free variables won't have
    -- unlifted type (there are no unlifted things at top level)
    is_dll_arg :: StgArg -> Bool
    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
                             && isDllName dflags this_mod (idName v)
    is_dll_arg _             = False

-- True of machine addresses; these are the things that don't
-- work across DLLs. The key point here is that VoidRep comes
-- out False, so that a top level nullary GADT constructor is
-- False for isDllConApp
--    data T a where
--      T1 :: T Int
-- gives
--    T1 :: forall a. (a~Int) -> T a
-- and hence the top-level binding
--    $WT1 :: T Int
--    $WT1 = T1 Int (Coercion (Refl Int))
-- The coercion argument here gets VoidRep
isAddrRep :: PrimRep -> Bool
isAddrRep AddrRep     = True
isAddrRep LiftedRep   = True
isAddrRep UnliftedRep = True
isAddrRep _           = False

-- | Type of an @StgArg@
--
-- Very half baked because we have lost the type arguments.
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v)   = idType v
stgArgType (StgLitArg lit) = literalType lit

-- | Strip ticks of a given type from an STG expression
stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop p = go []
   where go ts (StgTick t e) | p t = go (t:ts) e
         go ts other               = (reverse ts, other)

-- | Given an alt type and whether the program is unarised, return whether the
-- case binder is in scope.
--
-- Case binders of unboxed tuple or unboxed sum type always dead after the
-- unariser has run. See Note [Post-unarisation invariants].
stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
stgCaseBndrInScope alt_ty unarised =
    case alt_ty of
      AlgAlt _      -> True
      PrimAlt _     -> True
      MultiValAlt _ -> not unarised
      PolyAlt       -> True

{-
************************************************************************
*                                                                      *
\subsection{STG expressions}
*                                                                      *
************************************************************************

The @GenStgExpr@ data type is parameterised on binder and occurrence
info, as before.

************************************************************************
*                                                                      *
\subsubsection{@GenStgExpr@ application}
*                                                                      *
************************************************************************

An application is of a function to a list of atoms [not expressions].
Operationally, we want to push the arguments on the stack and call the
function. (If the arguments were expressions, we would have to build
their closures first.)

There is no constructor for a lone variable; it would appear as
@StgApp var []@.
-}

data GenStgExpr pass
  = StgApp
        Id       -- function
        [StgArg] -- arguments; may be empty

{-
************************************************************************
*                                                                      *
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
*                                                                      *
************************************************************************

There are specialised forms of application, for constructors,
primitives, and literals.
-}

  | StgLit      Literal

        -- StgConApp is vital for returning unboxed tuples or sums
        -- which can't be let-bound first
  | StgConApp   DataCon
                [StgArg] -- Saturated
                [Type]   -- See Note [Types in StgConApp] in UnariseStg

  | StgOpApp    StgOp    -- Primitive op or foreign call
                [StgArg] -- Saturated.
                Type     -- Result type
                         -- We need to know this so that we can
                         -- assign result registers

{-
************************************************************************
*                                                                      *
\subsubsection{@StgLam@}
*                                                                      *
************************************************************************

StgLam is used *only* during CoreToStg's work. Before CoreToStg has
finished it encodes (\x -> e) as (let f = \x -> e in f)
TODO: Encode this via an extension to GenStgExpr Ã  la TTG.
-}

  | StgLam
        (NonEmpty (BinderP pass))
        StgExpr    -- Body of lambda

{-
************************************************************************
*                                                                      *
\subsubsection{@GenStgExpr@: case-expressions}
*                                                                      *
************************************************************************

This has the same boxed/unboxed business as Core case expressions.
-}

  | StgCase
        (GenStgExpr pass) -- the thing to examine
        (BinderP pass) -- binds the result of evaluating the scrutinee
        AltType
        [GenStgAlt pass]
                    -- The DEFAULT case is always *first*
                    -- if it is there at all

{-
************************************************************************
*                                                                      *
\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
*                                                                      *
************************************************************************

The various forms of let(rec)-expression encode most of the
interesting things we want to do.
\begin{enumerate}
\item
\begin{verbatim}
let-closure x = [free-vars] [args] expr
in e
\end{verbatim}
is equivalent to
\begin{verbatim}
let x = (\free-vars -> \args -> expr) free-vars
\end{verbatim}
\tr{args} may be empty (and is for most closures).  It isn't under
circumstances like this:
\begin{verbatim}
let x = (\y -> y+z)
\end{verbatim}
This gets mangled to
\begin{verbatim}
let-closure x = [z] [y] (y+z)
\end{verbatim}
The idea is that we compile code for @(y+z)@ in an environment in which
@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
offset from the stack pointer.

(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)

\item
\begin{verbatim}
let-constructor x = Constructor [args]
in e
\end{verbatim}

(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)

\item
Letrec-expressions are essentially the same deal as
let-closure/let-constructor, so we use a common structure and
distinguish between them with an @is_recursive@ boolean flag.

\item
\begin{verbatim}
let-unboxed u = an arbitrary arithmetic expression in unboxed values
in e
\end{verbatim}
All the stuff on the RHS must be fully evaluated.
No function calls either!

(We've backed away from this toward case-expressions with
suitably-magical alts ...)

\item
~[Advanced stuff here! Not to start with, but makes pattern matching
generate more efficient code.]

\begin{verbatim}
let-escapes-not fail = expr
in e'
\end{verbatim}
Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
or pass it to another function. All @e'@ will ever do is tail-call @fail@.
Rather than build a closure for @fail@, all we need do is to record the stack
level at the moment of the @let-escapes-not@; then entering @fail@ is just
a matter of adjusting the stack pointer back down to that point and entering
the code for it.

Another example:
\begin{verbatim}
f x y = let z = huge-expression in
        if y==1 then z else
        if y==2 then z else
        1
\end{verbatim}

(A let-escapes-not is an @StgLetNoEscape@.)

\item
We may eventually want:
\begin{verbatim}
let-literal x = Literal
in e
\end{verbatim}
\end{enumerate}

And so the code for let(rec)-things:
-}

  | StgLet
        (XLet pass)
        (GenStgBinding pass)    -- right hand sides (see below)
        (GenStgExpr pass)       -- body

  | StgLetNoEscape
        (XLetNoEscape pass)
        (GenStgBinding pass)    -- right hand sides (see below)
        (GenStgExpr pass)       -- body

{-
%************************************************************************
%*                                                                      *
\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
%*                                                                      *
%************************************************************************

Finally for @hpc@ expressions we introduce a new STG construct.
-}

  | StgTick
    (Tickish Id)
    (GenStgExpr pass)       -- sub expression

-- END of GenStgExpr

{-
************************************************************************
*                                                                      *
\subsection{STG right-hand sides}
*                                                                      *
************************************************************************

Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
-}

data GenStgRhs pass
  = StgRhsClosure
        (XRhsClosure pass) -- ^ Extension point for non-global free var
                           --   list just before 'CodeGen'.
        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)
        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
        [BinderP pass]     -- ^ arguments; if empty, then not a function;
                           --   as above, order is important.
        (GenStgExpr pass)  -- ^ body

{-
An example may be in order.  Consider:
\begin{verbatim}
let t = \x -> \y -> ... x ... y ... p ... q in e
\end{verbatim}
Pulling out the free vars and stylising somewhat, we get the equivalent:
\begin{verbatim}
let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
\end{verbatim}
Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
offsets from @Node@ into the closure, and the code ptr for the closure
will be exactly that in parentheses above.

The second flavour of right-hand-side is for constructors (simple but important):
-}

  | StgRhsCon
        CostCentreStack -- CCS to be attached (default is CurrentCCS).
                        -- Top-level (static) ones will end up with
                        -- DontCareCCS, because we don't count static
                        -- data in heap profiles, and we don't set CCCS
                        -- from static closure.
        DataCon         -- Constructor. Never an unboxed tuple or sum, as those
                        -- are not allocated.
        [StgArg]        -- Args

-- | Used as a data type index for the stgSyn AST
data StgPass
  = Vanilla
  | LiftLams
  | CodeGen

-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
-- 'empty'.
data NoExtSilent = NoExtSilent
  deriving (Data, Eq, Ord)

instance Outputable NoExtSilent where
  ppr _ = empty

-- | Used when constructing a term with an unused extension point that should
-- not appear in pretty-printed output at all.
noExtSilent :: NoExtSilent
noExtSilent = NoExtSilent
-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
-- on build time...

-- TODO: Do we really want to the extension point type families to have a closed
-- domain?
type family BinderP (pass :: StgPass)
type instance BinderP 'Vanilla = Id
type instance BinderP 'CodeGen = Id

type family XRhsClosure (pass :: StgPass)
type instance XRhsClosure 'Vanilla = NoExtSilent
-- | Code gen needs to track non-global free vars
type instance XRhsClosure 'CodeGen = DIdSet

type family XLet (pass :: StgPass)
type instance XLet 'Vanilla = NoExtSilent
type instance XLet 'CodeGen = NoExtSilent

type family XLetNoEscape (pass :: StgPass)
type instance XLetNoEscape 'Vanilla = NoExtSilent
type instance XLetNoEscape 'CodeGen = NoExtSilent

stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure _ _ _ bndrs _)
  = ASSERT( all isId bndrs ) length bndrs
  -- The arity never includes type parameters, but they should have gone by now
stgRhsArity (StgRhsCon _ _ _) = 0

-- Note [CAF consistency]
-- ~~~~~~~~~~~~~~~~~~~~~~
--
-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
-- reality.
--
-- Specifically, if the RHS mentions any Id that itself is marked
-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
-- have taken place since then.

topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
  = topRhsHasCafRefs rhs
topStgBindHasCafRefs (StgTopLifted (StgRec binds))
  = any topRhsHasCafRefs (map snd binds)
topStgBindHasCafRefs StgTopStringLit{}
  = False

topRhsHasCafRefs :: GenStgRhs pass -> Bool
topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
  = -- See Note [CAF consistency]
    isUpdatable upd || exprHasCafRefs body
topRhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

exprHasCafRefs :: GenStgExpr pass -> Bool
exprHasCafRefs (StgApp f args)
  = stgIdHasCafRefs f || any stgArgHasCafRefs args
exprHasCafRefs StgLit{}
  = False
exprHasCafRefs (StgConApp _ args _)
  = any stgArgHasCafRefs args
exprHasCafRefs (StgOpApp _ args _)
  = any stgArgHasCafRefs args
exprHasCafRefs (StgLam _ body)
  = exprHasCafRefs body
exprHasCafRefs (StgCase scrt _ _ alts)
  = exprHasCafRefs scrt || any altHasCafRefs alts
exprHasCafRefs (StgLet _ bind body)
  = bindHasCafRefs bind || exprHasCafRefs body
exprHasCafRefs (StgLetNoEscape _ bind body)
  = bindHasCafRefs bind || exprHasCafRefs body
exprHasCafRefs (StgTick _ expr)
  = exprHasCafRefs expr

bindHasCafRefs :: GenStgBinding pass -> Bool
bindHasCafRefs (StgNonRec _ rhs)
  = rhsHasCafRefs rhs
bindHasCafRefs (StgRec binds)
  = any rhsHasCafRefs (map snd binds)

rhsHasCafRefs :: GenStgRhs pass -> Bool
rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
  = exprHasCafRefs body
rhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

altHasCafRefs :: GenStgAlt pass -> Bool
altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs

stgArgHasCafRefs :: StgArg -> Bool
stgArgHasCafRefs (StgVarArg id)
  = stgIdHasCafRefs id
stgArgHasCafRefs _
  = False

stgIdHasCafRefs :: Id -> Bool
stgIdHasCafRefs id =
  -- We are looking for occurrences of an Id that is bound at top level, and may
  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
  -- imported or defined in this module) are GlobalIds, so the test is easy.
  isGlobalId id && mayHaveCafRefs (idCafInfo id)

{-
************************************************************************
*                                                                      *
\subsection[Stg-case-alternatives]{STG case alternatives}
*                                                                      *
************************************************************************

Very like in @CoreSyntax@ (except no type-world stuff).

The type constructor is guaranteed not to be abstract; that is, we can
see its representation. This is important because the code generator
uses it to determine return conventions etc. But it's not trivial
where there's a module loop involved, because some versions of a type
constructor might not have all the constructors visible. So
mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
constructors or literals (which are guaranteed to have the Real McCoy)
rather than from the scrutinee type.
-}

type GenStgAlt pass
  = (AltCon,          -- alts: data constructor,
     [BinderP pass],  -- constructor's parameters,
     GenStgExpr pass) -- ...right-hand side.

data AltType
  = PolyAlt             -- Polymorphic (a lifted type variable)
  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
                        -- the arity could indeed be 1 for unary unboxed tuple
                        -- or enum-like unboxed sums
  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts

{-
************************************************************************
*                                                                      *
\subsection[Stg]{The Plain STG parameterisation}
*                                                                      *
************************************************************************

This happens to be the only one we use at the moment.
-}

type StgTopBinding = GenStgTopBinding 'Vanilla
type StgBinding    = GenStgBinding    'Vanilla
type StgExpr       = GenStgExpr       'Vanilla
type StgRhs        = GenStgRhs        'Vanilla
type StgAlt        = GenStgAlt        'Vanilla

type LlStgTopBinding = GenStgTopBinding 'LiftLams
type LlStgBinding    = GenStgBinding    'LiftLams
type LlStgExpr       = GenStgExpr       'LiftLams
type LlStgRhs        = GenStgRhs        'LiftLams
type LlStgAlt        = GenStgAlt        'LiftLams

type CgStgTopBinding = GenStgTopBinding 'CodeGen
type CgStgBinding    = GenStgBinding    'CodeGen
type CgStgExpr       = GenStgExpr       'CodeGen
type CgStgRhs        = GenStgRhs        'CodeGen
type CgStgAlt        = GenStgAlt        'CodeGen

{- Many passes apply a substitution, and it's very handy to have type
   synonyms to remind us whether or not the substitution has been applied.
   See CoreSyn for precedence in Core land
-}

type InStgTopBinding  = StgTopBinding
type InStgBinding     = StgBinding
type InStgArg         = StgArg
type InStgExpr        = StgExpr
type InStgRhs         = StgRhs
type InStgAlt         = StgAlt
type OutStgTopBinding = StgTopBinding
type OutStgBinding    = StgBinding
type OutStgArg        = StgArg
type OutStgExpr       = StgExpr
type OutStgRhs        = StgRhs
type OutStgAlt        = StgAlt

{-

************************************************************************
*                                                                      *
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
*                                                                      *
************************************************************************

This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.

A @ReEntrant@ closure may be entered multiple times, but should not be
updated or blackholed. An @Updatable@ closure should be updated after
evaluation (and may be blackholed during evaluation). A @SingleEntry@
closure will only be entered once, and so need not be updated but may
safely be blackholed.
-}

data UpdateFlag = ReEntrant | Updatable | SingleEntry

instance Outputable UpdateFlag where
    ppr u = char $ case u of
                       ReEntrant   -> 'r'
                       Updatable   -> 'u'
                       SingleEntry -> 's'

isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True

{-
************************************************************************
*                                                                      *
\subsubsection{StgOp}
*                                                                      *
************************************************************************

An StgOp allows us to group together PrimOps and ForeignCalls.
It's quite useful to move these around together, notably
in StgOpApp and COpStmt.
-}

data StgOp
  = StgPrimOp  PrimOp

  | StgPrimCallOp PrimCall

  | StgFCallOp ForeignCall Unique
        -- The Unique is occasionally needed by the C pretty-printer
        -- (which lacks a unique supply), notably when generating a
        -- typedef for foreign-export-dynamic

{-
************************************************************************
*                                                                      *
\subsection[Stg-pretty-printing]{Pretty-printing}
*                                                                      *
************************************************************************

Robin Popplestone asked for semi-colon separators on STG binds; here's
hoping he likes terminators instead...  Ditto for case alternatives.
-}

type OutputablePass pass =
  ( Outputable (XLet pass)
  , Outputable (XLetNoEscape pass)
  , Outputable (XRhsClosure pass)
  , OutputableBndr (BinderP pass)
  )

pprGenStgTopBinding
  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
pprGenStgTopBinding (StgTopStringLit bndr str)
  = hang (hsep [pprBndr LetBind bndr, equals])
        4 (pprHsBytes str <> semi)
pprGenStgTopBinding (StgTopLifted bind)
  = pprGenStgBinding bind

pprGenStgBinding
  :: OutputablePass pass => GenStgBinding pass -> SDoc

pprGenStgBinding (StgNonRec bndr rhs)
  = hang (hsep [pprBndr LetBind bndr, equals])
        4 (ppr rhs <> semi)

pprGenStgBinding (StgRec pairs)
  = vcat [ text "Rec {"
         , vcat (map ppr_bind pairs)
         , text "end Rec }" ]
  where
    ppr_bind (bndr, expr)
      = hang (hsep [pprBndr LetBind bndr, equals])
             4 (ppr expr <> semi)

pprGenStgTopBindings
  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings binds
  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)

pprStgBinding :: StgBinding -> SDoc
pprStgBinding = pprGenStgBinding

pprStgTopBindings :: [StgTopBinding] -> SDoc
pprStgTopBindings = pprGenStgTopBindings

instance Outputable StgArg where
    ppr = pprStgArg

instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
    ppr = pprGenStgTopBinding

instance OutputablePass pass => Outputable (GenStgBinding pass) where
    ppr = pprGenStgBinding

instance OutputablePass pass => Outputable (GenStgExpr pass) where
    ppr = pprStgExpr

instance OutputablePass pass => Outputable (GenStgRhs pass) where
    ppr rhs = pprStgRhs rhs

pprStgArg :: StgArg -> SDoc
pprStgArg (StgVarArg var) = ppr var
pprStgArg (StgLitArg con) = ppr con

pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
-- special case
pprStgExpr (StgLit lit)     = ppr lit

-- general case
pprStgExpr (StgApp func args)
  = hang (ppr func) 4 (sep (map (ppr) args))

pprStgExpr (StgConApp con args _)
  = hsep [ ppr con, brackets (interppSP args) ]

pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]

pprStgExpr (StgLam bndrs body)
  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
            <+> text "->",
         pprStgExpr body ]
  where ppr_list = brackets . fsep . punctuate comma

-- special case: let v = <very specific thing>
--               in
--               let ...
--               in
--               ...
--
-- Very special!  Suspicious! (SLPJ)

{-
pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
                        expr@(StgLet _ _))
  = ($$)
      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
                          ppr cc,
                          pp_binder_info bi,
                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),
                          ppr upd_flag, text " [",
                          interppSP args, char ']'])
            8 (sep [hsep [ppr rhs, text "} in"]]))
      (ppr expr)
-}

-- special case: let ... in let ...

pprStgExpr (StgLet ext bind expr@StgLet{})
  = ($$)
      (sep [hang (text "let" <+> ppr ext <+> text "{")
                2 (hsep [pprGenStgBinding bind, text "} in"])])
      (ppr expr)

-- general case
pprStgExpr (StgLet ext bind expr)
  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
           hang (text "} in ") 2 (ppr expr)]

pprStgExpr (StgLetNoEscape ext bind expr)
  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
                2 (pprGenStgBinding bind),
           hang (text "} in ")
                2 (ppr expr)]

pprStgExpr (StgTick tickish expr)
  = sdocWithDynFlags $ \dflags ->
    if gopt Opt_SuppressTicks dflags
    then pprStgExpr expr
    else sep [ ppr tickish, pprStgExpr expr ]

pprStgExpr (StgCase expr bndr alt_type alts)
  = sep [sep [text "case",
           nest 4 (hsep [pprStgExpr expr,
             whenPprDebug (dcolon <+> ppr alt_type)]),
           text "of", pprBndr CaseBind bndr, char '{'],
           nest 2 (vcat (map pprStgAlt alts)),
           char '}']

pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
pprStgAlt (con, params, expr)
  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
         4 (ppr expr <> semi)

pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp  op)   = ppr op
pprStgOp (StgPrimCallOp op)= ppr op
pprStgOp (StgFCallOp op _) = ppr op

instance Outputable AltType where
  ppr PolyAlt         = text "Polymorphic"
  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc

pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc

-- special case
pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
  = sdocWithDynFlags $ \dflags ->
    hsep [ ppr cc,
           if not $ gopt Opt_SuppressStgExts dflags
             then ppr ext else empty,
           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]

-- general case
pprStgRhs (StgRhsClosure ext cc upd_flag args body)
  = sdocWithDynFlags $ \dflags ->
    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
                if not $ gopt Opt_SuppressStgExts dflags
                  then ppr ext else empty,
                char '\\' <> ppr upd_flag, brackets (interppSP args)])
         4 (ppr body)

pprStgRhs (StgRhsCon cc con args)
  = hcat [ ppr cc,
           space, ppr con, text "! ", brackets (interppSP args)]