Module hierarchy (#13009): Stg

5 files changed, 0 insertions, 2416 deletions

diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
deleted file mode 100644
index 4982ad68f4..0000000000
--- a/compiler/stgSyn/CoreToStg.hs
+++ /dev/null
@@ -1,939 +0,0 @@
-{-# LANGUAGE CPP, DeriveFunctor #-}
-
---
--- (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(..), primOpWrapperId )
-import SrcLoc           ( mkGeneralSrcSpan )
-
-import Data.List.NonEmpty (nonEmpty, toList)
-import Data.Maybe    (fromMaybe)
-import Control.Monad (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 dflags env $
-              coreToTopStgRhs dflags ccs this_mod (id,rhs)
-
-        bind = StgTopLifted $ StgNonRec id stg_rhs
-    in
-    assertConsistentCafInfo dflags id bind (ppr bind)
-      -- 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 dflags 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
-    assertConsistentCafInfo dflags (head binders) bind (ppr binders)
-    (env', ccs', bind)
-
--- | CAF consistency issues will generally result in segfaults and are quite
--- difficult to debug (see #16846). We enable checking of the
--- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that
--- we catch these issues.
-assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
-assertConsistentCafInfo dflags id bind err_doc result
-  | gopt Opt_DoStgLinting dflags || debugIsOn
-  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc
-  | otherwise = result
-
--- 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
-        --      (#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 v               [] []
-coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] []
-
-coreToStgExpr expr@(App _ _)
-  = coreToStgApp 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 :: 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.
-                -- As described in Note [Primop wrappers] in PrimOp.hs, here we
-                -- turn unsaturated primop applications into applications of
-                -- the primop's wrapper.
-                PrimOpId op
-                  | saturated    -> StgOpApp (StgPrimOp op) args' res_ty
-                  | otherwise    -> StgApp (primOpWrapperId op) args'
-
-                -- 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 (idType 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
-
-    dflags <- getDynFlags
-    let
-        arg_rep = typePrimRep (exprType arg)
-        stg_arg_rep = typePrimRep (stgArgType stg_arg)
-        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)
-
-    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 noExtFieldSilent bind2 body2
-                | otherwise       = StgLet noExtFieldSilent 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 noExtFieldSilent
-                    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 noExtFieldSilent
-                    caf_ccs
-                    upd_flag [] rhs
-    , collectCC caf_cc caf_ccs ccs )
-
-  | otherwise
-  = ( StgRhsClosure noExtFieldSilent
-                    all_cafs_ccs
-                    upd_flag [] rhs
-    , ccs )
-
-  where
-    unticked_rhs = stripStgTicksTopE (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 noExtFieldSilent
-                  currentCCS
-                  ReEntrant
-                  (toList bndrs) body
-
-  | isJoinId bndr -- must be a nullary join point
-  = ASSERT(idJoinArity bndr == 0)
-    StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  ReEntrant -- ignored for LNE
-                  [] rhs
-
-  | StgConApp con args _ <- unticked_rhs
-  = StgRhsCon currentCCS con args
-
-  | otherwise
-  = StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  upd_flag [] rhs
-  where
-    unticked_rhs = stripStgTicksTopE (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 :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
-             -> IdEnv HowBound
-             -> a
-    }
-    deriving (Functor)
-
-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 :: DynFlags -> IdEnv HowBound -> CtsM a -> a
-initCts dflags env m = unCtsM m dflags 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 $ \dflags env
-  -> unCtsM (k (unCtsM m dflags env)) dflags env
-
-instance Applicative CtsM where
-    pure = returnCts
-    (<*>) = ap
-
-instance Monad CtsM where
-    (>>=)  = thenCts
-
-instance HasDynFlags CtsM where
-    getDynFlags = CtsM $ \dflags _ -> dflags
-
--- Functions specific to this monad:
-
-extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
-extendVarEnvCts ids_w_howbound expr
-   =    CtsM $   \dflags env
-   -> unCtsM expr dflags (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
diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
deleted file mode 100644
index ad02642aa9..0000000000
--- a/compiler/stgSyn/StgFVs.hs
+++ /dev/null
@@ -1,130 +0,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 [Tracking 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 [Tracking 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 [Tracking 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 [Tracking 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 [Tracking 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 [Tracking local binders]
-    (e', rhs_fvs) = expr (addLocals bndrs env) e
-    fvs = delDVarSetList rhs_fvs bndrs
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
deleted file mode 100644
index f83b44859c..0000000000
--- a/compiler/stgSyn/StgLint.hs
+++ /dev/null
@@ -1,396 +0,0 @@
-{- |
-(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,
-  DeriveFunctor #-}
-
-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)
-    }
-    deriving (Functor)
-
-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 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)
diff --git a/compiler/stgSyn/StgSubst.hs b/compiler/stgSyn/StgSubst.hs
deleted file mode 100644
index 0616c6c529..0000000000
--- a/compiler/stgSyn/StgSubst.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# 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 TyCoSubst 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)
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
deleted file mode 100644
index 052ef2b6c7..0000000000
--- a/compiler/stgSyn/StgSyn.hs
+++ /dev/null
@@ -1,871 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-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,
-        NoExtFieldSilent, noExtFieldSilent,
-        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, stripStgTicksTopE,
-        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 ForeignCall ( ForeignCall )
-import Id
-import IdInfo      ( mayHaveCafRefs )
-import VarSet
-import Literal     ( Literal, literalType )
-import Module      ( Module )
-import Outputable
-import Packages    ( isDllName )
-import GHC.Platform
-import PprCore     ( {- instances -} )
-import PrimOp      ( PrimOp, PrimCall )
-import TyCon       ( PrimRep(..), TyCon )
-import Type        ( Type )
-import RepType     ( typePrimRep1 )
-import Util
-
-import Data.List.NonEmpty ( NonEmpty, toList )
-
-{-
-************************************************************************
-*                                                                      *
-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)]
-
-{-
-************************************************************************
-*                                                                      *
-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)
-
--- | Strip ticks of a given type from an STG expression returning only the expression.
-stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
-stripStgTicksTopE p = go
-   where go (StgTick t e) | p t = go e
-         go other               = 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
-
-{-
-************************************************************************
-*                                                                      *
-STG expressions
-*                                                                      *
-************************************************************************
-
-The @GenStgExpr@ data type is parameterised on binder and occurrence info, as
-before.
-
-************************************************************************
-*                                                                      *
-GenStgExpr
-*                                                                      *
-************************************************************************
-
-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
-
-{-
-************************************************************************
-*                                                                      *
-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
-  | 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
-
-{-
-************************************************************************
-*                                                                      *
-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
-
-{-
-************************************************************************
-*                                                                      *
-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
-
-{-
-************************************************************************
-*                                                                      *
-GenStgExpr: let(rec)-expressions
-*                                                                      *
-************************************************************************
-
-The various forms of let(rec)-expression encode most of the interesting things
-we want to do.
-
--   let-closure x = [free-vars] [args] expr in e
-
-  is equivalent to
-
-    let x = (\free-vars -> \args -> expr) free-vars
-
-  @args@ may be empty (and is for most closures). It isn't under circumstances
-  like this:
-
-    let x = (\y -> y+z)
-
-  This gets mangled to
-
-    let-closure x = [z] [y] (y+z)
-
-  The idea is that we compile code for @(y+z)@ in an environment in which @z@ is
-  bound to an offset from Node, and `y` is bound to an offset from the stack
-  pointer.
-
-  (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
-
--   let-constructor x = Constructor [args] in e
-
-  (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
-
-- 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.
-
--   let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e
-
-  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 ...)
-
-- Advanced stuff here! Not to start with, but makes pattern matching generate
-  more efficient code.
-
-    let-escapes-not fail = expr
-    in e'
-
-  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:
-
-    f x y = let z = huge-expression in
-            if y==1 then z else
-            if y==2 then z else
-            1
-
-  (A let-escapes-not is an @StgLetNoEscape@.)
-
-- We may eventually want:
-
-    let-literal x = Literal in e
-
-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
-
-{-
-*************************************************************************
-*                                                                      *
-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
-
-{-
-************************************************************************
-*                                                                      *
-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:
-
-  let t = \x -> \y -> ... x ... y ... p ... q in e
-
-Pulling out the free vars and stylising somewhat, we get the equivalent:
-
-  let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
-
-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 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that
--- returns 'empty'.
-data NoExtFieldSilent = NoExtFieldSilent
-  deriving (Data, Eq, Ord)
-
-instance Outputable NoExtFieldSilent where
-  ppr _ = empty
-
--- | Used when constructing a term with an unused extension point that should
--- not appear in pretty-printed output at all.
-noExtFieldSilent :: NoExtFieldSilent
-noExtFieldSilent = NoExtFieldSilent
--- TODO: Maybe move this to GHC.Hs.Extension? 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 = NoExtFieldSilent
--- | Code gen needs to track non-global free vars
-type instance XRhsClosure 'CodeGen = DIdSet
-
-type family XLet (pass :: StgPass)
-type instance XLet 'Vanilla = NoExtFieldSilent
-type instance XLet 'CodeGen = NoExtFieldSilent
-
-type family XLetNoEscape (pass :: StgPass)
-type instance XLetNoEscape 'Vanilla = NoExtFieldSilent
-type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
-
-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)
-
-{-
-************************************************************************
-*                                                                      *
-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
-
-{-
-************************************************************************
-*                                                                      *
-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
-
-{-
-
-************************************************************************
-*                                                                      *
-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
-
-{-
-************************************************************************
-*                                                                      *
-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 Type
-        -- The Type, which is obtained from the foreign import declaration
-        -- itself, is needed by the stg-to-cmm pass to determine the offset to
-        -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note
-        -- [Unlifted boxed arguments to foreign calls]
-
-{-
-************************************************************************
-*                                                                      *
-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 (intersperse blankLine (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 ]
-
-
--- Don't indent for a single case alternative.
-pprStgExpr (StgCase expr bndr alt_type [alt])
-  = sep [sep [text "case",
-           nest 4 (hsep [pprStgExpr expr,
-             whenPprDebug (dcolon <+> ppr alt_type)]),
-           text "of", pprBndr CaseBind bndr, char '{'],
-           pprStgAlt False alt,
-           char '}']
-
-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 True) alts)),
-           char '}']
-
-
-pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
-pprStgAlt indent (con, params, expr)
-  | indent    = hang altPattern 4 (ppr expr <> semi)
-  | otherwise = sep [altPattern, ppr expr <> semi]
-    where
-      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
-
-
-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
-
-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)]