packages feed

ghc-lib 0.20191201 → 0.20200102

raw patch · 115 files changed

+9034/−8675 lines, 115 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

+ compiler/GHC/CoreToStg.hs view
@@ -0,0 +1,939 @@+{-# 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 GHC.CoreToStg ( coreToStg ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import CoreUtils        ( exprType, findDefault, isJoinBind+                        , exprIsTickedString_maybe )+import CoreArity        ( manifestArity )+import GHC.Stg.Syntax++import Type+import GHC.Types.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
+ compiler/GHC/CoreToStg/Prep.hs view
@@ -0,0 +1,1733 @@+{-+(c) The University of Glasgow, 1994-2006+++Core pass to saturate constructors and PrimOps+-}++{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}++module GHC.CoreToStg.Prep (+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,+      lookupMkIntegerName, lookupIntegerSDataConName,+      lookupMkNaturalName, lookupNaturalSDataConName+  ) where++#include "HsVersions.h"++import GhcPrelude++import OccurAnal++import HscTypes+import PrelNames+import MkId             ( realWorldPrimId )+import CoreUtils+import CoreArity+import CoreFVs+import CoreMonad        ( CoreToDo(..) )+import CoreLint         ( endPassIO )+import CoreSyn+import CoreSubst+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here+import Type+import Literal+import Coercion+import TcEnv+import TyCon+import Demand+import Var+import VarSet+import VarEnv+import Id+import IdInfo+import TysWiredIn+import DataCon+import BasicTypes+import Module+import UniqSupply+import Maybes+import OrdList+import ErrUtils+import DynFlags+import Util+import Outputable+import GHC.Platform+import FastString+import Name             ( NamedThing(..), nameSrcSpan )+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import Data.Bits+import MonadUtils       ( mapAccumLM )+import Data.List        ( mapAccumL )+import Control.Monad+import CostCentre       ( CostCentre, ccFromThisModule )+import qualified Data.Set as S++{-+-- ---------------------------------------------------------------------------+-- Note [CorePrep Overview]+-- ---------------------------------------------------------------------------++The goal of this pass is to prepare for code generation.++1.  Saturate constructor applications.++2.  Convert to A-normal form; that is, function arguments+    are always variables.++    * Use case for strict arguments:+        f E ==> case E of x -> f x+        (where f is strict)++    * Use let for non-trivial lazy arguments+        f E ==> let x = E in f x+        (were f is lazy and x is non-trivial)++3.  Similarly, convert any unboxed lets into cases.+    [I'm experimenting with leaving 'ok-for-speculation'+     rhss in let-form right up to this point.]++4.  Ensure that *value* lambdas only occur as the RHS of a binding+    (The code generator can't deal with anything else.)+    Type lambdas are ok, however, because the code gen discards them.++5.  [Not any more; nuked Jun 2002] Do the seq/par munging.++6.  Clone all local Ids.+    This means that all such Ids are unique, rather than the+    weaker guarantee of no clashes which the simplifier provides.+    And that is what the code generator needs.++    We don't clone TyVars or CoVars. The code gen doesn't need that,+    and doing so would be tiresome because then we'd need+    to substitute in types and coercions.++7.  Give each dynamic CCall occurrence a fresh unique; this is+    rather like the cloning step above.++8.  Inject bindings for the "implicit" Ids:+        * Constructor wrappers+        * Constructor workers+    We want curried definitions for all of these in case they+    aren't inlined by some caller.++9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs+    Also replace (noinline e) by e.++10. Convert (LitInteger i t) into the core representation+    for the Integer i. Normally this uses mkInteger, but if+    we are using the integer-gmp implementation then there is a+    special case where we use the S# constructor for Integers that+    are in the range of Int.++11. Same for LitNatural.++12. Uphold tick consistency while doing this: We move ticks out of+    (non-type) applications where we can, and make sure that we+    annotate according to scoping rules when floating.++13. Collect cost centres (including cost centres in unfoldings) if we're in+    profiling mode. We have to do this here beucase we won't have unfoldings+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].++This is all done modulo type applications and abstractions, so that+when type erasure is done for conversion to STG, we don't end up with+any trivial or useless bindings.+++Note [CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the syntax of the Core produced by CorePrep:++    Trivial expressions+       arg ::= lit |  var+              | arg ty  |  /\a. arg+              | truv co  |  /\c. arg  |  arg |> co++    Applications+       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co++    Expressions+       body ::= app+              | let(rec) x = rhs in body     -- Boxed only+              | case body of pat -> body+              | /\a. body | /\c. body+              | body |> co++    Right hand sides (only place where value lambdas can occur)+       rhs ::= /\a.rhs  |  \x.rhs  |  body++We define a synonym for each of these non-terminals.  Functions+with the corresponding name produce a result in that syntax.+-}++type CpeArg  = CoreExpr    -- Non-terminal 'arg'+type CpeApp  = CoreExpr    -- Non-terminal 'app'+type CpeBody = CoreExpr    -- Non-terminal 'body'+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'++{-+************************************************************************+*                                                                      *+                Top level stuff+*                                                                      *+************************************************************************+-}++corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]+            -> IO (CoreProgram, S.Set CostCentre)+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =+    withTiming dflags+               (text "CorePrep"<+>brackets (ppr this_mod))+               (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env++    let cost_centres+          | WayProf `elem` ways dflags+          = collectCostCentres this_mod binds+          | otherwise+          = S.empty++        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons+            -- NB: we must feed mkImplicitBinds through corePrep too+            -- so that they are suitably cloned and eta-expanded++        binds_out = initUs_ us $ do+                      floats1 <- corePrepTopBinds initialCorePrepEnv binds+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds+                      return (deFloatTop (floats1 `appendFloats` floats2))++    endPassIO hsc_env alwaysQualify CorePrep binds_out []+    return (binds_out, cost_centres)+  where+    dflags = hsc_dflags hsc_env++corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr+corePrepExpr dflags hsc_env expr =+    withTiming dflags (text "CorePrep [expr]") (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env+    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+    return new_expr++corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats+-- Note [Floating out of top level bindings]+corePrepTopBinds initialCorePrepEnv binds+  = go initialCorePrepEnv binds+  where+    go _   []             = return emptyFloats+    go env (bind : binds) = do (env', floats, maybe_new_bind)+                                 <- cpeBind TopLevel env bind+                               MASSERT(isNothing maybe_new_bind)+                                 -- Only join points get returned this way by+                                 -- cpeBind, and no join point may float to top+                               floatss <- go env' binds+                               return (floats `appendFloats` floatss)++mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in TidyPgm+mkDataConWorkers dflags mod_loc data_tycons+  = [ NonRec id (tick_it (getName data_con) (Var id))+                                -- The ice is thin here, but it works+    | tycon <- data_tycons,     -- CorePrep will eta-expand it+      data_con <- tyConDataCons tycon,+      let id = dataConWorkId data_con+    ]+ where+   -- If we want to generate debug info, we put a source note on the+   -- worker. This is useful, especially for heap profiling.+   tick_it name+     | debugLevel dflags == 0                = id+     | RealSrcSpan span <- nameSrcSpan name  = tick span+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)+     | otherwise                             = tick (span1 "???")+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++{-+Note [Floating out of top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: we do need to float out of top-level bindings+Consider        x = length [True,False]+We want to get+                s1 = False : []+                s2 = True  : s1+                x  = length s2++We return a *list* of bindings, because we may start with+        x* = f (g y)+where x is demanded, in which case we want to finish with+        a = g y+        x* = f a+And then x will actually end up case-bound++Note [CafInfo and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we try to float bindings to the top level?  At this+point all the CafInfo is supposed to be correct, and we must make certain+that is true of the new top-level bindings.  There are two cases+to consider++a) The top-level binding is marked asCafRefs.  In that case we are+   basically fine.  The floated bindings had better all be lazy lets,+   so they can float to top level, but they'll all have HasCafRefs+   (the default) which is safe.++b) The top-level binding is marked NoCafRefs.  This really happens+   Example.  CoreTidy produces+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...+   Now CorePrep has to eta-expand to+      $fApplicativeSTM = let sat = \xy. retry x y+                         in D:Alternative sat ...blah...+   So what we *want* is+      sat [NoCafRefs] = \xy. retry x y+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...++   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,+   *and* substitute the modified 'sat' into the old RHS.++   It should be the case that 'sat' is itself [NoCafRefs] (a value, no+   cafs) else the original top-level binding would not itself have been+   marked [NoCafRefs].  The DEBUG check in CoreToStg for+   consistentCafInfo will find this.++This is all very gruesome and horrible. It would be better to figure+out CafInfo later, after CorePrep.  We'll do that in due course.+Meanwhile this horrible hack works.++Note [Join points and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points can float out of other join points but not out of value bindings:++  let z =+    let  w = ... in -- can float+    join k = ... in -- can't float+    ... jump k ...+  join j x1 ... xn =+    let  y = ... in -- can float (but don't want to)+    join h = ... in -- can float (but not much point)+    ... jump h ...+  in ...++Here, the jump to h remains valid if h is floated outward, but the jump to k+does not.++We don't float *out* of join points. It would only be safe to float out of+nullary join points (or ones where the arguments are all either type arguments+or dead binders). Nullary join points aren't ever recursive, so they're always+effectively one-shot functions, which we don't float out of. We *could* float+join points from nullary join points, but there's no clear benefit at this+stage.++Note [Data constructor workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Create any necessary "implicit" bindings for data con workers.  We+create the rather strange (non-recursive!) binding++        $wC = \x y -> $wC x y++i.e. a curried constructor that allocates.  This means that we can+treat the worker for a constructor like any other function in the rest+of the compiler.  The point here is that CoreToStg will generate a+StgConApp for the RHS, rather than a call to the worker (which would+give a loop).  As Lennart says: the ice is thin here, but it works.++Hmm.  Should we create bindings for dictionary constructors?  They are+always fully applied, and the bindings are just there to support+partial applications. But it's easier to let them through.+++Note [Dead code in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Imagine that we got an input program like this (see #4962):++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g True (Just x) + g () (Just x), g)+    where+      g :: Show a => a -> Maybe Int -> Int+      g _ Nothing = x+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown++After specialisation and SpecConstr, we would get something like this:++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)+    where+      {-# RULES g $dBool = g$Bool+                g $dUnit = g$Unit #-}+      g = ...+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}+      g$Bool = ...+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}+      g$Unit = ...+      g$Bool_True_Just = ...+      g$Unit_Unit_Just = ...++Note that the g$Bool and g$Unit functions are actually dead code: they+are only kept alive by the occurrence analyser because they are+referred to by the rules of g, which is being kept alive by the fact+that it is used (unspecialised) in the returned pair.++However, at the CorePrep stage there is no way that the rules for g+will ever fire, and it really seems like a shame to produce an output+program that goes to the trouble of allocating a closure for the+unreachable g$Bool and g$Unit functions.++The way we fix this is to:+ * In cloneBndr, drop all unfoldings/rules++ * In deFloatTop, run a simple dead code analyser on each top-level+   RHS to drop the dead local bindings. For that call to OccAnal, we+   disable the binder swap, else the occurrence analyser sometimes+   introduces new let bindings for cased binders, which lead to the bug+   in #5433.++The reason we don't just OccAnal the whole output of CorePrep is that+the tidier ensures that all top-level binders are GlobalIds, so they+don't show up in the free variables any longer. So if you run the+occurrence analyser on the output of CoreTidy (or later) you e.g. turn+this program:++  Rec {+  f = ... f ...+  }++Into this one:++  f = ... f ...++(Since f is not considered to be free in its own RHS.)+++************************************************************************+*                                                                      *+                The main code+*                                                                      *+************************************************************************+-}++cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind+        -> UniqSM (CorePrepEnv,+                   Floats,         -- Floating value bindings+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float+                                   -- Nothing <=> added bind' to floats instead+cpeBind top_lvl env (NonRec bndr rhs)+  | not (isJoinId bndr)+  = do { (_, bndr1) <- cpCloneBndr env bndr+       ; let dmd         = idDemandInfo bndr+             is_unlifted = isUnliftedType (idType bndr)+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive+                                   dmd is_unlifted+                                   env bndr1 rhs+       -- See Note [Inlining in CorePrep]+       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl+            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)+            else do {++       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1++       ; return (extendCorePrepEnv env bndr bndr1,+                 addFloat floats new_float,+                 Nothing) }}++  | otherwise -- A join point; see Note [Join points and floating]+  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point+    do { (_, bndr1) <- cpCloneBndr env bndr+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs+       ; return (extendCorePrepEnv env bndr bndr2,+                 emptyFloats,+                 Just (NonRec bndr2 rhs1)) }++cpeBind top_lvl env (Rec pairs)+  | not (isJoinId (head bndrs))+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')+                           bndrs1 rhss++       ; let (floats_s, rhss1) = unzip stuff+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)+                                           (concatFloats floats_s)++       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),+                 unitFloat (FloatLet (Rec all_pairs)),+                 Nothing) }++  | otherwise -- See Note [Join points and floating]+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss++       ; let bndrs2 = map fst pairs1+       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+                 emptyFloats,+                 Just (Rec pairs1)) }+  where+    (bndrs, rhss) = unzip pairs++        -- Flatten all the floats, and the current+        -- group into a single giant Rec+    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2+    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2+    add_float b                       _    = pprPanic "cpeBind" (ppr b)++---------------+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool+        -> CorePrepEnv -> OutId -> CoreExpr+        -> UniqSM (Floats, CpeRhs)+-- Used for all bindings+-- The binder is already cloned, hence an OutId+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs+  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+    do { (floats1, rhs1) <- cpeRhsE env rhs++       -- See if we are allowed to float this stuff out of the RHS+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1++       -- Make the arity match up+       ; (floats3, rhs3)+            <- if manifestArity rhs1 <= arity+               then return (floats2, cpeEtaExpand arity rhs2)+               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+                               -- Note [Silly extra arguments]+                    (do { v <- newVar (idType bndr)+                        ; let float = mkFloat topDmd False v rhs2+                        ; return ( addFloat floats2 float+                                 , cpeEtaExpand arity (Var v)) })++        -- Wrap floating ticks+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3++       ; return (floats4, rhs4) }+  where+    platform = targetPlatform (cpe_dynFlags env)++    arity = idArity bndr        -- We must match this arity++    ---------------------+    float_from_rhs floats rhs+      | isEmptyFloats floats = return (emptyFloats, rhs)+      | isTopLevel top_lvl   = float_top    floats rhs+      | otherwise            = float_nested floats rhs++    ---------------------+    float_nested floats rhs+      | wantFloatNested is_rec dmd is_unlifted floats rhs+                  = return (floats, rhs)+      | otherwise = dontFloat floats rhs++    ---------------------+    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]+      | mayHaveCafRefs (idCafInfo bndr)+      , allLazyTop floats+      = return (floats, rhs)++      -- So the top-level binding is marked NoCafRefs+      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs+      = return (floats', rhs')++      | otherwise+      = dontFloat floats rhs++dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)+-- Non-empty floats, but do not want to float from rhs+-- So wrap the rhs in the floats+-- But: rhs1 might have lambdas, and we can't+--      put them inside a wrapBinds+dontFloat floats1 rhs+  = do { (floats2, body) <- rhsToBody rhs+        ; return (emptyFloats, wrapBinds floats1 $+                               wrapBinds floats2 body) }++{- Note [Silly extra arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we had this+        f{arity=1} = \x\y. e+We *must* match the arity on the Id, so we have to generate+        f' = \x\y. e+        f  = \x. f' x++It's a bizarre case: why is the arity on the Id wrong?  Reason+(in the days of __inline_me__):+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)+When InlineMe notes go away this won't happen any more.  But+it seems good for CorePrep to be robust.+-}++---------------+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr+            -> UniqSM (JoinId, CpeRhs)+-- Used for all join bindings+-- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils+cpeJoinPair env bndr rhs+  = ASSERT(isJoinId bndr)+    do { let Just join_arity = isJoinId_maybe bndr+             (bndrs, body)   = collectNBinders join_arity rhs++       ; (env', bndrs') <- cpCloneBndrs env bndrs++       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts+                                      -- with a lambda++       ; let rhs'  = mkCoreLams bndrs' body'+             bndr' = bndr `setIdUnfolding` evaldUnfolding+                          `setIdArity` count isId bndrs+                            -- See Note [Arity and join points]++       ; return (bndr', rhs') }++{-+Note [Arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Up to now, we've allowed a join point to have an arity greater than its join+arity (minus type arguments), since this is what's useful for eta expansion.+However, for code gen purposes, its arity must be exactly the number of value+arguments it will be called with, and it must have exactly that many value+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:++  join j x y z = \w -> ... in ...+    =>+  join j x y z = (let f = \w -> ... in f) in ...++This is also what happens with Note [Silly extra arguments]. Note that it's okay+for us to mess with the arity because a join point is never exported.+-}++-- ---------------------------------------------------------------------------+--              CpeRhs: produces a result satisfying CpeRhs+-- ---------------------------------------------------------------------------++cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- If+--      e  ===>  (bs, e')+-- then+--      e = let bs in e'        (semantically, that is!)+--+-- For example+--      f (g x)   ===>   ([v = g x], f v)++cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)+cpeRhsE env (Lit (LitNumber LitNumInteger i _))+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)+                   (cpe_integerSDataCon env) i)+cpeRhsE env (Lit (LitNumber LitNumNatural i _))+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)+                   (cpe_naturalSDataCon env) i)+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)+cpeRhsE env expr@(Var {})  = cpeApp env expr+cpeRhsE env expr@(App {}) = cpeApp env expr++cpeRhsE env (Let bind body)+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind+       ; (body_floats, body') <- cpeRhsE env' body+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'+                                         Nothing    -> body'+       ; return (bind_floats `appendFloats` body_floats, expr') }++cpeRhsE env (Tick tickish expr)+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope+  = do { (floats, body) <- cpeRhsE env expr+         -- See [Floating Ticks in CorePrep]+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }+  | otherwise+  = do { body <- cpeBodyNF env expr+       ; return (emptyFloats, mkTick tickish' body) }+  where+    tickish' | Breakpoint n fvs <- tickish+             -- See also 'substTickish'+             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)+             | otherwise+             = tickish++cpeRhsE env (Cast expr co)+   = do { (floats, expr') <- cpeRhsE env expr+        ; return (floats, Cast expr' co) }++cpeRhsE env expr@(Lam {})+   = do { let (bndrs,body) = collectBinders expr+        ; (env', bndrs') <- cpCloneBndrs env bndrs+        ; body' <- cpeBodyNF env' body+        ; return (emptyFloats, mkLams bndrs' body') }++cpeRhsE env (Case scrut bndr ty alts)+  = do { (floats, scrut') <- cpeBody env scrut+       ; (env', bndr2) <- cpCloneBndr env bndr+       ; let alts'+                 -- This flag is intended to aid in debugging strictness+                 -- analysis bugs. These are particularly nasty to chase down as+                 -- they may manifest as segmentation faults. When this flag is+                 -- enabled we instead produce an 'error' expression to catch+                 -- the case where a function we think should bottom+                 -- unexpectedly returns.+               | gopt Opt_CatchBottoms (cpe_dynFlags env)+               , not (altsAreExhaustive alts)+               = addDefault alts (Just err)+               | otherwise = alts+               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty+                                             "Bottoming expression returned"+       ; alts'' <- mapM (sat_alt env') alts'+       ; return (floats, Case scrut' bndr2 ty alts'') }+  where+    sat_alt env (con, bs, rhs)+       = do { (env2, bs') <- cpCloneBndrs env bs+            ; rhs' <- cpeBodyNF env2 rhs+            ; return (con, bs', rhs') }++cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+-- Here we convert a literal Integer to the low-level+-- representation. Exactly how we do this depends on the+-- library that implements Integer.  If it's GMP we+-- use the S# data constructor for small literals.+-- See Note [Integer literals] in Literal+cvtLitInteger dflags _ (Just sdatacon) i+  | inIntRange dflags i -- Special case for small integers+    = mkConApp sdatacon [Lit (mkLitInt dflags i)]++cvtLitInteger dflags mk_integer _ i+    = mkApps (Var mk_integer) [isNonNegative, ints]+  where isNonNegative = if i < 0 then mkConApp falseDataCon []+                                 else mkConApp trueDataCon  []+        ints = mkListExpr intTy (f (abs i))+        f 0 = []+        f x = let low  = x .&. mask+                  high = x `shiftR` bits+              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high+        bits = 31+        mask = 2 ^ bits - 1++cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+-- Here we convert a literal Natural to the low-level+-- representation.+-- See Note [Natural literals] in Literal+cvtLitNatural dflags _ (Just sdatacon) i+  | inWordRange dflags i -- Special case for small naturals+    = mkConApp sdatacon [Lit (mkLitWord dflags i)]++cvtLitNatural dflags mk_natural _ i+    = mkApps (Var mk_natural) [words]+  where words = mkListExpr wordTy (f i)+        f 0 = []+        f x = let low  = x .&. mask+                  high = x `shiftR` bits+              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high+        bits = 32+        mask = 2 ^ bits - 1++-- ---------------------------------------------------------------------------+--              CpeBody: produces a result satisfying CpeBody+-- ---------------------------------------------------------------------------++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without+-- producing any floats (any generated floats are immediately+-- let-bound using 'wrapBinds').  Generally you want this, esp.+-- when you've reached a binding form (e.g., a lambda) and+-- floating any further would be incorrect.+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody+cpeBodyNF env expr+  = do { (floats, body) <- cpeBody env expr+       ; return (wrapBinds floats body) }++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce+-- a list of 'Floats' which are being propagated upwards.  In+-- fact, this function is used in only two cases: to+-- implement 'cpeBodyNF' (which is what you usually want),+-- and in the case when a let-binding is in a case scrutinee--here,+-- we can always float out:+--+--      case (let x = y in z) of ...+--      ==> let x = y in case z of ...+--+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)+cpeBody env expr+  = do { (floats1, rhs) <- cpeRhsE env expr+       ; (floats2, body) <- rhsToBody rhs+       ; return (floats1 `appendFloats` floats2, body) }++--------+rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)+-- Remove top level lambdas by let-binding++rhsToBody (Tick t expr)+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations+  = do { (floats, expr') <- rhsToBody expr+       ; return (floats, mkTick t expr') }++rhsToBody (Cast e co)+        -- You can get things like+        --      case e of { p -> coerce t (\s -> ...) }+  = do { (floats, e') <- rhsToBody e+       ; return (floats, Cast e' co) }++rhsToBody expr@(Lam {})+  | Just no_lam_result <- tryEtaReducePrep bndrs body+  = return (emptyFloats, no_lam_result)+  | all isTyVar bndrs           -- Type lambdas are ok+  = return (emptyFloats, expr)+  | otherwise                   -- Some value lambdas+  = do { fn <- newVar (exprType expr)+       ; let rhs   = cpeEtaExpand (exprArity expr) expr+             float = FloatLet (NonRec fn rhs)+       ; return (unitFloat float, Var fn) }+  where+    (bndrs,body) = collectBinders expr++rhsToBody expr = return (emptyFloats, expr)++++-- ---------------------------------------------------------------------------+--              CpeApp: produces a result satisfying CpeApp+-- ---------------------------------------------------------------------------++data ArgInfo = CpeApp  CoreArg+             | CpeCast Coercion+             | CpeTick (Tickish Id)++{- Note [runRW arg]+~~~~~~~~~~~~~~~~~~~+If we got, say+   runRW# (case bot of {})+which happened in #11291, we do /not/ want to turn it into+   (case bot of {}) realWorldPrimId#+because that gives a panic in CoreToStg.myCollectArgs, which expects+only variables in function position.  But if we are sure to make+runRW# strict (which we do in MkId), this can't happen+-}++cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- May return a CpeRhs because of saturating primops+cpeApp top_env expr+  = do { let (terminal, args, depth) = collect_args expr+       ; cpe_app top_env terminal args depth+       }++  where+    -- We have a nested data structure of the form+    -- e `App` a1 `App` a2 ... `App` an, convert it into+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)+    -- We use 'ArgInfo' because we may also need to+    -- record casts and ticks.  Depth counts the number+    -- of arguments that would consume strictness information+    -- (so, no type or coercion arguments.)+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)+    collect_args e = go e [] 0+      where+        go (App fun arg)      as !depth+            = go fun (CpeApp arg : as)+                (if isTyCoArg arg then depth else depth + 1)+        go (Cast fun co)      as depth+            = go fun (CpeCast co : as) depth+        go (Tick tickish fun) as depth+            | tickishPlace tickish == PlaceNonLam+            && tickish `tickishScopesLike` SoftScope+            = go fun (CpeTick tickish : as) depth+        go terminal as depth = (terminal, as, depth)++    cpe_app :: CorePrepEnv+            -> CoreExpr+            -> [ArgInfo]+            -> Int+            -> UniqSM (Floats, CpeRhs)+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a+        -- Consider the code:+        --+        --      lazy (f x) y+        --+        -- We need to make sure that we need to recursively collect arguments on+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and+        -- end up with this awful -ddump-prep:+        --+        --      case f x of f_x {+        --        __DEFAULT -> f_x y+        --      }+        --+        -- rather than the far superior "f x y".  Test case is par01.+        = let (terminal, args', depth') = collect_args arg+          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)+    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1+        | f `hasKey` runRWKey+        -- See Note [runRW magic]+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this+        -- is why we return a CorePrepEnv as well)+        = case arg of+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0+            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1+    cpe_app env (Var v) args depth+      = do { v1 <- fiddleCCall v+           ; let e2 = lookupCorePrepEnv env v1+                 hd = getIdFromTrivialExpr_maybe e2+           -- NB: depth from collect_args is right, because e2 is a trivial expression+           -- and thus its embedded Id *must* be at the same depth as any+           -- Apps it is under are type applications only (c.f.+           -- exprIsTrivial).  But note that we need the type of the+           -- expression, not the id.+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts+           ; mb_saturate hd app floats depth }+        where+          stricts = case idStrictness v of+                            StrictSig (DmdType _ demands _)+                              | listLengthCmp demands depth /= GT -> demands+                                    -- length demands <= depth+                              | otherwise                         -> []+                -- If depth < length demands, then we have too few args to+                -- satisfy strictness  info so we have to  ignore all the+                -- strictness info, e.g. + (error "urk")+                -- Here, we can't evaluate the arg strictly, because this+                -- partial application might be seq'd++        -- We inlined into something that's not a var and has no args.+        -- Bounce it back up to cpeRhsE.+    cpe_app env fun [] _ = cpeRhsE env fun++        -- N-variable fun, better let-bind it+    cpe_app env fun args depth+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty+                          -- The evalDmd says that it's sure to be evaluated,+                          -- so we'll end up case-binding it+           ; (app, floats) <- rebuild_app args fun' ty fun_floats []+           ; mb_saturate Nothing app floats depth }+        where+          ty = exprType fun++    -- Saturate if necessary+    mb_saturate head app floats depth =+       case head of+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth+                          ; return (floats, sat_app) }+         _other              -> return (floats, app)++    -- Deconstruct and rebuild the application, floating any non-atomic+    -- arguments to the outside.  We collect the type of the expression,+    -- the head of the application, and the number of actual value arguments,+    -- all of which are used to possibly saturate this application if it+    -- has a constructor or primop at the head.+    rebuild_app+        :: [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp+        -> Type+        -> Floats+        -> [Demand]+        -> UniqSM (CpeApp, Floats)+    rebuild_app [] app _ floats ss = do+      MASSERT(null ss) -- make sure we used all the strictness info+      return (app, floats)+    rebuild_app (a : as) fun' fun_ty floats ss = case a of+      CpeApp arg@(Type arg_ty) ->+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss+      CpeApp arg@(Coercion {}) ->+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss+      CpeApp arg -> do+        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId+               = case (ss, isLazyExpr arg) of+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)+                   ([],            _)     -> (topDmd, [])+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $+                               splitFunTy_maybe fun_ty+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest+      CpeCast co ->+        let ty2 = coercionRKind co+        in rebuild_app as (Cast fun' co) ty2 floats ss+      CpeTick tickish ->+        -- See [Floating Ticks in CorePrep]+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss++isLazyExpr :: CoreExpr -> Bool+-- See Note [lazyId magic] in MkId+isLazyExpr (Cast e _)              = isLazyExpr e+isLazyExpr (Tick _ e)              = isLazyExpr e+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey+isLazyExpr _                       = False++{- Note [runRW magic]+~~~~~~~~~~~~~~~~~~~~~+Some definitions, for instance @runST@, must have careful control over float out+of the bindings in their body. Consider this use of @runST@,++    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s+                             (_, s'') = fill_in_array_or_something a x s'+                         in freezeArray# a s'' )++If we inline @runST@, we'll get:++    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}+              (_, s'') = fill_in_array_or_something a x s'+          in freezeArray# a s''++And now if we allow the @newArray#@ binding to float out to become a CAF,+we end up with a result that is totally and utterly wrong:++    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+        in \ x ->+            let (_, s'') = fill_in_array_or_something a x s'+            in freezeArray# a s''++All calls to @f@ will share a {\em single} array! Clearly this is nonsense and+must be prevented.++This is what @runRW#@ gives us: by being inlined extremely late in the+optimization (right before lowering to STG, in CorePrep), we can ensure that+no further floating will occur. This allows us to safely inline things like+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).++'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE+pragma.  It is levity-polymorphic.++    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)+           => (State# RealWorld -> (# State# RealWorld, o #))+                              -> (# State# RealWorld, o #)++It needs no special treatment in GHC except this special inlining here+in CorePrep (and in ByteCodeGen).++-- ---------------------------------------------------------------------------+--      CpeArg: produces a result satisfying CpeArg+-- ---------------------------------------------------------------------------++Note [ANF-ising literal string arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a program like,++    data Foo = Foo Addr#++    foo = Foo "turtle"#++When we go to ANFise this we might think that we want to float the string+literal like we do any other non-trivial argument. This would look like,++    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }++However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)+wreaks havoc on the CAF annotations that we produce here since we the result+above is caffy since it is updateable. Ideally at some point in the future we+would like to just float the literal to the top level as suggested in #11312,++    s = "turtle"#+    foo = Foo s++However, until then we simply add a special case excluding literals from the+floating done by cpeArg.+-}++-- | Is an argument okay to CPE?+okCpeArg :: CoreExpr -> Bool+-- Don't float literals. See Note [ANF-ising literal string arguments].+okCpeArg (Lit _) = False+-- Do not eta expand a trivial argument+okCpeArg expr    = not (exprIsTrivial expr)++-- This is where we arrange that a non-trivial argument is let-bound+cpeArg :: CorePrepEnv -> Demand+       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg arg_ty+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda+       ; (floats2, arg2) <- if want_float floats1 arg1+                            then return (floats1, arg1)+                            else dontFloat floats1 arg1+                -- Else case: arg1 might have lambdas, and we can't+                --            put them inside a wrapBinds++       ; if okCpeArg arg2+         then do { v <- newVar arg_ty+                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2+                       arg_float = mkFloat dmd is_unlifted v arg3+                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }+         else return (floats2, arg2)+       }+  where+    is_unlifted = isUnliftedType arg_ty+    want_float  = wantFloatNested NonRecursive dmd is_unlifted++{-+Note [Floating unlifted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    C (let v* = expensive in v)++where the "*" indicates "will be demanded".  Usually v will have been+inlined by now, but let's suppose it hasn't (see #2756).  Then we+do *not* want to get++     let v* = expensive in C v++because that has different strictness.  Hence the use of 'allLazy'.+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)+++------------------------------------------------------------------------------+-- Building the saturated syntax+-- ---------------------------------------------------------------------------++Note [Eta expansion of hasNoBinding things in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+maybeSaturate deals with eta expanding to saturate things that can't deal with+unsaturated applications (identified by 'hasNoBinding', currently just+foreign calls and unboxed tuple/sum constructors).++Note that eta expansion in CorePrep is very fragile due to the "prediction" of+CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta+expansion in CorePrep] in TidyPgm for details.  We previously saturated primop+applications here as well but due to this fragility (see #16846) we now deal+with this another way, as described in Note [Primop wrappers] in PrimOp.++It's quite likely that eta expansion of constructor applications will+eventually break in a similar way to how primops did. We really should+eliminate this case as well.+-}++maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs+maybeSaturate fn expr n_args+  | hasNoBinding fn        -- There's no binding+  = return sat_expr++  | otherwise+  = return expr+  where+    fn_arity     = idArity fn+    excess_arity = fn_arity - n_args+    sat_expr     = cpeEtaExpand excess_arity expr++{-+************************************************************************+*                                                                      *+                Simple CoreSyn operations+*                                                                      *+************************************************************************+-}++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~~+Eta expand to match the arity claimed by the binder Remember,+CorePrep must not change arity++Eta expansion might not have happened already, because it is done by+the simplifier only when there at least one lambda already.++NB1:we could refrain when the RHS is trivial (which can happen+    for exported things).  This would reduce the amount of code+    generated (a little) and make things a little words for+    code compiled without -O.  The case in point is data constructor+    wrappers.++NB2: we have to be careful that the result of etaExpand doesn't+   invalidate any of the assumptions that CorePrep is attempting+   to establish.  One possible cause is eta expanding inside of+   an SCC note - we're now careful in etaExpand to make sure the+   SCC is pushed inside any new lambdas that are generated.++Note [Eta expansion and the CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out to be much much easier to do eta expansion+*after* the main CorePrep stuff.  But that places constraints+on the eta expander: given a CpeRhs, it must return a CpeRhs.++For example here is what we do not want:+                f = /\a -> g (h 3)      -- h has arity 2+After ANFing we get+                f = /\a -> let s = h 3 in g s+and now we do NOT want eta expansion to give+                f = /\a -> \ y -> (let s = h 3 in g s) y++Instead CoreArity.etaExpand gives+                f = /\a -> \y -> let s = h 3 in g s y++-}++cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs+cpeEtaExpand arity expr+  | arity == 0 = expr+  | otherwise  = etaExpand arity expr++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Why try eta reduction?  Hasn't the simplifier already done eta?+But the simplifier only eta reduces if that leaves something+trivial (like f, or f Int).  But for deLam it would be enough to+get to a partial application:+        case x of { p -> \xs. map f xs }+    ==> case x of { p -> map f }+-}++-- When updating this function, make sure it lines up with+-- CoreUtils.tryEtaReduce!+tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr+tryEtaReducePrep bndrs expr@(App _ _)+  | ok_to_eta_reduce f+  , n_remaining >= 0+  , and (zipWith ok bndrs last_args)+  , not (any (`elemVarSet` fvs_remaining) bndrs)+  , exprIsHNF remaining_expr   -- Don't turn value into a non-value+                               -- else the behaviour with 'seq' changes+  = Just remaining_expr+  where+    (f, args) = collectArgs expr+    remaining_expr = mkApps f remaining_args+    fvs_remaining = exprFreeVars remaining_expr+    (remaining_args, last_args) = splitAt n_remaining args+    n_remaining = length args - length bndrs++    ok bndr (Var arg) = bndr == arg+    ok _    _         = False++    -- We can't eta reduce something which must be saturated.+    ok_to_eta_reduce (Var f) = not (hasNoBinding f)+    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise+++tryEtaReducePrep bndrs (Tick tickish e)+  | tickishFloatable tickish+  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e++tryEtaReducePrep _ _ = Nothing++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************++Note [Pin demand info on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin demand info on floated lets, so that we can see the one-shot thunks.+-}++data FloatingBind+  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss+                         -- They are always of lifted type;+                         -- unlifted ones are done with FloatCase++ | FloatCase+      Id CpeBody+      Bool              -- The bool indicates "ok-for-speculation"++ -- | See Note [Floating Ticks in CorePrep]+ | FloatTick (Tickish Id)++data Floats = Floats OkToSpec (OrdList FloatingBind)++instance Outputable FloatingBind where+  ppr (FloatLet b) = ppr b+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r+  ppr (FloatTick t) = ppr t++instance Outputable Floats where+  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>+                         braces (vcat (map ppr (fromOL fs)))++instance Outputable OkToSpec where+  ppr OkToSpec    = text "OkToSpec"+  ppr IfUnboxedOk = text "IfUnboxedOk"+  ppr NotOkToSpec = text "NotOkToSpec"++-- Can we float these binds out of the rhs of a let?  We cache this decision+-- to avoid having to recompute it in a non-linear way when there are+-- deeply nested lets.+data OkToSpec+   = OkToSpec           -- Lazy bindings of lifted type+   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n+                        -- ok-to-speculate unlifted bindings+   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings++mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat dmd is_unlifted bndr rhs+  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)+  | is_hnf    = FloatLet (NonRec bndr                       rhs)+  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)+                   -- See Note [Pin demand info on floats]+  where+    is_hnf    = exprIsHNF rhs+    is_strict = isStrictDmd dmd+    use_case  = is_unlifted || is_strict && not is_hnf+                -- Don't make a case for a value binding,+                -- even if it's strict.  Otherwise we get+                --      case (\x -> e) of ...!++emptyFloats :: Floats+emptyFloats = Floats OkToSpec nilOL++isEmptyFloats :: Floats -> Bool+isEmptyFloats (Floats _ bs) = isNilOL bs++wrapBinds :: Floats -> CpeBody -> CpeBody+wrapBinds (Floats _ binds) body+  = foldrOL mk_bind body binds+  where+    mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body+    mk_bind (FloatLet bind)        body = Let bind body+    mk_bind (FloatTick tickish)    body = mkTick tickish body++addFloat :: Floats -> FloatingBind -> Floats+addFloat (Floats ok_to_spec floats) new_float+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)+  where+    check (FloatLet _) = OkToSpec+    check (FloatCase _ _ ok_for_spec)+        | ok_for_spec  =  IfUnboxedOk+        | otherwise    =  NotOkToSpec+    check FloatTick{}  = OkToSpec+        -- The ok-for-speculation flag says that it's safe to+        -- float this Case out of a let, and thereby do it more eagerly+        -- We need the top-level flag because it's never ok to float+        -- an unboxed binding to the top level++unitFloat :: FloatingBind -> Floats+unitFloat = addFloat emptyFloats++appendFloats :: Floats -> Floats -> Floats+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)++concatFloats :: [Floats] -> OrdList FloatingBind+concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL++combine :: OkToSpec -> OkToSpec -> OkToSpec+combine NotOkToSpec _ = NotOkToSpec+combine _ NotOkToSpec = NotOkToSpec+combine IfUnboxedOk _ = IfUnboxedOk+combine _ IfUnboxedOk = IfUnboxedOk+combine _ _           = OkToSpec++deFloatTop :: Floats -> [CoreBind]+-- For top level only; we don't expect any FloatCases+deFloatTop (Floats _ floats)+  = foldrOL get [] floats+  where+    get (FloatLet b) bs = occurAnalyseRHSs b : bs+    get (FloatCase var body _) bs  =+      occurAnalyseRHSs (NonRec var body) : bs+    get b _ = pprPanic "corePrepPgm" (ppr b)++    -- See Note [Dead code in CorePrep]+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]++---------------------------------------------------------------------------++canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)+       -- Note [CafInfo and floating]+canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs+  | OkToSpec <- ok_to_spec           -- Worth trying+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)+  = Just (Floats OkToSpec fs', subst_expr subst rhs)+  | otherwise+  = Nothing+  where+    subst_expr = substExpr (text "CorePrep")++    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]+       -> Maybe (Subst, OrdList FloatingBind)++    go (subst, fbs_out) [] = Just (subst, fbs_out)++    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)+      | rhs_ok r+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (subst', b') = set_nocaf_bndr subst b+        new_fb = FloatLet (NonRec b' (subst_expr subst r))++    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)+      | all rhs_ok rs+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (bs,rs) = unzip prs+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs+        rs' = map (subst_expr subst') rs+        new_fb = FloatLet (Rec (bs' `zip` rs'))++    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)+      = go (subst, fbs_out `snocOL` ft) fbs_in++    go _ _ = Nothing      -- Encountered a caffy binding++    ------------+    set_nocaf_bndr subst bndr+      = (extendIdSubst subst bndr (Var bndr'), bndr')+      where+        bndr' = bndr `setIdCafInfo` NoCafRefs++    ------------+    rhs_ok :: CoreExpr -> Bool+    -- We can only float to top level from a NoCaf thing if+    -- the new binding is static. However it can't mention+    -- any non-static things or it would *already* be Caffy+    rhs_ok = rhsIsStatic platform (\_ -> False)+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))+                         -- Integer or Natural literals should not show up++wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool+wantFloatNested is_rec dmd is_unlifted floats rhs+  =  isEmptyFloats floats+  || isStrictDmd dmd+  || is_unlifted+  || (allLazyNested is_rec floats && exprIsHNF rhs)+        -- Why the test for allLazyNested?+        --      v = f (x `divInt#` y)+        -- we don't want to float the case, even if f has arity 2,+        -- because floating the case would make it evaluated too early++allLazyTop :: Floats -> Bool+allLazyTop (Floats OkToSpec _) = True+allLazyTop _                   = False++allLazyNested :: RecFlag -> Floats -> Bool+allLazyNested _      (Floats OkToSpec    _) = True+allLazyNested _      (Floats NotOkToSpec _) = False+allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec++{-+************************************************************************+*                                                                      *+                Cloning+*                                                                      *+************************************************************************+-}++-- ---------------------------------------------------------------------------+--                      The environment+-- ---------------------------------------------------------------------------++-- Note [Inlining in CorePrep]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There is a subtle but important invariant that must be upheld in the output+-- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core+-- is impermissible:+--+--      let x :: ()+--          x = y+--+-- (where y is a reference to a GLOBAL variable).  Thunks like this are silly:+-- they can always be profitably replaced by inlining x with y. Consequently,+-- the code generator/runtime does not bother implementing this properly+-- (specifically, there is no implementation of stg_ap_0_upd_info, which is the+-- stack frame that would be used to update this thunk.  The "0" means it has+-- zero free variables.)+--+-- In general, the inliner is good at eliminating these let-bindings.  However,+-- there is one case where these trivial updatable thunks can arise: when+-- we are optimizing away 'lazy' (see Note [lazyId magic], and also+-- 'cpeRhsE'.)  Then, we could have started with:+--+--      let x :: ()+--          x = lazy @ () y+--+-- which is a perfectly fine, non-trivial thunk, but then CorePrep will+-- drop 'lazy', giving us 'x = y' which is trivial and impermissible.+-- The solution is CorePrep to have a miniature inlining pass which deals+-- with cases like this.  We can then drop the let-binding altogether.+--+-- Why does the removal of 'lazy' have to occur in CorePrep?+-- The gory details are in Note [lazyId magic] in MkId, but the+-- main reason is that lazy must appear in unfoldings (optimizer+-- output) and it must prevent call-by-value for catch# (which+-- is implemented by CorePrep.)+--+-- An alternate strategy for solving this problem is to have the+-- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.+-- We decided not to adopt this solution to keep the definition+-- of 'exprIsTrivial' simple.+--+-- There is ONE caveat however: for top-level bindings we have+-- to preserve the binding so that we float the (hacky) non-recursive+-- binding for data constructors; see Note [Data constructor workers].+--+-- Note [CorePrep inlines trivial CoreExpr not Id]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an+-- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks+-- as per Note [Inlining in CorePrep] always have the form+-- 'lazy @ SomeType gbl_id'.  But this is not true: the following is+-- perfectly reasonable Core:+--+--      let x :: ()+--          x = lazy @ (forall a. a) y @ Bool+--+-- When we inline 'x' after eliminating 'lazy', we need to replace+-- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like+-- this can easily arise with higher-rank types; thus, cpe_env must+-- map to CoreExprs, not Ids.++data CorePrepEnv+  = CPE { cpe_dynFlags        :: DynFlags+        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids+        -- ^ This environment is used for three operations:+        --+        --      1. To support cloning of local Ids so that they are+        --      all unique (see item (6) of CorePrep overview).+        --+        --      2. To support beta-reduction of runRW, see+        --      Note [runRW magic] and Note [runRW arg].+        --+        --      3. To let us inline trivial RHSs of non top-level let-bindings,+        --      see Note [lazyId magic], Note [Inlining in CorePrep]+        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)+        , cpe_mkIntegerId     :: Id+        , cpe_mkNaturalId     :: Id+        , cpe_integerSDataCon :: Maybe DataCon+        , cpe_naturalSDataCon :: Maybe DataCon+    }++lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id+lookupMkIntegerName dflags hsc_env+    = guardIntegerUse dflags $ liftM tyThingId $+      lookupGlobal hsc_env mkIntegerName++lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id+lookupMkNaturalName dflags hsc_env+    = guardNaturalUse dflags $ liftM tyThingId $+      lookupGlobal hsc_env mkNaturalName++-- See Note [The integer library] in PrelNames+lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)+lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $+                  lookupGlobal hsc_env integerSDataConName+    IntegerSimple -> return Nothing++lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)+lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $+                  lookupGlobal hsc_env naturalSDataConName+    IntegerSimple -> return Nothing++-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'+guardIntegerUse :: DynFlags -> IO a -> IO a+guardIntegerUse dflags act+  | thisPackage dflags == primUnitId+  = return $ panic "Can't use Integer in ghc-prim"+  | thisPackage dflags == integerUnitId+  = return $ panic "Can't use Integer in integer-*"+  | otherwise = act++-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'+--+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.+guardNaturalUse :: DynFlags -> IO a -> IO a+guardNaturalUse dflags act+  | thisPackage dflags == primUnitId+  = return $ panic "Can't use Natural in ghc-prim"+  | thisPackage dflags == integerUnitId+  = return $ panic "Can't use Natural in integer-*"+  | thisPackage dflags == baseUnitId+  = return $ panic "Can't use Natural in base"+  | otherwise = act++mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv+mkInitialCorePrepEnv dflags hsc_env+    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+         mkNaturalId <- lookupMkNaturalName dflags hsc_env+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env+         return $ CPE {+                      cpe_dynFlags = dflags,+                      cpe_env = emptyVarEnv,+                      cpe_mkIntegerId = mkIntegerId,+                      cpe_mkNaturalId = mkNaturalId,+                      cpe_integerSDataCon = integerSDataCon,+                      cpe_naturalSDataCon = naturalSDataCon+                  }++extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv+extendCorePrepEnv cpe id id'+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }++extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv+extendCorePrepEnvExpr cpe id expr+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }++extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv+extendCorePrepEnvList cpe prs+    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)+                        (map (\(id, id') -> (id, Var id')) prs) }++lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr+lookupCorePrepEnv cpe id+  = case lookupVarEnv (cpe_env cpe) id of+        Nothing  -> Var id+        Just exp -> exp++getMkIntegerId :: CorePrepEnv -> Id+getMkIntegerId = cpe_mkIntegerId++getMkNaturalId :: CorePrepEnv -> Id+getMkNaturalId = cpe_mkNaturalId++------------------------------------------------------------------------------+-- Cloning binders+-- ---------------------------------------------------------------------------++cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs++cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+cpCloneBndr env bndr+  | not (isId bndr)+  = return (env, bndr)++  | otherwise+  = do { bndr' <- clone_it bndr++       -- Drop (now-useless) rules/unfoldings+       -- See Note [Drop unfoldings and rules]+       -- and Note [Preserve evaluatedness] in CoreTidy+       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)+                          -- Simplifier will set the Id's unfolding++             bndr'' = bndr' `setIdUnfolding`      unfolding'+                            `setIdSpecialisation` emptyRuleInfo++       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }+  where+    clone_it bndr+      | isLocalId bndr, not (isCoVar bndr)+      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }+      | otherwise   -- Top level things, which we don't want+                    -- to clone, have become GlobalIds by now+                    -- And we don't clone tyvars, or coercion variables+      = return bndr++{- Note [Drop unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to drop the unfolding/rules on every Id:++  - We are now past interface-file generation, and in the+    codegen pipeline, so we really don't need full unfoldings/rules++  - The unfolding/rule may be keeping stuff alive that we'd like+    to discard.  See  Note [Dead code in CorePrep]++  - Getting rid of unnecessary unfoldings reduces heap usage++  - We are changing uniques, so if we didn't discard unfoldings/rules+    we'd have to substitute in them++HOWEVER, we want to preserve evaluated-ness;+see Note [Preserve evaluatedness] in CoreTidy.+-}++------------------------------------------------------------------------------+-- Cloning ccall Ids; each must have a unique name,+-- to give the code generator a handle to hang it on+-- ---------------------------------------------------------------------------++fiddleCCall :: Id -> UniqSM Id+fiddleCCall id+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM+  | otherwise    = return id++------------------------------------------------------------------------------+-- Generating new binders+-- ---------------------------------------------------------------------------++newVar :: Type -> UniqSM Id+newVar ty+ = seqType ty `seq` do+     uniq <- getUniqueM+     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)+++------------------------------------------------------------------------------+-- Floating ticks+-- ---------------------------------------------------------------------------+--+-- Note [Floating Ticks in CorePrep]+--+-- It might seem counter-intuitive to float ticks by default, given+-- that we don't actually want to move them if we can help it. On the+-- other hand, nothing gets very far in CorePrep anyway, and we want+-- to preserve the order of let bindings and tick annotations in+-- relation to each other. For example, if we just wrapped let floats+-- when they pass through ticks, we might end up performing the+-- following transformation:+--+--   src<...> let foo = bar in baz+--   ==>  let foo = src<...> bar in src<...> baz+--+-- Because the let-binding would float through the tick, and then+-- immediately materialize, achieving nothing but decreasing tick+-- accuracy. The only special case is the following scenario:+--+--   let foo = src<...> (let a = b in bar) in baz+--   ==>  let foo = src<...> bar; a = src<...> b in baz+--+-- Here we would not want the source tick to end up covering "baz" and+-- therefore refrain from pushing ticks outside. Instead, we copy them+-- into the floating binds (here "a") in cpePair. Note that where "b"+-- or "bar" are (value) lambdas we have to push the annotations+-- further inside in order to uphold our rules.+--+-- All of this is implemented below in @wrapTicks@.++-- | Like wrapFloats, but only wraps tick floats+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)+wrapTicks (Floats flag floats0) expr =+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0+        -- Deeply nested constructors will produce long lists of+        -- redundant source note floats here. We need to eliminate+        -- those early, as relying on mkTick to spot it after the fact+        -- can yield O(n^3) complexity [#11095]+        go (floats, ticks) (FloatTick t)+          = ASSERT(tickishPlace t == PlaceNonLam)+            (floats, if any (flip tickishContains t) ticks+                     then ticks else t:ticks)+        go (floats, ticks) f+          = (foldr wrap f (reverse ticks):floats, ticks)++        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"+                                             (ppr other)+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)++------------------------------------------------------------------------------+-- Collecting cost centres+-- ---------------------------------------------------------------------------++-- | Collect cost centres defined in the current module, including those in+-- unfoldings.+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre+collectCostCentres mod_name+  = foldl' go_bind S.empty+  where+    go cs e = case e of+      Var{} -> cs+      Lit{} -> cs+      App e1 e2 -> go (go cs e1) e2+      Lam _ e -> go cs e+      Let b e -> go (go_bind cs b) e+      Case scrt _ _ alts -> go_alts (go cs scrt) alts+      Cast e _ -> go cs e+      Tick (ProfNote cc _ _) e ->+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e+      Tick _ e -> go cs e+      Type{} -> cs+      Coercion{} -> cs++    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)++    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre+    go_bind cs (NonRec b e) =+      go (maybe cs (go cs) (get_unf b)) e+    go_bind cs (Rec bs) =+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs++    -- Unfoldings may have cost centres that in the original definion are+    -- optimized away, see #5889.+    get_unf = maybeUnfoldingTemplate . realIdUnfolding
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -90,14 +90,14 @@   dflags <- getDynFlags   printer <- mkPrintUnqualifiedDs   liftIO $ dumpIfSet_dyn_printer printer dflags-            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))+            Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))  -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique ->   let occname = mkVarOccFS $ fsLit "pm"       name    = mkInternalName unique occname noSrcSpan-  in  return (mkLocalId name ty)+  in  return (mkLocalIdOrCoVar name ty)  ----------------------------------------------- -- * Caching possible matches of a COMPLETE set@@ -508,7 +508,7 @@   unique <- getUniqueM   let occname = mkVarOccFS (fsLit ("pm_"++show unique))       idname  = mkInternalName unique occname noSrcSpan-  return (mkLocalId idname pred_ty)+  return (mkLocalIdOrCoVar idname pred_ty)  -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@).
+ compiler/GHC/Stg/CSE.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE TypeFamilies #-}++{-|+Note [CSE for Stg]+~~~~~~~~~~~~~~~~~~+This module implements a simple common subexpression elimination pass for STG.+This is useful because there are expressions that we want to common up (because+they are operationally equivalent), but that we cannot common up in Core, because+their types differ.+This was originally reported as #9291.++There are two types of common code occurrences that we aim for, see+note [Case 1: CSEing allocated closures] and+note [Case 2: CSEing case binders] below.+++Note [Case 1: CSEing allocated closures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The first kind of CSE opportunity we aim for is generated by this Haskell code:++    bar :: a -> (Either Int a, Either Bool a)+    bar x = (Right x, Right x)++which produces this Core:++    bar :: forall a. a -> (Either Int a, Either Bool a)+    bar @a x = (Right @Int @a x, Right @Bool @a x)++where the two components of the tuple are different terms, and cannot be+commoned up (easily). On the STG level we have++    bar [x] = let c1 = Right [x]+                  c2 = Right [x]+              in (c1,c2)++and now it is obvious that we can write++    bar [x] = let c1 = Right [x]+              in (c1,c1)++instead.+++Note [Case 2: CSEing case binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The second kind of CSE opportunity we aim for is more interesting, and+came up in #9291 and #5344: The Haskell code++    foo :: Either Int a -> Either Bool a+    foo (Right x) = Right x+    foo _         = Left False++produces this Core++    foo :: forall a. Either Int a -> Either Bool a+    foo @a e = case e of b { Left n -> …+                           , Right x -> Right @Bool @a x }++where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have+different types. But in STG we have++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> Right [x] }++and nothing stops us from transforming that to++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> b}+++Note [StgCse after unarisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider two unboxed sum terms:++    (# 1 | #) :: (# Int | Int# #)+    (# 1 | #) :: (# Int | Int  #)++These two terms are not equal as they unarise to different unboxed+tuples. However if we run StgCse before Unarise, it'll think the two+terms (# 1 | #) are equal, and replace one of these with a binder to+the other. That's bad -- #15300.++Solution: do unarise first.++-}++module GHC.Stg.CSE (stgCse) where++import GhcPrelude++import DataCon+import Id+import GHC.Stg.Syntax+import Outputable+import VarEnv+import CoreSyn (AltCon(..))+import Data.List (mapAccumL)+import Data.Maybe (fromMaybe)+import CoreMap+import NameEnv+import Control.Monad( (>=>) )++--------------+-- The Trie --+--------------++-- A lookup trie for data constructor applications, i.e.+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.++data StgArgMap a = SAM+    { sam_var :: DVarEnv a+    , sam_lit :: LiteralMap a+    }++instance TrieMap StgArgMap where+    type Key StgArgMap = StgArg+    emptyTM  = SAM { sam_var = emptyTM+                   , sam_lit = emptyTM }+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }++newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }++instance TrieMap ConAppMap where+    type Key ConAppMap = (DataCon, [StgArg])+    emptyTM  = CAM emptyTM+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args+    alterTM  (dataCon, args) f m =+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }+    foldTM k = un_cam >.> foldTM (foldTM k)+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM++-----------------+-- The CSE Env --+-----------------++-- | The CSE environment. See note [CseEnv Example]+data CseEnv = CseEnv+    { ce_conAppMap :: ConAppMap OutId+        -- ^ The main component of the environment is the trie that maps+        --   data constructor applications (with their `OutId` arguments)+        --   to an in-scope name that can be used instead.+        --   This name is always either a let-bound variable or a case binder.+    , ce_subst     :: IdEnv OutId+        -- ^ This substitution is applied to the code as we traverse it.+        --   Entries have one of two reasons:+        --+        --   * The input might have shadowing (see Note [Shadowing]), so we have+        --     to rename some binders as we traverse the tree.+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,+        --     we note this here as x ↦ y.+    , ce_bndrMap     :: IdEnv OutId+        -- ^ If we come across a case expression case x as b of … with a trivial+        --   binder, we add b ↦ x to this.+        --   This map is *only* used when looking something up in the ce_conAppMap.+        --   See Note [Trivial case scrutinee]+    , ce_in_scope  :: InScopeSet+        -- ^ The third component is an in-scope set, to rename away any+        --   shadowing binders+    }++{-|+Note [CseEnv Example]+~~~~~~~~~~~~~~~~~~~~~+The following tables shows how the CseEnvironment changes as code is traversed,+as well as the changes to that code.++  InExpr                         OutExpr+     conAppMap                   subst          in_scope+  ───────────────────────────────────────────────────────────+  -- empty                       {}             {}+  case … as a of {Con x y ->     case … as a of {Con x y ->+  -- Con x y ↦ a                 {}             {a,x,y}+  let b = Con x y                (removed)+  -- Con x y ↦ a                 b↦a            {a,x,y,b}+  let c = Bar a                  let c = Bar a+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}+  let c = some expression        let c' = some expression+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}+  let d = Bar b                  (removed)+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}+  (a, b, c d)                    (a, a, c' c)+-}++initEnv :: InScopeSet -> CseEnv+initEnv in_scope = CseEnv+    { ce_conAppMap = emptyTM+    , ce_subst     = emptyVarEnv+    , ce_bndrMap   = emptyVarEnv+    , ce_in_scope  = in_scope+    }++envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)+  where args' = map go args -- See Note [Trivial case scrutinee]+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)+        go (StgLitArg lit) = StgLitArg lit++addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv+-- do not bother with nullary data constructors, they are static anyways+addDataCon _ _ [] env = env+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+  where+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)++forgetCse :: CseEnv -> CseEnv+forgetCse env = env { ce_conAppMap = emptyTM }+    -- See note [Free variables of an StgClosure]++addSubst :: OutId -> OutId -> CseEnv -> CseEnv+addSubst from to env+    = env { ce_subst = extendVarEnv (ce_subst env) from to }++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+addTrivCaseBndr from to env+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }++substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]+substArgs env = map (substArg env)++substArg :: CseEnv -> InStgArg -> OutStgArg+substArg env (StgVarArg from) = StgVarArg (substVar env from)+substArg _   (StgLitArg lit)  = StgLitArg lit++substVar :: CseEnv -> InId -> OutId+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id++-- Functions to enter binders++-- This is much simpler than the equivalent code in CoreSubst:+--  * We do not substitute type variables, and+--  * There is nothing relevant in IdInfo at this stage+--    that needs substitutions.+-- Therefore, no special treatment for a recursive group is required.++substBndr :: CseEnv -> InId -> (CseEnv, OutId)+substBndr env old_id+  = (new_env, new_id)+  where+    new_id = uniqAway (ce_in_scope env) old_id+    no_change = new_id == old_id+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }+    new_env | no_change = env'+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }++substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])+substBndrs env bndrs = mapAccumL substBndr env bndrs++substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])+substPairs env bndrs = mapAccumL go env bndrs+  where go env (id, x) = let (env', id') = substBndr env id+                         in (env', (id', x))++-- Main entry point++stgCse :: [InStgTopBinding] -> [OutStgTopBinding]+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds++-- Top level bindings.+--+-- We do not CSE these, as top-level closures are allocated statically anyways.+-- Also, they might be exported.+-- But we still have to collect the set of in-scope variables, otherwise+-- uniqAway might shadow a top-level closure.++stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))+    = (in_scope'+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))+  where in_scope' = in_scope `extendInScopeSet` bndr++stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))+    = ( in_scope'+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]++stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)+    = let body' = stgCseExpr (initEnv in_scope) body+      in  StgRhsClosure ext ccs upd args body'+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)+    = StgRhsCon ccs dataCon args++------------------------------+-- The actual AST traversal --+------------------------------++-- Trivial cases+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr+stgCseExpr env (StgApp fun args)+    = StgApp fun' args'+  where fun' = substVar env fun+        args' = substArgs env args+stgCseExpr _ (StgLit lit)+    = StgLit lit+stgCseExpr env (StgOpApp op args tys)+    = StgOpApp op args' tys+  where args' = substArgs env args+stgCseExpr _ (StgLam _ _)+    = pprPanic "stgCseExp" (text "StgLam")+stgCseExpr env (StgTick tick body)+    = let body' = stgCseExpr env body+      in StgTick tick body'+stgCseExpr env (StgCase scrut bndr ty alts)+    = mkStgCase scrut' bndr' ty alts'+  where+    scrut' = stgCseExpr env scrut+    (env1, bndr') = substBndr env bndr+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+                 -- See Note [Trivial case scrutinee]+         | otherwise                         = env1+    alts' = map (stgCseAlt env2 ty bndr') alts+++-- A constructor application.+-- To be removed by a variable use when found in the CSE environment+stgCseExpr env (StgConApp dataCon args tys)+    | Just bndr' <- envLookup dataCon args' env+    = StgApp bndr' []+    | otherwise+    = StgConApp dataCon args' tys+  where args' = substArgs env args++-- Let bindings+-- The binding might be removed due to CSE (we do not want trivial bindings on+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding+-- if empty.+stgCseExpr env (StgLet ext binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet (StgLet ext) binds' body'+stgCseExpr env (StgLetNoEscape ext binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet (StgLetNoEscape ext) binds' body'++-- Case alternatives+-- Extend the CSE environment+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)+    = let (env1, args') = substBndrs env args+          env2+            -- To avoid dealing with unboxed sums StgCse runs after unarise and+            -- should maintain invariants listed in Note [Post-unarisation+            -- invariants]. One of the invariants is that some binders are not+            -- used (unboxed tuple case binders) which is what we check with+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we+            -- don't add it to the CSE env. See also #15300.+            | stgCaseBndrInScope ty True -- CSE runs after unarise+            = addDataCon case_bndr dataCon (map StgVarArg args') env1+            | otherwise+            = env1+            -- see note [Case 2: CSEing case binders]+          rhs' = stgCseExpr env2 rhs+      in (DataAlt dataCon, args', rhs')+stgCseAlt env _ _ (altCon, args, rhs)+    = let (env1, args') = substBndrs env args+          rhs' = stgCseExpr env1 rhs+      in (altCon, args', rhs')++-- Bindings+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)+stgCseBind env (StgNonRec b e)+    = let (env1, b') = substBndr env b+      in case stgCseRhs env1 b' e of+        (Nothing,      env2) -> (Nothing,                env2)+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)+stgCseBind env (StgRec pairs)+    = let (env1, pairs1) = substPairs env pairs+      in case stgCsePairs env1 pairs1 of+        ([],     env2) -> (Nothing, env2)+        (pairs2, env2) -> (Just (StgRec pairs2), env2)++stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)+stgCsePairs env [] = ([], env)+stgCsePairs env0 ((b,e):pairs)+  = let (pairMB, env1) = stgCseRhs env0 b e+        (pairs', env2) = stgCsePairs env1 pairs+    in (pairMB `mbCons` pairs', env2)+  where+    mbCons = maybe id (:)++-- The RHS of a binding.+-- If it is a constructor application, either short-cut it or extend the environment+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)+stgCseRhs env bndr (StgRhsCon ccs dataCon args)+    | Just other_bndr <- envLookup dataCon args' env+    = let env' = addSubst bndr other_bndr env+      in (Nothing, env')+    | otherwise+    = let env' = addDataCon bndr dataCon args' env+            -- see note [Case 1: CSEing allocated closures]+          pair = (bndr, StgRhsCon ccs dataCon args')+      in (Just pair, env')+  where args' = substArgs env args+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)+    = let (env1, args') = substBndrs env args+          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+          body' = stgCseExpr env2 body+      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)+++mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr+mkStgCase scrut bndr ty alts | all isBndr alts = scrut+                             | otherwise       = StgCase scrut bndr ty alts++  where+    -- see Note [All alternatives are the binder]+    isBndr (_, _, StgApp f []) = f == bndr+    isBndr _                   = False+++-- Utilities++-- | This function short-cuts let-bindings that are now obsolete+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b+mkStgLet _      Nothing      body = body+mkStgLet stgLet (Just binds) body = stgLet binds body+++{-+Note [All alternatives are the binder]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When all alternatives simply refer to the case binder, then we do not have+to bother with the case expression at all (#13588). CoreSTG does this as well,+but sometimes, types get into the way:++    newtype T = MkT Int+    f :: (Int, Int) -> (T, Int)+    f (x, y) = (MkT x, y)++Core cannot just turn this into++    f p = p++as this would not be well-typed. But to STG, where MkT is no longer in the way,+we can.++Note [Trivial case scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to be able to handle nested reconstruction of constructors as in++    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)+    nested (Right (Right v)) = Right (Right v)+    nested _ = Left True++So if we come across++    case x of r1+      Right a -> case a of r2+              Right b -> let v = Right b+                         in Right v++we first replace v with r2. Next we want to replace Right r2 with r1. But the+ce_conAppMap contains Right a!++Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use+this substitution before looking Right r2 up in ce_conAppMap, and everything+works out.++Note [Free variables of an StgClosure]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+StgClosures (function and thunks) have an explicit list of free variables:++foo [x] =+    let not_a_free_var = Left [x]+    let a_free_var = Right [x]+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var+    in closure++If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,+then the list of free variables would be wrong, so for now, we do not CSE+across such a closure, simply because I (Joachim) was not sure about possible+knock-on effects. If deemed safe and worth the slight code complication of+re-calculating this list during or after this pass, this can surely be done.+-}
+ compiler/GHC/Stg/FVs.hs view
@@ -0,0 +1,130 @@+-- | Free variable analysis on STG terms.+module GHC.Stg.FVs (+    annTopBindingsFreeVars,+    annBindingFreeVars+  ) where++import GhcPrelude++import GHC.Stg.Syntax+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
+ compiler/GHC/Stg/Lift.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE CPP #-}++-- | Implements a selective lambda lifter, running late in the optimisation+-- pipeline.+--+-- If you are interested in the cost model that is employed to decide whether+-- to lift a binding or not, look at "GHC.Stg.Lift.Analysis".+-- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some+-- plumbing of the transformation.+module GHC.Stg.Lift+   (+    -- * Late lambda lifting in STG+    -- $note+   stgLiftLams+   )+where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import DynFlags+import Id+import IdInfo+import GHC.Stg.FVs ( annBindingFreeVars )+import GHC.Stg.Lift.Analysis+import GHC.Stg.Lift.Monad+import GHC.Stg.Syntax+import Outputable+import UniqSupply+import Util+import VarSet+import Control.Monad ( when )+import Data.Maybe ( isNothing )++-- Note [Late lambda lifting in STG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- $note+-- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>+-- and #9476.+--+-- The basic idea behind lambda lifting is to turn locally defined functions+-- into top-level functions. Free variables are then passed as additional+-- arguments at *call sites* instead of having a closure allocated for them at+-- *definition site*. Example:+--+-- @+--    let x = ...; y = ... in+--    let f = {x y} \a -> a + x + y in+--    let g = {f x} \b -> f b + x in+--    g 5+-- @+--+-- Lambda lifting @f@ would+--+--   1. Turn @f@'s free variables into formal parameters+--   2. Update @f@'s call site within @g@ to @f x y b@+--   3. Update @g@'s closure: Add @y@ as an additional free variable, while+--      removing @f@, because @f@ no longer allocates and can be floated to+--      top-level.+--   4. Actually float the binding of @f@ to top-level, eliminating the @let@+--      in the process.+--+-- This results in the following program (with free var annotations):+--+-- @+--    f x y a = a + x + y;+--    let x = ...; y = ... in+--    let g = {x y} \b -> f x y b + x in+--    g 5+-- @+--+-- This optimisation is all about lifting only when it is beneficial to do so.+-- The above seems like a worthwhile lift, judging from heap allocation:+-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while+-- not changing the size of @g@'s closure.+--+-- You can probably sense that there's some kind of cost model at play here.+-- And you are right! But we also employ a couple of other heuristics for the+-- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when".+--+-- The transformation is done in "GHC.Stg.Lift", which calls out to+-- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision.  It relies on+-- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a+-- monadic substrate.+--+-- Suffice to say: We trade heap allocation for stack allocation.+-- The additional arguments have to passed on the stack (or in registers,+-- depending on architecture) every time we call the function to save a single+-- heap allocation when entering the let binding. Nofib suggests a mean+-- improvement of about 1% for this pass, so it seems like a worthwhile thing to+-- do. Compile-times went up by 0.6%, so all in all a very modest change.+--+-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'+-- that is ultimately compiled to something like this+-- (module desugaring/lowering to actual STG):+--+-- @+--    propagate dt = ...;+--    runExperiment ... =+--      let xs = ... in+--      let ys = ... in+--      let go = {dt go} \xs ys -> case (xs, ys) of+--            ([], []) -> []+--            (x:xs', y:ys') -> propagate dt x y : go xs' ys'+--      in go xs ys+-- @+--+-- This will lambda lift @go@ to top-level, speeding up the resulting program+-- by roughly one percent:+--+-- @+--    propagate dt = ...;+--    go dt xs ys = case (xs, ys) of+--      ([], []) -> []+--      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'+--    runExperiment ... =+--      let xs = ... in+--      let ys = ... in+--      in go dt xs ys+-- @++++-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').+--+-- (Mostly) textbook instance of the lambda lifting transformation, selecting+-- which bindings to lambda lift by consulting 'goodToLift'.+stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())++liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()+liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do+  addTopStringLit bndr' lit+  rest+liftTopLvl (StgTopLifted bind) rest = do+  let is_rec = isRec $ fst $ decomposeStgBinding bind+  when is_rec startBindingGroup+  let bind_w_fvs = annBindingFreeVars bind+  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do+    -- We signal lifting of a binding through returning Nothing.+    -- Should never happen for a top-level binding, though, since we are already+    -- at top-level.+    case mb_bind' of+      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")+      Just bind' -> addLiftedBinding bind'+    when is_rec endBindingGroup+    rest++withLiftedBind+  :: TopLevelFlag+  -> LlStgBinding+  -> Skeleton+  -> (Maybe OutStgBinding -> LiftM a)+  -> LiftM a+withLiftedBind top_lvl bind scope k+  | isTopLevel top_lvl+  = withCaffyness (is_caffy pairs) go+  | otherwise+  = go+  where+    (rec, pairs) = decomposeStgBinding bind+    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)+    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))++withLiftedBindPairs+  :: TopLevelFlag+  -> RecFlag+  -> [(BinderInfo, LlStgRhs)]+  -> Skeleton+  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)+  -> LiftM a+withLiftedBindPairs top rec pairs scope k = do+  let (infos, rhss) = unzip pairs+  let bndrs = map binderInfoBndr infos+  expander <- liftedIdsExpander+  dflags <- getDynFlags+  case goodToLift dflags top rec expander pairs scope of+    -- @abs_ids@ is the set of all variables that need to become parameters.+    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do+      -- Within this block, all binders in @bndrs@ will be noted as lifted, so+      -- that the return value of @liftedIdsExpander@ in this context will also+      -- expand the bindings in @bndrs@ to their free variables.+      -- Now we can recurse into the RHSs and see if we can lift any further+      -- bindings. We pass the set of expanded free variables (thus OutIds) on+      -- to @liftRhs@ so that it can add them as parameter binders.+      when (isRec rec) startBindingGroup+      rhss' <- traverse (liftRhs (Just abs_ids)) rhss+      let pairs' = zip bndrs' rhss'+      addLiftedBinding (mkStgBinding rec pairs')+      when (isRec rec) endBindingGroup+      k Nothing+    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do+      -- Don't lift the current binding, but possibly some bindings in their+      -- RHSs.+      rhss' <- traverse (liftRhs Nothing) rhss+      let pairs' = zip bndrs' rhss'+      k (Just pairs')++liftRhs+  :: Maybe (DIdSet)+  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@+  -- as lambda binders, discarding all free vars.+  -> LlStgRhs+  -> LiftM OutStgRhs+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)+    StgRhsCon ccs con <$> traverse liftArgs args+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do+  -- This RHS wasn't lifted.+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+    StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do+  -- This RHS was lifted. Insert extra binders for @former_fvs@.+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do+    let bndrs'' = dVarSetElems former_fvs ++ bndrs'+    StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body++liftArgs :: InStgArg -> LiftM OutStgArg+liftArgs a@(StgLitArg _) = pure a+liftArgs (StgVarArg occ) = do+  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )+  StgVarArg <$> substOcc occ++liftExpr :: LlStgExpr -> LiftM OutStgExpr+liftExpr (StgLit lit) = pure (StgLit lit)+liftExpr (StgTick t e) = StgTick t <$> liftExpr e+liftExpr (StgApp f args) = do+  f' <- substOcc f+  args' <- traverse liftArgs args+  fvs' <- formerFreeVars f+  let top_lvl_args = map StgVarArg fvs' ++ args'+  pure (StgApp f' top_lvl_args)+liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys+liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty+liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")+liftExpr (StgCase scrut info ty alts) = do+  scrut' <- liftExpr scrut+  withSubstBndr (binderInfoBndr info) $ \bndr' -> do+    alts' <- traverse liftAlt alts+    pure (StgCase scrut' bndr' ty alts')+liftExpr (StgLet scope bind body)+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do+      body' <- liftExpr body+      case mb_bind' of+        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats+        Just bind' -> pure (StgLet noExtFieldSilent bind' body')+liftExpr (StgLetNoEscape scope bind body)+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do+      body' <- liftExpr body+      case mb_bind' of+        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")+        Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')++liftAlt :: LlStgAlt -> LiftM OutStgAlt+liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+  (,,) con bndrs' <$> liftExpr rhs
+ compiler/GHC/Stg/Lift/Analysis.hs view
@@ -0,0 +1,565 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++-- | Provides the heuristics for when it's beneficial to lambda lift bindings.+-- Most significantly, this employs a cost model to estimate impact on heap+-- allocations, by looking at an STG expression's 'Skeleton'.+module GHC.Stg.Lift.Analysis (+    -- * #when# When to lift+    -- $when++    -- * #clogro# Estimating closure growth+    -- $clogro++    -- * AST annotation+    Skeleton(..), BinderInfo(..), binderInfoBndr,+    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,+    -- * Lifting decision+    goodToLift,+    closureGrowth -- Exported just for the docs+  ) where++import GhcPrelude++import BasicTypes+import Demand+import DynFlags+import Id+import SMRep ( WordOff )+import GHC.Stg.Syntax+import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep+import qualified GHC.StgToCmm.Closure as StgToCmm.Closure+import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout+import Outputable+import Util+import VarSet++import Data.Maybe ( mapMaybe )++-- Note [When to lift]+-- ~~~~~~~~~~~~~~~~~~~+-- $when+-- The analysis proceeds in two steps:+--+--   1. It tags the syntax tree with analysis information in the form of+--      'BinderInfo' at each binder and 'Skeleton's at each let-binding+--      by 'tagSkeletonTopBind' and friends.+--   2. The resulting syntax tree is treated by the "GHC.Stg.Lift"+--      module, calling out to 'goodToLift' to decide if a binding is worthwhile+--      to lift.+--      'goodToLift' consults argument occurrence information in 'BinderInfo'+--      and estimates 'closureGrowth', for which it needs the 'Skeleton'.+--+-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',+-- which employs a number of heuristics to identify and exclude lambda lifting+-- opportunities deemed non-beneficial:+--+--  [Top-level bindings] can't be lifted.+--  [Thunks] and data constructors shouldn't be lifted in order not to destroy+--    sharing.+--  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.+--    Doing the lift would re-introduce the very allocation at call sites that+--    we tried to get rid off in the first place. We capture analysis+--    information in 'BinderInfo'. Note that we also consider a nullary+--    application as argument occurrence, because it would turn into an n-ary+--    partial application created by a generic apply function. This occurs in+--    CPS-heavy code like the CS benchmark.+--  [Join points] should not be lifted, simply because there's no reduction in+--    allocation to be had.+--  [Abstracting over join points] destroys join points, because they end up as+--    arguments to the lifted function.+--  [Abstracting over known local functions] turns a known call into an unknown+--    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off+--    with @-fstg-lift-lams-known@.+--  [Calling convention] Don't lift when the resulting function would have a+--    higher arity than available argument registers for the calling convention.+--    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.+--  [Closure growth] introduced when former free variables have to be available+--    at call sites may actually lead to an increase in overall allocations+--  resulting from a lift. Estimating closure growth is described in+--  "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately+--  concerned with.+--+-- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with+-- some more background and history.++-- Note [Estimating closure growth]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- $clogro+-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',+-- capturing only syntactic details relevant to 'closureGrowth', such as+--+--   * 'ClosureSk', representing closure allocation.+--   * 'RhsSk', representing a RHS of a binding and how many times it's called+--     by an appropriate 'DmdShell'.+--   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.+--+-- This abstraction is mostly so that the main analysis function 'closureGrowth'+-- can stay simple and focused. Also, skeletons tend to be much smaller than+-- the syntax tree they abstract, so it makes sense to construct them once and+-- and operate on them instead of the actual syntax tree.+--+-- A more detailed treatment of computing closure growth, including examples,+-- can be found in the paper referenced from the+-- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.++llTrace :: String -> SDoc -> a -> a+llTrace _ _ c = c+-- llTrace a b c = pprTrace a b c++type instance BinderP      'LiftLams = BinderInfo+type instance XRhsClosure  'LiftLams = DIdSet+type instance XLet         'LiftLams = Skeleton+type instance XLetNoEscape 'LiftLams = Skeleton++freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet+freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs++-- | Captures details of the syntax tree relevant to the cost model, such as+-- closures, multi-shot lambdas and case expressions.+data Skeleton+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton+  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton+  | AltSk !Skeleton !Skeleton+  | BothSk !Skeleton !Skeleton+  | NilSk++bothSk :: Skeleton -> Skeleton -> Skeleton+bothSk NilSk b = b+bothSk a NilSk = a+bothSk a b     = BothSk a b++altSk :: Skeleton -> Skeleton -> Skeleton+altSk NilSk b = b+altSk a NilSk = a+altSk a b     = AltSk a b++rhsSk :: DmdShell -> Skeleton -> Skeleton+rhsSk _        NilSk = NilSk+rhsSk body_dmd skel  = RhsSk body_dmd skel++-- | The type used in binder positions in 'GenStgExpr's.+data BinderInfo+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag+                           --   indicating whether it occurs as an argument+                           --   or in a nullary application+                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").+  | BoringBinder !Id       -- ^ Every other kind of binder++-- | Gets the bound 'Id' out a 'BinderInfo'.+binderInfoBndr :: BinderInfo -> Id+binderInfoBndr (BoringBinder bndr)   = bndr+binderInfoBndr (BindsClosure bndr _) = bndr++-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating+-- occurrences as argument or in a nullary applications otherwise.+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool+binderInfoOccursAsArg BoringBinder{}     = Nothing+binderInfoOccursAsArg (BindsClosure _ b) = Just b++instance Outputable Skeleton where+  ppr NilSk = text ""+  ppr (AltSk l r) = vcat+    [ text "{ " <+> ppr l+    , text "ALT"+    , text "  " <+> ppr r+    , text "}"+    ]+  ppr (BothSk l r) = ppr l $$ ppr r+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)+  ppr (RhsSk body_dmd body) = hcat+    [ text "λ["+    , ppr str+    , text ", "+    , ppr use+    , text "]. "+    , ppr body+    ]+    where+      str+        | isStrictDmd body_dmd = '1'+        | otherwise = '0'+      use+        | isAbsDmd body_dmd = '0'+        | isUsedOnce body_dmd = '1'+        | otherwise = 'ω'++instance Outputable BinderInfo where+  ppr = ppr . binderInfoBndr++instance OutputableBndr BinderInfo where+  pprBndr b = pprBndr b . binderInfoBndr+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr+  pprInfixOcc = pprInfixOcc . binderInfoBndr+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr++mkArgOccs :: [StgArg] -> IdSet+mkArgOccs = mkVarSet . mapMaybe stg_arg_var+  where+    stg_arg_var (StgVarArg occ) = Just occ+    stg_arg_var _               = Nothing++-- | Tags every binder with its 'BinderInfo' and let bindings with their+-- 'Skeleton's.+tagSkeletonTopBind :: CgStgBinding -> LlStgBinding+-- NilSk is OK when tagging top-level bindings. Also, top-level things are never+-- lambda-lifted, so no need to track their argument occurrences. They can also+-- never be let-no-escapes (thus we pass False).+tagSkeletonTopBind bind = bind'+  where+    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind++-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with+-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder+-- occurrences in argument and nullary application position+-- (cf. "GHC.Stg.Lift.Analysis#arg_occs").+tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)+tagSkeletonExpr (StgLit lit)+  = (NilSk, emptyVarSet, StgLit lit)+tagSkeletonExpr (StgConApp con args tys)+  = (NilSk, mkArgOccs args, StgConApp con args tys)+tagSkeletonExpr (StgOpApp op args ty)+  = (NilSk, mkArgOccs args, StgOpApp op args ty)+tagSkeletonExpr (StgApp f args)+  = (NilSk, arg_occs, StgApp f args)+  where+    arg_occs+      -- This checks for nullary applications, which we treat the same as+      -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs".+      | null args = unitVarSet f+      | otherwise = mkArgOccs args+tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")+tagSkeletonExpr (StgCase scrut bndr ty alts)+  = (skel, arg_occs, StgCase scrut' bndr' ty alts')+  where+    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut+    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts+    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)+    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr+    bndr' = BoringBinder bndr+tagSkeletonExpr (StgTick t e)+  = (skel, arg_occs, StgTick t e')+  where+    (skel, arg_occs, e') = tagSkeletonExpr e+tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind+tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind++mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr+mkLet True = StgLetNoEscape+mkLet _    = StgLet++tagSkeletonLet+  :: Bool+  -- ^ Is the binding a let-no-escape?+  -> CgStgExpr+  -- ^ Let body+  -> CgStgBinding+  -- ^ Binding group+  -> (Skeleton, IdSet, LlStgExpr)+  -- ^ RHS skeletons, argument occurrences and annotated binding+tagSkeletonLet is_lne body bind+  = (let_skel, arg_occs, mkLet is_lne scope bind' body')+  where+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body+    (let_skel, arg_occs, scope, bind')+      = tagSkeletonBinding is_lne body_skel body_arg_occs bind++tagSkeletonBinding+  :: Bool+  -- ^ Is the binding a let-no-escape?+  -> Skeleton+  -- ^ Let body skeleton+  -> IdSet+  -- ^ Argument occurrences in the body+  -> CgStgBinding+  -- ^ Binding group+  -> (Skeleton, IdSet, Skeleton, LlStgBinding)+  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and+  --   the annotated binding+tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)+  = (let_skel, arg_occs, scope, bind')+  where+    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs+    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr+    bind_skel+      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes+      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel+    let_skel = bothSk body_skel bind_skel+    occurs_as_arg = bndr `elemVarSet` body_arg_occs+    -- Compared to the recursive case, this exploits the fact that @bndr@ is+    -- never free in @rhs@.+    scope = body_skel+    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'+tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)+  = (let_skel, arg_occs, scope, StgRec pairs')+  where+    (bndrs, _) = unzip pairs+    -- Local recursive STG bindings also regard the defined binders as free+    -- vars. We want to delete those for our cost model, as these are known+    -- calls anyway when we add them to the same top-level recursive group as+    -- the top-level binding currently being analysed.+    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs+    rhss_arg_occs = map sndOf3 skel_occs_rhss'+    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)+    arg_occs = scope_occs `delVarSetList` bndrs+    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,+    -- but we also need the un-wrapped skeletons for calculating the @scope@+    -- of the group, as the outer closures don't contribute to closure growth+    -- when we lift this specific binding.+    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'+    -- Now we can build the actual Skeleton for the expression just by+    -- iterating over each bind pair.+    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')+    let_skel = foldr bothSk body_skel bind_skels+    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))+      where+        -- Here, we finally add the closure around each @skel_rhs@.+        bind_skel+          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes+          | otherwise = ClosureSk bndr fvs skel_rhs+        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs+        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)++tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)+tagSkeletonRhs _ (StgRhsCon ccs dc args)+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)+  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')+  where+    bndrs' = map BoringBinder bndrs+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body+    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel++-- | How many times will the lambda body of the RHS bound to the given+-- identifier be evaluated, relative to its defining context? This function+-- computes the answer in form of a 'DmdShell'.+rhsDmdShell :: Id -> DmdShell+rhsDmdShell bndr+  | is_thunk = oneifyDmd ds+  | otherwise = peelManyCalls (idArity bndr) cd+  where+    is_thunk = idArity bndr == 0+    -- Let's pray idDemandInfo is still OK after unarise...+    (ds, cd) = toCleanDmd (idDemandInfo bndr)++tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)+tagSkeletonAlt (con, bndrs, rhs)+  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))+  where+    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs+    arg_occs = alt_arg_occs `delVarSetList` bndrs++-- | Combines several heuristics to decide whether to lambda-lift a given+-- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details.+goodToLift+  :: DynFlags+  -> TopLevelFlag+  -> RecFlag+  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into+                        -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'.+  -> [(BinderInfo, LlStgRhs)]+  -> Skeleton+  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to+                        -- lift and @abs_ids@ are the variables it would+                        -- abstract over+goodToLift dflags top_lvl rec_flag expander pairs scope = decide+  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]+  , ("memoized", any_memoized)+  , ("argument occurrences", arg_occs)+  , ("join point", is_join_point)+  , ("abstracts join points", abstracts_join_ids)+  , ("abstracts known local function", abstracts_known_local_fun)+  , ("args spill on stack", args_spill_on_stack)+  , ("increases allocation", inc_allocs)+  ] where+      decide deciders+        | not (fancy_or deciders)+        = llTrace "stgLiftLams:lifting"+                  (ppr bndrs <+> ppr abs_ids $$+                   ppr allocs $$+                   ppr scope) $+          Just abs_ids+        | otherwise+        = Nothing+      ppr_deciders = vcat . map (text . fst) . filter snd+      fancy_or deciders+        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $+          any snd deciders++      bndrs = map (binderInfoBndr . fst) pairs+      bndrs_set = mkVarSet bndrs+      rhss = map snd pairs++      -- First objective: Calculate @abs_ids@, e.g. the former free variables+      -- the lifted binding would abstract over. We have to merge the free+      -- variables of all RHS to get the set of variables that will have to be+      -- passed through parameters.+      fvs = unionDVarSets (map freeVarsOfRhs rhss)+      -- To lift the binding to top-level, we want to delete the lifted binders+      -- themselves from the free var set. Local let bindings track recursive+      -- occurrences in their free variable set. We neither want to apply our+      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters+      -- when lifted, as these are known calls. We call the resulting set the+      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.+      -- We will save the set in 'LiftM.e_expansions' for each of the variables+      -- if we perform the lift.+      abs_ids = expander (delDVarSetList fvs bndrs)++      -- We don't lift updatable thunks or constructors+      any_memoized = any is_memoized_rhs rhss+      is_memoized_rhs StgRhsCon{} = True+      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd++      -- Don't lift binders occurring as arguments. This would result in complex+      -- argument expressions which would have to be given a name, reintroducing+      -- the very allocation at each call site that we wanted to get rid off in+      -- the first place.+      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)++      -- These don't allocate anyway.+      is_join_point = any isJoinId bndrs++      -- Abstracting over join points/let-no-escapes spoils them.+      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)++      -- Abstracting over known local functions that aren't floated themselves+      -- turns a known, fast call into an unknown, slow call:+      --+      --    let f x = ...+      --        g y = ... f x ... -- this was a known call+      --    in g 4+      --+      -- After lifting @g@, but not @f@:+      --+      --    l_g f y = ... f y ... -- this is now an unknown call+      --    let f x = ...+      --    in l_g f 4+      --+      -- We can abuse the results of arity analysis for this:+      -- idArity f > 0 ==> known+      known_fun id = idArity id > 0+      abstracts_known_local_fun+        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)++      -- Number of arguments of a RHS in the current binding group if we decide+      -- to lift it+      n_args+        = length+        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm+        . (dVarSetElems abs_ids ++)+        . rhsLambdaBndrs+      max_n_args+        | isRec rec_flag = liftLamsRecArgs dflags+        | otherwise      = liftLamsNonRecArgs dflags+      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess+      -- args are passed on the stack, which means slow memory accesses+      args_spill_on_stack+        | Just n <- max_n_args = maximum (map n_args rhss) > n+        | otherwise = False++      -- We only perform the lift if allocations didn't increase.+      -- Note that @clo_growth@ will be 'infinity' if there was positive growth+      -- under a multi-shot lambda.+      -- Also, abstracting over LNEs is unacceptable. LNEs might return+      -- unlifted tuples, which idClosureFootprint can't cope with.+      inc_allocs = abstracts_join_ids || allocs > 0+      allocs = clo_growth + mkIntWithInf (negate closuresSize)+      -- We calculate and then add up the size of each binding's closure.+      -- GHC does not currently share closure environments, and we either lift+      -- the entire recursive binding group or none of it.+      closuresSize = sum $ flip map rhss $ \rhs ->+        closureSize dflags+        . dVarSetElems+        . expander+        . flip dVarSetMinusVarSet bndrs_set+        $ freeVarsOfRhs rhs+      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope++rhsLambdaBndrs :: LlStgRhs -> [Id]+rhsLambdaBndrs StgRhsCon{} = []+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs++-- | The size in words of a function closure closing over the given 'Id's,+-- including the header.+closureSize :: DynFlags -> [Id] -> WordOff+closureSize dflags ids = words + sTD_HDR_SIZE dflags+  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't+  -- optimise differently when profiling is enabled.+  where+    (words, _, _)+      -- Functions have a StdHeader (as opposed to ThunkHeader).+      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader+      . StgToCmm.Closure.addIdReps+      . StgToCmm.Closure.nonVoidIds+      $ ids++-- | The number of words a single 'Id' adds to a closure's size.+-- Note that this can't handle unboxed tuples (which may still be present in+-- let-no-escapes, even after Unarise), in which case+-- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash.+idClosureFootprint:: DynFlags -> Id -> WordOff+idClosureFootprint dflags+  = StgToCmm.ArgRep.argRepSizeW dflags+  . StgToCmm.ArgRep.idArgRep++-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words+-- as a result of lifting @f@ to top-level. If there was any growing closure+-- under a multi-shot lambda, the result will be 'infinity'.+-- Also see "GHC.Stg.Lift.Analysis#clogro".+closureGrowth+  :: (DIdSet -> DIdSet)+  -- ^ Expands outer free ids that were lifted to their free vars+  -> (Id -> Int)+  -- ^ Computes the closure footprint of an identifier+  -> IdSet+  -- ^ Binding group for which lifting is to be decided+  -> DIdSet+  -- ^ Free vars of the whole binding group prior to lifting it. These must be+  --   available at call sites if we decide to lift the binding group.+  -> Skeleton+  -- ^ Abstraction of the scope of the function+  -> IntWithInf+  -- ^ Closure growth. 'infinity' indicates there was growth under a+  --   (multi-shot) lambda.+closureGrowth expander sizer group abs_ids = go+  where+    go NilSk = 0+    go (BothSk a b) = go a + go b+    go (AltSk a b) = max (go a) (go b)+    go (ClosureSk _ clo_fvs rhs)+      -- If no binder of the @group@ occurs free in the closure, the lifting+      -- won't have any effect on it and we can omit the recursive call.+      | n_occs == 0 = 0+      -- Otherwise, we account the cost of allocating the closure and add it to+      -- the closure growth of its RHS.+      | otherwise   = mkIntWithInf cost + go rhs+      where+        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)+        -- What we close over considering prior lifting decisions+        clo_fvs' = expander clo_fvs+        -- Variables that would additionally occur free in the closure body if+        -- we lift @f@+        newbies = abs_ids `minusDVarSet` clo_fvs'+        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@+        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs+    go (RhsSk body_dmd body)+      -- The conservative assumption would be that+      --   1. Every RHS with positive growth would be called multiple times,+      --      modulo thunks.+      --   2. Every RHS with negative growth wouldn't be called at all.+      --+      -- In the first case, we'd have to return 'infinity', while in the+      -- second case, we'd have to return 0. But we can do far better+      -- considering information from the demand analyser, which provides us+      -- with conservative estimates on minimum and maximum evaluation+      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of+      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body+      -- relative to its defining context.+      | isAbsDmd body_dmd   = 0+      | cg <= 0             = if isStrictDmd body_dmd then cg else 0+      | isUsedOnce body_dmd = cg+      | otherwise           = infinity+      where+        cg = go body
+ compiler/GHC/Stg/Lift/Monad.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'+-- monad.+module GHC.Stg.Lift.Monad (+    decomposeStgBinding, mkStgBinding,+    Env (..),+    -- * #floats# Handling floats+    -- $floats+    FloatLang (..), collectFloats, -- Exported just for the docs+    -- * Transformation monad+    LiftM, runLiftM, withCaffyness,+    -- ** Adding bindings+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,+    -- ** Substitution and binders+    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,+    -- ** Occurrences+    substOcc, isLifted, formerFreeVars, liftedIdsExpander+  ) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import CostCentre ( isCurrentCCS, dontCareCCS )+import DynFlags+import FastString+import Id+import IdInfo+import Name+import Outputable+import OrdList+import GHC.Stg.Subst+import GHC.Stg.Syntax+import Type+import UniqSupply+import Util+import VarEnv+import VarSet++import Control.Arrow ( second )+import Control.Monad.Trans.Class+import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )+import qualified Control.Monad.Trans.RWS.Strict as RWS+import Control.Monad.Trans.Cont ( ContT (..) )+import Data.ByteString ( ByteString )++-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@+decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])+decomposeStgBinding (StgRec pairs) = (Recursive, pairs)+decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])++mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass+mkStgBinding Recursive = StgRec+mkStgBinding NonRecursive = uncurry StgNonRec . head++-- | Environment threaded around in a scoped, @Reader@-like fashion.+data Env+  = Env+  { e_dflags     :: !DynFlags+  -- ^ Read-only.+  , e_subst      :: !Subst+  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',+  -- because shadowing might make a closure's free variables unavailable at its+  -- call sites. Consider:+  -- @+  --    let f y = x + y in let x = 4 in f x+  -- @+  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't+  -- available at its call site.+  , e_expansions :: !(IdEnv DIdSet)+  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because+  -- they are bound at the top-level. Every occurrence must supply the formerly+  -- free variables of the lifted 'Id', so they in turn become free variables of+  -- the call sites. This environment tracks this expansion from lifted 'Id's to+  -- their free variables.+  --+  -- 'InId's to 'OutId's.+  --+  -- Invariant: 'Id's not present in this map won't be substituted.+  , e_in_caffy_context :: !Bool+  -- ^ Are we currently analysing within a caffy context (e.g. the containing+  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely+  -- assume that functions we lift out aren't caffy either.+  }++emptyEnv :: DynFlags -> Env+emptyEnv dflags = Env dflags emptySubst emptyVarEnv False+++-- Note [Handling floats]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- $floats+-- Consider the following expression:+--+-- @+--     f x =+--       let g y = ... f y ...+--       in g x+-- @+--+-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@+-- binding above the binding for @f@:+--+-- @+--     g f y = ... f y ...+--     f x = g f x+-- @+--+-- But this very unnecessarily turns a known call to @f@ into an unknown one, in+-- addition to complicating matters for the analysis.+-- Instead, we'd really like to put both functions in the same recursive group,+-- thereby preserving the known call:+--+-- @+--     Rec {+--       g y = ... f y ...+--       f x = g x+--     }+-- @+--+-- But we don't want this to happen for just /any/ binding. That would create+-- possibly huge recursive groups in the process, calling for an occurrence+-- analyser on STG.+-- So, we need to track when we lift a binding out of a recursive RHS and add+-- the binding to the same recursive group as the enclosing recursive binding+-- (which must have either already been at the top-level or decided to be+-- lifted itself in order to preserve the known call).+--+-- This is done by expressing this kind of nesting structure as a 'Writer' over+-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to+-- 'collectFloats'.+-- API-wise, the analysis will not need to know about the whole 'FloatLang'+-- business and will just manipulate it indirectly through actions in 'LiftM'.++-- | We need to detect when we are lifting something out of the RHS of a+-- recursive binding (c.f. "GHC.Stg.Lift.Monad#floats"), in which case that+-- binding needs to be added to the same top-level recursive group. This+-- requires we detect a certain nesting structure, which is encoded by+-- 'StartBindingGroup' and 'EndBindingGroup'.+--+-- Although 'collectFloats' will only ever care if the current binding to be+-- lifted (through 'LiftedBinding') will occur inside such a binding group or+-- not, e.g. doesn't care about the nesting level as long as its greater than 0.+data FloatLang+  = StartBindingGroup+  | EndBindingGroup+  | PlainTopBinding OutStgTopBinding+  | LiftedBinding OutStgBinding++instance Outputable FloatLang where+  ppr StartBindingGroup = char '('+  ppr EndBindingGroup = char ')'+  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"+  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)+  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)+    where+      (rec, pairs) = decomposeStgBinding bind++-- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.+-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and+-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding+-- group has at least one recursive binding inside. Otherwise there's no point+-- in announcing the binding group in the first place and an @ASSERT@ will+-- trigger.+collectFloats :: [FloatLang] -> [OutStgTopBinding]+collectFloats = go (0 :: Int) []+  where+    go 0 [] [] = []+    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")+    go n binds (f:rest) = case f of+      StartBindingGroup -> go (n+1) binds rest+      EndBindingGroup+        | n == 0 -> pprPanic "collectFloats" (text "no group to end")+        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest+        | otherwise -> go (n-1) binds rest+      PlainTopBinding top_bind+        | n == 0 -> top_bind : go n binds rest+        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")+      LiftedBinding bind+        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest+        | otherwise -> go n (bind:binds) rest++    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding+    rm_cccs = map_rhss removeRhsCCCS+    merge_binds binds = ASSERT( any is_rec binds )+                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)+    is_rec StgRec{} = True+    is_rec _ = False++-- | Omitting this makes for strange closure allocation schemes that crash the+-- GC.+removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)+  | isCurrentCCS ccs+  = StgRhsClosure ext dontCareCCS upd bndrs body+removeRhsCCCS (StgRhsCon ccs con args)+  | isCurrentCCS ccs+  = StgRhsCon dontCareCCS con args+removeRhsCCCS rhs = rhs++-- | The analysis monad consists of the following 'RWST' components:+--+--     * 'Env': Reader-like context. Contains a substitution, info about how+--       how lifted identifiers are to be expanded into applications and details+--       such as 'DynFlags' and a flag helping with determining if a lifted+--       binding is caffy.+--+--     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.+--+--     * No pure state component+--+--     * But wrapping around 'UniqSM' for generating fresh lifted binders.+--       (The @uniqAway@ approach could give the same name to two different+--       lifted binders, so this is necessary.)+newtype LiftM a+  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }+  deriving (Functor, Applicative, Monad)++instance HasDynFlags LiftM where+  getDynFlags = LiftM (RWS.asks e_dflags)++instance MonadUnique LiftM where+  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)+  getUniqueM = LiftM (lift getUniqueM)+  getUniquesM = LiftM (lift getUniquesM)++runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]+runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)+  where+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())++-- | Assumes a given caffyness for the execution of the passed action, which+-- influences the 'cafInfo' of lifted bindings.+withCaffyness :: Bool -> LiftM a -> LiftM a+withCaffyness caffy action+  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))++-- | Writes a plain 'StgTopStringLit' to the output.+addTopStringLit :: OutId -> ByteString -> LiftM ()+addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id++-- | Starts a recursive binding group. See #floats# and 'collectFloats'.+startBindingGroup :: LiftM ()+startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup++-- | Ends a recursive binding group. See #floats# and 'collectFloats'.+endBindingGroup :: LiftM ()+endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup++-- | Lifts a binding to top-level. Depending on whether it's declared inside+-- a recursive RHS (see #floats# and 'collectFloats'), this might be added to+-- an existing recursive top-level binding group.+addLiftedBinding :: OutStgBinding -> LiftM ()+addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding++-- | Takes a binder and a continuation which is called with the substituted+-- binder. The continuation will be evaluated in a 'LiftM' context in which that+-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After+-- the continuation finishes, the new binding won't be in scope anymore.+withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a+withSubstBndr bndr inner = LiftM $ do+  subst <- RWS.asks e_subst+  let (bndr', subst') = substBndr bndr subst+  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))++-- | See 'withSubstBndr'.+withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a+withSubstBndrs = runContT . traverse (ContT . withSubstBndr)++-- | Similarly to 'withSubstBndr', this function takes a set of variables to+-- abstract over, the binder to lift (and generate a fresh, substituted name+-- for) and a continuation in which that fresh, lifted binder is in scope.+--+-- It takes care of all the details involved with copying and adjusting the+-- binder, fresh name generation and caffyness.+withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a+withLiftedBndr abs_ids bndr inner = do+  uniq <- getUniqueM+  let str = "$l" ++ occNameString (getOccName bndr)+  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)+  -- When the enclosing top-level binding is not caffy, then the lifted+  -- binding will not be caffy either. If we don't recognize this, non-caffy+  -- things call caffy things and then codegen screws up.+  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)+  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs+  let bndr'+        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least+        -- for arity information.+        = transferPolyIdInfo bndr (dVarSetElems abs_ids)+        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is+        -- assumed to be caffy and will need an SRT. Transitive call sites might+        -- not be caffy themselves and subsequently will miss a static link+        -- field in their closure. Chaos ensues.+        . flip setIdCafInfo caf_info+        . mkSysLocal (mkFastString str) uniq+        $ ty+  LiftM $ RWS.local+    (\e -> e+      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e+      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids+      })+    (unwrapLiftM (inner bndr'))++-- | See 'withLiftedBndr'.+withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a+withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)++-- | Substitutes a binder /occurrence/, which was brought in scope earlier by+-- 'withSubstBndr'\/'withLiftedBndr'.+substOcc :: Id -> LiftM Id+substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))++-- | Whether the given binding was decided to be lambda lifted.+isLifted :: InId -> LiftM Bool+isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))++-- | Returns an empty list for a binding that was not lifted and the list of all+-- local variables the binding abstracts over (so, exactly the additional+-- arguments at adjusted call sites) otherwise.+formerFreeVars :: InId -> LiftM [OutId]+formerFreeVars f = LiftM $ do+  expansions <- RWS.asks e_expansions+  pure $ case lookupVarEnv expansions f of+    Nothing -> []+    Just fvs -> dVarSetElems fvs++-- | Creates an /expander function/ for the current set of lifted binders.+-- This expander function will replace any 'InId' by their corresponding 'OutId'+-- and, in addition, will expand any lifted binders by the former free variables+-- it abstracts over.+liftedIdsExpander :: LiftM (DIdSet -> DIdSet)+liftedIdsExpander = LiftM $ do+  expansions <- RWS.asks e_expansions+  subst <- RWS.asks e_subst+  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"+  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.+  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in+  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much+  -- trouble.+  let go set fv = case lookupVarEnv expansions fv of+        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted+        Just fvs' -> unionDVarSet set fvs'+  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)+  pure expander
+ compiler/GHC/Stg/Lint.hs view
@@ -0,0 +1,396 @@+{- |+(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 GHC.Stg.Lint ( lintStgTopBindings ) where++import GhcPrelude++import GHC.Stg.Syntax++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 GHC.Types.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)
+ compiler/GHC/Stg/Pipeline.hs view
@@ -0,0 +1,141 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[SimplStg]{Driver for simplifying @STG@ programs}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Stg.Pipeline ( stg2stg ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Stg.Syntax++import GHC.Stg.Lint     ( lintStgTopBindings )+import GHC.Stg.Stats    ( showStgStats )+import GHC.Stg.Unarise  ( unarise )+import GHC.Stg.CSE      ( stgCse )+import GHC.Stg.Lift     ( stgLiftLams )+import Module           ( Module )++import DynFlags+import ErrUtils+import UniqSupply+import Outputable+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict++newtype StgM a = StgM { _unStgM :: StateT Char IO a }+  deriving (Functor, Applicative, Monad, MonadIO)++instance MonadUnique StgM where+  getUniqueSupplyM = StgM $ do { mask <- get+                               ; liftIO $! mkSplitUniqSupply mask}+  getUniqueM = StgM $ do { mask <- get+                         ; liftIO $! uniqFromMask mask}++runStgM :: Char -> StgM a -> IO a+runStgM mask (StgM m) = evalStateT m mask++stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do+        -> Module                    -- module being compiled+        -> [StgTopBinding]           -- input program+        -> IO [StgTopBinding]        -- output program++stg2stg dflags this_mod binds+  = do  { dump_when Opt_D_dump_stg "STG:" binds+        ; showPass dflags "Stg2Stg"+        -- Do the main business!+        ; binds' <- runStgM 'g' $+            foldM do_stg_pass binds (getStgToDo dflags)++        ; dump_when Opt_D_dump_stg_final "Final STG:" binds'++        ; return binds'+   }++  where+    stg_linter unarised+      | gopt Opt_DoStgLinting dflags+      = lintStgTopBindings dflags this_mod unarised+      | otherwise+      = \ _whodunnit _binds -> return ()++    -------------------------------------------+    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]+    do_stg_pass binds to_do+      = case to_do of+          StgDoNothing ->+            return binds++          StgStats ->+            trace (showStgStats binds) (return binds)++          StgCSE -> do+            let binds' = {-# SCC "StgCse" #-} stgCse binds+            end_pass "StgCse" binds'++          StgLiftLams -> do+            us <- getUniqueSupplyM+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds+            end_pass "StgLiftLams" binds'++          StgUnarise -> do+            us <- getUniqueSupplyM+            liftIO (stg_linter False "Pre-unarise" binds)+            let binds' = unarise us binds+            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')+            liftIO (stg_linter True "Unarise" binds')+            return binds'++    dump_when flag header binds+      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds)++    end_pass what binds2+      = liftIO $ do -- report verbosely, if required+          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what+            FormatSTG (vcat (map ppr binds2))+          stg_linter False what binds2+          return binds2++-- -----------------------------------------------------------------------------+-- StgToDo:  abstraction of stg-to-stg passes to run.++-- | Optional Stg-to-Stg passes.+data StgToDo+  = StgCSE+  -- ^ Common subexpression elimination+  | StgLiftLams+  -- ^ Lambda lifting closure variables, trading stack/register allocation for+  -- heap allocation+  | StgStats+  | StgUnarise+  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders+  | StgDoNothing+  -- ^ Useful for building up 'getStgToDo'+  deriving Eq++-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo :: DynFlags -> [StgToDo]+getStgToDo dflags =+  filter (/= StgDoNothing)+    [ mandatory StgUnarise+    -- Important that unarisation comes first+    -- See Note [StgCse after unarisation] in GHC.Stg.CSE+    , optional Opt_StgCSE StgCSE+    , optional Opt_StgLiftLams StgLiftLams+    , optional Opt_StgStats StgStats+    ] where+      optional opt = runWhen (gopt opt dflags)+      mandatory = id++runWhen :: Bool -> StgToDo -> StgToDo+runWhen True todo = todo+runWhen _    _    = StgDoNothing
+ compiler/GHC/Stg/Stats.hs view
@@ -0,0 +1,173 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[StgStats]{Gathers statistical information about programs}+++The program gather statistics about+\begin{enumerate}+\item number of boxed cases+\item number of unboxed cases+\item number of let-no-escapes+\item number of non-updatable lets+\item number of updatable lets+\item number of applications+\item number of primitive applications+\item number of closures (does not include lets bound to constructors)+\item number of free variables in closures+%\item number of top-level functions+%\item number of top-level CAFs+\item number of constructors+\end{enumerate}+-}++{-# LANGUAGE CPP #-}++module GHC.Stg.Stats ( showStgStats ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Stg.Syntax++import Id (Id)+import Panic++import Data.Map (Map)+import qualified Data.Map as Map++data CounterType+  = Literals+  | Applications+  | ConstructorApps+  | PrimitiveApps+  | LetNoEscapes+  | StgCases+  | FreeVariables+  | ConstructorBinds Bool{-True<=>top-level-}+  | ReEntrantBinds   Bool{-ditto-}+  | SingleEntryBinds Bool{-ditto-}+  | UpdatableBinds   Bool{-ditto-}+  deriving (Eq, Ord)++type Count      = Int+type StatEnv    = Map CounterType Count++emptySE :: StatEnv+emptySE = Map.empty++combineSE :: StatEnv -> StatEnv -> StatEnv+combineSE = Map.unionWith (+)++combineSEs :: [StatEnv] -> StatEnv+combineSEs = foldr combineSE emptySE++countOne :: CounterType -> StatEnv+countOne c = Map.singleton c 1++{-+************************************************************************+*                                                                      *+\subsection{Top-level list of bindings (a ``program'')}+*                                                                      *+************************************************************************+-}++showStgStats :: [StgTopBinding] -> String++showStgStats prog+  = "STG Statistics:\n\n"+    ++ concat (map showc (Map.toList (gatherStgStats prog)))+  where+    showc (x,n) = (showString (s x) . shows n) "\n"++    s Literals                = "Literals                   "+    s Applications            = "Applications               "+    s ConstructorApps         = "ConstructorApps            "+    s PrimitiveApps           = "PrimitiveApps              "+    s LetNoEscapes            = "LetNoEscapes               "+    s StgCases                = "StgCases                   "+    s FreeVariables           = "FreeVariables              "+    s (ConstructorBinds True) = "ConstructorBinds_Top       "+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "++gatherStgStats :: [StgTopBinding] -> StatEnv+gatherStgStats binds = combineSEs (map statTopBinding binds)++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++statTopBinding :: StgTopBinding -> StatEnv+statTopBinding (StgTopStringLit _ _) = countOne Literals+statTopBinding (StgTopLifted bind) = statBinding True bind++statBinding :: Bool -- True <=> top-level; False <=> nested+            -> StgBinding+            -> StatEnv++statBinding top (StgNonRec b rhs)+  = statRhs top (b, rhs)++statBinding top (StgRec pairs)+  = combineSEs (map (statRhs top) pairs)++statRhs :: Bool -> (Id, StgRhs) -> StatEnv++statRhs top (_, StgRhsCon _ _ _)+  = countOne (ConstructorBinds top)++statRhs top (_, StgRhsClosure _ _ u _ body)+  = statExpr body `combineSE`+    countOne (+      case u of+        ReEntrant   -> ReEntrantBinds   top+        Updatable   -> UpdatableBinds   top+        SingleEntry -> SingleEntryBinds top+    )++{-+************************************************************************+*                                                                      *+\subsection{Expressions}+*                                                                      *+************************************************************************+-}++statExpr :: StgExpr -> StatEnv++statExpr (StgApp _ _)     = countOne Applications+statExpr (StgLit _)       = countOne Literals+statExpr (StgConApp _ _ _)= countOne ConstructorApps+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps+statExpr (StgTick _ e)    = statExpr e++statExpr (StgLetNoEscape _ binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body                               `combineSE`+    countOne LetNoEscapes++statExpr (StgLet _ binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body++statExpr (StgCase expr _ _ alts)+  = statExpr expr       `combineSE`+    stat_alts alts      `combineSE`+    countOne StgCases+  where+    stat_alts alts+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])++statExpr (StgLam {}) = panic "statExpr StgLam"
+ compiler/GHC/Stg/Subst.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}++module GHC.Stg.Subst 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)
+ compiler/GHC/Stg/Syntax.hs view
@@ -0,0 +1,871 @@+{-+(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 GHC.Stg.Syntax (+        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 GHC.Types.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 GHC.Stg.Unarise++  | 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)]
+ compiler/GHC/Stg/Unarise.hs view
@@ -0,0 +1,769 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012++Note [Unarisation]+~~~~~~~~~~~~~~~~~~+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum+binders. So for example:++  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)++  ==>++  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True++It is important that we do this at the STG level and NOT at the Core level+because it would be very hard to make this pass Core-type-preserving. In this+example the type of 'f' changes, for example.++STG fed to the code generators *must* be unarised because the code generators do+not support unboxed tuple and unboxed sum binders natively.++In more detail: (see next note for unboxed sums)++Suppose that a variable x : (# t1, t2 #).++  * At the binding site for x, make up fresh vars  x1:t1, x2:t2++  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]++  * Replace the binding with a curried binding for x1,x2++       Lambda:   \x.e                ==>   \x1 x2. e+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e++  * Replace argument occurrences with a sequence of args via a lookup in+    UnariseEnv++       f a b x c d   ==>   f a b x1 x2 c d++  * Replace tail-call occurrences with an unboxed tuple via a lookup in+    UnariseEnv++       x  ==>  (# x1, x2 #)++    So, for example++       f x = x    ==>   f x1 x2 = (# x1, x2 #)++  * We /always/ eliminate a case expression when++       - It scrutinises an unboxed tuple or unboxed sum++       - The scrutinee is a variable (or when it is an explicit tuple, but the+         simplifier eliminates those)++    The case alternative (there can be only one) can be one of these two+    things:++      - An unboxed tuple pattern. e.g.++          case v of x { (# x1, x2, x3 #) -> ... }++        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the+        environment with++          x :-> MultiVal [t1,t2,t3]+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3++      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3++By the end of this pass, we only have unboxed tuples in return positions.+Unboxed sums are completely eliminated, see next note.++Note [Translating unboxed sums to unboxed tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unarise also eliminates unboxed sum binders, and translates unboxed sums in+return positions to unboxed tuples. We want to overlap fields of a sum when+translating it to a tuple to have efficient memory layout. When translating a+sum pattern to a tuple pattern, we need to translate it so that binders of sum+alternatives will be mapped to right arguments after the term translation. So+translation of sum DataCon applications to tuple DataCon applications and+translation of sum patterns to tuple patterns need to be in sync.++These translations work like this. Suppose we have++  (# x1 | | ... #) :: (# t1 | t2 | ... #)++remember that t1, t2 ... can be sums and tuples too. So we first generate+layouts of those. Then we "merge" layouts of each alternative, which gives us a+sum layout with best overlapping possible.++Layout of a flat type 'ty1' is just [ty1].+Layout of a tuple is just concatenation of layouts of its fields.++For layout of a sum type,++  - We first get layouts of all alternatives.+  - We sort these layouts based on their "slot types".+  - We merge all the alternatives.++For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)++  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]+  - Merge all alternatives together: [ Ptr, Word, Word ]++We add a slot for the tag to the first position. So our tuple type is++  (# Tag#, Any, Word#, Word# #)+  (we use Any for pointer slots)++Now, any term of this sum type needs to generate a tuple of this type instead.+The translation works by simply putting arguments to first slots that they fit+in. Suppose we had++  (# (# 42#, 'c' #) | | #)++42# fits in Word#, 'c' fits in Any, so we generate this application:++  (# 1#, 'c', 42#, rubbish #)++Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,+3# fits in Word #, so we get:++  (# 2#, rubbish, 2#, 3# #).++Note [Types in StgConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this unboxed sum term:++  (# 123 | #)++What will be the unboxed tuple representation? We can't tell without knowing the+type of this term. For example, these are all valid tuples for this:++  (# 1#, 123 #)          -- when type is (# Int | String #)+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)+  (# 1#, 123, rubbish, rubbish #)+                         -- when type is (# Int | (# Int, Int, Int #) #)++So we pass type arguments of the DataCon's TyCon in StgConApp to decide what+layout to use. Note that unlifted values can't be let-bound, so we don't need+types in StgRhsCon.++Note [UnariseEnv can map to literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv+needs to map variables to literals too. Suppose we have this Core:++  f (# x | #)++  ==> (CorePrep)++  case (# x | #) of y {+    _ -> f y+  }++  ==> (MultiVal)++  case (# 1#, x #) of [x1, x2] {+    _ -> f x1 x2+  }++To eliminate this case expression we need to map x1 to 1# in UnariseEnv:++  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x++so that `f x1 x2` becomes `f 1# x`.++Note [Unarisation and arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of unarisation, the arity that will be recorded in the generated info+table for an Id may be larger than the idArity. Instead we record what we call+the RepArity, which is the Arity taking into account any expanded arguments, and+corresponds to the number of (possibly-void) *registers* arguments will arrive+in.++Note [Post-unarisation invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+STG programs after unarisation have these invariants:++  * No unboxed sums at all.++  * No unboxed tuple binders. Tuples only appear in return position.++  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.+    This means that it's safe to wrap `StgArg`s of DataCon applications with+    `GHC.StgToCmm.Env.NonVoid`, for example.++  * Alt binders (binders in patterns) are always non-void.++  * Binders always have zero (for void arguments) or one PrimRep.+-}++{-# LANGUAGE CPP, TupleSections #-}++module GHC.Stg.Unarise (unarise) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import CoreSyn+import DataCon+import FastString (FastString, mkFastString)+import Id+import Literal+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)+import MkId (voidPrimId, voidArgId)+import MonadUtils (mapAccumLM)+import Outputable+import GHC.Types.RepType+import GHC.Stg.Syntax+import Type+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)+import TysWiredIn+import UniqSupply+import Util+import VarEnv++import Data.Bifunctor (second)+import Data.Maybe (mapMaybe)+import qualified Data.IntMap as IM++--------------------------------------------------------------------------------++-- | A mapping from binders to the Ids they were expanded/renamed to.+--+--   x :-> MultiVal [a,b,c] in rho+--+-- iff  x's typePrimRep is not a singleton, or equivalently+--      x's type is an unboxed tuple, sum or void.+--+--    x :-> UnaryVal x'+--+-- iff x's RepType is UnaryRep or equivalently+--     x's type is not unboxed tuple, sum or void.+--+-- So+--     x :-> MultiVal [a] in rho+-- means x is represented by singleton tuple.+--+--     x :-> MultiVal [] in rho+-- means x is void.+--+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes+--            (i.e. no unboxed tuples, sums or voids)+--+type UnariseEnv = VarEnv UnariseVal++data UnariseVal+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].++instance Outputable UnariseVal where+  ppr (MultiVal args) = text "MultiVal" <+> ppr args+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg++-- | Extend the environment, checking the UnariseEnv invariant.+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv+extendRho rho x (MultiVal args)+  = ASSERT(all (isNvUnaryType . stgArgType) args)+    extendVarEnv rho x (MultiVal args)+extendRho rho x (UnaryVal val)+  = ASSERT(isNvUnaryType (stgArgType val))+    extendVarEnv rho x (UnaryVal val)++--------------------------------------------------------------------------------++unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)++unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding+unariseTopBinding rho (StgTopLifted bind)+  = StgTopLifted <$> unariseBinding rho bind+unariseTopBinding _ bind@StgTopStringLit{} = return bind++unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding+unariseBinding rho (StgNonRec x rhs)+  = StgNonRec x <$> unariseRhs rho rhs+unariseBinding rho (StgRec xrhss)+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss++unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)+  = do (rho', args1) <- unariseFunArgBinders rho args+       expr' <- unariseExpr rho' expr+       return (StgRhsClosure ext ccs update_flag args1 expr')++unariseRhs rho (StgRhsCon ccs con args)+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))+    return (StgRhsCon ccs con (unariseConArgs rho args))++--------------------------------------------------------------------------------++unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr++unariseExpr rho e@(StgApp f [])+  = case lookupVarEnv rho f of+      Just (MultiVal args)  -- Including empty tuples+        -> return (mkTuple args)+      Just (UnaryVal (StgVarArg f'))+        -> return (StgApp f' [])+      Just (UnaryVal (StgLitArg f'))+        -> return (StgLit f')+      Nothing+        -> return e++unariseExpr rho e@(StgApp f args)+  = return (StgApp f' (unariseFunArgs rho args))+  where+    f' = case lookupVarEnv rho f of+           Just (UnaryVal (StgVarArg f')) -> f'+           Nothing -> f+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)+               -- Can't happen because 'args' is non-empty, and+               -- a tuple or sum cannot be applied to anything++unariseExpr _ (StgLit l)+  = return (StgLit l)++unariseExpr rho (StgConApp dc args ty_args)+  | Just args' <- unariseMulti_maybe rho dc args ty_args+  = return (mkTuple args')++  | otherwise+  , let args' = unariseConArgs rho args+  = return (StgConApp dc args' (map stgArgType args'))++unariseExpr rho (StgOpApp op args ty)+  = return (StgOpApp op (unariseFunArgs rho args) ty)++unariseExpr _ e@StgLam{}+  = pprPanic "unariseExpr: found lambda" (ppr e)++unariseExpr rho (StgCase scrut bndr alt_ty alts)+  -- tuple/sum binders in the scrutinee can always be eliminated+  | StgApp v [] <- scrut+  , Just (MultiVal xs) <- lookupVarEnv rho v+  = elimCase rho xs bndr alt_ty alts++  -- Handle strict lets for tuples and sums:+  --   case (# a,b #) of r -> rhs+  -- and analogously for sums+  | StgConApp dc args ty_args <- scrut+  , Just args' <- unariseMulti_maybe rho dc args ty_args+  = elimCase rho args' bndr alt_ty alts++  -- general case+  | otherwise+  = do scrut' <- unariseExpr rho scrut+       alts'  <- unariseAlts rho alt_ty bndr alts+       return (StgCase scrut' bndr alt_ty alts')+                       -- bndr may have a unboxed sum/tuple type but it will be+                       -- dead after unarise (checked in GHC.Stg.Lint)++unariseExpr rho (StgLet ext bind e)+  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgLetNoEscape ext bind e)+  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgTick tick e)+  = StgTick tick <$> unariseExpr rho e++-- Doesn't return void args.+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]+unariseMulti_maybe rho dc args ty_args+  | isUnboxedTupleCon dc+  = Just (unariseConArgs rho args)++  | isUnboxedSumCon dc+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  = Just (mkUbxSum dc ty_args args1)++  | otherwise+  = Nothing++--------------------------------------------------------------------------------++elimCase :: UnariseEnv+         -> [OutStgArg] -- non-void args+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr++elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+  = do let rho1 = extendRho rho bndr (MultiVal args)+           rho2+             | isUnboxedTupleBndr bndr+             = mapTupleIdBinders bndrs args rho1+             | otherwise+             = ASSERT(isUnboxedSumBndr bndr)+               if null bndrs then rho1+                             else mapSumIdBinders bndrs args rho1++       unariseExpr rho2 rhs++elimCase rho args bndr (MultiValAlt _) alts+  | isUnboxedSumBndr bndr+  = do let (tag_arg : real_args) = args+       tag_bndr <- mkId (mkFastString "tag") tagTy+          -- this won't be used but we need a binder anyway+       let rho1 = extendRho rho bndr (MultiVal args)+           scrut' = case tag_arg of+                      StgVarArg v     -> StgApp v []+                      StgLitArg l     -> StgLit l++       alts' <- unariseSumAlts rho1 real_args alts+       return (StgCase scrut' tag_bndr tagAltTy alts')++elimCase _ args bndr alt_ty alts+  = pprPanic "elimCase - unhandled case"+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)++--------------------------------------------------------------------------------++unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys) <- unariseConArgBinder rho bndr+       e' <- unariseExpr rho' e+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]++unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys1) <- unariseConArgBinders rho ys+       MASSERT(ys1 `lengthIs` n)+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))+       e' <- unariseExpr rho'' e+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]++unariseAlts _ (MultiValAlt _) bndr alts+  | isUnboxedTupleBndr bndr+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)++-- In this case we don't need to scrutinize the tag bit+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr+       rhs' <- unariseExpr rho_sum_bndrs rhs+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]++unariseAlts rho (MultiValAlt _) bndr alts+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),+                 scrt_bndrs,+                 inner_case) ]++unariseAlts rho _ _ alts+  = mapM (\alt -> unariseAlt rho alt) alts++unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt+unariseAlt rho (con, xs, e)+  = do (rho', xs') <- unariseConArgBinders rho xs+       (con, xs',) <$> unariseExpr rho' e++--------------------------------------------------------------------------------++-- | Make alternatives that match on the tag of a sum+-- (i.e. generate LitAlts for the tag)+unariseSumAlts :: UnariseEnv+               -> [StgArg] -- sum components _excluding_ the tag bit.+               -> [StgAlt] -- original alternative with sum LHS+               -> UniqSM [StgAlt]+unariseSumAlts env args alts+  = do alts' <- mapM (unariseSumAlt env args) alts+       return (mkDefaultLitAlt alts')++unariseSumAlt :: UnariseEnv+              -> [StgArg] -- sum components _excluding_ the tag bit.+              -> StgAlt   -- original alternative with sum LHS+              -> UniqSM StgAlt+unariseSumAlt rho _ (DEFAULT, _, e)+  = ( DEFAULT, [], ) <$> unariseExpr rho e++unariseSumAlt rho args (DataAlt sumCon, bs, e)+  = do let rho' = mapSumIdBinders bs args rho+       e' <- unariseExpr rho' e+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )++unariseSumAlt _ scrt alt+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)++--------------------------------------------------------------------------------++mapTupleIdBinders+  :: [InId]       -- Un-processed binders of a tuple alternative.+                  -- Can have void binders.+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).+                  -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv+mapTupleIdBinders ids args0 rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args0))+    let+      ids_unarised :: [(Id, [PrimRep])]+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids++      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv+      map_ids rho [] _  = rho+      map_ids rho ((x, x_reps) : xs) args =+        let+          x_arity = length x_reps+          (x_args, args') =+            ASSERT(args `lengthAtLeast` x_arity)+            splitAt x_arity args++          rho'+            | x_arity == 1+            = ASSERT(x_args `lengthIs` 1)+              extendRho rho x (UnaryVal (head x_args))+            | otherwise+            = extendRho rho x (MultiVal x_args)+        in+          map_ids rho' xs args'+    in+      map_ids rho0 ids_unarised args0++mapSumIdBinders+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns+                 -- only have one binder, so this list should be a singleton)+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).+                 -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv++mapSumIdBinders [id] args rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args))+    let+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args+      id_slots  = map primRepSlot $ typePrimRep (idType id)+      layout1   = layoutUbxSum arg_slots id_slots+    in+      if isMultiValBndr id+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])+        else ASSERT(layout1 `lengthIs` 1)+             extendRho rho0 id (UnaryVal (args !! head layout1))++mapSumIdBinders ids sum_args _+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)++-- | Build a unboxed sum term from arguments of an alternative.+--+-- Example, for (# x | #) :: (# (# #) | Int #) we call+--+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]+--+-- which returns+--+--   [ 1#, rubbish ]+--+mkUbxSum+  :: DataCon      -- Sum data con+  -> [Type]       -- Type arguments of the sum data con+  -> [OutStgArg]  -- Actual arguments of the alternative.+  -> [OutStgArg]  -- Final tuple arguments+mkUbxSum dc ty_args args0+  = let+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)+        -- drop tag slot++      tag = dataConTag dc++      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)++      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]+      mkTupArgs _ [] _+        = []+      mkTupArgs arg_idx (slot : slots_left) arg_map+        | Just stg_arg <- IM.lookup arg_idx arg_map+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map+        | otherwise+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map++      slotRubbishArg :: SlotTy -> StgArg+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)+      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)+      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)+    in+      tag_arg : mkTupArgs 0 sum_slots arg_idxs++--------------------------------------------------------------------------------++{-+For arguments (StgArg) and binders (Id) we have two kind of unarisation:++  - When unarising function arg binders and arguments, we don't want to remove+    void binders and arguments. For example,++      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...+      f x y z = <body>++    Here after unarise we should still get a function with arity 3. Similarly+    in the call site we shouldn't remove void arguments:++      f (# (# #), (# #) #) voidId rw++    When unarising <body>, we extend the environment with these binders:++      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []++    Because their rep types are `MultiRep []` (aka. void). This means that when+    we see `x` in a function argument position, we actually replace it with a+    void argument. When we see it in a DataCon argument position, we just get+    rid of it, because DataCon applications in STG are always saturated.++  - When unarising case alternative binders we remove void binders, but we+    still update the environment the same way, because those binders may be+    used in the RHS. Example:++      case x of y {+        (# x1, x2, x3 #) -> <RHS>+      }++    We know that y can't be void, because we don't scrutinize voids, so x will+    be unarised to some number of arguments, and those arguments will have at+    least one non-void thing. So in the rho we will have something like:++      x :-> MultiVal [xu1, xu2]++    Now, after we eliminate void binders in the pattern, we get exactly the same+    number of binders, and extend rho again with these:++      x1 :-> UnaryVal xu1+      x2 :-> MultiVal [] -- x2 is void+      x3 :-> UnaryVal xu2++    Now when we see x2 in a function argument position or in return position, we+    generate void#. In constructor argument position, we just remove it.++So in short, when we have a void id,++  - We keep it if it's a lambda argument binder or+                       in argument position of an application.++  - We remove it if it's a DataCon field binder or+                         in argument position of a DataCon application.+-}++unariseArgBinder+    :: Bool -- data con arg?+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseArgBinder is_con_arg rho x =+  case typePrimRep (idType x) of+    []+      | is_con_arg+      -> return (extendRho rho x (MultiVal []), [])+      | otherwise -- fun arg, do not remove void binders+      -> return (extendRho rho x (MultiVal []), [voidArgId])++    [rep]+      -- Arg represented as single variable, but original type may still be an+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).+      --+      -- While not unarising the binder in this case does not break any programs+      -- (because it unarises to a single variable), it triggers StgLint as we+      -- break the the post-unarisation invariant that says unboxed tuple/sum+      -- binders should vanish. See Note [Post-unarisation invariants].+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])+      | otherwise+      -> return (rho, [x])++    reps -> do+      xs <- mkIds (mkFastString "us") (map primRepToType reps)+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)++--------------------------------------------------------------------------------++-- | MultiVal a function argument. Never returns an empty list.+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]+unariseFunArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args+    Just (MultiVal as)  -> as+    Just (UnaryVal arg) -> [arg]+    Nothing             -> [StgVarArg x]+unariseFunArg _ arg = [arg]++unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]+unariseFunArgs = concatMap . unariseFunArg++unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs++-- Result list of binders is never empty+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseFunArgBinder = unariseArgBinder False++--------------------------------------------------------------------------------++-- | MultiVal a DataCon argument. Returns an empty list when argument is void.+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]+unariseConArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (UnaryVal arg) -> [arg]+    Just (MultiVal as) -> as      -- 'as' can be empty+    Nothing+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#+                                  -- Here realWorld# is not in the envt, but+                                  -- is a void, and so should be eliminated+      | otherwise -> [StgVarArg x]+unariseConArg _ arg@(StgLitArg lit) =+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals+    [arg]++unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]+unariseConArgs = concatMap . unariseConArg++unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs++-- Different from `unariseFunArgBinder`: result list of binders may be empty.+-- See DataCon applications case in Note [Post-unarisation invariants].+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseConArgBinder = unariseArgBinder True++--------------------------------------------------------------------------------++mkIds :: FastString -> [UnaryType] -> UniqSM [Id]+mkIds fs tys = mapM (mkId fs) tys++mkId :: FastString -> UnaryType -> UniqSM Id+mkId = mkSysLocalM++isMultiValBndr :: Id -> Bool+isMultiValBndr id+  | [_] <- typePrimRep (idType id)+  = False+  | otherwise+  = True++isUnboxedSumBndr :: Id -> Bool+isUnboxedSumBndr = isUnboxedSumType . idType++isUnboxedTupleBndr :: Id -> Bool+isUnboxedTupleBndr = isUnboxedTupleType . idType++mkTuple :: [StgArg] -> StgExpr+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)++tagAltTy :: AltType+tagAltTy = PrimAlt IntRep++tagTy :: Type+tagTy = intPrimTy++voidArg :: StgArg+voidArg = StgVarArg voidPrimId++mkDefaultLitAlt :: [StgAlt] -> [StgAlt]+-- We have an exhauseive list of literal alternatives+--    1# -> e1+--    2# -> e2+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid+-- generating a final test. Remember, the DEFAULT comes first if it exists.+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
compiler/GHC/StgToCmm.hs view
@@ -30,7 +30,7 @@ import CmmUtils import CLabel -import StgSyn+import GHC.Stg.Syntax import DynFlags import ErrUtils @@ -38,7 +38,7 @@ import CostCentre import Id import IdInfo-import RepType+import GHC.Types.RepType import DataCon import TyCon import Module@@ -147,7 +147,7 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)   = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)       -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg+      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)   = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
compiler/GHC/StgToCmm/Bind.hs view
@@ -36,7 +36,7 @@ import CmmInfo import CmmUtils import CLabel-import StgSyn+import GHC.Stg.Syntax import CostCentre import Id import IdInfo@@ -206,7 +206,7 @@   = withNewTickyCounterCon (idName id) $     buildDynCon id True cc con (assertNonVoidStgArgs args)       -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg+      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  {- See Note [GC recovery] in compiler/GHC.StgToCmm/Closure.hs -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)@@ -275,7 +275,7 @@    , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))                                    -- pattern binders are always non-void,-                                   -- see Note [Post-unarisation invariants] in UnariseStg+                                   -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise   , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)    , let offset_into_int = bytesToWordsRoundUp dflags the_offset
compiler/GHC/StgToCmm/Bind.hs-boot view
@@ -1,6 +1,6 @@ module GHC.StgToCmm.Bind where  import GHC.StgToCmm.Monad( FCode )-import StgSyn( CgStgBinding )+import GHC.Stg.Syntax( CgStgBinding )  cgBind :: CgStgBinding -> FCode ()
compiler/GHC/StgToCmm/Closure.hs view
@@ -66,7 +66,7 @@  import GhcPrelude -import StgSyn+import GHC.Stg.Syntax import SMRep import Cmm import PprCmmExpr() -- For Outputable instances@@ -82,7 +82,7 @@ import TyCoRep import TcType import TyCon-import RepType+import GHC.Types.RepType import BasicTypes import Outputable import DynFlags@@ -142,7 +142,7 @@  -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions.--- See Note [Post-unarisation invariants] in UnariseStg.+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. assertNonVoidIds :: [Id] -> [NonVoid Id] assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))                        coerce ids@@ -152,7 +152,7 @@  -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments.--- See Note [Post-unarisation invariants] in UnariseStg.+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))                             coerce args@@ -169,7 +169,7 @@ -- See Note [Post-unarisation invariants] idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep1 (idType id)-    -- See also Note [VoidRep] in RepType+    -- See also Note [VoidRep] in GHC.Types.RepType  -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants]@@ -362,20 +362,19 @@ --    * big, otherwise. -- -- Small families can have the constructor tag in the tag bits.--- Big families only use the tag value 1 to represent evaluatedness.+-- Big families always use the tag values 1..mAX_PTR_TAG to represent+-- evaluatedness, the last one lumping together all overflowing ones. -- We don't have very many tag bits: for example, we have 2 bits on -- x86-32 and 3 bits on x86-64.+--+-- Also see Note [Tagging big families] in GHC.StgToCmm.Expr  isSmallFamily :: DynFlags -> Int -> Bool isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags  tagForCon :: DynFlags -> DataCon -> DynTag-tagForCon dflags con-  | isSmallFamily dflags fam_size = con_tag-  | otherwise                     = 1-  where-    con_tag  = dataConTag con -- NB: 1-indexed-    fam_size = tyConFamilySize (dataConTyCon con)+tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags)+-- NB: 1-indexed  tagForArity :: DynFlags -> RepArity -> DynTag tagForArity dflags arity
compiler/GHC/StgToCmm/DataCon.hs view
@@ -19,7 +19,7 @@  import GhcPrelude -import StgSyn+import GHC.Stg.Syntax import CoreSyn  ( AltCon(..) )  import GHC.StgToCmm.Monad@@ -40,7 +40,7 @@ import DynFlags import FastString import Id-import RepType (countConRepArgs)+import GHC.Types.RepType (countConRepArgs) import Literal import PrelInfo import Outputable
compiler/GHC/StgToCmm/Env.hs view
@@ -41,7 +41,7 @@ import MkGraph import Name import Outputable-import StgSyn+import GHC.Stg.Syntax import Type import TysPrim import UniqFM
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-}  ----------------------------------------------------------------------------- --@@ -28,28 +28,30 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import StgSyn+import GHC.Stg.Syntax  import MkGraph import BlockId-import Cmm+import Cmm hiding ( succ ) import CmmInfo import CoreSyn import DataCon+import DynFlags         ( mAX_PTR_TAG ) import ForeignCall import Id import PrimOp import TyCon import Type             ( isUnliftedType )-import RepType          ( isVoidTy, countConRepArgs )+import GHC.Types.RepType          ( isVoidTy, countConRepArgs ) import CostCentre       ( CostCentreStack, currentCCS ) import Maybes import Util import FastString import Outputable -import Control.Monad (unless,void)-import Control.Arrow (first)+import Control.Monad ( unless, void )+import Control.Arrow ( first )+import Data.List     ( partition )  ------------------------------------------------------------------------ --              cgExpr: the main function@@ -570,7 +572,7 @@ isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp+-- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args                  = do     arg_exprs <- getNonVoidArgAmodes stg_args@@ -583,7 +585,7 @@ chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id] -- These are the binders of a case that are assigned by the evaluation of the -- scrutinee.--- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.+-- They're non-void, see Note [Post-unarisation invariants] in GHC.Stg.Unarise. chooseReturnBndrs bndr (PrimAlt _) _alts   = assertNonVoidIds [bndr] @@ -631,30 +633,153 @@          ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts -        ; let fam_sz   = tyConFamilySize tycon-              bndr_reg = CmmLocal (idToReg dflags bndr)+        ; let !fam_sz   = tyConFamilySize tycon+              !bndr_reg = CmmLocal (idToReg dflags bndr)+              !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+              !branches' = first succ <$> branches+              !maxpt = mAX_PTR_TAG dflags+              (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'+              !small = isSmallFamily dflags fam_sz -                    -- Is the constructor tag in the node reg?-        ; if isSmallFamily dflags fam_sz-          then do-                let   -- Yes, bndr_reg has constr. tag in ls bits-                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)-                   branches' = [(tag+1,branch) | (tag,branch) <- branches]-                emitSwitch tag_expr branches' mb_deflt 1 fam_sz+                -- Is the constructor tag in the node reg?+                -- See Note [Tagging big families]+        ; if small || null via_info+           then -- Yes, bndr_reg has constructor tag in ls bits+               emitSwitch ptag_expr branches' mb_deflt 1+                 (if small then fam_sz else maxpt) -           else -- No, get tag from info table-                let -- Note that ptr _always_ has tag 1-                    -- when the family size is big enough-                    untagged_ptr = cmmRegOffB bndr_reg (-1)-                    tag_expr = getConstrTag dflags (untagged_ptr)-                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)+           else -- No, the get exact tag from info table when mAX_PTR_TAG+                -- See Note [Double switching for big families]+              do+                let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)+                    !itag_expr = getConstrTag dflags untagged_ptr+                    !info0 = first pred <$> via_info+                if null via_ptr then+                  emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)+                else do+                  infos_lbl <- newBlockId+                  infos_scp <- getTickScope +                  let spillover = (maxpt, (mkBranch infos_lbl, infos_scp))++                  (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of+                      (Just (stmts, scp)) ->+                          do lbl <- newBlockId+                             return ( Just (mkLabel lbl scp <*> stmts, scp)+                                    , Just (mkBranch lbl, scp))+                      _ -> return (Nothing, Nothing)+                  -- Switch on pointer tag+                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt+                  join_lbl <- newBlockId+                  emit (mkBranch join_lbl)+                  -- Switch on info table tag+                  emitLabel infos_lbl+                  emitSwitch itag_expr info0 mb_shared_branch+                    (maxpt - 1) (fam_sz - 1)+                  emitLabel join_lbl+         ; return AssignedDirectly }  cgAlts _ _ _ _ = panic "cgAlts"         -- UbxTupAlt and PolyAlt have only one alternative +-- Note [Double switching for big families]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- An algebraic data type can have a n >= 0 summands+-- (or alternatives), which are identified (labeled) by+-- constructors. In memory they are kept apart by tags+-- (see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure).+-- Due to the characteristics of the platform that+-- contribute to the alignment of memory objects, there+-- is a natural limit of information about constructors+-- that can be encoded in the pointer tag. When the mapping+-- of constructors to the pointer tag range 1..mAX_PTR_TAG+-- is not injective, then we have a "big data type", also+-- called a "big (constructor) family" in the literature.+-- Constructor tags residing in the info table are injective,+-- but considerably more expensive to obtain, due to additional+-- memory access(es).+--+-- When doing case analysis on a value of a "big data type"+-- we need two nested switch statements to make up for the lack+-- of injectivity of pointer tagging, also taking the info+-- table tag into account. The exact mechanism is described next.+--+-- In the general case, switching on big family alternatives+-- is done by two nested switch statements. According to+-- Note [Tagging big families], the outer switch+-- looks at the pointer tag and the inner dereferences the+-- pointer and switches on the info table tag.+--+-- We can handle a simple case first, namely when none+-- of the case alternatives mention a constructor having+-- a pointer tag of 1..mAX_PTR_TAG-1. In this case we+-- simply emit a switch on the info table tag.+-- Note that the other simple case is when all mentioned+-- alternatives lie in 1..mAX_PTR_TAG-1, in which case we can+-- switch on the ptr tag only, just like in the small family case.+--+-- There is a single intricacy with a nested switch:+-- Both should branch to the same default alternative, and as such+-- avoid duplicate codegen of potentially heavy code. The outer+-- switch generates the actual code with a prepended fresh label,+-- while the inner one only generates a jump to that label.+--+-- For example, let's assume a 64-bit architecture, so that all+-- heap objects are 8-byte aligned, and hence the address of a+-- heap object ends in `000` (three zero bits).+--+-- Then consider the following data type+--+--   > data Big = T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8+--   Ptr tag:      1    2    3    4    5    6    7    7    7+--   As bits:    001  010  011  100  101  110  111  111  111+--   Info pointer tag (zero based):+--                 0    1    2    3    4    5    6    7    8+--+-- Then     \case T2 -> True; T8 -> True; _ -> False+-- will result in following code (slightly cleaned-up and+-- commented -ddump-cmm-from-stg):+{-+           R1 = _sqI::P64;  -- scrutinee+           if (R1 & 7 != 0) goto cqO; else goto cqP;+       cqP: // global       -- enter+           call (I64[R1])(R1) returns to cqO, args: 8, res: 8, upd: 8;+       cqO: // global       -- already WHNF+           _sqJ::P64 = R1;+           _cqX::P64 = _sqJ::P64 & 7;  -- extract pointer tag+           switch [1 .. 7] _cqX::P64 {+               case 3 : goto cqW;+               case 7 : goto cqR;+               default: {goto cqS;}+           }+       cqR: // global+           _cr2 = I32[I64[_sqJ::P64 & (-8)] - 4]; -- tag from info pointer+           switch [6 .. 8] _cr2::I64 {+               case 8 : goto cr1;+               default: {goto cr0;}+           }+       cr1: // global+           R1 = GHC.Types.True_closure+2;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+       cr0: // global     -- technically necessary label+           goto cqS;+       cqW: // global+           R1 = GHC.Types.True_closure+2;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+       cqS: // global+           R1 = GHC.Types.False_closure+1;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+-}+--+-- For 32-bit systems we only have 2 tag bits in the pointers at our disposal,+-- so the performance win is dubious, especially in face of the increased code+-- size due to double switching. But we can take the viewpoint that 32-bit+-- architectures are not relevant for performance any more, so this can be+-- considered as moot. + -- Note [alg-alt heap check] -- -- In an algebraic case with more than one alternative, we will have@@ -675,6 +800,55 @@ --   x = R1 --   goto L1 ++-- Note [Tagging big families]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Both the big and the small constructor families are tagged,+-- that is, greater unions which overflow the tag space of TAG_BITS+-- (i.e. 3 on 32 resp. 7 constructors on 64 bit archs).+--+-- For example, let's assume a 64-bit architecture, so that all+-- heap objects are 8-byte aligned, and hence the address of a+-- heap object ends in `000` (three zero bits).  Then consider+-- > data Maybe a = Nothing | Just a+-- > data Day a = Mon | Tue | Wed | Thu | Fri | Sat | Sun+-- > data Grade = G1 | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10+--+-- Since `Grade` has more than 7 constructors, it counts as a+-- "big data type" (also referred to as "big constructor family" in papers).+-- On the other hand, `Maybe` and `Day` have 7 constructors or fewer, so they+-- are "small data types".+--+-- Then+--   * A pointer to an unevaluated thunk of type `Maybe Int`, `Day` or `Grade` will end in `000`+--   * A tagged pointer to a `Nothing`, `Mon` or `G1` will end in `001`+--   * A tagged pointer to a `Just x`, `Tue` or `G2`  will end in `010`+--   * A tagged pointer to `Wed` or `G3` will end in `011`+--       ...+--   * A tagged pointer to `Sat` or `G6` will end in `110`+--   * A tagged pointer to `Sun` or `G7` or `G8` or `G9` or `G10` will end in `111`+--+-- For big families we employ a mildly clever way of combining pointer and+-- info-table tagging. We use 1..MAX_PTR_TAG-1 as pointer-resident tags where+-- the tags in the pointer and the info table are in a one-to-one+-- relation, whereas tag MAX_PTR_TAG is used as "spill over", signifying+-- we have to fall back and get the precise constructor tag from the+-- info-table.+--+-- Consequently we now cascade switches, because we have to check+-- the pointer tag first, and when it is MAX_PTR_TAG, fetch the precise+-- tag from the info table, and switch on that. The only technically+-- tricky part is that the default case needs (logical) duplication.+-- To do this we emit an extra label for it and branch to that from+-- the second switch. This avoids duplicated codegen. See Trac #14373.+-- See note [Double switching for big families] for the mechanics+-- involved.+--+-- Also see note [Data constructor dynamic tags]+-- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging+--+ ------------------- cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]              -> FCode ( Maybe CmmAGraphScoped@@ -708,7 +882,7 @@         maybeAltHeapCheck gc_plan $         do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)                     -- alt binders are always non-void,-                    -- see Note [Post-unarisation invariants] in UnariseStg+                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise            ; _ <- cgExpr rhs            ; return con }   forkAlts (map cg_alt alts)@@ -736,7 +910,7 @@     do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False                                      currentCCS con (assertNonVoidStgArgs stg_args)                                      -- con args are always non-void,-                                     -- see Note [Post-unarisation invariants] in UnariseStg+                                     -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise                 -- The first "con" says that the name bound to this                 -- closure is "con", which is a bit of a fudge, but                 -- it only affects profiling (hence the False)
compiler/GHC/StgToCmm/Foreign.hs view
@@ -20,7 +20,7 @@  import GhcPrelude hiding( succ, (<*>) ) -import StgSyn+import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env import GHC.StgToCmm.Monad@@ -33,7 +33,7 @@ import CmmUtils import MkGraph import Type-import RepType+import GHC.Types.RepType import CLabel import SMRep import ForeignCall
compiler/GHC/StgToCmm/Heap.hs view
@@ -22,7 +22,7 @@  import GhcPrelude hiding ((<*>)) -import StgSyn+import GHC.Stg.Syntax import CLabel import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils
compiler/GHC/StgToCmm/Layout.hs view
@@ -48,7 +48,7 @@ import CmmUtils import CmmInfo import CLabel-import StgSyn+import GHC.Stg.Syntax import Id import TyCon             ( PrimRep(..), primRepSizeB ) import BasicTypes        ( RepArity )
compiler/GHC/StgToCmm/Prim.hs view
@@ -40,7 +40,7 @@ import BasicTypes import BlockId import MkGraph-import StgSyn+import GHC.Stg.Syntax import Cmm import Module   ( rtsUnitId ) import Type     ( Type, tyConAppTyCon )@@ -1426,10 +1426,17 @@     if ncg && (x86ish || ppc) || llvm     then Left (MO_U_Mul2     (wordWidth dflags))     else Right genericWordMul2Op++  IntMul2Op  -> \_ -> OpDest_CallishHandledLater $+    if ncg && x86ish+    then Left (MO_S_Mul2     (wordWidth dflags))+    else Right genericIntMul2Op+   FloatFabsOp -> \_ -> OpDest_CallishHandledLater $     if (ncg && x86ish || ppc) || llvm     then Left MO_F32_Fabs     else Right $ genericFabsOp W32+   DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $     if (ncg && x86ish || ppc) || llvm     then Left MO_F64_Fabs@@ -1869,6 +1876,31 @@                         topHalf (CmmReg xlyh),                         topHalf (CmmReg r)])] genericWordMul2Op _ _ = panic "genericWordMul2Op"++genericIntMul2Op :: GenericOp+genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174+      let t = cmmExprType dflags arg_x+      p   <- newTemp t+      -- 1) compute the multiplication as if numbers were unsigned+      let wordMul2 = fromMaybe (panic "Unsupported out-of-line WordMul2Op")+                               (emitPrimOp dflags WordMul2Op [arg_x,arg_y])+      wordMul2 [p,res_l]+      -- 2) correct the high bits of the unsigned result+      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]+          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]+          and x y     = CmmMachOp (MO_And   ww) [x, y]+          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]+          f   x y     = (carryFill x) `and` y+          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)+          rl x        = CmmReg (CmmLocal x)+          ww          = wordWidth dflags+      emit $ catAGraphs+             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)+             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))+             ]+genericIntMul2Op _ _ = panic "genericIntMul2Op"  -- This replicates what we had in libraries/base/GHC/Float.hs: --
compiler/GHC/StgToCmm/Ticky.hs view
@@ -111,7 +111,7 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad -import StgSyn+import GHC.Stg.Syntax import CmmExpr import MkGraph import CmmUtils
compiler/GHC/StgToCmm/Utils.hs view
@@ -75,7 +75,7 @@ import DynFlags import FastString import Outputable-import RepType+import GHC.Types.RepType  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8
compiler/cmm/CmmMachOp.hs view
@@ -583,6 +583,7 @@    | MO_UF_Conv Width +  | MO_S_Mul2    Width   | MO_S_QuotRem Width   | MO_U_QuotRem Width   | MO_U_QuotRem2 Width
compiler/cmm/CmmPipeline.hs view
@@ -45,7 +45,7 @@      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog       (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops-     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)       return (srtInfo, cmms) @@ -92,7 +92,7 @@                pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $                   minimalProcPointSet (targetPlatform dflags) call_pps g                dumpWith dflags Opt_D_dump_cmm_proc "Proc points"-                     (ppr l $$ ppr pp $$ ppr g)+                     FormatCMM (ppr l $$ ppr pp $$ ppr g)                return pp              else                return call_pps@@ -112,15 +112,15 @@         ------------- CAF analysis ----------------------------------------------        let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g-       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)         g <- if splitting_proc_points             then do                ------------- Split into separate procedures -----------------------                let pp_map = {-# SCC "procPointAnalysis" #-}                             procPointAnalysis proc_points g-               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $-                    ppr pp_map+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"+                  FormatCMM (ppr pp_map)                g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $                     splitAtProcPoints dflags l call_pps proc_points pp_map                                       (CmmProc h l v g)@@ -151,7 +151,7 @@         dump = dumpGraph dflags          dumps flag name-           = mapM_ (dumpWith dflags flag name . ppr)+           = mapM_ (dumpWith dflags flag name FormatCMM . ppr)          condPass flag pass g dumpflag dumpname =             if gopt flag dflags@@ -347,7 +347,7 @@ dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () dumpGraph dflags flag name g = do   when (gopt Opt_DoCmmLinting dflags) $ do_lint g-  dumpWith dflags flag name (ppr g)+  dumpWith dflags flag name FormatCMM (ppr g)  where   do_lint g = case cmmLintGraph dflags g of                  Just err -> do { fatalErrorMsg dflags err@@ -355,12 +355,13 @@                                 }                  Nothing  -> return () -dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()-dumpWith dflags flag txt sdoc = do-  dumpIfSet_dyn dflags flag txt sdoc+dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpWith dflags flag txt fmt sdoc = do+  dumpIfSet_dyn dflags flag txt fmt sdoc   when (not (dopt flag dflags)) $     -- If `-ddump-cmm-verbose -ddump-to-file` is specified,     -- dump each Cmm pipeline stage output to a separate file.  #16930     when (dopt Opt_D_dump_cmm_verbose dflags)-      $ dumpSDoc dflags alwaysQualify flag txt sdoc-  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc+      $ dumpAction dflags (mkDumpStyle dflags alwaysQualify)+                   (dumpOptionsFromFlag flag) txt fmt sdoc+  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
compiler/cmm/CmmUtils.hs view
@@ -71,7 +71,7 @@ import GhcPrelude  import TyCon    ( PrimRep(..), PrimElemRep(..) )-import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )+import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )  import SMRep import Cmm
compiler/cmm/MkGraph.hs view
@@ -151,7 +151,7 @@ catAGraphs     :: [CmmAGraph] -> CmmAGraph catAGraphs      = concatOL --- | created a sequence "goto id; id:" as an AGraph+-- | creates a sequence "goto id; id:" as an AGraph mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph mkLabel bid scp = unitOL (CgLabel bid scp) @@ -159,7 +159,7 @@ mkMiddle        :: CmmNode O O -> CmmAGraph mkMiddle middle = unitOL (CgStmt middle) --- | created a closed AGraph from a given node+-- | creates a closed AGraph from a given node mkLast         :: CmmNode O C -> CmmAGraph mkLast last     = unitOL (CgLast last)
compiler/cmm/PprC.hs view
@@ -825,6 +825,7 @@         (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)         (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w) +        MO_S_Mul2     {} -> unsupported         MO_S_QuotRem  {} -> unsupported         MO_U_QuotRem  {} -> unsupported         MO_U_QuotRem2 {} -> unsupported
compiler/coreSyn/CoreLint.hs view
@@ -47,7 +47,7 @@ import Coercion import SrcLoc import Type-import RepType+import GHC.Types.RepType import TyCoRep       -- checks validity of types/coercions import TyCoSubst import TyCoFVs@@ -259,8 +259,10 @@                -> CoreProgram -> [CoreRule]                -> IO () dumpPassResult dflags unqual mb_flag hdr extra_info binds rules-  = do { forM_ mb_flag $ \flag ->-           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc+  = do { forM_ mb_flag $ \flag -> do+           let sty = mkDumpStyle dflags unqual+           dumpAction dflags sty (dumpOptionsFromFlag flag)+              (showSDoc dflags hdr) FormatCore dump_doc           -- Report result size          -- This has the side effect of forcing the intermediate to be evaluated@@ -2367,7 +2369,7 @@                             2 (pprBndr LetBind id_occ)     bad_global id_bnd = isGlobalId id_occ                      && isLocalId id_bnd-                     && not (isWiredInName (idName id_occ))+                     && not (isWiredIn id_occ)        -- 'bad_global' checks for the case where an /occurrence/ is        -- a GlobalId, but there is an enclosing binding fora a LocalId.        -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
− compiler/coreSyn/CorePrep.hs 
@@ -1,1734 +0,0 @@-{--(c) The University of Glasgow, 1994-2006---Core pass to saturate constructors and PrimOps--}--{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}--module CorePrep (-      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,-      lookupMkIntegerName, lookupIntegerSDataConName,-      lookupMkNaturalName, lookupNaturalSDataConName-  ) where--#include "HsVersions.h"--import GhcPrelude--import OccurAnal--import HscTypes-import PrelNames-import MkId             ( realWorldPrimId )-import CoreUtils-import CoreArity-import CoreFVs-import CoreMonad        ( CoreToDo(..) )-import CoreLint         ( endPassIO )-import CoreSyn-import CoreSubst-import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here-import Type-import Literal-import Coercion-import TcEnv-import TyCon-import Demand-import Var-import VarSet-import VarEnv-import Id-import IdInfo-import TysWiredIn-import DataCon-import BasicTypes-import Module-import UniqSupply-import Maybes-import OrdList-import ErrUtils-import DynFlags-import Util-import Pair-import Outputable-import GHC.Platform-import FastString-import Name             ( NamedThing(..), nameSrcSpan )-import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )-import Data.Bits-import MonadUtils       ( mapAccumLM )-import Data.List        ( mapAccumL )-import Control.Monad-import CostCentre       ( CostCentre, ccFromThisModule )-import qualified Data.Set as S--{---- ------------------------------------------------------------------------------ Note [CorePrep Overview]--- -----------------------------------------------------------------------------The goal of this pass is to prepare for code generation.--1.  Saturate constructor applications.--2.  Convert to A-normal form; that is, function arguments-    are always variables.--    * Use case for strict arguments:-        f E ==> case E of x -> f x-        (where f is strict)--    * Use let for non-trivial lazy arguments-        f E ==> let x = E in f x-        (were f is lazy and x is non-trivial)--3.  Similarly, convert any unboxed lets into cases.-    [I'm experimenting with leaving 'ok-for-speculation'-     rhss in let-form right up to this point.]--4.  Ensure that *value* lambdas only occur as the RHS of a binding-    (The code generator can't deal with anything else.)-    Type lambdas are ok, however, because the code gen discards them.--5.  [Not any more; nuked Jun 2002] Do the seq/par munging.--6.  Clone all local Ids.-    This means that all such Ids are unique, rather than the-    weaker guarantee of no clashes which the simplifier provides.-    And that is what the code generator needs.--    We don't clone TyVars or CoVars. The code gen doesn't need that,-    and doing so would be tiresome because then we'd need-    to substitute in types and coercions.--7.  Give each dynamic CCall occurrence a fresh unique; this is-    rather like the cloning step above.--8.  Inject bindings for the "implicit" Ids:-        * Constructor wrappers-        * Constructor workers-    We want curried definitions for all of these in case they-    aren't inlined by some caller.--9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs-    Also replace (noinline e) by e.--10. Convert (LitInteger i t) into the core representation-    for the Integer i. Normally this uses mkInteger, but if-    we are using the integer-gmp implementation then there is a-    special case where we use the S# constructor for Integers that-    are in the range of Int.--11. Same for LitNatural.--12. Uphold tick consistency while doing this: We move ticks out of-    (non-type) applications where we can, and make sure that we-    annotate according to scoping rules when floating.--13. Collect cost centres (including cost centres in unfoldings) if we're in-    profiling mode. We have to do this here beucase we won't have unfoldings-    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].--This is all done modulo type applications and abstractions, so that-when type erasure is done for conversion to STG, we don't end up with-any trivial or useless bindings.---Note [CorePrep invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is the syntax of the Core produced by CorePrep:--    Trivial expressions-       arg ::= lit |  var-              | arg ty  |  /\a. arg-              | truv co  |  /\c. arg  |  arg |> co--    Applications-       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co--    Expressions-       body ::= app-              | let(rec) x = rhs in body     -- Boxed only-              | case body of pat -> body-              | /\a. body | /\c. body-              | body |> co--    Right hand sides (only place where value lambdas can occur)-       rhs ::= /\a.rhs  |  \x.rhs  |  body--We define a synonym for each of these non-terminals.  Functions-with the corresponding name produce a result in that syntax.--}--type CpeArg  = CoreExpr    -- Non-terminal 'arg'-type CpeApp  = CoreExpr    -- Non-terminal 'app'-type CpeBody = CoreExpr    -- Non-terminal 'body'-type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'--{--************************************************************************-*                                                                      *-                Top level stuff-*                                                                      *-************************************************************************--}--corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]-            -> IO (CoreProgram, S.Set CostCentre)-corePrepPgm hsc_env this_mod mod_loc binds data_tycons =-    withTiming dflags-               (text "CorePrep"<+>brackets (ppr this_mod))-               (const ()) $ do-    us <- mkSplitUniqSupply 's'-    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env--    let cost_centres-          | WayProf `elem` ways dflags-          = collectCostCentres this_mod binds-          | otherwise-          = S.empty--        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons-            -- NB: we must feed mkImplicitBinds through corePrep too-            -- so that they are suitably cloned and eta-expanded--        binds_out = initUs_ us $ do-                      floats1 <- corePrepTopBinds initialCorePrepEnv binds-                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds-                      return (deFloatTop (floats1 `appendFloats` floats2))--    endPassIO hsc_env alwaysQualify CorePrep binds_out []-    return (binds_out, cost_centres)-  where-    dflags = hsc_dflags hsc_env--corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr-corePrepExpr dflags hsc_env expr =-    withTiming dflags (text "CorePrep [expr]") (const ()) $ do-    us <- mkSplitUniqSupply 's'-    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env-    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)-    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)-    return new_expr--corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats--- Note [Floating out of top level bindings]-corePrepTopBinds initialCorePrepEnv binds-  = go initialCorePrepEnv binds-  where-    go _   []             = return emptyFloats-    go env (bind : binds) = do (env', floats, maybe_new_bind)-                                 <- cpeBind TopLevel env bind-                               MASSERT(isNothing maybe_new_bind)-                                 -- Only join points get returned this way by-                                 -- cpeBind, and no join point may float to top-                               floatss <- go env' binds-                               return (floats `appendFloats` floatss)--mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]--- See Note [Data constructor workers]--- c.f. Note [Injecting implicit bindings] in TidyPgm-mkDataConWorkers dflags mod_loc data_tycons-  = [ NonRec id (tick_it (getName data_con) (Var id))-                                -- The ice is thin here, but it works-    | tycon <- data_tycons,     -- CorePrep will eta-expand it-      data_con <- tyConDataCons tycon,-      let id = dataConWorkId data_con-    ]- where-   -- If we want to generate debug info, we put a source note on the-   -- worker. This is useful, especially for heap profiling.-   tick_it name-     | debugLevel dflags == 0                = id-     | RealSrcSpan span <- nameSrcSpan name  = tick span-     | Just file <- ml_hs_file mod_loc       = tick (span1 file)-     | otherwise                             = tick (span1 "???")-     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))-           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1--{--Note [Floating out of top level bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: we do need to float out of top-level bindings-Consider        x = length [True,False]-We want to get-                s1 = False : []-                s2 = True  : s1-                x  = length s2--We return a *list* of bindings, because we may start with-        x* = f (g y)-where x is demanded, in which case we want to finish with-        a = g y-        x* = f a-And then x will actually end up case-bound--Note [CafInfo and floating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-What happens when we try to float bindings to the top level?  At this-point all the CafInfo is supposed to be correct, and we must make certain-that is true of the new top-level bindings.  There are two cases-to consider--a) The top-level binding is marked asCafRefs.  In that case we are-   basically fine.  The floated bindings had better all be lazy lets,-   so they can float to top level, but they'll all have HasCafRefs-   (the default) which is safe.--b) The top-level binding is marked NoCafRefs.  This really happens-   Example.  CoreTidy produces-      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...-   Now CorePrep has to eta-expand to-      $fApplicativeSTM = let sat = \xy. retry x y-                         in D:Alternative sat ...blah...-   So what we *want* is-      sat [NoCafRefs] = \xy. retry x y-      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...--   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,-   *and* substitute the modified 'sat' into the old RHS.--   It should be the case that 'sat' is itself [NoCafRefs] (a value, no-   cafs) else the original top-level binding would not itself have been-   marked [NoCafRefs].  The DEBUG check in CoreToStg for-   consistentCafInfo will find this.--This is all very gruesome and horrible. It would be better to figure-out CafInfo later, after CorePrep.  We'll do that in due course.-Meanwhile this horrible hack works.--Note [Join points and floating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Join points can float out of other join points but not out of value bindings:--  let z =-    let  w = ... in -- can float-    join k = ... in -- can't float-    ... jump k ...-  join j x1 ... xn =-    let  y = ... in -- can float (but don't want to)-    join h = ... in -- can float (but not much point)-    ... jump h ...-  in ...--Here, the jump to h remains valid if h is floated outward, but the jump to k-does not.--We don't float *out* of join points. It would only be safe to float out of-nullary join points (or ones where the arguments are all either type arguments-or dead binders). Nullary join points aren't ever recursive, so they're always-effectively one-shot functions, which we don't float out of. We *could* float-join points from nullary join points, but there's no clear benefit at this-stage.--Note [Data constructor workers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Create any necessary "implicit" bindings for data con workers.  We-create the rather strange (non-recursive!) binding--        $wC = \x y -> $wC x y--i.e. a curried constructor that allocates.  This means that we can-treat the worker for a constructor like any other function in the rest-of the compiler.  The point here is that CoreToStg will generate a-StgConApp for the RHS, rather than a call to the worker (which would-give a loop).  As Lennart says: the ice is thin here, but it works.--Hmm.  Should we create bindings for dictionary constructors?  They are-always fully applied, and the bindings are just there to support-partial applications. But it's easier to let them through.---Note [Dead code in CorePrep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Imagine that we got an input program like this (see #4962):--  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)-  f x = (g True (Just x) + g () (Just x), g)-    where-      g :: Show a => a -> Maybe Int -> Int-      g _ Nothing = x-      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown--After specialisation and SpecConstr, we would get something like this:--  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)-  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)-    where-      {-# RULES g $dBool = g$Bool-                g $dUnit = g$Unit #-}-      g = ...-      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}-      g$Bool = ...-      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}-      g$Unit = ...-      g$Bool_True_Just = ...-      g$Unit_Unit_Just = ...--Note that the g$Bool and g$Unit functions are actually dead code: they-are only kept alive by the occurrence analyser because they are-referred to by the rules of g, which is being kept alive by the fact-that it is used (unspecialised) in the returned pair.--However, at the CorePrep stage there is no way that the rules for g-will ever fire, and it really seems like a shame to produce an output-program that goes to the trouble of allocating a closure for the-unreachable g$Bool and g$Unit functions.--The way we fix this is to:- * In cloneBndr, drop all unfoldings/rules-- * In deFloatTop, run a simple dead code analyser on each top-level-   RHS to drop the dead local bindings. For that call to OccAnal, we-   disable the binder swap, else the occurrence analyser sometimes-   introduces new let bindings for cased binders, which lead to the bug-   in #5433.--The reason we don't just OccAnal the whole output of CorePrep is that-the tidier ensures that all top-level binders are GlobalIds, so they-don't show up in the free variables any longer. So if you run the-occurrence analyser on the output of CoreTidy (or later) you e.g. turn-this program:--  Rec {-  f = ... f ...-  }--Into this one:--  f = ... f ...--(Since f is not considered to be free in its own RHS.)---************************************************************************-*                                                                      *-                The main code-*                                                                      *-************************************************************************--}--cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind-        -> UniqSM (CorePrepEnv,-                   Floats,         -- Floating value bindings-                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float-                                   -- Nothing <=> added bind' to floats instead-cpeBind top_lvl env (NonRec bndr rhs)-  | not (isJoinId bndr)-  = do { (_, bndr1) <- cpCloneBndr env bndr-       ; let dmd         = idDemandInfo bndr-             is_unlifted = isUnliftedType (idType bndr)-       ; (floats, rhs1) <- cpePair top_lvl NonRecursive-                                   dmd is_unlifted-                                   env bndr1 rhs-       -- See Note [Inlining in CorePrep]-       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl-            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)-            else do {--       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1--       ; return (extendCorePrepEnv env bndr bndr1,-                 addFloat floats new_float,-                 Nothing) }}--  | otherwise -- A join point; see Note [Join points and floating]-  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point-    do { (_, bndr1) <- cpCloneBndr env bndr-       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs-       ; return (extendCorePrepEnv env bndr bndr2,-                 emptyFloats,-                 Just (NonRec bndr2 rhs1)) }--cpeBind top_lvl env (Rec pairs)-  | not (isJoinId (head bndrs))-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')-                           bndrs1 rhss--       ; let (floats_s, rhss1) = unzip stuff-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)-                                           (concatFloats floats_s)--       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),-                 unitFloat (FloatLet (Rec all_pairs)),-                 Nothing) }--  | otherwise -- See Note [Join points and floating]-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs-       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss--       ; let bndrs2 = map fst pairs1-       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),-                 emptyFloats,-                 Just (Rec pairs1)) }-  where-    (bndrs, rhss) = unzip pairs--        -- Flatten all the floats, and the current-        -- group into a single giant Rec-    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2-    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2-    add_float b                       _    = pprPanic "cpeBind" (ppr b)------------------cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool-        -> CorePrepEnv -> OutId -> CoreExpr-        -> UniqSM (Floats, CpeRhs)--- Used for all bindings--- The binder is already cloned, hence an OutId-cpePair top_lvl is_rec dmd is_unlifted env bndr rhs-  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair-    do { (floats1, rhs1) <- cpeRhsE env rhs--       -- See if we are allowed to float this stuff out of the RHS-       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1--       -- Make the arity match up-       ; (floats3, rhs3)-            <- if manifestArity rhs1 <= arity-               then return (floats2, cpeEtaExpand arity rhs2)-               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)-                               -- Note [Silly extra arguments]-                    (do { v <- newVar (idType bndr)-                        ; let float = mkFloat topDmd False v rhs2-                        ; return ( addFloat floats2 float-                                 , cpeEtaExpand arity (Var v)) })--        -- Wrap floating ticks-       ; let (floats4, rhs4) = wrapTicks floats3 rhs3--       ; return (floats4, rhs4) }-  where-    platform = targetPlatform (cpe_dynFlags env)--    arity = idArity bndr        -- We must match this arity--    ----------------------    float_from_rhs floats rhs-      | isEmptyFloats floats = return (emptyFloats, rhs)-      | isTopLevel top_lvl   = float_top    floats rhs-      | otherwise            = float_nested floats rhs--    ----------------------    float_nested floats rhs-      | wantFloatNested is_rec dmd is_unlifted floats rhs-                  = return (floats, rhs)-      | otherwise = dontFloat floats rhs--    ----------------------    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]-      | mayHaveCafRefs (idCafInfo bndr)-      , allLazyTop floats-      = return (floats, rhs)--      -- So the top-level binding is marked NoCafRefs-      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs-      = return (floats', rhs')--      | otherwise-      = dontFloat floats rhs--dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)--- Non-empty floats, but do not want to float from rhs--- So wrap the rhs in the floats--- But: rhs1 might have lambdas, and we can't---      put them inside a wrapBinds-dontFloat floats1 rhs-  = do { (floats2, body) <- rhsToBody rhs-        ; return (emptyFloats, wrapBinds floats1 $-                               wrapBinds floats2 body) }--{- Note [Silly extra arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we had this-        f{arity=1} = \x\y. e-We *must* match the arity on the Id, so we have to generate-        f' = \x\y. e-        f  = \x. f' x--It's a bizarre case: why is the arity on the Id wrong?  Reason-(in the days of __inline_me__):-        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)-When InlineMe notes go away this won't happen any more.  But-it seems good for CorePrep to be robust.--}------------------cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr-            -> UniqSM (JoinId, CpeRhs)--- Used for all join bindings--- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils-cpeJoinPair env bndr rhs-  = ASSERT(isJoinId bndr)-    do { let Just join_arity = isJoinId_maybe bndr-             (bndrs, body)   = collectNBinders join_arity rhs--       ; (env', bndrs') <- cpCloneBndrs env bndrs--       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts-                                      -- with a lambda--       ; let rhs'  = mkCoreLams bndrs' body'-             bndr' = bndr `setIdUnfolding` evaldUnfolding-                          `setIdArity` count isId bndrs-                            -- See Note [Arity and join points]--       ; return (bndr', rhs') }--{--Note [Arity and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Up to now, we've allowed a join point to have an arity greater than its join-arity (minus type arguments), since this is what's useful for eta expansion.-However, for code gen purposes, its arity must be exactly the number of value-arguments it will be called with, and it must have exactly that many value-lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:--  join j x y z = \w -> ... in ...-    =>-  join j x y z = (let f = \w -> ... in f) in ...--This is also what happens with Note [Silly extra arguments]. Note that it's okay-for us to mess with the arity because a join point is never exported.--}---- ------------------------------------------------------------------------------              CpeRhs: produces a result satisfying CpeRhs--- -----------------------------------------------------------------------------cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)--- If---      e  ===>  (bs, e')--- then---      e = let bs in e'        (semantically, that is!)------ For example---      f (g x)   ===>   ([v = g x], f v)--cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)-cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)-cpeRhsE env (Lit (LitNumber LitNumInteger i _))-    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)-                   (cpe_integerSDataCon env) i)-cpeRhsE env (Lit (LitNumber LitNumNatural i _))-    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)-                   (cpe_naturalSDataCon env) i)-cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)-cpeRhsE env expr@(Var {})  = cpeApp env expr-cpeRhsE env expr@(App {}) = cpeApp env expr--cpeRhsE env (Let bind body)-  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind-       ; (body_floats, body') <- cpeRhsE env' body-       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'-                                         Nothing    -> body'-       ; return (bind_floats `appendFloats` body_floats, expr') }--cpeRhsE env (Tick tickish expr)-  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope-  = do { (floats, body) <- cpeRhsE env expr-         -- See [Floating Ticks in CorePrep]-       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }-  | otherwise-  = do { body <- cpeBodyNF env expr-       ; return (emptyFloats, mkTick tickish' body) }-  where-    tickish' | Breakpoint n fvs <- tickish-             -- See also 'substTickish'-             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)-             | otherwise-             = tickish--cpeRhsE env (Cast expr co)-   = do { (floats, expr') <- cpeRhsE env expr-        ; return (floats, Cast expr' co) }--cpeRhsE env expr@(Lam {})-   = do { let (bndrs,body) = collectBinders expr-        ; (env', bndrs') <- cpCloneBndrs env bndrs-        ; body' <- cpeBodyNF env' body-        ; return (emptyFloats, mkLams bndrs' body') }--cpeRhsE env (Case scrut bndr ty alts)-  = do { (floats, scrut') <- cpeBody env scrut-       ; (env', bndr2) <- cpCloneBndr env bndr-       ; let alts'-                 -- This flag is intended to aid in debugging strictness-                 -- analysis bugs. These are particularly nasty to chase down as-                 -- they may manifest as segmentation faults. When this flag is-                 -- enabled we instead produce an 'error' expression to catch-                 -- the case where a function we think should bottom-                 -- unexpectedly returns.-               | gopt Opt_CatchBottoms (cpe_dynFlags env)-               , not (altsAreExhaustive alts)-               = addDefault alts (Just err)-               | otherwise = alts-               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty-                                             "Bottoming expression returned"-       ; alts'' <- mapM (sat_alt env') alts'-       ; return (floats, Case scrut' bndr2 ty alts'') }-  where-    sat_alt env (con, bs, rhs)-       = do { (env2, bs') <- cpCloneBndrs env bs-            ; rhs' <- cpeBodyNF env2 rhs-            ; return (con, bs', rhs') }--cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr--- Here we convert a literal Integer to the low-level--- representation. Exactly how we do this depends on the--- library that implements Integer.  If it's GMP we--- use the S# data constructor for small literals.--- See Note [Integer literals] in Literal-cvtLitInteger dflags _ (Just sdatacon) i-  | inIntRange dflags i -- Special case for small integers-    = mkConApp sdatacon [Lit (mkLitInt dflags i)]--cvtLitInteger dflags mk_integer _ i-    = mkApps (Var mk_integer) [isNonNegative, ints]-  where isNonNegative = if i < 0 then mkConApp falseDataCon []-                                 else mkConApp trueDataCon  []-        ints = mkListExpr intTy (f (abs i))-        f 0 = []-        f x = let low  = x .&. mask-                  high = x `shiftR` bits-              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high-        bits = 31-        mask = 2 ^ bits - 1--cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr--- Here we convert a literal Natural to the low-level--- representation.--- See Note [Natural literals] in Literal-cvtLitNatural dflags _ (Just sdatacon) i-  | inWordRange dflags i -- Special case for small naturals-    = mkConApp sdatacon [Lit (mkLitWord dflags i)]--cvtLitNatural dflags mk_natural _ i-    = mkApps (Var mk_natural) [words]-  where words = mkListExpr wordTy (f i)-        f 0 = []-        f x = let low  = x .&. mask-                  high = x `shiftR` bits-              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high-        bits = 32-        mask = 2 ^ bits - 1---- ------------------------------------------------------------------------------              CpeBody: produces a result satisfying CpeBody--- ------------------------------------------------------------------------------- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without--- producing any floats (any generated floats are immediately--- let-bound using 'wrapBinds').  Generally you want this, esp.--- when you've reached a binding form (e.g., a lambda) and--- floating any further would be incorrect.-cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody-cpeBodyNF env expr-  = do { (floats, body) <- cpeBody env expr-       ; return (wrapBinds floats body) }---- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce--- a list of 'Floats' which are being propagated upwards.  In--- fact, this function is used in only two cases: to--- implement 'cpeBodyNF' (which is what you usually want),--- and in the case when a let-binding is in a case scrutinee--here,--- we can always float out:------      case (let x = y in z) of ...---      ==> let x = y in case z of ...----cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)-cpeBody env expr-  = do { (floats1, rhs) <- cpeRhsE env expr-       ; (floats2, body) <- rhsToBody rhs-       ; return (floats1 `appendFloats` floats2, body) }-----------rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)--- Remove top level lambdas by let-binding--rhsToBody (Tick t expr)-  | tickishScoped t == NoScope  -- only float out of non-scoped annotations-  = do { (floats, expr') <- rhsToBody expr-       ; return (floats, mkTick t expr') }--rhsToBody (Cast e co)-        -- You can get things like-        --      case e of { p -> coerce t (\s -> ...) }-  = do { (floats, e') <- rhsToBody e-       ; return (floats, Cast e' co) }--rhsToBody expr@(Lam {})-  | Just no_lam_result <- tryEtaReducePrep bndrs body-  = return (emptyFloats, no_lam_result)-  | all isTyVar bndrs           -- Type lambdas are ok-  = return (emptyFloats, expr)-  | otherwise                   -- Some value lambdas-  = do { fn <- newVar (exprType expr)-       ; let rhs   = cpeEtaExpand (exprArity expr) expr-             float = FloatLet (NonRec fn rhs)-       ; return (unitFloat float, Var fn) }-  where-    (bndrs,body) = collectBinders expr--rhsToBody expr = return (emptyFloats, expr)------ ------------------------------------------------------------------------------              CpeApp: produces a result satisfying CpeApp--- -----------------------------------------------------------------------------data ArgInfo = CpeApp  CoreArg-             | CpeCast Coercion-             | CpeTick (Tickish Id)--{- Note [runRW arg]-~~~~~~~~~~~~~~~~~~~-If we got, say-   runRW# (case bot of {})-which happened in #11291, we do /not/ want to turn it into-   (case bot of {}) realWorldPrimId#-because that gives a panic in CoreToStg.myCollectArgs, which expects-only variables in function position.  But if we are sure to make-runRW# strict (which we do in MkId), this can't happen--}--cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)--- May return a CpeRhs because of saturating primops-cpeApp top_env expr-  = do { let (terminal, args, depth) = collect_args expr-       ; cpe_app top_env terminal args depth-       }--  where-    -- We have a nested data structure of the form-    -- e `App` a1 `App` a2 ... `App` an, convert it into-    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)-    -- We use 'ArgInfo' because we may also need to-    -- record casts and ticks.  Depth counts the number-    -- of arguments that would consume strictness information-    -- (so, no type or coercion arguments.)-    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)-    collect_args e = go e [] 0-      where-        go (App fun arg)      as !depth-            = go fun (CpeApp arg : as)-                (if isTyCoArg arg then depth else depth + 1)-        go (Cast fun co)      as depth-            = go fun (CpeCast co : as) depth-        go (Tick tickish fun) as depth-            | tickishPlace tickish == PlaceNonLam-            && tickish `tickishScopesLike` SoftScope-            = go fun (CpeTick tickish : as) depth-        go terminal as depth = (terminal, as, depth)--    cpe_app :: CorePrepEnv-            -> CoreExpr-            -> [ArgInfo]-            -> Int-            -> UniqSM (Floats, CpeRhs)-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth-        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and-       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a-        -- Consider the code:-        ---        --      lazy (f x) y-        ---        -- We need to make sure that we need to recursively collect arguments on-        -- "f x", otherwise we'll float "f x" out (it's not a variable) and-        -- end up with this awful -ddump-prep:-        ---        --      case f x of f_x {-        --        __DEFAULT -> f_x y-        --      }-        ---        -- rather than the far superior "f x y".  Test case is par01.-        = let (terminal, args', depth') = collect_args arg-          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)-    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1-        | f `hasKey` runRWKey-        -- See Note [runRW magic]-        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this-        -- is why we return a CorePrepEnv as well)-        = case arg of-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0-            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1-    cpe_app env (Var v) args depth-      = do { v1 <- fiddleCCall v-           ; let e2 = lookupCorePrepEnv env v1-                 hd = getIdFromTrivialExpr_maybe e2-           -- NB: depth from collect_args is right, because e2 is a trivial expression-           -- and thus its embedded Id *must* be at the same depth as any-           -- Apps it is under are type applications only (c.f.-           -- exprIsTrivial).  But note that we need the type of the-           -- expression, not the id.-           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts-           ; mb_saturate hd app floats depth }-        where-          stricts = case idStrictness v of-                            StrictSig (DmdType _ demands _)-                              | listLengthCmp demands depth /= GT -> demands-                                    -- length demands <= depth-                              | otherwise                         -> []-                -- If depth < length demands, then we have too few args to-                -- satisfy strictness  info so we have to  ignore all the-                -- strictness info, e.g. + (error "urk")-                -- Here, we can't evaluate the arg strictly, because this-                -- partial application might be seq'd--        -- We inlined into something that's not a var and has no args.-        -- Bounce it back up to cpeRhsE.-    cpe_app env fun [] _ = cpeRhsE env fun--        -- N-variable fun, better let-bind it-    cpe_app env fun args depth-      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty-                          -- The evalDmd says that it's sure to be evaluated,-                          -- so we'll end up case-binding it-           ; (app, floats) <- rebuild_app args fun' ty fun_floats []-           ; mb_saturate Nothing app floats depth }-        where-          ty = exprType fun--    -- Saturate if necessary-    mb_saturate head app floats depth =-       case head of-         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth-                          ; return (floats, sat_app) }-         _other              -> return (floats, app)--    -- Deconstruct and rebuild the application, floating any non-atomic-    -- arguments to the outside.  We collect the type of the expression,-    -- the head of the application, and the number of actual value arguments,-    -- all of which are used to possibly saturate this application if it-    -- has a constructor or primop at the head.-    rebuild_app-        :: [ArgInfo]                  -- The arguments (inner to outer)-        -> CpeApp-        -> Type-        -> Floats-        -> [Demand]-        -> UniqSM (CpeApp, Floats)-    rebuild_app [] app _ floats ss = do-      MASSERT(null ss) -- make sure we used all the strictness info-      return (app, floats)-    rebuild_app (a : as) fun' fun_ty floats ss = case a of-      CpeApp arg@(Type arg_ty) ->-        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss-      CpeApp arg@(Coercion {}) ->-        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss-      CpeApp arg -> do-        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId-               = case (ss, isLazyExpr arg) of-                   (_   : ss_rest, True)  -> (topDmd, ss_rest)-                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)-                   ([],            _)     -> (topDmd, [])-            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $-                               splitFunTy_maybe fun_ty-        (fs, arg') <- cpeArg top_env ss1 arg arg_ty-        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest-      CpeCast co ->-        let Pair _ty1 ty2 = coercionKind co-        in rebuild_app as (Cast fun' co) ty2 floats ss-      CpeTick tickish ->-        -- See [Floating Ticks in CorePrep]-        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss--isLazyExpr :: CoreExpr -> Bool--- See Note [lazyId magic] in MkId-isLazyExpr (Cast e _)              = isLazyExpr e-isLazyExpr (Tick _ e)              = isLazyExpr e-isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey-isLazyExpr _                       = False--{- Note [runRW magic]-~~~~~~~~~~~~~~~~~~~~~-Some definitions, for instance @runST@, must have careful control over float out-of the bindings in their body. Consider this use of @runST@,--    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s-                             (_, s'') = fill_in_array_or_something a x s'-                         in freezeArray# a s'' )--If we inline @runST@, we'll get:--    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}-              (_, s'') = fill_in_array_or_something a x s'-          in freezeArray# a s''--And now if we allow the @newArray#@ binding to float out to become a CAF,-we end up with a result that is totally and utterly wrong:--    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!-        in \ x ->-            let (_, s'') = fill_in_array_or_something a x s'-            in freezeArray# a s''--All calls to @f@ will share a {\em single} array! Clearly this is nonsense and-must be prevented.--This is what @runRW#@ gives us: by being inlined extremely late in the-optimization (right before lowering to STG, in CorePrep), we can ensure that-no further floating will occur. This allows us to safely inline things like-@runST@, which are otherwise needlessly expensive (see #10678 and #5916).--'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE-pragma.  It is levity-polymorphic.--    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)-           => (State# RealWorld -> (# State# RealWorld, o #))-                              -> (# State# RealWorld, o #)--It needs no special treatment in GHC except this special inlining here-in CorePrep (and in ByteCodeGen).---- ------------------------------------------------------------------------------      CpeArg: produces a result satisfying CpeArg--- -----------------------------------------------------------------------------Note [ANF-ising literal string arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider a program like,--    data Foo = Foo Addr#--    foo = Foo "turtle"#--When we go to ANFise this we might think that we want to float the string-literal like we do any other non-trivial argument. This would look like,--    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }--However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)-wreaks havoc on the CAF annotations that we produce here since we the result-above is caffy since it is updateable. Ideally at some point in the future we-would like to just float the literal to the top level as suggested in #11312,--    s = "turtle"#-    foo = Foo s--However, until then we simply add a special case excluding literals from the-floating done by cpeArg.--}---- | Is an argument okay to CPE?-okCpeArg :: CoreExpr -> Bool--- Don't float literals. See Note [ANF-ising literal string arguments].-okCpeArg (Lit _) = False--- Do not eta expand a trivial argument-okCpeArg expr    = not (exprIsTrivial expr)---- This is where we arrange that a non-trivial argument is let-bound-cpeArg :: CorePrepEnv -> Demand-       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)-cpeArg env dmd arg arg_ty-  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda-       ; (floats2, arg2) <- if want_float floats1 arg1-                            then return (floats1, arg1)-                            else dontFloat floats1 arg1-                -- Else case: arg1 might have lambdas, and we can't-                --            put them inside a wrapBinds--       ; if okCpeArg arg2-         then do { v <- newVar arg_ty-                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2-                       arg_float = mkFloat dmd is_unlifted v arg3-                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }-         else return (floats2, arg2)-       }-  where-    is_unlifted = isUnliftedType arg_ty-    want_float  = wantFloatNested NonRecursive dmd is_unlifted--{--Note [Floating unlifted arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider    C (let v* = expensive in v)--where the "*" indicates "will be demanded".  Usually v will have been-inlined by now, but let's suppose it hasn't (see #2756).  Then we-do *not* want to get--     let v* = expensive in C v--because that has different strictness.  Hence the use of 'allLazy'.-(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)------------------------------------------------------------------------------------ Building the saturated syntax--- -----------------------------------------------------------------------------Note [Eta expansion of hasNoBinding things in CorePrep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-maybeSaturate deals with eta expanding to saturate things that can't deal with-unsaturated applications (identified by 'hasNoBinding', currently just-foreign calls and unboxed tuple/sum constructors).--Note that eta expansion in CorePrep is very fragile due to the "prediction" of-CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta-expansion in CorePrep] in TidyPgm for details.  We previously saturated primop-applications here as well but due to this fragility (see #16846) we now deal-with this another way, as described in Note [Primop wrappers] in PrimOp.--It's quite likely that eta expansion of constructor applications will-eventually break in a similar way to how primops did. We really should-eliminate this case as well.--}--maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs-maybeSaturate fn expr n_args-  | hasNoBinding fn        -- There's no binding-  = return sat_expr--  | otherwise-  = return expr-  where-    fn_arity     = idArity fn-    excess_arity = fn_arity - n_args-    sat_expr     = cpeEtaExpand excess_arity expr--{--************************************************************************-*                                                                      *-                Simple CoreSyn operations-*                                                                      *-************************************************************************--}--{---- --------------------------------------------------------------------------------      Eta reduction--- -------------------------------------------------------------------------------Note [Eta expansion]-~~~~~~~~~~~~~~~~~~~~~-Eta expand to match the arity claimed by the binder Remember,-CorePrep must not change arity--Eta expansion might not have happened already, because it is done by-the simplifier only when there at least one lambda already.--NB1:we could refrain when the RHS is trivial (which can happen-    for exported things).  This would reduce the amount of code-    generated (a little) and make things a little words for-    code compiled without -O.  The case in point is data constructor-    wrappers.--NB2: we have to be careful that the result of etaExpand doesn't-   invalidate any of the assumptions that CorePrep is attempting-   to establish.  One possible cause is eta expanding inside of-   an SCC note - we're now careful in etaExpand to make sure the-   SCC is pushed inside any new lambdas that are generated.--Note [Eta expansion and the CorePrep invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It turns out to be much much easier to do eta expansion-*after* the main CorePrep stuff.  But that places constraints-on the eta expander: given a CpeRhs, it must return a CpeRhs.--For example here is what we do not want:-                f = /\a -> g (h 3)      -- h has arity 2-After ANFing we get-                f = /\a -> let s = h 3 in g s-and now we do NOT want eta expansion to give-                f = /\a -> \ y -> (let s = h 3 in g s) y--Instead CoreArity.etaExpand gives-                f = /\a -> \y -> let s = h 3 in g s y---}--cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs-cpeEtaExpand arity expr-  | arity == 0 = expr-  | otherwise  = etaExpand arity expr--{---- --------------------------------------------------------------------------------      Eta reduction--- -------------------------------------------------------------------------------Why try eta reduction?  Hasn't the simplifier already done eta?-But the simplifier only eta reduces if that leaves something-trivial (like f, or f Int).  But for deLam it would be enough to-get to a partial application:-        case x of { p -> \xs. map f xs }-    ==> case x of { p -> map f }--}---- When updating this function, make sure it lines up with--- CoreUtils.tryEtaReduce!-tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr-tryEtaReducePrep bndrs expr@(App _ _)-  | ok_to_eta_reduce f-  , n_remaining >= 0-  , and (zipWith ok bndrs last_args)-  , not (any (`elemVarSet` fvs_remaining) bndrs)-  , exprIsHNF remaining_expr   -- Don't turn value into a non-value-                               -- else the behaviour with 'seq' changes-  = Just remaining_expr-  where-    (f, args) = collectArgs expr-    remaining_expr = mkApps f remaining_args-    fvs_remaining = exprFreeVars remaining_expr-    (remaining_args, last_args) = splitAt n_remaining args-    n_remaining = length args - length bndrs--    ok bndr (Var arg) = bndr == arg-    ok _    _         = False--    -- We can't eta reduce something which must be saturated.-    ok_to_eta_reduce (Var f) = not (hasNoBinding f)-    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise---tryEtaReducePrep bndrs (Tick tickish e)-  | tickishFloatable tickish-  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e--tryEtaReducePrep _ _ = Nothing--{--************************************************************************-*                                                                      *-                Floats-*                                                                      *-************************************************************************--Note [Pin demand info on floats]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin demand info on floated lets, so that we can see the one-shot thunks.--}--data FloatingBind-  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss-                         -- They are always of lifted type;-                         -- unlifted ones are done with FloatCase-- | FloatCase-      Id CpeBody-      Bool              -- The bool indicates "ok-for-speculation"-- -- | See Note [Floating Ticks in CorePrep]- | FloatTick (Tickish Id)--data Floats = Floats OkToSpec (OrdList FloatingBind)--instance Outputable FloatingBind where-  ppr (FloatLet b) = ppr b-  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r-  ppr (FloatTick t) = ppr t--instance Outputable Floats where-  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>-                         braces (vcat (map ppr (fromOL fs)))--instance Outputable OkToSpec where-  ppr OkToSpec    = text "OkToSpec"-  ppr IfUnboxedOk = text "IfUnboxedOk"-  ppr NotOkToSpec = text "NotOkToSpec"---- Can we float these binds out of the rhs of a let?  We cache this decision--- to avoid having to recompute it in a non-linear way when there are--- deeply nested lets.-data OkToSpec-   = OkToSpec           -- Lazy bindings of lifted type-   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n-                        -- ok-to-speculate unlifted bindings-   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings--mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind-mkFloat dmd is_unlifted bndr rhs-  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)-  | is_hnf    = FloatLet (NonRec bndr                       rhs)-  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)-                   -- See Note [Pin demand info on floats]-  where-    is_hnf    = exprIsHNF rhs-    is_strict = isStrictDmd dmd-    use_case  = is_unlifted || is_strict && not is_hnf-                -- Don't make a case for a value binding,-                -- even if it's strict.  Otherwise we get-                --      case (\x -> e) of ...!--emptyFloats :: Floats-emptyFloats = Floats OkToSpec nilOL--isEmptyFloats :: Floats -> Bool-isEmptyFloats (Floats _ bs) = isNilOL bs--wrapBinds :: Floats -> CpeBody -> CpeBody-wrapBinds (Floats _ binds) body-  = foldrOL mk_bind body binds-  where-    mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body-    mk_bind (FloatLet bind)        body = Let bind body-    mk_bind (FloatTick tickish)    body = mkTick tickish body--addFloat :: Floats -> FloatingBind -> Floats-addFloat (Floats ok_to_spec floats) new_float-  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)-  where-    check (FloatLet _) = OkToSpec-    check (FloatCase _ _ ok_for_spec)-        | ok_for_spec  =  IfUnboxedOk-        | otherwise    =  NotOkToSpec-    check FloatTick{}  = OkToSpec-        -- The ok-for-speculation flag says that it's safe to-        -- float this Case out of a let, and thereby do it more eagerly-        -- We need the top-level flag because it's never ok to float-        -- an unboxed binding to the top level--unitFloat :: FloatingBind -> Floats-unitFloat = addFloat emptyFloats--appendFloats :: Floats -> Floats -> Floats-appendFloats (Floats spec1 floats1) (Floats spec2 floats2)-  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)--concatFloats :: [Floats] -> OrdList FloatingBind-concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL--combine :: OkToSpec -> OkToSpec -> OkToSpec-combine NotOkToSpec _ = NotOkToSpec-combine _ NotOkToSpec = NotOkToSpec-combine IfUnboxedOk _ = IfUnboxedOk-combine _ IfUnboxedOk = IfUnboxedOk-combine _ _           = OkToSpec--deFloatTop :: Floats -> [CoreBind]--- For top level only; we don't expect any FloatCases-deFloatTop (Floats _ floats)-  = foldrOL get [] floats-  where-    get (FloatLet b) bs = occurAnalyseRHSs b : bs-    get (FloatCase var body _) bs  =-      occurAnalyseRHSs (NonRec var body) : bs-    get b _ = pprPanic "corePrepPgm" (ppr b)--    -- See Note [Dead code in CorePrep]-    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)-    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]-------------------------------------------------------------------------------canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)-       -- Note [CafInfo and floating]-canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs-  | OkToSpec <- ok_to_spec           -- Worth trying-  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)-  = Just (Floats OkToSpec fs', subst_expr subst rhs)-  | otherwise-  = Nothing-  where-    subst_expr = substExpr (text "CorePrep")--    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]-       -> Maybe (Subst, OrdList FloatingBind)--    go (subst, fbs_out) [] = Just (subst, fbs_out)--    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)-      | rhs_ok r-      = go (subst', fbs_out `snocOL` new_fb) fbs_in-      where-        (subst', b') = set_nocaf_bndr subst b-        new_fb = FloatLet (NonRec b' (subst_expr subst r))--    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)-      | all rhs_ok rs-      = go (subst', fbs_out `snocOL` new_fb) fbs_in-      where-        (bs,rs) = unzip prs-        (subst', bs') = mapAccumL set_nocaf_bndr subst bs-        rs' = map (subst_expr subst') rs-        new_fb = FloatLet (Rec (bs' `zip` rs'))--    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)-      = go (subst, fbs_out `snocOL` ft) fbs_in--    go _ _ = Nothing      -- Encountered a caffy binding--    -------------    set_nocaf_bndr subst bndr-      = (extendIdSubst subst bndr (Var bndr'), bndr')-      where-        bndr' = bndr `setIdCafInfo` NoCafRefs--    -------------    rhs_ok :: CoreExpr -> Bool-    -- We can only float to top level from a NoCaf thing if-    -- the new binding is static. However it can't mention-    -- any non-static things or it would *already* be Caffy-    rhs_ok = rhsIsStatic platform (\_ -> False)-                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))-                         -- Integer or Natural literals should not show up--wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool-wantFloatNested is_rec dmd is_unlifted floats rhs-  =  isEmptyFloats floats-  || isStrictDmd dmd-  || is_unlifted-  || (allLazyNested is_rec floats && exprIsHNF rhs)-        -- Why the test for allLazyNested?-        --      v = f (x `divInt#` y)-        -- we don't want to float the case, even if f has arity 2,-        -- because floating the case would make it evaluated too early--allLazyTop :: Floats -> Bool-allLazyTop (Floats OkToSpec _) = True-allLazyTop _                   = False--allLazyNested :: RecFlag -> Floats -> Bool-allLazyNested _      (Floats OkToSpec    _) = True-allLazyNested _      (Floats NotOkToSpec _) = False-allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec--{--************************************************************************-*                                                                      *-                Cloning-*                                                                      *-************************************************************************--}---- ------------------------------------------------------------------------------                      The environment--- ------------------------------------------------------------------------------- Note [Inlining in CorePrep]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- There is a subtle but important invariant that must be upheld in the output--- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core--- is impermissible:------      let x :: ()---          x = y------ (where y is a reference to a GLOBAL variable).  Thunks like this are silly:--- they can always be profitably replaced by inlining x with y. Consequently,--- the code generator/runtime does not bother implementing this properly--- (specifically, there is no implementation of stg_ap_0_upd_info, which is the--- stack frame that would be used to update this thunk.  The "0" means it has--- zero free variables.)------ In general, the inliner is good at eliminating these let-bindings.  However,--- there is one case where these trivial updatable thunks can arise: when--- we are optimizing away 'lazy' (see Note [lazyId magic], and also--- 'cpeRhsE'.)  Then, we could have started with:------      let x :: ()---          x = lazy @ () y------ which is a perfectly fine, non-trivial thunk, but then CorePrep will--- drop 'lazy', giving us 'x = y' which is trivial and impermissible.--- The solution is CorePrep to have a miniature inlining pass which deals--- with cases like this.  We can then drop the let-binding altogether.------ Why does the removal of 'lazy' have to occur in CorePrep?--- The gory details are in Note [lazyId magic] in MkId, but the--- main reason is that lazy must appear in unfoldings (optimizer--- output) and it must prevent call-by-value for catch# (which--- is implemented by CorePrep.)------ An alternate strategy for solving this problem is to have the--- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.--- We decided not to adopt this solution to keep the definition--- of 'exprIsTrivial' simple.------ There is ONE caveat however: for top-level bindings we have--- to preserve the binding so that we float the (hacky) non-recursive--- binding for data constructors; see Note [Data constructor workers].------ Note [CorePrep inlines trivial CoreExpr not Id]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an--- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks--- as per Note [Inlining in CorePrep] always have the form--- 'lazy @ SomeType gbl_id'.  But this is not true: the following is--- perfectly reasonable Core:------      let x :: ()---          x = lazy @ (forall a. a) y @ Bool------ When we inline 'x' after eliminating 'lazy', we need to replace--- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like--- this can easily arise with higher-rank types; thus, cpe_env must--- map to CoreExprs, not Ids.--data CorePrepEnv-  = CPE { cpe_dynFlags        :: DynFlags-        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids-        -- ^ This environment is used for three operations:-        ---        --      1. To support cloning of local Ids so that they are-        --      all unique (see item (6) of CorePrep overview).-        ---        --      2. To support beta-reduction of runRW, see-        --      Note [runRW magic] and Note [runRW arg].-        ---        --      3. To let us inline trivial RHSs of non top-level let-bindings,-        --      see Note [lazyId magic], Note [Inlining in CorePrep]-        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)-        , cpe_mkIntegerId     :: Id-        , cpe_mkNaturalId     :: Id-        , cpe_integerSDataCon :: Maybe DataCon-        , cpe_naturalSDataCon :: Maybe DataCon-    }--lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id-lookupMkIntegerName dflags hsc_env-    = guardIntegerUse dflags $ liftM tyThingId $-      lookupGlobal hsc_env mkIntegerName--lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id-lookupMkNaturalName dflags hsc_env-    = guardNaturalUse dflags $ liftM tyThingId $-      lookupGlobal hsc_env mkNaturalName---- See Note [The integer library] in PrelNames-lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)-lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of-    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $-                  lookupGlobal hsc_env integerSDataConName-    IntegerSimple -> return Nothing--lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)-lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of-    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $-                  lookupGlobal hsc_env naturalSDataConName-    IntegerSimple -> return Nothing---- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'-guardIntegerUse :: DynFlags -> IO a -> IO a-guardIntegerUse dflags act-  | thisPackage dflags == primUnitId-  = return $ panic "Can't use Integer in ghc-prim"-  | thisPackage dflags == integerUnitId-  = return $ panic "Can't use Integer in integer-*"-  | otherwise = act---- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'------ Just like we can't use Integer literals in `integer-*`, we can't use Natural--- literals in `base`. If we do, we get interface loading error for GHC.Natural.-guardNaturalUse :: DynFlags -> IO a -> IO a-guardNaturalUse dflags act-  | thisPackage dflags == primUnitId-  = return $ panic "Can't use Natural in ghc-prim"-  | thisPackage dflags == integerUnitId-  = return $ panic "Can't use Natural in integer-*"-  | thisPackage dflags == baseUnitId-  = return $ panic "Can't use Natural in base"-  | otherwise = act--mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv-mkInitialCorePrepEnv dflags hsc_env-    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env-         mkNaturalId <- lookupMkNaturalName dflags hsc_env-         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env-         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env-         return $ CPE {-                      cpe_dynFlags = dflags,-                      cpe_env = emptyVarEnv,-                      cpe_mkIntegerId = mkIntegerId,-                      cpe_mkNaturalId = mkNaturalId,-                      cpe_integerSDataCon = integerSDataCon,-                      cpe_naturalSDataCon = naturalSDataCon-                  }--extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv-extendCorePrepEnv cpe id id'-    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }--extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv-extendCorePrepEnvExpr cpe id expr-    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }--extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv-extendCorePrepEnvList cpe prs-    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)-                        (map (\(id, id') -> (id, Var id')) prs) }--lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr-lookupCorePrepEnv cpe id-  = case lookupVarEnv (cpe_env cpe) id of-        Nothing  -> Var id-        Just exp -> exp--getMkIntegerId :: CorePrepEnv -> Id-getMkIntegerId = cpe_mkIntegerId--getMkNaturalId :: CorePrepEnv -> Id-getMkNaturalId = cpe_mkNaturalId----------------------------------------------------------------------------------- Cloning binders--- -----------------------------------------------------------------------------cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])-cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs--cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)-cpCloneBndr env bndr-  | not (isId bndr)-  = return (env, bndr)--  | otherwise-  = do { bndr' <- clone_it bndr--       -- Drop (now-useless) rules/unfoldings-       -- See Note [Drop unfoldings and rules]-       -- and Note [Preserve evaluatedness] in CoreTidy-       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)-                          -- Simplifier will set the Id's unfolding--             bndr'' = bndr' `setIdUnfolding`      unfolding'-                            `setIdSpecialisation` emptyRuleInfo--       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }-  where-    clone_it bndr-      | isLocalId bndr, not (isCoVar bndr)-      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }-      | otherwise   -- Top level things, which we don't want-                    -- to clone, have become GlobalIds by now-                    -- And we don't clone tyvars, or coercion variables-      = return bndr--{- Note [Drop unfoldings and rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to drop the unfolding/rules on every Id:--  - We are now past interface-file generation, and in the-    codegen pipeline, so we really don't need full unfoldings/rules--  - The unfolding/rule may be keeping stuff alive that we'd like-    to discard.  See  Note [Dead code in CorePrep]--  - Getting rid of unnecessary unfoldings reduces heap usage--  - We are changing uniques, so if we didn't discard unfoldings/rules-    we'd have to substitute in them--HOWEVER, we want to preserve evaluated-ness;-see Note [Preserve evaluatedness] in CoreTidy.--}----------------------------------------------------------------------------------- Cloning ccall Ids; each must have a unique name,--- to give the code generator a handle to hang it on--- -----------------------------------------------------------------------------fiddleCCall :: Id -> UniqSM Id-fiddleCCall id-  | isFCallId id = (id `setVarUnique`) <$> getUniqueM-  | otherwise    = return id----------------------------------------------------------------------------------- Generating new binders--- -----------------------------------------------------------------------------newVar :: Type -> UniqSM Id-newVar ty- = seqType ty `seq` do-     uniq <- getUniqueM-     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)------------------------------------------------------------------------------------ Floating ticks--- --------------------------------------------------------------------------------- Note [Floating Ticks in CorePrep]------ It might seem counter-intuitive to float ticks by default, given--- that we don't actually want to move them if we can help it. On the--- other hand, nothing gets very far in CorePrep anyway, and we want--- to preserve the order of let bindings and tick annotations in--- relation to each other. For example, if we just wrapped let floats--- when they pass through ticks, we might end up performing the--- following transformation:------   src<...> let foo = bar in baz---   ==>  let foo = src<...> bar in src<...> baz------ Because the let-binding would float through the tick, and then--- immediately materialize, achieving nothing but decreasing tick--- accuracy. The only special case is the following scenario:------   let foo = src<...> (let a = b in bar) in baz---   ==>  let foo = src<...> bar; a = src<...> b in baz------ Here we would not want the source tick to end up covering "baz" and--- therefore refrain from pushing ticks outside. Instead, we copy them--- into the floating binds (here "a") in cpePair. Note that where "b"--- or "bar" are (value) lambdas we have to push the annotations--- further inside in order to uphold our rules.------ All of this is implemented below in @wrapTicks@.---- | Like wrapFloats, but only wraps tick floats-wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)-wrapTicks (Floats flag floats0) expr =-    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))-  where (floats1, ticks1) = foldlOL go ([], []) $ floats0-        -- Deeply nested constructors will produce long lists of-        -- redundant source note floats here. We need to eliminate-        -- those early, as relying on mkTick to spot it after the fact-        -- can yield O(n^3) complexity [#11095]-        go (floats, ticks) (FloatTick t)-          = ASSERT(tickishPlace t == PlaceNonLam)-            (floats, if any (flip tickishContains t) ticks-                     then ticks else t:ticks)-        go (floats, ticks) f-          = (foldr wrap f (reverse ticks):floats, ticks)--        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)-        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok-        wrap _ other              = pprPanic "wrapTicks: unexpected float!"-                                             (ppr other)-        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)-        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)----------------------------------------------------------------------------------- Collecting cost centres--- ------------------------------------------------------------------------------- | Collect cost centres defined in the current module, including those in--- unfoldings.-collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre-collectCostCentres mod_name-  = foldl' go_bind S.empty-  where-    go cs e = case e of-      Var{} -> cs-      Lit{} -> cs-      App e1 e2 -> go (go cs e1) e2-      Lam _ e -> go cs e-      Let b e -> go (go_bind cs b) e-      Case scrt _ _ alts -> go_alts (go cs scrt) alts-      Cast e _ -> go cs e-      Tick (ProfNote cc _ _) e ->-        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e-      Tick _ e -> go cs e-      Type{} -> cs-      Coercion{} -> cs--    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)--    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre-    go_bind cs (NonRec b e) =-      go (maybe cs (go cs) (get_unf b)) e-    go_bind cs (Rec bs) =-      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs--    -- Unfoldings may have cost centres that in the original definion are-    -- optimized away, see #5889.-    get_unf = maybeUnfoldingTemplate . realIdUnfolding
compiler/deSugar/Coverage.hs view
@@ -111,7 +111,8 @@      hashNo <- writeMixEntries dflags mod tickCount entries orig_file2      modBreaks <- mkModBreaks hsc_env mod tickCount entries -     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)+     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell+       (pprLHsBinds binds1)       return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
compiler/deSugar/Desugar.hs view
@@ -270,7 +270,7 @@        ; case mb_core_expr of             Nothing   -> return ()             Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"-                         (pprCoreExpr expr)+                         FormatCore (pprCoreExpr expr)         ; return (msgs, mb_core_expr) }
compiler/deSugar/DsExpr.hs view
@@ -11,7 +11,8 @@ {-# LANGUAGE ViewPatterns #-}  module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds-              , dsValBinds, dsLit, dsSyntaxExpr ) where+              , dsValBinds, dsLit, dsSyntaxExpr+              , dsHandleMonadicFailure ) where  #include "HsVersions.h" @@ -918,7 +919,7 @@             ; var   <- selectSimpleMatchVarL pat             ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat                                       res1_ty (cantFailMatchResult body)-            ; match_code <- handle_failure pat match fail_op+            ; match_code <- dsHandleMonadicFailure pat match fail_op             ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }      go _ (ApplicativeStmt body_ty args mb_join) stmts@@ -940,7 +941,7 @@                    = do { var   <- selectSimpleMatchVarL pat                         ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat                                    body_ty (cantFailMatchResult body)-                        ; match_code <- handle_failure pat match fail_op+                        ; match_code <- dsHandleMonadicFailure pat match fail_op                         ; return (var:vs, match_code)                         } @@ -990,10 +991,10 @@     go _ (TransStmt {}) _ = panic "dsDo TransStmt"     go _ (XStmtLR nec)  _ = noExtCon nec -handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr     -- In a do expression, pattern-match failure just calls     -- the monadic 'fail' rather than throwing an exception-handle_failure pat match fail_op+dsHandleMonadicFailure pat match fail_op   | matchCanFail match   = do { dflags <- getDynFlags        ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
compiler/deSugar/DsExpr.hs-boot view
@@ -1,6 +1,6 @@ module DsExpr where-import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )-import DsMonad     ( DsM )+import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )+import DsMonad     ( DsM, MatchResult ) import CoreSyn     ( CoreExpr ) import GHC.Hs.Extension ( GhcTc) @@ -8,3 +8,5 @@ dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr++dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
compiler/deSugar/DsForeign.hs view
@@ -31,7 +31,7 @@ import Module import Name import Type-import RepType+import GHC.Types.RepType import TyCon import Coercion import TcEnv@@ -51,7 +51,6 @@ import DynFlags import GHC.Platform import OrdList-import Pair import Util import Hooks import Encoding@@ -156,7 +155,7 @@           -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do    dflags <- getDynFlags-   let ty  = pFst $ coercionKind co+   let ty  = coercionLKind co        fod = case tyConAppTyCon_maybe (dropForAlls ty) of              Just tycon               | tyConUnique tycon == funPtrTyConKey ->@@ -204,7 +203,7 @@         -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsFCall fn_id co fcall mDeclHeader = do     let-        ty                   = pFst $ coercionKind co+        ty                   = coercionLKind co         (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty         (arg_tys, io_res_ty) = tcSplitFunTys rho @@ -305,7 +304,7 @@            -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsPrimCall fn_id co fcall = do     let-        ty                   = pFst $ coercionKind co+        ty                   = coercionLKind co         (tvs, fun_ty)        = tcSplitForAllTys ty         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty @@ -355,7 +354,7 @@  dsFExport fn_id co ext_name cconv isDyn = do     let-       ty                     = pSnd $ coercionKind co+       ty                     = coercionRKind co        (bndrs, orig_res_ty)   = tcSplitPiTys ty        fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs        -- We must use tcSplits here, because we want to see@@ -477,7 +476,7 @@     return ([fed], h_code, c_code)   where-  ty                       = pFst (coercionKind co0)+  ty                       = coercionLKind co0   (tvs,sans_foralls)       = tcSplitForAllTys ty   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
compiler/deSugar/DsListComp.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )+import {-# SOURCE #-} DsExpr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )  import GHC.Hs import TcHsSyn@@ -624,25 +624,8 @@         ; var      <- selectSimpleMatchVarL pat         ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat                                   res1_ty (cantFailMatchResult body)-        ; match_code <- handle_failure pat match fail_op+        ; match_code <- dsHandleMonadicFailure pat match fail_op         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }--  where-    -- In a monad comprehension expression, pattern-match failure just calls-    -- the monadic `fail` rather than throwing an exception-    handle_failure pat match fail_op-      | matchCanFail match-        = do { dflags <- getDynFlags-             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)-             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]-             ; extractMatchResult match fail_expr }-      | otherwise-        = extractMatchResult match (error "It can't fail")--    mk_fail_msg :: DynFlags -> Located e -> String-    mk_fail_msg dflags pat-        = "Pattern match failure in monad comprehension at " ++-          showPpr dflags (getLoc pat)  -- Desugar nested monad comprehensions, for example in `then..` constructs --    dsInnerMonadComp quals [a,b,c] ret_op
compiler/deSugar/DsMeta.hs view
@@ -177,7 +177,7 @@     no_warn (L loc (Warning _ thing _))       = notHandledL loc "WARNING and DEPRECATION pragmas" $                     text "Pragma for declaration of" <+> ppr thing-    no_warn _ = panic "repTopDs"+    no_warn (L _ (XWarnDecl nec)) = noExtCon nec     no_doc (L loc _)       = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup nec) = noExtCon nec@@ -337,7 +337,7 @@        ; return $ Just (loc, dec)        } -repTyClD _ = panic "repTyClD"+repTyClD (L _ (XTyClDecl nec)) = noExtCon nec  ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)@@ -347,7 +347,7 @@        ; roles2 <- coreList roleTyConName roles1        ; dec <- repRoleAnnotD tycon1 roles2        ; return (loc, dec) }-repRoleD _ = panic "repRoleD"+repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec  ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)@@ -425,7 +425,7 @@                   ; repDataFamilyD tc1 bndrs kind }        ; return (loc, dec)        }-repFamilyDecl _ = panic "repFamilyDecl"+repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec  -- | Represent result signature of a type family repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)@@ -446,7 +446,9 @@ repFamilyResultSigToMaybeKind (KindSig _ ki) =     do { ki' <- repLTy ki        ; coreJust kindQTyConName ki' }-repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"+repFamilyResultSigToMaybeKind TyVarSig{} =+    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"+repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec  -- | Represent injectivity annotation of a type family repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)@@ -490,7 +492,7 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl }))   = do { dec <- repClsInstD cls_decl        ; return (loc, dec) }-repInstD _ = panic "repInstD"+repInstD (L _ (XInstDecl nec)) = noExtCon nec  repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds@@ -533,7 +535,7 @@        ; return (loc, dec) }   where     (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)-repStandaloneDerivD _ = panic "repStandaloneDerivD"+repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec  repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })@@ -638,7 +640,8 @@     chStr = case mch of             Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "             _ -> ""-repForD decl = notHandled "Foreign declaration" (ppr decl)+repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)+repForD (L _ (XForeignDecl nec)) = noExtCon nec  repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv CCallConv          = rep2 cCallName []@@ -664,7 +667,7 @@                    ; dec <- rep2 rep_fn [prec', name']                    ; return (loc,dec) }        ; mapM do_one names }-repFixD _ = panic "repFixD"+repFixD (L _ (XFixitySig nec)) = noExtCon nec  repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule { rd_name = n@@ -691,17 +694,17 @@                          ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }            ; wrapGenSyms ss rule  }        ; return (loc, rule) }-repRuleD _ = panic "repRuleD"+repRuleD (L _ (XRuleDecl nec)) = noExtCon nec  ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n] ruleBndrNames (L _ (RuleBndrSig _ n sig))   | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig   = unLoc n : vars-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))-  = panic "ruleBndrNames"-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))-  = panic "ruleBndrNames"+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))+  = noExtCon nec+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))+  = noExtCon nec ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec  repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)@@ -712,7 +715,7 @@   = do { MkC n'  <- lookupLBinder n        ; MkC ty' <- repLTy (hsSigWcType sig)        ; rep2 typedRuleVarName [n', ty'] }-repRuleBndr _ = panic "repRuleBndr"+repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec  repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))@@ -720,7 +723,7 @@        ; exp'   <- repE exp        ; dec    <- repPragAnn target exp'        ; return (loc, dec) }-repAnnD _ = panic "repAnnD"+repAnnD (L _ (XAnnDecl nec)) = noExtCon nec  repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance (L _ n))@@ -776,7 +779,7 @@          then return c'          else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } -repC _ = panic "repC"+repC (L _ (XConDecl nec)) = noExtCon nec   repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)@@ -824,7 +827,7 @@   where     rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)     rep_deriv_ty ty = repLTy ty-repDerivClause _ = panic "repDerivClause"+repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec  rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn                -> DsM ([GenSymBind], [Core TH.DecQ])@@ -868,7 +871,7 @@ rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _ _st cls mty))   = rep_complete_sig cls mty loc-rep_sig _ = panic "rep_sig"+rep_sig (L _ (XSig nec)) = noExtCon nec  rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name            -> DsM (SrcSpan, Core TH.DecQ)@@ -968,10 +971,10 @@        ; return [(loc, pragma)] }  repInline :: InlineSpec -> DsM (Core TH.Inline)-repInline NoInline  = dataCon noInlineDataConName-repInline Inline    = dataCon inlineDataConName-repInline Inlinable = dataCon inlinableDataConName-repInline spec      = notHandled "repInline" (ppr spec)+repInline NoInline     = dataCon noInlineDataConName+repInline Inline       = dataCon inlineDataConName+repInline Inlinable    = dataCon inlinableDataConName+repInline NoUserInline = notHandled "NOUSERINLINE" empty  repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName@@ -1068,7 +1071,7 @@   = repPlainTV nm repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm   = repLTy ki >>= repKindedTV nm-repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"+repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec  -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)@@ -1079,7 +1082,7 @@   = do { nm' <- lookupBinder nm        ; ki' <- repLTy ki        ; repKindedTV nm' ki' }-repTyVarBndr _ = panic "repTyVarBndr"+repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec  -- represent a type context --@@ -1270,7 +1273,7 @@ repE e@(HsRecFld _ f) = case f of   Unambiguous x _ -> repE (HsVar noExtField (noLoc x))   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)-  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)+  XAmbiguousFieldOcc nec -> noExtCon nec          -- Remember, we're desugaring renamer output here, so         -- HsOverlit can definitely occur@@ -1398,6 +1401,7 @@ repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e) repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e) repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)+repE (XExpr nec)           = noExtCon nec repE e                     = notHandled "Expression form" (ppr e)  -----------------------------------------------------------------------------@@ -1428,7 +1432,7 @@      ; clause <- repClause ps1 gs ds      ; wrapGenSyms (ss1++ss2) clause }}} repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec-repClauseTup _ = panic "repClauseTup"+repClauseTup (L _ (XMatch nec)) = noExtCon nec  repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ) repGuards [L _ (GRHS _ [] e)]@@ -1449,7 +1453,7 @@        ; rhs' <- addBinds gs $ repLE rhs        ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'        ; return (gs, guarded) }-repLGRHS _ = panic "repLGRHS"+repLGRHS (L _ (XGRHS nec)) = noExtCon nec  repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds })@@ -1469,7 +1473,8 @@       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)                                    ; e  <- repLE (hsRecFieldArg fld)                                    ; repFieldExp fn e }-      _                      -> notHandled "Ambiguous record updates" (ppr fld)+      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)+      XAmbiguousFieldOcc nec -> noExtCon nec   @@ -1549,6 +1554,7 @@        ; z <- repRecSt (nonEmptyCoreList rss)        ; (ss2,zs) <- addBinds ss1 (repSts ss)        ; return (ss1++ss2, z : zs) }+repSts (XStmtLR nec : _) = noExtCon nec repSts []    = return ([],[]) repSts other = notHandled "Exotic statement" (ppr other) @@ -1569,8 +1575,7 @@         ; return ([], core_list)         } -repBinds b@(HsIPBinds _ XHsIPBinds {})- = notHandled "Implicit parameter binds extension" (ppr b)+repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec  repBinds (HsValBinds _ decs)  = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }@@ -1584,7 +1589,7 @@         ; core_list <- coreList decQTyConName                                 (de_loc (sort_by_loc prs))         ; return (ss, core_list) }-repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)+repBinds (XHsLocalBindsLR nec) = noExtCon nec  rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))@@ -1595,8 +1600,7 @@       ; rhs' <- repE rhs       ; ipb <- repImplicitParamBind name rhs'       ; return (loc, ipb) }-rep_implicit_param_bind (L _ b@(XIPBind _))- = notHandled "Implicit parameter bind extension" (ppr b)+rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec  rep_implicit_param_name :: HsIPName -> DsM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)@@ -1780,6 +1784,9 @@       ; lam <- addBinds ss (                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })       ; wrapGenSyms ss lam }+repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]+                                          (L _ (XHsLocalBindsLR nec)) } ))+ = noExtCon nec  repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) @@ -1840,7 +1847,7 @@                          ; t' <- repLTy (hsSigWcType t)                          ; repPsig p' t' } repP (SplicePat _ splice) = repSplice splice-+repP (XPat nec) = noExtCon nec repP other = notHandled "Exotic pattern" (ppr other)  ----------------------------------------------------------
compiler/deSugar/DsMonad.hs view
@@ -349,8 +349,8 @@         ; return (setIdUnique old_local uniq) }  newPredVarDs :: PredType -> DsM Var-newPredVarDs pred- = newSysLocalDs pred+newPredVarDs+ = mkSysLocalOrCoVarM (fsLit "ds")  -- like newSysLocalDs, but we allow covars  newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDsNoLP  = mk_local (fsLit "ds")@@ -358,8 +358,8 @@ -- this variant should be used when the caller can be sure that the variable type -- is not levity-polymorphic. It is necessary when the type is knot-tied because -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]-newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")-newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")+newSysLocalDs = mkSysLocalM (fsLit "ds")+newFailLocalDs = mkSysLocalM (fsLit "fail")   -- the fail variable is used only in a situation where we can tell that   -- levity-polymorphism is impossible.
compiler/ghci/ByteCodeGen.hs view
@@ -37,7 +37,7 @@ import PrimOp import CoreFVs import Type-import RepType+import GHC.Types.RepType import DataCon import TyCon import Util@@ -107,7 +107,8 @@              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")          dumpIfSet_dyn dflags Opt_D_dump_BCOs-           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))+           "Proto-BCOs" FormatByteCode+           (vcat (intersperse (char ' ') (map ppr proto_bcos)))          cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)           (case modBreaks of@@ -164,19 +165,19 @@       -- create a totally bogus name for the top-level BCO; this       -- should be harmless, since it's never used for anything       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")-          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")        -- the uniques are needed to generate fresh variables when we introduce new       -- let bindings for ticked expressions       us <- mkSplitUniqSupply 'y'       (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)          <- runBc hsc_env us this_mod Nothing emptyVarEnv $-              schemeTopBind (invented_id, simpleFreeVars expr)+              schemeR [] (invented_name, simpleFreeVars expr)        when (notNull mallocd)            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") -      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)+      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode+         (ppr proto_bco)        assembleOneBCO hsc_env proto_bco   where dflags = hsc_dflags hsc_env@@ -321,7 +322,7 @@                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})    | otherwise-  = schemeR [{- No free variables -}] (id, rhs)+  = schemeR [{- No free variables -}] (getName id, rhs)   -- -----------------------------------------------------------------------------@@ -333,13 +334,13 @@ -- removing the free variables and arguments. -- -- Park the resulting BCO in the monad.  Also requires the--- variable to which this value was bound, so as to give the--- resulting BCO a name.+-- name of the variable to which this value was bound,+-- so as to give the resulting BCO a name.  schemeR :: [Id]                 -- Free vars of the RHS, ordered as they                                 -- will appear in the thunk.  Empty for                                 -- top-level things, which have no free vars.-        -> (Id, AnnExpr Id DVarSet)+        -> (Name, AnnExpr Id DVarSet)         -> BcM (ProtoBCO Name) schemeR fvs (nm, rhs) {-@@ -370,7 +371,7 @@  schemeR_wrk     :: [Id]-    -> Id+    -> Name     -> AnnExpr Id DVarSet             -- expression e, for debugging only     -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e     -> BcM (ProtoBCO Name)@@ -396,7 +397,7 @@          bitmap = mkBitmap dflags bits      body_code <- schemeER_wrk sum_szsb_args p_init body -     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)+     emitBc (mkProtoBCO dflags nm body_code (Right original_body)                  arity bitmap_size bitmap False{-not alts-})  -- introduce break instructions for ticked expressions@@ -575,7 +576,7 @@                      _other -> False           compile_bind d' fvs x rhs size arity off = do-                bco <- schemeR fvs (x,rhs)+                bco <- schemeR fvs (getName x,rhs)                 build_thunk d' fvs size bco off arity           compile_binds =
compiler/ghci/ByteCodeItbls.hs view
@@ -19,7 +19,7 @@ import NameEnv import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )-import RepType+import GHC.Types.RepType import GHC.StgToCmm.Layout  ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) import Util
compiler/ghci/Debugger.hs view
@@ -91,6 +91,7 @@          Just subst' -> do { dflags <- GHC.getSessionDynFlags                            ; liftIO $                                dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                                 FormatText                                  (fsep $ [text "RTTI Improvement for", ppr id,                                   text "old substitution:" , ppr subst,                                   text "new substitution:" , ppr subst'])
compiler/ghci/RtClosureInspect.hs view
@@ -33,7 +33,7 @@  import DataCon import Type-import RepType+import GHC.Types.RepType import qualified Unify as U import Var import TcRnMonad
compiler/iface/FlagChecker.hs view
@@ -61,7 +61,7 @@         ticky =           map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] -        flags = (mainis, safeHs, lang, cpp, paths, prof, ticky)+        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel))      in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags
compiler/iface/LoadIface.hs view
@@ -156,7 +156,7 @@   where     nd_doc = text "Need decl for" <+> ppr name     not_found_msg = hang (text "Can't find interface-file declaration for" <+>-                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)+                                pprNameSpace (nameNameSpace name) <+> ppr name)                        2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",                                 text "Use -ddump-if-trace to get an idea of which file caused the error"])     found_things_msg eps =
compiler/iface/MkIface.hs view
@@ -167,7 +167,7 @@       addFingerprints hsc_env partial_iface      -- Debug printing-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface)+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)      return full_iface @@ -311,7 +311,7 @@           mi_doc_hdr     = doc_hdr,           mi_decl_docs   = decl_docs,           mi_arg_docs    = arg_docs,-          mi_final_exts        = () }+          mi_final_exts  = () }   where      cmp_rule     = comparing ifRuleName      -- Compare these lexicographically by OccName, *not* by unique,
compiler/iface/TcIface.hs view
@@ -1321,6 +1321,8 @@     let         scrut_ty   = exprType scrut'         case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty+     -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors+     -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.         tc_app     = splitTyConApp scrut_ty                 -- NB: Won't always succeed (polymorphic case)                 --     but won't be demanded in those cases@@ -1337,7 +1339,7 @@         ; ty'     <- tcIfaceType ty         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}                               NotTopLevel name ty' info-        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info+        ; let id = mkLocalIdWithInfo name ty' id_info                      `asJoinId_maybe` tcJoinInfo ji         ; rhs' <- tcIfaceExpr rhs         ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)@@ -1353,7 +1355,7 @@    tc_rec_bndr (IfLetBndr fs ty _ ji)      = do { name <- newIfaceName (mkVarOccFS fs)           ; ty'  <- tcIfaceType ty-          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }+          ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }    tc_pair (IfLetBndr _ _ info _, rhs) id      = do { rhs' <- tcIfaceExpr rhs           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}@@ -1365,7 +1367,7 @@     -- If debug flag is not set: Ignore source notes     dbgLvl <- fmap debugLevel getDynFlags     case tickish of-      IfaceSource{} | dbgLvl > 0+      IfaceSource{} | dbgLvl == 0                     -> return expr'       _otherwise    -> do         tickish' <- tcIfaceTickish tickish@@ -1733,6 +1735,7 @@   = do  { name <- newIfaceName (mkVarOccFS fs)         ; ty' <- tcIfaceType ty         ; let id = mkLocalIdOrCoVar name ty'+          -- We should not have "OrCoVar" here, this is a bug (#17545)         ; extendIfaceIdEnv [id] (thing_inside id) }  bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
compiler/llvmGen/LlvmCodeGen.hs view
@@ -17,11 +17,8 @@ import LlvmCodeGen.Regs import LlvmMangler -import BlockId import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import Cmm-import CmmUtils-import Hoopl.Block import Hoopl.Collections import PprCmm @@ -31,7 +28,6 @@ import ErrUtils import FastString import Outputable-import UniqSupply import SysTools ( figureLlvmVersion ) import qualified Stream @@ -150,46 +146,16 @@         renderLlvm $ pprLlvmData (concat gss', concat tss) --- | LLVM can't handle entry blocks which loop back to themselves (could be--- seen as an LLVM bug) so we rearrange the code to keep the original entry--- label which branches to a newly generated second label that branches back--- to itself. See: #11649-fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl-fixBottom cp@(CmmProc hdr entry_lbl live g) =-    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map-  where-    blk_map = toBlockMap g--    fix_block :: CmmBlock -> LlvmM RawCmmDecl-    fix_block blk-        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk-        , isEmptyBlock middle-        , e_lbl == b_lbl = do-            new_lbl <- mkBlockId <$> getUniqueM--            let fst_blk =-                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)-                snd_blk =-                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)--            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)-                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]--    fix_block _ = pure cp--fixBottom rcd = pure rcd- -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM () cmmLlvmGen cmm@CmmProc{} = do      -- rewrite assignments to global regs     dflags <- getDynFlag id-    fixed_cmm <- fixBottom $-                    {-# SCC "llvm_fix_regs" #-}-                    fixStgRegisters dflags cmm+    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm -    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])+    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"+      FormatCMM (pprCmmGroup [fixed_cmm])      -- generate llvm code from cmm     llvmBC <- withClearVars $ genLlvmProc fixed_cmm
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -337,10 +337,10 @@ getLlvmPlatform = getDynFlag targetPlatform  -- | Dumps the document if the corresponding flag has been set by the user-dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()-dumpIfSetLlvm flag hdr doc = do+dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()+dumpIfSetLlvm flag hdr fmt doc = do   dflags <- getDynFlags-  liftIO $ dumpIfSet_dyn dflags flag hdr doc+  liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc  -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM ()@@ -353,7 +353,7 @@                (Outp.mkCodeStyle Outp.CStyle) sdoc      -- Dump, if requested-    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc     return ()  -- | Marks a variable as "used"
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -66,20 +66,24 @@  -- | Generate code for a list of blocks that make up a complete -- procedure. The first block in the list is expected to be the entry--- point and will get the prologue.+-- point. basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]                       -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) basicBlocksCodeGen _    []                     = panic "no entry block!"-basicBlocksCodeGen live (entryBlock:cmmBlocks)-  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)+basicBlocksCodeGen live cmmBlocks+  = do -- Emit the prologue+       -- N.B. this must be its own block to ensure that the entry block of the+       -- procedure has no predecessors, as required by the LLVM IR. See #17589+       -- and #11649.+       bid <- newBlockId+       (prologue, prologueTops) <- funPrologue live cmmBlocks+       let entryBlock = BasicBlock bid (fromOL prologue)         -- Generate code-       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock        (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks         -- Compose-       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)-       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)+       return (entryBlock : blocks, prologueTops ++ concat topss)   -- | Generate code for one block@@ -833,6 +837,7 @@     MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."                              ++ showSDoc dflags (ppr $ widthToLlvmInt w) +    MO_S_Mul2    {}  -> unsupported     MO_S_QuotRem {}  -> unsupported     MO_U_QuotRem {}  -> unsupported     MO_U_QuotRem2 {} -> unsupported@@ -1833,7 +1838,10 @@         markStackReg r         return $ toOL [alloc, Store rval reg] -  return (concatOL stmtss, [])+  return (concatOL stmtss `snocOL` jumpToEntry, [])+  where+    entryBlk : _ = cmmBlocks+    jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)  -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here.
compiler/main/CodeOutput.hs view
@@ -212,7 +212,9 @@         createDirectoryIfMissing True (takeDirectory stub_h)          dumpIfSet_dyn dflags Opt_D_dump_foreign-                      "Foreign export header file" stub_h_output_d+                      "Foreign export header file"+                      FormatC+                      stub_h_output_d          -- we need the #includes from the rts package for the stub files         let rts_includes =@@ -230,7 +232,7 @@                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr          dumpIfSet_dyn dflags Opt_D_dump_foreign-                      "Foreign export stubs" stub_c_output_d+                      "Foreign export stubs" FormatC stub_c_output_d          stub_c_file_exists            <- outputForeignStubs_help stub_c stub_c_output_w
compiler/main/Elf.hs view
@@ -408,15 +408,6 @@ -- | Generate the GAS code to create a Note section -- -- Header fields for notes are 32-bit long (see Note [ELF specification]).------ It seems there is no easy way to force GNU AS to generate a 32-bit word in--- every case. Hence we use .int directive to create them: however "The byte--- order and bit size of the number depends on what kind of target the assembly--- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)------ If we add new target platforms, we need to check that the generated words--- are 32-bit long, otherwise we need to use platform specific directives to--- force 32-bit .int in asWord32. makeElfNote :: String -> String -> Word32 -> String -> SDoc makeElfNote sectionName noteName typ contents = hcat [     text "\t.section ",@@ -424,6 +415,7 @@     text ",\"\",",     sectionType "note",     text "\n",+    text "\t.balign 4\n",      -- note name length (+ 1 for ending \0)     asWord32 (length noteName + 1),@@ -438,20 +430,20 @@     text "\t.asciz \"",     text noteName,     text "\"\n",-    text "\t.align 4\n",+    text "\t.balign 4\n",      -- note contents (.ascii to avoid ending \0) + padding     text "\t.ascii \"",     text (escape contents),     text "\"\n",-    text "\t.align 4\n"]+    text "\t.balign 4\n"]   where     escape :: String -> String     escape = concatMap (charToC.fromIntegral.ord)      asWord32 :: Show a => a -> SDoc     asWord32 x = hcat [-      text "\t.int ",+      text "\t.4byte ",       text (show x),       text "\n"]
compiler/main/GHC.hs view
@@ -196,7 +196,7 @@          -- ** Data constructors         DataCon,-        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,+        dataConType, dataConTyCon, dataConFieldLabels,         dataConIsInfix, isVanillaDataCon, dataConUserType,         dataConSrcBangs,         StrictnessMark(..), isMarkedStrict,
compiler/main/HscMain.hs view
@@ -123,16 +123,16 @@ import Desugar import SimplCore import TidyPgm-import CorePrep-import CoreToStg        ( coreToStg )+import GHC.CoreToStg.Prep+import GHC.CoreToStg        ( coreToStg )+import GHC.Stg.Syntax+import GHC.Stg.FVs      ( annTopBindingsFreeVars )+import GHC.Stg.Pipeline ( stg2stg ) import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import StgSyn-import StgFVs           ( annTopBindingsFreeVars ) import CostCentre import ProfInit import TyCon import Name-import SimplStg         ( stg2stg ) import Cmm import CmmParse         ( parseCmmFile ) import CmmBuildInfoTables@@ -356,12 +356,12 @@         POk pst rdr_module -> do             let (warns, errs) = getMessages pst dflags             logWarnings warns-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $-                                   ppr rdr_module-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $-                                   showAstData NoBlankSrcSpan rdr_module-            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $-                                   ppSourceStats False rdr_module+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr rdr_module)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan rdr_module)+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"+                        FormatText (ppSourceStats False rdr_module)             when (not $ isEmptyBag errs) $ throwErrors errs              -- To get the list of extra source files, we take the list@@ -412,8 +412,8 @@     let rn_info = getRenamedStuff tc_result      dflags <- getDynFlags-    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $-                           showAstData NoBlankSrcSpan rn_info+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan rn_info)      -- Create HIE files     when (gopt Opt_WriteHie dflags) $ do@@ -1456,9 +1456,10 @@             rawcmms0 <- {-# SCC "cmmToRawCmm" #-}                       cmmToRawCmm dflags cmms -            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"-                              (ppr a)-                            return a+            let dump a = do+                  unless (null a) $+                    dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a)+                  return a                 rawcmms1 = Stream.mapM dump rawcmms0              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ())@@ -1506,13 +1507,15 @@     let dflags = hsc_dflags hsc_env     cmm <- ioMsgMaybe $ parseCmmFile dflags filename     liftIO $ do-        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm)+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm)         let -- Make up a module name to give the NCG. We can't pass bottom here             -- lest we reproduce #11784.             mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename             cmm_mod = mkModule (thisPackage dflags) mod_name         (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm-        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)+        unless (null cmmgroup) $+          dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"+            FormatCMM (ppr cmmgroup)         rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []              rawCmms@@ -1549,20 +1552,23 @@         -- CmmGroup on input may produce many CmmGroups on output due         -- to proc-point splitting). -    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg-                       "Cmm produced by codegen" (ppr a)-                     return a+    let dump1 a = do+          unless (null a) $+            dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg+              "Cmm produced by codegen" FormatCMM (ppr a)+          return a          ppr_stream1 = Stream.mapM dump1 cmm_stream -        pipeline_stream-           = {-# SCC "cmmPipeline" #-}-             let run_pipeline = cmmPipeline hsc_env-             in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1+        pipeline_stream =+          {-# SCC "cmmPipeline" #-}+          let run_pipeline = cmmPipeline hsc_env+          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 -        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm-                        "Output Cmm" (ppr a)-                     return a+        dump2 a = do+          unless (null a) $+            dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a)+          return a          ppr_stream2 = Stream.mapM dump2 pipeline_stream @@ -1853,9 +1859,10 @@          POk pst thing -> do             logWarningsReportErrors (getMessages pst dflags)-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $-                                   showAstData NoBlankSrcSpan thing+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr thing)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan thing)             return thing
compiler/main/InteractiveEval.hs view
@@ -61,7 +61,7 @@ import CoreFVs    ( orphNamesOfFamInst ) import TyCon import Type             hiding( typeKind )-import RepType+import GHC.Types.RepType import TcType import Constraint import TcOrigin@@ -639,6 +639,7 @@                Just subst -> do                  let dflags = hsc_dflags hsc_env                  dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                   FormatText                    (fsep [text "RTTI Improvement for", ppr id, equals,                           ppr subst])
compiler/main/SysTools/Info.hs view
@@ -231,13 +231,13 @@         -- FreeBSD clang         | any ("FreeBSD clang version" `isInfixOf`) stde =           return Clang-        -- XCode 5.1 clang+        -- Xcode 5.1 clang         | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =           return AppleClang51-        -- XCode 5 clang+        -- Xcode 5 clang         | any ("Apple LLVM version" `isPrefixOf`) stde =           return AppleClang-        -- XCode 4.1 clang+        -- Xcode 4.1 clang         | any ("Apple clang version" `isPrefixOf`) stde =           return AppleClang          -- Unknown linker.
compiler/main/TidyPgm.hs view
@@ -21,7 +21,7 @@ import CoreFVs import CoreTidy import CoreMonad-import CorePrep+import GHC.CoreToStg.Prep import CoreUtils        (rhsIsStatic) import CoreStats        (coreBindsStats, CoreStats(..)) import CoreSeq          (seqBinds)@@ -174,7 +174,7 @@                 | id <- typeEnvIds type_env                 , keep_it id ] -    final_tcs  = filterOut (isWiredInName . getName) tcs+    final_tcs  = filterOut isWiredIn tcs                  -- See Note [Drop wired-in things]     type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts     insts'     = mkFinalClsInsts type_env1 insts@@ -385,10 +385,10 @@               ; final_ids  = [ if omit_prags then trimId id else id                              | id <- bindersOfBinds tidy_binds                              , isExternalName (idName id)-                             , not (isWiredInName (getName id))+                             , not (isWiredIn id)                              ]   -- See Note [Drop wired-in things] -              ; final_tcs      = filterOut (isWiredInName . getName) tcs+              ; final_tcs      = filterOut isWiredIn tcs                                  -- See Note [Drop wired-in things]               ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts               ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts@@ -417,11 +417,13 @@         ; unless (dopt Opt_D_dump_simpl dflags) $             Err.dumpIfSet_dyn dflags Opt_D_dump_rules               (showSDoc dflags (ppr CoreTidy <+> text "rules"))+              Err.FormatText               (pprRulesForUser dflags tidy_rules)            -- Print one-line size info         ; let cs = coreBindsStats tidy_binds         ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"+            Err.FormatText             (text "Tidy size (terms,types,coercions)"              <+> ppr (moduleName mod) <> colon              <+> int (cs_tm cs)
compiler/nativeGen/AsmCodeGen.hs view
@@ -359,6 +359,7 @@           let platform = targetPlatform dflags           dumpIfSet_dyn dflags                   Opt_D_dump_asm_conflicts "Register conflict graph"+                  FormatText                   $ Color.dotGraph                           (targetRegDotColor platform)                           (Color.trivColorable platform@@ -377,7 +378,9 @@                 $ makeImportsDoc dflags (concat (ngs_imports ngs))         return us'   where-    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"+    dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify)+                   (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"+                   FormatText  cmmNativeGenStream :: (Outputable statics, Outputable instr                       ,Outputable jumpDest, Instruction instr)@@ -420,7 +423,7 @@               -- See Note [What is this unwinding business?] in Debug.               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs               unless (null ldbgs) $-                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText                   (vcat $ map ppr ldbgs)                -- Accumulate debug information for emission in finishNativeGen.@@ -505,7 +508,7 @@          -- dump native code         dumpIfSet_dyn dflags-                Opt_D_dump_asm "Asm code"+                Opt_D_dump_asm "Asm code" FormatASM                 sdoc  -- | Complete native code generation phase for a single top-level chunk of Cmm.@@ -550,7 +553,7 @@                 cmmToCmm dflags this_mod fixed_cmm          dumpIfSet_dyn dflags-                Opt_D_dump_opt_cmm "Optimised Cmm"+                Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM                 (pprCmmGroup [opt_cmm])          let cmmCfg = {-# SCC "getCFG" #-}@@ -564,7 +567,7 @@                                         fileIds dbgMap opt_cmm cmmCfg          dumpIfSet_dyn dflags-                Opt_D_dump_asm_native "Native code"+                Opt_D_dump_asm_native "Native code" FormatASM                 (vcat $ map (pprNatCmmDecl ncgImpl) native)          maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name@@ -582,6 +585,7 @@          dumpIfSet_dyn dflags                 Opt_D_dump_asm_liveness "Liveness annotations added"+                FormatCMM                 (vcat $ map ppr withLiveness)          -- allocate registers@@ -621,10 +625,12 @@                 -- dump out what happened during register allocation                 dumpIfSet_dyn dflags                         Opt_D_dump_asm_regalloc "Registers allocated"+                        FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)                  dumpIfSet_dyn dflags                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"+                        FormatText                         (vcat   $ map (\(stage, stats)                                         -> text "# --------------------------"                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage@@ -663,6 +669,7 @@                  dumpIfSet_dyn dflags                         Opt_D_dump_asm_regalloc "Registers allocated"+                        FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)                  let mPprStats =@@ -697,6 +704,7 @@          when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags                 Opt_D_dump_cfg_weights "CFG Update information"+                FormatText                 ( text "stack:" <+> ppr stack_updt_blks $$                   text "linearAlloc:" <+> ppr cfgRegAllocUpdates ) @@ -753,6 +761,7 @@          dumpIfSet_dyn dflags                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"+                FormatCMM                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)          -- generate unwinding information from cmm@@ -779,6 +788,7 @@         | otherwise         = dumpIfSet_dyn                 dflags Opt_D_dump_cfg_weights msg+                FormatText                 (proc_name <> char ':' $$ pprEdgeWeights cfg)  -- | Make sure all blocks we want the layout algorithm to place have been placed.
compiler/nativeGen/BlockLayout.hs view
@@ -76,7 +76,7 @@   We have a CFG with edge weights based on which we try to place blocks next to   each other. -  Edge weights not only represent likelyhood of control transfer between blocks+  Edge weights not only represent likelihood of control transfer between blocks   but also how much a block would benefit from being placed sequentially after   it's predecessor.   For example blocks which are preceded by an info table are more likely to end
compiler/nativeGen/PPC/CodeGen.hs view
@@ -602,7 +602,7 @@           _ -> case x of                  CmmLit (CmmInt imm _)                    | Just _ <- makeImmediate rep True imm-                   -- subfi ('substract from' with immediate) doesn't exist+                   -- subfi ('subtract from' with immediate) doesn't exist                    -> trivialCode rep True SUBFC y x                  _ -> trivialCodeNoImm' (intFormat rep) SUBF y x @@ -2021,6 +2021,7 @@                     MO_AtomicRead _  -> unsupported                     MO_AtomicWrite _ -> unsupported +                    MO_S_Mul2    {}  -> unsupported                     MO_S_QuotRem {}  -> unsupported                     MO_U_QuotRem {}  -> unsupported                     MO_U_QuotRem2 {} -> unsupported
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -681,6 +681,7 @@         MO_AtomicRead w -> fsLit $ atomicReadLabel w         MO_AtomicWrite w -> fsLit $ atomicWriteLabel w +        MO_S_Mul2    {}  -> unsupported         MO_S_QuotRem {}  -> unsupported         MO_U_QuotRem {}  -> unsupported         MO_U_QuotRem2 {} -> unsupported
compiler/nativeGen/X86/CodeGen.hs view
@@ -2613,6 +2613,26 @@                                 MOV format (OpReg rax) (OpReg reg_l)]                return code         _ -> panic "genCCall: Wrong number of arguments/results for mul2"+    (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) ->+        case args of+        [arg_x, arg_y] ->+            do (y_reg, y_code) <- getRegOrMem arg_y+               x_code <- getAnyReg arg_x+               reg_tmp <- getNewRegNat II8+               let format = intFormat width+                   reg_h = getRegisterReg platform (CmmLocal res_h)+                   reg_l = getRegisterReg platform (CmmLocal res_l)+                   reg_c = getRegisterReg platform (CmmLocal res_c)+                   code = y_code `appOL`+                          x_code rax `appOL`+                          toOL [ IMUL2 format y_reg+                               , MOV format (OpReg rdx) (OpReg reg_h)+                               , MOV format (OpReg rax) (OpReg reg_l)+                               , SETCC CARRY (OpReg reg_tmp)+                               , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+                               ]+               return code+        _ -> panic "genCCall: Wrong number of arguments/results for imul2"      _ -> if is32Bit          then genCCall32' dflags target dest_regs args@@ -3204,6 +3224,7 @@                MO_UF_Conv _ -> unsupported +              MO_S_Mul2    {}  -> unsupported               MO_S_QuotRem {}  -> unsupported               MO_U_QuotRem {}  -> unsupported               MO_U_QuotRem2 {} -> unsupported
compiler/rename/RnEnv.hs view
@@ -1475,9 +1475,16 @@     lookup_top keep_me       = do { env <- getGlobalRdrEnv            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)-           ; let candidates_msg = candidates $ map gre_name-                                             $ filter isLocalGRE-                                             $ globalRdrEnvElts env+                 names_in_scope = -- If rdr_name lacks a binding, only+                                  -- recommend alternatives from related+                                  -- namespaces. See #17593.+                                  filter (\n -> nameSpacesRelated+                                                  (rdrNameSpace rdr_name)+                                                  (nameNameSpace n))+                                $ map gre_name+                                $ filter isLocalGRE+                                $ globalRdrEnvElts env+                 candidates_msg = candidates names_in_scope            ; case filter (keep_me . gre_name) all_gres of                [] | null all_gres -> bale_out_with candidates_msg                   | otherwise     -> bale_out_with local_msg
compiler/rename/RnSource.hs view
@@ -1231,7 +1231,7 @@   the type synonym S. While we know that S depends upon 'Q depends upon Closed,   we have no idea that Closed depends upon Open! -  To accomodate for these situations, we ensure that an instance is checked+  To accommodate for these situations, we ensure that an instance is checked   before every @TyClDecl@ on which it does not depend. That's to say, instances   are checked as early as possible in @tcTyAndClassDecls@.
compiler/rename/RnSplice.hs view
@@ -40,7 +40,7 @@  import DynFlags import FastString-import ErrUtils         ( dumpIfSet_dyn_printer )+import ErrUtils         ( dumpIfSet_dyn_printer, DumpFormat (..) ) import TcEnv            ( tcMetaTy ) import Hooks import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName@@ -746,7 +746,7 @@        ; when is_decl $  -- Raw material for -dth-dec-file          do { dflags <- getDynFlags             ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file-                                             (spliceCodeDoc loc) } }+                                             "" FormatHaskell (spliceCodeDoc loc) } }   where     -- `-ddump-splices`     spliceDebugDoc :: SrcSpan -> SDoc
compiler/simplCore/FloatOut.hs view
@@ -19,7 +19,7 @@ import CoreMonad        ( FloatOutSwitches(..) )  import DynFlags-import ErrUtils         ( dumpIfSet_dyn )+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) ) import Id               ( Id, idArity, idType, isBottomingId,                           isJoinId, isJoinId_maybe ) import SetLevels@@ -174,11 +174,13 @@             } ;          dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"+                  FormatCore                   (vcat (map ppr annotated_w_levels));          let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };          dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"+                FormatText                 (hcat [ int tlets,  text " Lets floated to top level; ",                         int ntlets, text " Lets floated elsewhere; from ",                         int lams,   text " Lambda groups"]);
compiler/simplCore/SetLevels.hs view
@@ -1658,7 +1658,7 @@      mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs                              transfer_join_info bndr $-                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty+                             mkSysLocal (mkFastString str) uniq poly_ty                            where                              str     = "poly_" ++ occNameString (getOccName bndr)                              poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))@@ -1693,7 +1693,7 @@       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))                             rhs_ty       | otherwise-      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty+      = mkSysLocal (mkFastString "lvl") uniq rhs_ty  -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
compiler/simplCore/SimplCore.hs view
@@ -36,7 +36,7 @@ import FloatOut         ( floatOutwards ) import FamInstEnv import Id-import ErrUtils         ( withTiming, withTimingD )+import ErrUtils         ( withTiming, withTimingD, DumpFormat (..) ) import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) import VarSet import VarEnv@@ -90,6 +90,7 @@         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats              "Grand total simplifier statistics"+             FormatText              (pprSimplCount stats)         ; return guts2 }@@ -576,6 +577,7 @@                   "Simplifier statistics" (pprSimplCount counts)          ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+                        FormatCore                         (pprCoreExpr expr')          ; return expr'@@ -688,6 +690,7 @@                                      binds                } ;            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+                     FormatCore                      (pprCoreBindings tagged_binds);                  -- Get any new rules, and extend the rule base
compiler/simplCore/SimplMonad.hs view
@@ -141,6 +141,7 @@ traceSmpl herald doc   = do { dflags <- getDynFlags        ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"+           FormatText            (hang (text herald) 2 doc) }  {-
compiler/simplCore/SimplUtils.hs view
@@ -66,7 +66,6 @@ import OrdList          ( isNilOL ) import MonadUtils import Outputable-import Pair import PrelRules import FastString       ( fsLit ) @@ -297,7 +296,7 @@  addCastTo :: ArgInfo -> OutCoercion -> ArgInfo addCastTo ai co = ai { ai_args = CastBy co : ai_args ai-                     , ai_type = pSnd (coercionKind co) }+                     , ai_type = coercionRKind co }  argInfoAppArgs :: [ArgSpec] -> [OutExpr] argInfoAppArgs []                              = []@@ -407,7 +406,7 @@ contHoleType :: SimplCont -> OutType contHoleType (Stop ty _)                      = ty contHoleType (TickIt _ k)                     = contHoleType k-contHoleType (CastIt co _)                    = pFst (coercionKind co)+contHoleType (CastIt co _)                    = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })   = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)@@ -1801,7 +1800,7 @@            ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name                   poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course                   poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs-                              mkLocalIdOrCoVar poly_name poly_ty+                              mkLocalId poly_name poly_ty            ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }                 -- In the olden days, it was crucial to copy the occInfo of the original var,                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
compiler/simplCore/Simplify.hs view
@@ -50,7 +50,6 @@ import Control.Monad import Outputable import FastString-import Pair import Util import ErrUtils import Module          ( moduleName, pprModuleName )@@ -261,7 +260,8 @@       | not (dopt Opt_D_verbose_core2core dflags)       = thing_inside       | otherwise-      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside+      = traceAction dflags ("SimplBind " ++ what)+         (ppr old_bndr) thing_inside  -------------------------- simplLazyBind :: SimplEnv@@ -440,7 +440,7 @@ --            x = Just a -- See Note [prepareRhs] prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]-  | Pair ty1 _ty2 <- coercionKind co         -- Do *not* do this if rhs has an unlifted type+  | let ty1 = coercionLKind co         -- Do *not* do this if rhs has an unlifted type   , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]   = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs         ; return (floats, Cast rhs' co) }@@ -579,7 +579,7 @@           else do         { uniq <- getUniqueM         ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdOrCoVarWithInfo name expr_ty info+              var  = mkLocalIdWithInfo name expr_ty info          -- Now something very like completeBind,         -- but without the postInlineUnconditinoally part@@ -1308,7 +1308,7 @@             -- only needed by `sc_hole_ty` which is often not forced.             -- Consequently it is worthwhile using a lazy pattern match here to             -- avoid unnecessary coercionKind evaluations.-          , ~(Pair hole_ty _) <- coercionKind co+          , let hole_ty = coercionLKind co           = {-#SCC "addCoerce-pushCoTyArg" #-}             do { tail' <- addCoerceM m_co' tail                ; return (cont { sc_arg_ty  = arg_ty'@@ -1319,7 +1319,7 @@         addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se                                       , sc_dup = dup, sc_cont = tail })           | Just (co1, m_co2) <- pushCoValArg co-          , Pair _ new_ty <- coercionKind co1+          , let new_ty = coercionRKind co1           , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg                                         -- See Note [Levity polymorphism invariants] in CoreSyn                                         -- test: typecheck/should_run/EtaExpandLevPoly@@ -1794,14 +1794,20 @@     interesting_cont = interestingCallContext env call_cont     active_unf       = activeUnfolding (getMode env) var +    log_inlining doc+      = liftIO $ dumpAction dflags+           (mkUserStyle dflags alwaysQualify AllTheWay)+           (dumpOptionsFromFlag Opt_D_dump_inlinings)+           "" FormatText doc+     dump_inline unfolding cont       | not (dopt Opt_D_dump_inlinings dflags) = return ()       | not (dopt Opt_D_verbose_core2core dflags)       = when (isExternalName (idName var)) $-            liftIO $ printOutputForUser dflags alwaysQualify $+            log_inlining $                 sep [text "Inlining done:", nest 4 (ppr var)]       | otherwise-      = liftIO $ printOutputForUser dflags alwaysQualify $+      = liftIO $ log_inlining $            sep [text "Inlining done: " <> ppr var,                 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),                               text "Cont:  " <+> ppr cont])]@@ -2066,17 +2072,21 @@      nodump       | dopt Opt_D_dump_rule_rewrites dflags-      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty+      = liftIO $ do+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)        | dopt Opt_D_dump_rule_firings dflags-      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty+      = liftIO $ do+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)        | otherwise       = return ()      log_rule dflags flag hdr details-      = liftIO . dumpSDoc dflags alwaysQualify flag "" $-                   sep [text hdr, nest 4 details]+      = liftIO $ do+         let sty = mkDumpStyle dflags alwaysQualify+         dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $+           sep [text hdr, nest 4 details]  trySeqRules :: SimplEnv             -> OutExpr -> InExpr   -- Scrutinee and RHS@@ -2789,8 +2799,8 @@         where           ppr_with_length list             = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp MarkedStrict = "MarkedStrict"-          strdisp NotMarkedStrict = "NotMarkedStrict"+          strdisp MarkedStrict = text "MarkedStrict"+          strdisp NotMarkedStrict = text "NotMarkedStrict"  zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id zapIdOccInfoAndSetEvald str v =
− compiler/simplStg/SimplStg.hs 
@@ -1,141 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--\section[SimplStg]{Driver for simplifying @STG@ programs}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--module SimplStg ( stg2stg ) where--#include "HsVersions.h"--import GhcPrelude--import StgSyn--import StgLint          ( lintStgTopBindings )-import StgStats         ( showStgStats )-import UnariseStg       ( unarise )-import StgCse           ( stgCse )-import StgLiftLams      ( stgLiftLams )-import Module           ( Module )--import DynFlags-import ErrUtils-import UniqSupply-import Outputable-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.State.Strict--newtype StgM a = StgM { _unStgM :: StateT Char IO a }-  deriving (Functor, Applicative, Monad, MonadIO)--instance MonadUnique StgM where-  getUniqueSupplyM = StgM $ do { mask <- get-                               ; liftIO $! mkSplitUniqSupply mask}-  getUniqueM = StgM $ do { mask <- get-                         ; liftIO $! uniqFromMask mask}--runStgM :: Char -> StgM a -> IO a-runStgM mask (StgM m) = evalStateT m mask--stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do-        -> Module                    -- module being compiled-        -> [StgTopBinding]           -- input program-        -> IO [StgTopBinding]        -- output program--stg2stg dflags this_mod binds-  = do  { dump_when Opt_D_dump_stg "STG:" binds-        ; showPass dflags "Stg2Stg"-        -- Do the main business!-        ; binds' <- runStgM 'g' $-            foldM do_stg_pass binds (getStgToDo dflags)--        ; dump_when Opt_D_dump_stg_final "Final STG:" binds'--        ; return binds'-   }--  where-    stg_linter unarised-      | gopt Opt_DoStgLinting dflags-      = lintStgTopBindings dflags this_mod unarised-      | otherwise-      = \ _whodunnit _binds -> return ()--    --------------------------------------------    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]-    do_stg_pass binds to_do-      = case to_do of-          StgDoNothing ->-            return binds--          StgStats ->-            trace (showStgStats binds) (return binds)--          StgCSE -> do-            let binds' = {-# SCC "StgCse" #-} stgCse binds-            end_pass "StgCse" binds'--          StgLiftLams -> do-            us <- getUniqueSupplyM-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds-            end_pass "StgLiftLams" binds'--          StgUnarise -> do-            us <- getUniqueSupplyM-            liftIO (stg_linter False "Pre-unarise" binds)-            let binds' = unarise us binds-            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')-            liftIO (stg_linter True "Unarise" binds')-            return binds'--    dump_when flag header binds-      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)--    end_pass what binds2-      = liftIO $ do -- report verbosely, if required-          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what-            (vcat (map ppr binds2))-          stg_linter False what binds2-          return binds2---- -------------------------------------------------------------------------------- StgToDo:  abstraction of stg-to-stg passes to run.---- | Optional Stg-to-Stg passes.-data StgToDo-  = StgCSE-  -- ^ Common subexpression elimination-  | StgLiftLams-  -- ^ Lambda lifting closure variables, trading stack/register allocation for-  -- heap allocation-  | StgStats-  | StgUnarise-  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders-  | StgDoNothing-  -- ^ Useful for building up 'getStgToDo'-  deriving Eq---- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.-getStgToDo :: DynFlags -> [StgToDo]-getStgToDo dflags =-  filter (/= StgDoNothing)-    [ mandatory StgUnarise-    -- Important that unarisation comes first-    -- See Note [StgCse after unarisation] in StgCse-    , optional Opt_StgCSE StgCSE-    , optional Opt_StgLiftLams StgLiftLams-    , optional Opt_StgStats StgStats-    ] where-      optional opt = runWhen (gopt opt dflags)-      mandatory = id--runWhen :: Bool -> StgToDo -> StgToDo-runWhen True todo = todo-runWhen _    _    = StgDoNothing
− compiler/simplStg/StgCse.hs 
@@ -1,483 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--{-|-Note [CSE for Stg]-~~~~~~~~~~~~~~~~~~-This module implements a simple common subexpression elimination pass for STG.-This is useful because there are expressions that we want to common up (because-they are operationally equivalent), but that we cannot common up in Core, because-their types differ.-This was originally reported as #9291.--There are two types of common code occurrences that we aim for, see-note [Case 1: CSEing allocated closures] and-note [Case 2: CSEing case binders] below.---Note [Case 1: CSEing allocated closures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The first kind of CSE opportunity we aim for is generated by this Haskell code:--    bar :: a -> (Either Int a, Either Bool a)-    bar x = (Right x, Right x)--which produces this Core:--    bar :: forall a. a -> (Either Int a, Either Bool a)-    bar @a x = (Right @Int @a x, Right @Bool @a x)--where the two components of the tuple are different terms, and cannot be-commoned up (easily). On the STG level we have--    bar [x] = let c1 = Right [x]-                  c2 = Right [x]-              in (c1,c2)--and now it is obvious that we can write--    bar [x] = let c1 = Right [x]-              in (c1,c1)--instead.---Note [Case 2: CSEing case binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The second kind of CSE opportunity we aim for is more interesting, and-came up in #9291 and #5344: The Haskell code--    foo :: Either Int a -> Either Bool a-    foo (Right x) = Right x-    foo _         = Left False--produces this Core--    foo :: forall a. Either Int a -> Either Bool a-    foo @a e = case e of b { Left n -> …-                           , Right x -> Right @Bool @a x }--where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have-different types. But in STG we have--    foo [e] = case e of b { Left [n] -> …-                          , Right [x] -> Right [x] }--and nothing stops us from transforming that to--    foo [e] = case e of b { Left [n] -> …-                          , Right [x] -> b}---Note [StgCse after unarisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider two unboxed sum terms:--    (# 1 | #) :: (# Int | Int# #)-    (# 1 | #) :: (# Int | Int  #)--These two terms are not equal as they unarise to different unboxed-tuples. However if we run StgCse before Unarise, it'll think the two-terms (# 1 | #) are equal, and replace one of these with a binder to-the other. That's bad -- #15300.--Solution: do unarise first.---}--module StgCse (stgCse) where--import GhcPrelude--import DataCon-import Id-import StgSyn-import Outputable-import VarEnv-import CoreSyn (AltCon(..))-import Data.List (mapAccumL)-import Data.Maybe (fromMaybe)-import CoreMap-import NameEnv-import Control.Monad( (>=>) )------------------- The Trie --------------------- A lookup trie for data constructor applications, i.e.--- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.--data StgArgMap a = SAM-    { sam_var :: DVarEnv a-    , sam_lit :: LiteralMap a-    }--instance TrieMap StgArgMap where-    type Key StgArgMap = StgArg-    emptyTM  = SAM { sam_var = emptyTM-                   , sam_lit = emptyTM }-    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var-    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit-    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }-    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }-    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)-    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =-        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }--newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }--instance TrieMap ConAppMap where-    type Key ConAppMap = (DataCon, [StgArg])-    emptyTM  = CAM emptyTM-    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args-    alterTM  (dataCon, args) f m =-        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }-    foldTM k = un_cam >.> foldTM (foldTM k)-    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM---------------------- The CSE Env ------------------------ | The CSE environment. See note [CseEnv Example]-data CseEnv = CseEnv-    { ce_conAppMap :: ConAppMap OutId-        -- ^ The main component of the environment is the trie that maps-        --   data constructor applications (with their `OutId` arguments)-        --   to an in-scope name that can be used instead.-        --   This name is always either a let-bound variable or a case binder.-    , ce_subst     :: IdEnv OutId-        -- ^ This substitution is applied to the code as we traverse it.-        --   Entries have one of two reasons:-        ---        --   * The input might have shadowing (see Note [Shadowing]), so we have-        --     to rename some binders as we traverse the tree.-        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,-        --     we note this here as x ↦ y.-    , ce_bndrMap     :: IdEnv OutId-        -- ^ If we come across a case expression case x as b of … with a trivial-        --   binder, we add b ↦ x to this.-        --   This map is *only* used when looking something up in the ce_conAppMap.-        --   See Note [Trivial case scrutinee]-    , ce_in_scope  :: InScopeSet-        -- ^ The third component is an in-scope set, to rename away any-        --   shadowing binders-    }--{-|-Note [CseEnv Example]-~~~~~~~~~~~~~~~~~~~~~-The following tables shows how the CseEnvironment changes as code is traversed,-as well as the changes to that code.--  InExpr                         OutExpr-     conAppMap                   subst          in_scope-  ───────────────────────────────────────────────────────────-  -- empty                       {}             {}-  case … as a of {Con x y ->     case … as a of {Con x y ->-  -- Con x y ↦ a                 {}             {a,x,y}-  let b = Con x y                (removed)-  -- Con x y ↦ a                 b↦a            {a,x,y,b}-  let c = Bar a                  let c = Bar a-  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}-  let c = some expression        let c' = some expression-  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}-  let d = Bar b                  (removed)-  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}-  (a, b, c d)                    (a, a, c' c)--}--initEnv :: InScopeSet -> CseEnv-initEnv in_scope = CseEnv-    { ce_conAppMap = emptyTM-    , ce_subst     = emptyVarEnv-    , ce_bndrMap   = emptyVarEnv-    , ce_in_scope  = in_scope-    }--envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId-envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)-  where args' = map go args -- See Note [Trivial case scrutinee]-        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)-        go (StgLitArg lit) = StgLitArg lit--addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv--- do not bother with nullary data constructors, they are static anyways-addDataCon _ _ [] env = env-addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }-  where-    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)--forgetCse :: CseEnv -> CseEnv-forgetCse env = env { ce_conAppMap = emptyTM }-    -- See note [Free variables of an StgClosure]--addSubst :: OutId -> OutId -> CseEnv -> CseEnv-addSubst from to env-    = env { ce_subst = extendVarEnv (ce_subst env) from to }--addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv-addTrivCaseBndr from to env-    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }--substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]-substArgs env = map (substArg env)--substArg :: CseEnv -> InStgArg -> OutStgArg-substArg env (StgVarArg from) = StgVarArg (substVar env from)-substArg _   (StgLitArg lit)  = StgLitArg lit--substVar :: CseEnv -> InId -> OutId-substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id---- Functions to enter binders---- This is much simpler than the equivalent code in CoreSubst:---  * We do not substitute type variables, and---  * There is nothing relevant in IdInfo at this stage---    that needs substitutions.--- Therefore, no special treatment for a recursive group is required.--substBndr :: CseEnv -> InId -> (CseEnv, OutId)-substBndr env old_id-  = (new_env, new_id)-  where-    new_id = uniqAway (ce_in_scope env) old_id-    no_change = new_id == old_id-    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }-    new_env | no_change = env'-            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }--substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])-substBndrs env bndrs = mapAccumL substBndr env bndrs--substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])-substPairs env bndrs = mapAccumL go env bndrs-  where go env (id, x) = let (env', id') = substBndr env id-                         in (env', (id', x))---- Main entry point--stgCse :: [InStgTopBinding] -> [OutStgTopBinding]-stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds---- Top level bindings.------ We do not CSE these, as top-level closures are allocated statically anyways.--- Also, they might be exported.--- But we still have to collect the set of in-scope variables, otherwise--- uniqAway might shadow a top-level closure.--stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)-stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)-stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))-    = (in_scope'-      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))-  where in_scope' = in_scope `extendInScopeSet` bndr--stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))-    = ( in_scope'-      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))-  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]--stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs-stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)-    = let body' = stgCseExpr (initEnv in_scope) body-      in  StgRhsClosure ext ccs upd args body'-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)-    = StgRhsCon ccs dataCon args----------------------------------- The actual AST traversal ------------------------------------- Trivial cases-stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr-stgCseExpr env (StgApp fun args)-    = StgApp fun' args'-  where fun' = substVar env fun-        args' = substArgs env args-stgCseExpr _ (StgLit lit)-    = StgLit lit-stgCseExpr env (StgOpApp op args tys)-    = StgOpApp op args' tys-  where args' = substArgs env args-stgCseExpr _ (StgLam _ _)-    = pprPanic "stgCseExp" (text "StgLam")-stgCseExpr env (StgTick tick body)-    = let body' = stgCseExpr env body-      in StgTick tick body'-stgCseExpr env (StgCase scrut bndr ty alts)-    = mkStgCase scrut' bndr' ty alts'-  where-    scrut' = stgCseExpr env scrut-    (env1, bndr') = substBndr env bndr-    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1-                 -- See Note [Trivial case scrutinee]-         | otherwise                         = env1-    alts' = map (stgCseAlt env2 ty bndr') alts----- A constructor application.--- To be removed by a variable use when found in the CSE environment-stgCseExpr env (StgConApp dataCon args tys)-    | Just bndr' <- envLookup dataCon args' env-    = StgApp bndr' []-    | otherwise-    = StgConApp dataCon args' tys-  where args' = substArgs env args---- Let bindings--- The binding might be removed due to CSE (we do not want trivial bindings on--- the STG level), so use the smart constructor `mkStgLet` to remove the binding--- if empty.-stgCseExpr env (StgLet ext binds body)-    = let (binds', env') = stgCseBind env binds-          body' = stgCseExpr env' body-      in mkStgLet (StgLet ext) binds' body'-stgCseExpr env (StgLetNoEscape ext binds body)-    = let (binds', env') = stgCseBind env binds-          body' = stgCseExpr env' body-      in mkStgLet (StgLetNoEscape ext) binds' body'---- Case alternatives--- Extend the CSE environment-stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt-stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)-    = let (env1, args') = substBndrs env args-          env2-            -- To avoid dealing with unboxed sums StgCse runs after unarise and-            -- should maintain invariants listed in Note [Post-unarisation-            -- invariants]. One of the invariants is that some binders are not-            -- used (unboxed tuple case binders) which is what we check with-            -- `stgCaseBndrInScope` here. If the case binder is not in scope we-            -- don't add it to the CSE env. See also #15300.-            | stgCaseBndrInScope ty True -- CSE runs after unarise-            = addDataCon case_bndr dataCon (map StgVarArg args') env1-            | otherwise-            = env1-            -- see note [Case 2: CSEing case binders]-          rhs' = stgCseExpr env2 rhs-      in (DataAlt dataCon, args', rhs')-stgCseAlt env _ _ (altCon, args, rhs)-    = let (env1, args') = substBndrs env args-          rhs' = stgCseExpr env1 rhs-      in (altCon, args', rhs')---- Bindings-stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)-stgCseBind env (StgNonRec b e)-    = let (env1, b') = substBndr env b-      in case stgCseRhs env1 b' e of-        (Nothing,      env2) -> (Nothing,                env2)-        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)-stgCseBind env (StgRec pairs)-    = let (env1, pairs1) = substPairs env pairs-      in case stgCsePairs env1 pairs1 of-        ([],     env2) -> (Nothing, env2)-        (pairs2, env2) -> (Just (StgRec pairs2), env2)--stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)-stgCsePairs env [] = ([], env)-stgCsePairs env0 ((b,e):pairs)-  = let (pairMB, env1) = stgCseRhs env0 b e-        (pairs', env2) = stgCsePairs env1 pairs-    in (pairMB `mbCons` pairs', env2)-  where-    mbCons = maybe id (:)---- The RHS of a binding.--- If it is a constructor application, either short-cut it or extend the environment-stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)-stgCseRhs env bndr (StgRhsCon ccs dataCon args)-    | Just other_bndr <- envLookup dataCon args' env-    = let env' = addSubst bndr other_bndr env-      in (Nothing, env')-    | otherwise-    = let env' = addDataCon bndr dataCon args' env-            -- see note [Case 1: CSEing allocated closures]-          pair = (bndr, StgRhsCon ccs dataCon args')-      in (Just pair, env')-  where args' = substArgs env args-stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)-    = let (env1, args') = substBndrs env args-          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]-          body' = stgCseExpr env2 body-      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)---mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr-mkStgCase scrut bndr ty alts | all isBndr alts = scrut-                             | otherwise       = StgCase scrut bndr ty alts--  where-    -- see Note [All alternatives are the binder]-    isBndr (_, _, StgApp f []) = f == bndr-    isBndr _                   = False----- Utilities---- | This function short-cuts let-bindings that are now obsolete-mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b-mkStgLet _      Nothing      body = body-mkStgLet stgLet (Just binds) body = stgLet binds body---{--Note [All alternatives are the binder]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When all alternatives simply refer to the case binder, then we do not have-to bother with the case expression at all (#13588). CoreSTG does this as well,-but sometimes, types get into the way:--    newtype T = MkT Int-    f :: (Int, Int) -> (T, Int)-    f (x, y) = (MkT x, y)--Core cannot just turn this into--    f p = p--as this would not be well-typed. But to STG, where MkT is no longer in the way,-we can.--Note [Trivial case scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to be able to handle nested reconstruction of constructors as in--    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)-    nested (Right (Right v)) = Right (Right v)-    nested _ = Left True--So if we come across--    case x of r1-      Right a -> case a of r2-              Right b -> let v = Right b-                         in Right v--we first replace v with r2. Next we want to replace Right r2 with r1. But the-ce_conAppMap contains Right a!--Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use-this substitution before looking Right r2 up in ce_conAppMap, and everything-works out.--Note [Free variables of an StgClosure]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-StgClosures (function and thunks) have an explicit list of free variables:--foo [x] =-    let not_a_free_var = Left [x]-    let a_free_var = Right [x]-    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var-    in closure--If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,-then the list of free variables would be wrong, so for now, we do not CSE-across such a closure, simply because I (Joachim) was not sure about possible-knock-on effects. If deemed safe and worth the slight code complication of-re-calculating this list during or after this pass, this can surely be done.--}
− compiler/simplStg/StgLiftLams.hs 
@@ -1,102 +0,0 @@--- | Implements a selective lambda lifter, running late in the optimisation--- pipeline.------ The transformation itself is implemented in "StgLiftLams.Transformation".--- If you are interested in the cost model that is employed to decide whether--- to lift a binding or not, look at "StgLiftLams.Analysis".--- "StgLiftLams.LiftM" contains the transformation monad that hides away some--- plumbing of the transformation.-module StgLiftLams (-    -- * Late lambda lifting in STG-    -- $note-    Transformation.stgLiftLams-  ) where--import qualified StgLiftLams.Transformation as Transformation---- Note [Late lambda lifting in STG]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- $note--- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>--- and #9476.------ The basic idea behind lambda lifting is to turn locally defined functions--- into top-level functions. Free variables are then passed as additional--- arguments at *call sites* instead of having a closure allocated for them at--- *definition site*. Example:------ @---    let x = ...; y = ... in---    let f = {x y} \a -> a + x + y in---    let g = {f x} \b -> f b + x in---    g 5--- @------ Lambda lifting @f@ would------   1. Turn @f@'s free variables into formal parameters---   2. Update @f@'s call site within @g@ to @f x y b@---   3. Update @g@'s closure: Add @y@ as an additional free variable, while---      removing @f@, because @f@ no longer allocates and can be floated to---      top-level.---   4. Actually float the binding of @f@ to top-level, eliminating the @let@---      in the process.------ This results in the following program (with free var annotations):------ @---    f x y a = a + x + y;---    let x = ...; y = ... in---    let g = {x y} \b -> f x y b + x in---    g 5--- @------ This optimisation is all about lifting only when it is beneficial to do so.--- The above seems like a worthwhile lift, judging from heap allocation:--- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while--- not changing the size of @g@'s closure.------ You can probably sense that there's some kind of cost model at play here.--- And you are right! But we also employ a couple of other heuristics for the--- lifting decision which are outlined in "StgLiftLams.Analysis#when".------ The transformation is done in "StgLiftLams.Transformation", which calls out--- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision.--- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants--- into a monadic substrate.------ Suffice to say: We trade heap allocation for stack allocation.--- The additional arguments have to passed on the stack (or in registers,--- depending on architecture) every time we call the function to save a single--- heap allocation when entering the let binding. Nofib suggests a mean--- improvement of about 1% for this pass, so it seems like a worthwhile thing to--- do. Compile-times went up by 0.6%, so all in all a very modest change.------ For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'--- that is ultimately compiled to something like this--- (module desugaring/lowering to actual STG):------ @---    propagate dt = ...;---    runExperiment ... =---      let xs = ... in---      let ys = ... in---      let go = {dt go} \xs ys -> case (xs, ys) of---            ([], []) -> []---            (x:xs', y:ys') -> propagate dt x y : go xs' ys'---      in go xs ys--- @------ This will lambda lift @go@ to top-level, speeding up the resulting program--- by roughly one percent:------ @---    propagate dt = ...;---    go dt xs ys = case (xs, ys) of---      ([], []) -> []---      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'---    runExperiment ... =---      let xs = ... in---      let ys = ... in---      in go dt xs ys--- @
− compiler/simplStg/StgLiftLams/Analysis.hs 
@@ -1,565 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}---- | Provides the heuristics for when it's beneficial to lambda lift bindings.--- Most significantly, this employs a cost model to estimate impact on heap--- allocations, by looking at an STG expression's 'Skeleton'.-module StgLiftLams.Analysis (-    -- * #when# When to lift-    -- $when--    -- * #clogro# Estimating closure growth-    -- $clogro--    -- * AST annotation-    Skeleton(..), BinderInfo(..), binderInfoBndr,-    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,-    -- * Lifting decision-    goodToLift,-    closureGrowth -- Exported just for the docs-  ) where--import GhcPrelude--import BasicTypes-import Demand-import DynFlags-import Id-import SMRep ( WordOff )-import StgSyn-import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep-import qualified GHC.StgToCmm.Closure as StgToCmm.Closure-import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout-import Outputable-import Util-import VarSet--import Data.Maybe ( mapMaybe )---- Note [When to lift]--- ~~~~~~~~~~~~~~~~~~~--- $when--- The analysis proceeds in two steps:------   1. It tags the syntax tree with analysis information in the form of---      'BinderInfo' at each binder and 'Skeleton's at each let-binding---      by 'tagSkeletonTopBind' and friends.---   2. The resulting syntax tree is treated by the "StgLiftLams.Transformation"---      module, calling out to 'goodToLift' to decide if a binding is worthwhile---      to lift.---      'goodToLift' consults argument occurrence information in 'BinderInfo'---      and estimates 'closureGrowth', for which it needs the 'Skeleton'.------ So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',--- which employs a number of heuristics to identify and exclude lambda lifting--- opportunities deemed non-beneficial:------  [Top-level bindings] can't be lifted.---  [Thunks] and data constructors shouldn't be lifted in order not to destroy---    sharing.---  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.---    Doing the lift would re-introduce the very allocation at call sites that---    we tried to get rid off in the first place. We capture analysis---    information in 'BinderInfo'. Note that we also consider a nullary---    application as argument occurrence, because it would turn into an n-ary---    partial application created by a generic apply function. This occurs in---    CPS-heavy code like the CS benchmark.---  [Join points] should not be lifted, simply because there's no reduction in---    allocation to be had.---  [Abstracting over join points] destroys join points, because they end up as---    arguments to the lifted function.---  [Abstracting over known local functions] turns a known call into an unknown---    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off---    with @-fstg-lift-lams-known@.---  [Calling convention] Don't lift when the resulting function would have a---    higher arity than available argument registers for the calling convention.---    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.---  [Closure growth] introduced when former free variables have to be available---    at call sites may actually lead to an increase in overall allocations---  resulting from a lift. Estimating closure growth is described in---  "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately---  concerned with.------ There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with--- some more background and history.---- Note [Estimating closure growth]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- $clogro--- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',--- capturing only syntactic details relevant to 'closureGrowth', such as------   * 'ClosureSk', representing closure allocation.---   * 'RhsSk', representing a RHS of a binding and how many times it's called---     by an appropriate 'DmdShell'.---   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.------ This abstraction is mostly so that the main analysis function 'closureGrowth'--- can stay simple and focused. Also, skeletons tend to be much smaller than--- the syntax tree they abstract, so it makes sense to construct them once and--- and operate on them instead of the actual syntax tree.------ A more detailed treatment of computing closure growth, including examples,--- can be found in the paper referenced from the--- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.--llTrace :: String -> SDoc -> a -> a-llTrace _ _ c = c--- llTrace a b c = pprTrace a b c--type instance BinderP      'LiftLams = BinderInfo-type instance XRhsClosure  'LiftLams = DIdSet-type instance XLet         'LiftLams = Skeleton-type instance XLetNoEscape 'LiftLams = Skeleton--freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet-freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]-freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs---- | Captures details of the syntax tree relevant to the cost model, such as--- closures, multi-shot lambdas and case expressions.-data Skeleton-  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton-  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton-  | AltSk !Skeleton !Skeleton-  | BothSk !Skeleton !Skeleton-  | NilSk--bothSk :: Skeleton -> Skeleton -> Skeleton-bothSk NilSk b = b-bothSk a NilSk = a-bothSk a b     = BothSk a b--altSk :: Skeleton -> Skeleton -> Skeleton-altSk NilSk b = b-altSk a NilSk = a-altSk a b     = AltSk a b--rhsSk :: DmdShell -> Skeleton -> Skeleton-rhsSk _        NilSk = NilSk-rhsSk body_dmd skel  = RhsSk body_dmd skel---- | The type used in binder positions in 'GenStgExpr's.-data BinderInfo-  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag-                           --   indicating whether it occurs as an argument-                           --   or in a nullary application-                           --   (see "StgLiftLams.Analysis#arg_occs").-  | BoringBinder !Id       -- ^ Every other kind of binder---- | Gets the bound 'Id' out a 'BinderInfo'.-binderInfoBndr :: BinderInfo -> Id-binderInfoBndr (BoringBinder bndr)   = bndr-binderInfoBndr (BindsClosure bndr _) = bndr---- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating--- occurrences as argument or in a nullary applications otherwise.-binderInfoOccursAsArg :: BinderInfo -> Maybe Bool-binderInfoOccursAsArg BoringBinder{}     = Nothing-binderInfoOccursAsArg (BindsClosure _ b) = Just b--instance Outputable Skeleton where-  ppr NilSk = text ""-  ppr (AltSk l r) = vcat-    [ text "{ " <+> ppr l-    , text "ALT"-    , text "  " <+> ppr r-    , text "}"-    ]-  ppr (BothSk l r) = ppr l $$ ppr r-  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)-  ppr (RhsSk body_dmd body) = hcat-    [ text "λ["-    , ppr str-    , text ", "-    , ppr use-    , text "]. "-    , ppr body-    ]-    where-      str-        | isStrictDmd body_dmd = '1'-        | otherwise = '0'-      use-        | isAbsDmd body_dmd = '0'-        | isUsedOnce body_dmd = '1'-        | otherwise = 'ω'--instance Outputable BinderInfo where-  ppr = ppr . binderInfoBndr--instance OutputableBndr BinderInfo where-  pprBndr b = pprBndr b . binderInfoBndr-  pprPrefixOcc = pprPrefixOcc . binderInfoBndr-  pprInfixOcc = pprInfixOcc . binderInfoBndr-  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr--mkArgOccs :: [StgArg] -> IdSet-mkArgOccs = mkVarSet . mapMaybe stg_arg_var-  where-    stg_arg_var (StgVarArg occ) = Just occ-    stg_arg_var _               = Nothing---- | Tags every binder with its 'BinderInfo' and let bindings with their--- 'Skeleton's.-tagSkeletonTopBind :: CgStgBinding -> LlStgBinding--- NilSk is OK when tagging top-level bindings. Also, top-level things are never--- lambda-lifted, so no need to track their argument occurrences. They can also--- never be let-no-escapes (thus we pass False).-tagSkeletonTopBind bind = bind'-  where-    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind---- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with--- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder--- occurrences in argument and nullary application position--- (cf. "StgLiftLams.Analysis#arg_occs").-tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)-tagSkeletonExpr (StgLit lit)-  = (NilSk, emptyVarSet, StgLit lit)-tagSkeletonExpr (StgConApp con args tys)-  = (NilSk, mkArgOccs args, StgConApp con args tys)-tagSkeletonExpr (StgOpApp op args ty)-  = (NilSk, mkArgOccs args, StgOpApp op args ty)-tagSkeletonExpr (StgApp f args)-  = (NilSk, arg_occs, StgApp f args)-  where-    arg_occs-      -- This checks for nullary applications, which we treat the same as-      -- argument occurrences, see "StgLiftLams.Analysis#arg_occs".-      | null args = unitVarSet f-      | otherwise = mkArgOccs args-tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")-tagSkeletonExpr (StgCase scrut bndr ty alts)-  = (skel, arg_occs, StgCase scrut' bndr' ty alts')-  where-    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut-    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts-    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)-    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr-    bndr' = BoringBinder bndr-tagSkeletonExpr (StgTick t e)-  = (skel, arg_occs, StgTick t e')-  where-    (skel, arg_occs, e') = tagSkeletonExpr e-tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind-tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind--mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr-mkLet True = StgLetNoEscape-mkLet _    = StgLet--tagSkeletonLet-  :: Bool-  -- ^ Is the binding a let-no-escape?-  -> CgStgExpr-  -- ^ Let body-  -> CgStgBinding-  -- ^ Binding group-  -> (Skeleton, IdSet, LlStgExpr)-  -- ^ RHS skeletons, argument occurrences and annotated binding-tagSkeletonLet is_lne body bind-  = (let_skel, arg_occs, mkLet is_lne scope bind' body')-  where-    (body_skel, body_arg_occs, body') = tagSkeletonExpr body-    (let_skel, arg_occs, scope, bind')-      = tagSkeletonBinding is_lne body_skel body_arg_occs bind--tagSkeletonBinding-  :: Bool-  -- ^ Is the binding a let-no-escape?-  -> Skeleton-  -- ^ Let body skeleton-  -> IdSet-  -- ^ Argument occurrences in the body-  -> CgStgBinding-  -- ^ Binding group-  -> (Skeleton, IdSet, Skeleton, LlStgBinding)-  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and-  --   the annotated binding-tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)-  = (let_skel, arg_occs, scope, bind')-  where-    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs-    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr-    bind_skel-      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes-      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel-    let_skel = bothSk body_skel bind_skel-    occurs_as_arg = bndr `elemVarSet` body_arg_occs-    -- Compared to the recursive case, this exploits the fact that @bndr@ is-    -- never free in @rhs@.-    scope = body_skel-    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'-tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)-  = (let_skel, arg_occs, scope, StgRec pairs')-  where-    (bndrs, _) = unzip pairs-    -- Local recursive STG bindings also regard the defined binders as free-    -- vars. We want to delete those for our cost model, as these are known-    -- calls anyway when we add them to the same top-level recursive group as-    -- the top-level binding currently being analysed.-    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs-    rhss_arg_occs = map sndOf3 skel_occs_rhss'-    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)-    arg_occs = scope_occs `delVarSetList` bndrs-    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,-    -- but we also need the un-wrapped skeletons for calculating the @scope@-    -- of the group, as the outer closures don't contribute to closure growth-    -- when we lift this specific binding.-    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'-    -- Now we can build the actual Skeleton for the expression just by-    -- iterating over each bind pair.-    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')-    let_skel = foldr bothSk body_skel bind_skels-    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))-      where-        -- Here, we finally add the closure around each @skel_rhs@.-        bind_skel-          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes-          | otherwise = ClosureSk bndr fvs skel_rhs-        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs-        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)--tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)-tagSkeletonRhs _ (StgRhsCon ccs dc args)-  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)-tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)-  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')-  where-    bndrs' = map BoringBinder bndrs-    (body_skel, body_arg_occs, body') = tagSkeletonExpr body-    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel---- | How many times will the lambda body of the RHS bound to the given--- identifier be evaluated, relative to its defining context? This function--- computes the answer in form of a 'DmdShell'.-rhsDmdShell :: Id -> DmdShell-rhsDmdShell bndr-  | is_thunk = oneifyDmd ds-  | otherwise = peelManyCalls (idArity bndr) cd-  where-    is_thunk = idArity bndr == 0-    -- Let's pray idDemandInfo is still OK after unarise...-    (ds, cd) = toCleanDmd (idDemandInfo bndr)--tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)-tagSkeletonAlt (con, bndrs, rhs)-  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))-  where-    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs-    arg_occs = alt_arg_occs `delVarSetList` bndrs---- | Combines several heuristics to decide whether to lambda-lift a given--- @let@-binding to top-level. See "StgLiftLams.Analysis#when" for details.-goodToLift-  :: DynFlags-  -> TopLevelFlag-  -> RecFlag-  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into-                        -- 'OutId's. See 'StgLiftLams.LiftM.liftedIdsExpander'.-  -> [(BinderInfo, LlStgRhs)]-  -> Skeleton-  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to-                        -- lift and @abs_ids@ are the variables it would-                        -- abstract over-goodToLift dflags top_lvl rec_flag expander pairs scope = decide-  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]-  , ("memoized", any_memoized)-  , ("argument occurrences", arg_occs)-  , ("join point", is_join_point)-  , ("abstracts join points", abstracts_join_ids)-  , ("abstracts known local function", abstracts_known_local_fun)-  , ("args spill on stack", args_spill_on_stack)-  , ("increases allocation", inc_allocs)-  ] where-      decide deciders-        | not (fancy_or deciders)-        = llTrace "stgLiftLams:lifting"-                  (ppr bndrs <+> ppr abs_ids $$-                   ppr allocs $$-                   ppr scope) $-          Just abs_ids-        | otherwise-        = Nothing-      ppr_deciders = vcat . map (text . fst) . filter snd-      fancy_or deciders-        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $-          any snd deciders--      bndrs = map (binderInfoBndr . fst) pairs-      bndrs_set = mkVarSet bndrs-      rhss = map snd pairs--      -- First objective: Calculate @abs_ids@, e.g. the former free variables-      -- the lifted binding would abstract over. We have to merge the free-      -- variables of all RHS to get the set of variables that will have to be-      -- passed through parameters.-      fvs = unionDVarSets (map freeVarsOfRhs rhss)-      -- To lift the binding to top-level, we want to delete the lifted binders-      -- themselves from the free var set. Local let bindings track recursive-      -- occurrences in their free variable set. We neither want to apply our-      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters-      -- when lifted, as these are known calls. We call the resulting set the-      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.-      -- We will save the set in 'LiftM.e_expansions' for each of the variables-      -- if we perform the lift.-      abs_ids = expander (delDVarSetList fvs bndrs)--      -- We don't lift updatable thunks or constructors-      any_memoized = any is_memoized_rhs rhss-      is_memoized_rhs StgRhsCon{} = True-      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd--      -- Don't lift binders occurring as arguments. This would result in complex-      -- argument expressions which would have to be given a name, reintroducing-      -- the very allocation at each call site that we wanted to get rid off in-      -- the first place.-      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)--      -- These don't allocate anyway.-      is_join_point = any isJoinId bndrs--      -- Abstracting over join points/let-no-escapes spoils them.-      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)--      -- Abstracting over known local functions that aren't floated themselves-      -- turns a known, fast call into an unknown, slow call:-      ---      --    let f x = ...-      --        g y = ... f x ... -- this was a known call-      --    in g 4-      ---      -- After lifting @g@, but not @f@:-      ---      --    l_g f y = ... f y ... -- this is now an unknown call-      --    let f x = ...-      --    in l_g f 4-      ---      -- We can abuse the results of arity analysis for this:-      -- idArity f > 0 ==> known-      known_fun id = idArity id > 0-      abstracts_known_local_fun-        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)--      -- Number of arguments of a RHS in the current binding group if we decide-      -- to lift it-      n_args-        = length-        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm-        . (dVarSetElems abs_ids ++)-        . rhsLambdaBndrs-      max_n_args-        | isRec rec_flag = liftLamsRecArgs dflags-        | otherwise      = liftLamsNonRecArgs dflags-      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess-      -- args are passed on the stack, which means slow memory accesses-      args_spill_on_stack-        | Just n <- max_n_args = maximum (map n_args rhss) > n-        | otherwise = False--      -- We only perform the lift if allocations didn't increase.-      -- Note that @clo_growth@ will be 'infinity' if there was positive growth-      -- under a multi-shot lambda.-      -- Also, abstracting over LNEs is unacceptable. LNEs might return-      -- unlifted tuples, which idClosureFootprint can't cope with.-      inc_allocs = abstracts_join_ids || allocs > 0-      allocs = clo_growth + mkIntWithInf (negate closuresSize)-      -- We calculate and then add up the size of each binding's closure.-      -- GHC does not currently share closure environments, and we either lift-      -- the entire recursive binding group or none of it.-      closuresSize = sum $ flip map rhss $ \rhs ->-        closureSize dflags-        . dVarSetElems-        . expander-        . flip dVarSetMinusVarSet bndrs_set-        $ freeVarsOfRhs rhs-      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope--rhsLambdaBndrs :: LlStgRhs -> [Id]-rhsLambdaBndrs StgRhsCon{} = []-rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs---- | The size in words of a function closure closing over the given 'Id's,--- including the header.-closureSize :: DynFlags -> [Id] -> WordOff-closureSize dflags ids = words + sTD_HDR_SIZE dflags-  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't-  -- optimise differently when profiling is enabled.-  where-    (words, _, _)-      -- Functions have a StdHeader (as opposed to ThunkHeader).-      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader-      . StgToCmm.Closure.addIdReps-      . StgToCmm.Closure.nonVoidIds-      $ ids---- | The number of words a single 'Id' adds to a closure's size.--- Note that this can't handle unboxed tuples (which may still be present in--- let-no-escapes, even after Unarise), in which case--- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash.-idClosureFootprint:: DynFlags -> Id -> WordOff-idClosureFootprint dflags-  = StgToCmm.ArgRep.argRepSizeW dflags-  . StgToCmm.ArgRep.idArgRep---- | @closureGrowth expander sizer f fvs@ computes the closure growth in words--- as a result of lifting @f@ to top-level. If there was any growing closure--- under a multi-shot lambda, the result will be 'infinity'.--- Also see "StgLiftLams.Analysis#clogro".-closureGrowth-  :: (DIdSet -> DIdSet)-  -- ^ Expands outer free ids that were lifted to their free vars-  -> (Id -> Int)-  -- ^ Computes the closure footprint of an identifier-  -> IdSet-  -- ^ Binding group for which lifting is to be decided-  -> DIdSet-  -- ^ Free vars of the whole binding group prior to lifting it. These must be-  --   available at call sites if we decide to lift the binding group.-  -> Skeleton-  -- ^ Abstraction of the scope of the function-  -> IntWithInf-  -- ^ Closure growth. 'infinity' indicates there was growth under a-  --   (multi-shot) lambda.-closureGrowth expander sizer group abs_ids = go-  where-    go NilSk = 0-    go (BothSk a b) = go a + go b-    go (AltSk a b) = max (go a) (go b)-    go (ClosureSk _ clo_fvs rhs)-      -- If no binder of the @group@ occurs free in the closure, the lifting-      -- won't have any effect on it and we can omit the recursive call.-      | n_occs == 0 = 0-      -- Otherwise, we account the cost of allocating the closure and add it to-      -- the closure growth of its RHS.-      | otherwise   = mkIntWithInf cost + go rhs-      where-        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)-        -- What we close over considering prior lifting decisions-        clo_fvs' = expander clo_fvs-        -- Variables that would additionally occur free in the closure body if-        -- we lift @f@-        newbies = abs_ids `minusDVarSet` clo_fvs'-        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@-        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs-    go (RhsSk body_dmd body)-      -- The conservative assumption would be that-      --   1. Every RHS with positive growth would be called multiple times,-      --      modulo thunks.-      --   2. Every RHS with negative growth wouldn't be called at all.-      ---      -- In the first case, we'd have to return 'infinity', while in the-      -- second case, we'd have to return 0. But we can do far better-      -- considering information from the demand analyser, which provides us-      -- with conservative estimates on minimum and maximum evaluation-      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of-      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body-      -- relative to its defining context.-      | isAbsDmd body_dmd   = 0-      | cg <= 0             = if isStrictDmd body_dmd then cg else 0-      | isUsedOnce body_dmd = cg-      | otherwise           = infinity-      where-        cg = go body
− compiler/simplStg/StgLiftLams/LiftM.hs 
@@ -1,348 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}---- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'--- monad.-module StgLiftLams.LiftM (-    decomposeStgBinding, mkStgBinding,-    Env (..),-    -- * #floats# Handling floats-    -- $floats-    FloatLang (..), collectFloats, -- Exported just for the docs-    -- * Transformation monad-    LiftM, runLiftM, withCaffyness,-    -- ** Adding bindings-    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,-    -- ** Substitution and binders-    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,-    -- ** Occurrences-    substOcc, isLifted, formerFreeVars, liftedIdsExpander-  ) where--#include "HsVersions.h"--import GhcPrelude--import BasicTypes-import CostCentre ( isCurrentCCS, dontCareCCS )-import DynFlags-import FastString-import Id-import IdInfo-import Name-import Outputable-import OrdList-import StgSubst-import StgSyn-import Type-import UniqSupply-import Util-import VarEnv-import VarSet--import Control.Arrow ( second )-import Control.Monad.Trans.Class-import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )-import qualified Control.Monad.Trans.RWS.Strict as RWS-import Control.Monad.Trans.Cont ( ContT (..) )-import Data.ByteString ( ByteString )---- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@-decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])-decomposeStgBinding (StgRec pairs) = (Recursive, pairs)-decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])--mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass-mkStgBinding Recursive = StgRec-mkStgBinding NonRecursive = uncurry StgNonRec . head---- | Environment threaded around in a scoped, @Reader@-like fashion.-data Env-  = Env-  { e_dflags     :: !DynFlags-  -- ^ Read-only.-  , e_subst      :: !Subst-  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',-  -- because shadowing might make a closure's free variables unavailable at its-  -- call sites. Consider:-  -- @-  --    let f y = x + y in let x = 4 in f x-  -- @-  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't-  -- available at its call site.-  , e_expansions :: !(IdEnv DIdSet)-  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because-  -- they are bound at the top-level. Every occurrence must supply the formerly-  -- free variables of the lifted 'Id', so they in turn become free variables of-  -- the call sites. This environment tracks this expansion from lifted 'Id's to-  -- their free variables.-  ---  -- 'InId's to 'OutId's.-  ---  -- Invariant: 'Id's not present in this map won't be substituted.-  , e_in_caffy_context :: !Bool-  -- ^ Are we currently analysing within a caffy context (e.g. the containing-  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely-  -- assume that functions we lift out aren't caffy either.-  }--emptyEnv :: DynFlags -> Env-emptyEnv dflags = Env dflags emptySubst emptyVarEnv False----- Note [Handling floats]--- ~~~~~~~~~~~~~~~~~~~~~~--- $floats--- Consider the following expression:------ @---     f x =---       let g y = ... f y ...---       in g x--- @------ What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@--- binding above the binding for @f@:------ @---     g f y = ... f y ...---     f x = g f x--- @------ But this very unnecessarily turns a known call to @f@ into an unknown one, in--- addition to complicating matters for the analysis.--- Instead, we'd really like to put both functions in the same recursive group,--- thereby preserving the known call:------ @---     Rec {---       g y = ... f y ...---       f x = g x---     }--- @------ But we don't want this to happen for just /any/ binding. That would create--- possibly huge recursive groups in the process, calling for an occurrence--- analyser on STG.--- So, we need to track when we lift a binding out of a recursive RHS and add--- the binding to the same recursive group as the enclosing recursive binding--- (which must have either already been at the top-level or decided to be--- lifted itself in order to preserve the known call).------ This is done by expressing this kind of nesting structure as a 'Writer' over--- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to--- 'collectFloats'.--- API-wise, the analysis will not need to know about the whole 'FloatLang'--- business and will just manipulate it indirectly through actions in 'LiftM'.---- | We need to detect when we are lifting something out of the RHS of a--- recursive binding (c.f. "StgLiftLams.LiftM#floats"), in which case that--- binding needs to be added to the same top-level recursive group. This--- requires we detect a certain nesting structure, which is encoded by--- 'StartBindingGroup' and 'EndBindingGroup'.------ Although 'collectFloats' will only ever care if the current binding to be--- lifted (through 'LiftedBinding') will occur inside such a binding group or--- not, e.g. doesn't care about the nesting level as long as its greater than 0.-data FloatLang-  = StartBindingGroup-  | EndBindingGroup-  | PlainTopBinding OutStgTopBinding-  | LiftedBinding OutStgBinding--instance Outputable FloatLang where-  ppr StartBindingGroup = char '('-  ppr EndBindingGroup = char ')'-  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"-  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)-  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)-    where-      (rec, pairs) = decomposeStgBinding bind---- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.--- Important pre-conditions: The nesting of opening 'StartBindinGroup's and--- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding--- group has at least one recursive binding inside. Otherwise there's no point--- in announcing the binding group in the first place and an @ASSERT@ will--- trigger.-collectFloats :: [FloatLang] -> [OutStgTopBinding]-collectFloats = go (0 :: Int) []-  where-    go 0 [] [] = []-    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")-    go n binds (f:rest) = case f of-      StartBindingGroup -> go (n+1) binds rest-      EndBindingGroup-        | n == 0 -> pprPanic "collectFloats" (text "no group to end")-        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest-        | otherwise -> go (n-1) binds rest-      PlainTopBinding top_bind-        | n == 0 -> top_bind : go n binds rest-        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")-      LiftedBinding bind-        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest-        | otherwise -> go n (bind:binds) rest--    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding-    rm_cccs = map_rhss removeRhsCCCS-    merge_binds binds = ASSERT( any is_rec binds )-                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)-    is_rec StgRec{} = True-    is_rec _ = False---- | Omitting this makes for strange closure allocation schemes that crash the--- GC.-removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass-removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)-  | isCurrentCCS ccs-  = StgRhsClosure ext dontCareCCS upd bndrs body-removeRhsCCCS (StgRhsCon ccs con args)-  | isCurrentCCS ccs-  = StgRhsCon dontCareCCS con args-removeRhsCCCS rhs = rhs---- | The analysis monad consists of the following 'RWST' components:------     * 'Env': Reader-like context. Contains a substitution, info about how---       how lifted identifiers are to be expanded into applications and details---       such as 'DynFlags' and a flag helping with determining if a lifted---       binding is caffy.------     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.------     * No pure state component------     * But wrapping around 'UniqSM' for generating fresh lifted binders.---       (The @uniqAway@ approach could give the same name to two different---       lifted binders, so this is necessary.)-newtype LiftM a-  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }-  deriving (Functor, Applicative, Monad)--instance HasDynFlags LiftM where-  getDynFlags = LiftM (RWS.asks e_dflags)--instance MonadUnique LiftM where-  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)-  getUniqueM = LiftM (lift getUniqueM)-  getUniquesM = LiftM (lift getUniquesM)--runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)-  where-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())---- | Assumes a given caffyness for the execution of the passed action, which--- influences the 'cafInfo' of lifted bindings.-withCaffyness :: Bool -> LiftM a -> LiftM a-withCaffyness caffy action-  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))---- | Writes a plain 'StgTopStringLit' to the output.-addTopStringLit :: OutId -> ByteString -> LiftM ()-addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id---- | Starts a recursive binding group. See #floats# and 'collectFloats'.-startBindingGroup :: LiftM ()-startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup---- | Ends a recursive binding group. See #floats# and 'collectFloats'.-endBindingGroup :: LiftM ()-endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup---- | Lifts a binding to top-level. Depending on whether it's declared inside--- a recursive RHS (see #floats# and 'collectFloats'), this might be added to--- an existing recursive top-level binding group.-addLiftedBinding :: OutStgBinding -> LiftM ()-addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding---- | Takes a binder and a continuation which is called with the substituted--- binder. The continuation will be evaluated in a 'LiftM' context in which that--- binder is deemed in scope. Think of it as a 'RWS.local' computation: After--- the continuation finishes, the new binding won't be in scope anymore.-withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a-withSubstBndr bndr inner = LiftM $ do-  subst <- RWS.asks e_subst-  let (bndr', subst') = substBndr bndr subst-  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))---- | See 'withSubstBndr'.-withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a-withSubstBndrs = runContT . traverse (ContT . withSubstBndr)---- | Similarly to 'withSubstBndr', this function takes a set of variables to--- abstract over, the binder to lift (and generate a fresh, substituted name--- for) and a continuation in which that fresh, lifted binder is in scope.------ It takes care of all the details involved with copying and adjusting the--- binder, fresh name generation and caffyness.-withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a-withLiftedBndr abs_ids bndr inner = do-  uniq <- getUniqueM-  let str = "$l" ++ occNameString (getOccName bndr)-  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)-  -- When the enclosing top-level binding is not caffy, then the lifted-  -- binding will not be caffy either. If we don't recognize this, non-caffy-  -- things call caffy things and then codegen screws up.-  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)-  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs-  let bndr'-        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least-        -- for arity information.-        = transferPolyIdInfo bndr (dVarSetElems abs_ids)-        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is-        -- assumed to be caffy and will need an SRT. Transitive call sites might-        -- not be caffy themselves and subsequently will miss a static link-        -- field in their closure. Chaos ensues.-        . flip setIdCafInfo caf_info-        . mkSysLocalOrCoVar (mkFastString str) uniq-        $ ty-  LiftM $ RWS.local-    (\e -> e-      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e-      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids-      })-    (unwrapLiftM (inner bndr'))---- | See 'withLiftedBndr'.-withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a-withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)---- | Substitutes a binder /occurrence/, which was brought in scope earlier by--- 'withSubstBndr'\/'withLiftedBndr'.-substOcc :: Id -> LiftM Id-substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))---- | Whether the given binding was decided to be lambda lifted.-isLifted :: InId -> LiftM Bool-isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))---- | Returns an empty list for a binding that was not lifted and the list of all--- local variables the binding abstracts over (so, exactly the additional--- arguments at adjusted call sites) otherwise.-formerFreeVars :: InId -> LiftM [OutId]-formerFreeVars f = LiftM $ do-  expansions <- RWS.asks e_expansions-  pure $ case lookupVarEnv expansions f of-    Nothing -> []-    Just fvs -> dVarSetElems fvs---- | Creates an /expander function/ for the current set of lifted binders.--- This expander function will replace any 'InId' by their corresponding 'OutId'--- and, in addition, will expand any lifted binders by the former free variables--- it abstracts over.-liftedIdsExpander :: LiftM (DIdSet -> DIdSet)-liftedIdsExpander = LiftM $ do-  expansions <- RWS.asks e_expansions-  subst <- RWS.asks e_subst-  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"-  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.-  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in-  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much-  -- trouble.-  let go set fv = case lookupVarEnv expansions fv of-        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted-        Just fvs' -> unionDVarSet set fvs'-  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)-  pure expander
− compiler/simplStg/StgLiftLams/Transformation.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP #-}---- | (Mostly) textbook instance of the lambda lifting transformation,--- selecting which bindings to lambda lift by consulting 'goodToLift'.-module StgLiftLams.Transformation (stgLiftLams) where--#include "HsVersions.h"--import GhcPrelude--import BasicTypes-import DynFlags-import Id-import IdInfo-import StgFVs ( annBindingFreeVars )-import StgLiftLams.Analysis-import StgLiftLams.LiftM-import StgSyn-import Outputable-import UniqSupply-import Util-import VarSet-import Control.Monad ( when )-import Data.Maybe ( isNothing )---- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').-stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]-stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())--liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()-liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do-  addTopStringLit bndr' lit-  rest-liftTopLvl (StgTopLifted bind) rest = do-  let is_rec = isRec $ fst $ decomposeStgBinding bind-  when is_rec startBindingGroup-  let bind_w_fvs = annBindingFreeVars bind-  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do-    -- We signal lifting of a binding through returning Nothing.-    -- Should never happen for a top-level binding, though, since we are already-    -- at top-level.-    case mb_bind' of-      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")-      Just bind' -> addLiftedBinding bind'-    when is_rec endBindingGroup-    rest--withLiftedBind-  :: TopLevelFlag-  -> LlStgBinding-  -> Skeleton-  -> (Maybe OutStgBinding -> LiftM a)-  -> LiftM a-withLiftedBind top_lvl bind scope k-  | isTopLevel top_lvl-  = withCaffyness (is_caffy pairs) go-  | otherwise-  = go-  where-    (rec, pairs) = decomposeStgBinding bind-    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)-    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))--withLiftedBindPairs-  :: TopLevelFlag-  -> RecFlag-  -> [(BinderInfo, LlStgRhs)]-  -> Skeleton-  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)-  -> LiftM a-withLiftedBindPairs top rec pairs scope k = do-  let (infos, rhss) = unzip pairs-  let bndrs = map binderInfoBndr infos-  expander <- liftedIdsExpander-  dflags <- getDynFlags-  case goodToLift dflags top rec expander pairs scope of-    -- @abs_ids@ is the set of all variables that need to become parameters.-    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do-      -- Within this block, all binders in @bndrs@ will be noted as lifted, so-      -- that the return value of @liftedIdsExpander@ in this context will also-      -- expand the bindings in @bndrs@ to their free variables.-      -- Now we can recurse into the RHSs and see if we can lift any further-      -- bindings. We pass the set of expanded free variables (thus OutIds) on-      -- to @liftRhs@ so that it can add them as parameter binders.-      when (isRec rec) startBindingGroup-      rhss' <- traverse (liftRhs (Just abs_ids)) rhss-      let pairs' = zip bndrs' rhss'-      addLiftedBinding (mkStgBinding rec pairs')-      when (isRec rec) endBindingGroup-      k Nothing-    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do-      -- Don't lift the current binding, but possibly some bindings in their-      -- RHSs.-      rhss' <- traverse (liftRhs Nothing) rhss-      let pairs' = zip bndrs' rhss'-      k (Just pairs')--liftRhs-  :: Maybe (DIdSet)-  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@-  -- as lambda binders, discarding all free vars.-  -> LlStgRhs-  -> LiftM OutStgRhs-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)-  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)-    StgRhsCon ccs con <$> traverse liftArgs args-liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do-  -- This RHS wasn't lifted.-  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-    StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body-liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do-  -- This RHS was lifted. Insert extra binders for @former_fvs@.-  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do-    let bndrs'' = dVarSetElems former_fvs ++ bndrs'-    StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body--liftArgs :: InStgArg -> LiftM OutStgArg-liftArgs a@(StgLitArg _) = pure a-liftArgs (StgVarArg occ) = do-  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )-  StgVarArg <$> substOcc occ--liftExpr :: LlStgExpr -> LiftM OutStgExpr-liftExpr (StgLit lit) = pure (StgLit lit)-liftExpr (StgTick t e) = StgTick t <$> liftExpr e-liftExpr (StgApp f args) = do-  f' <- substOcc f-  args' <- traverse liftArgs args-  fvs' <- formerFreeVars f-  let top_lvl_args = map StgVarArg fvs' ++ args'-  pure (StgApp f' top_lvl_args)-liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys-liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty-liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")-liftExpr (StgCase scrut info ty alts) = do-  scrut' <- liftExpr scrut-  withSubstBndr (binderInfoBndr info) $ \bndr' -> do-    alts' <- traverse liftAlt alts-    pure (StgCase scrut' bndr' ty alts')-liftExpr (StgLet scope bind body)-  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do-      body' <- liftExpr body-      case mb_bind' of-        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats-        Just bind' -> pure (StgLet noExtFieldSilent bind' body')-liftExpr (StgLetNoEscape scope bind body)-  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do-      body' <- liftExpr body-      case mb_bind' of-        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")-        Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')--liftAlt :: LlStgAlt -> LiftM OutStgAlt-liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-  (,,) con bndrs' <$> liftExpr rhs
− compiler/simplStg/StgStats.hs 
@@ -1,173 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[StgStats]{Gathers statistical information about programs}---The program gather statistics about-\begin{enumerate}-\item number of boxed cases-\item number of unboxed cases-\item number of let-no-escapes-\item number of non-updatable lets-\item number of updatable lets-\item number of applications-\item number of primitive applications-\item number of closures (does not include lets bound to constructors)-\item number of free variables in closures-%\item number of top-level functions-%\item number of top-level CAFs-\item number of constructors-\end{enumerate}--}--{-# LANGUAGE CPP #-}--module StgStats ( showStgStats ) where--#include "HsVersions.h"--import GhcPrelude--import StgSyn--import Id (Id)-import Panic--import Data.Map (Map)-import qualified Data.Map as Map--data CounterType-  = Literals-  | Applications-  | ConstructorApps-  | PrimitiveApps-  | LetNoEscapes-  | StgCases-  | FreeVariables-  | ConstructorBinds Bool{-True<=>top-level-}-  | ReEntrantBinds   Bool{-ditto-}-  | SingleEntryBinds Bool{-ditto-}-  | UpdatableBinds   Bool{-ditto-}-  deriving (Eq, Ord)--type Count      = Int-type StatEnv    = Map CounterType Count--emptySE :: StatEnv-emptySE = Map.empty--combineSE :: StatEnv -> StatEnv -> StatEnv-combineSE = Map.unionWith (+)--combineSEs :: [StatEnv] -> StatEnv-combineSEs = foldr combineSE emptySE--countOne :: CounterType -> StatEnv-countOne c = Map.singleton c 1--{--************************************************************************-*                                                                      *-\subsection{Top-level list of bindings (a ``program'')}-*                                                                      *-************************************************************************--}--showStgStats :: [StgTopBinding] -> String--showStgStats prog-  = "STG Statistics:\n\n"-    ++ concat (map showc (Map.toList (gatherStgStats prog)))-  where-    showc (x,n) = (showString (s x) . shows n) "\n"--    s Literals                = "Literals                   "-    s Applications            = "Applications               "-    s ConstructorApps         = "ConstructorApps            "-    s PrimitiveApps           = "PrimitiveApps              "-    s LetNoEscapes            = "LetNoEscapes               "-    s StgCases                = "StgCases                   "-    s FreeVariables           = "FreeVariables              "-    s (ConstructorBinds True) = "ConstructorBinds_Top       "-    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "-    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "-    s (UpdatableBinds True)   = "UpdatableBinds_Top         "-    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "-    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "-    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "-    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "--gatherStgStats :: [StgTopBinding] -> StatEnv-gatherStgStats binds = combineSEs (map statTopBinding binds)--{--************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}--statTopBinding :: StgTopBinding -> StatEnv-statTopBinding (StgTopStringLit _ _) = countOne Literals-statTopBinding (StgTopLifted bind) = statBinding True bind--statBinding :: Bool -- True <=> top-level; False <=> nested-            -> StgBinding-            -> StatEnv--statBinding top (StgNonRec b rhs)-  = statRhs top (b, rhs)--statBinding top (StgRec pairs)-  = combineSEs (map (statRhs top) pairs)--statRhs :: Bool -> (Id, StgRhs) -> StatEnv--statRhs top (_, StgRhsCon _ _ _)-  = countOne (ConstructorBinds top)--statRhs top (_, StgRhsClosure _ _ u _ body)-  = statExpr body `combineSE`-    countOne (-      case u of-        ReEntrant   -> ReEntrantBinds   top-        Updatable   -> UpdatableBinds   top-        SingleEntry -> SingleEntryBinds top-    )--{--************************************************************************-*                                                                      *-\subsection{Expressions}-*                                                                      *-************************************************************************--}--statExpr :: StgExpr -> StatEnv--statExpr (StgApp _ _)     = countOne Applications-statExpr (StgLit _)       = countOne Literals-statExpr (StgConApp _ _ _)= countOne ConstructorApps-statExpr (StgOpApp _ _ _) = countOne PrimitiveApps-statExpr (StgTick _ e)    = statExpr e--statExpr (StgLetNoEscape _ binds body)-  = statBinding False{-not top-level-} binds    `combineSE`-    statExpr body                               `combineSE`-    countOne LetNoEscapes--statExpr (StgLet _ binds body)-  = statBinding False{-not top-level-} binds    `combineSE`-    statExpr body--statExpr (StgCase expr _ _ alts)-  = statExpr expr       `combineSE`-    stat_alts alts      `combineSE`-    countOne StgCases-  where-    stat_alts alts-        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])--statExpr (StgLam {}) = panic "statExpr StgLam"
− compiler/simplStg/UnariseStg.hs 
@@ -1,769 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-2012--Note [Unarisation]-~~~~~~~~~~~~~~~~~~-The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum-binders. So for example:--  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)--  ==>--  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True--It is important that we do this at the STG level and NOT at the Core level-because it would be very hard to make this pass Core-type-preserving. In this-example the type of 'f' changes, for example.--STG fed to the code generators *must* be unarised because the code generators do-not support unboxed tuple and unboxed sum binders natively.--In more detail: (see next note for unboxed sums)--Suppose that a variable x : (# t1, t2 #).--  * At the binding site for x, make up fresh vars  x1:t1, x2:t2--  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]--  * Replace the binding with a curried binding for x1,x2--       Lambda:   \x.e                ==>   \x1 x2. e-       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e--  * Replace argument occurrences with a sequence of args via a lookup in-    UnariseEnv--       f a b x c d   ==>   f a b x1 x2 c d--  * Replace tail-call occurrences with an unboxed tuple via a lookup in-    UnariseEnv--       x  ==>  (# x1, x2 #)--    So, for example--       f x = x    ==>   f x1 x2 = (# x1, x2 #)--  * We /always/ eliminate a case expression when--       - It scrutinises an unboxed tuple or unboxed sum--       - The scrutinee is a variable (or when it is an explicit tuple, but the-         simplifier eliminates those)--    The case alternative (there can be only one) can be one of these two-    things:--      - An unboxed tuple pattern. e.g.--          case v of x { (# x1, x2, x3 #) -> ... }--        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the-        environment with--          x :-> MultiVal [t1,t2,t3]-          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3--      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3--By the end of this pass, we only have unboxed tuples in return positions.-Unboxed sums are completely eliminated, see next note.--Note [Translating unboxed sums to unboxed tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unarise also eliminates unboxed sum binders, and translates unboxed sums in-return positions to unboxed tuples. We want to overlap fields of a sum when-translating it to a tuple to have efficient memory layout. When translating a-sum pattern to a tuple pattern, we need to translate it so that binders of sum-alternatives will be mapped to right arguments after the term translation. So-translation of sum DataCon applications to tuple DataCon applications and-translation of sum patterns to tuple patterns need to be in sync.--These translations work like this. Suppose we have--  (# x1 | | ... #) :: (# t1 | t2 | ... #)--remember that t1, t2 ... can be sums and tuples too. So we first generate-layouts of those. Then we "merge" layouts of each alternative, which gives us a-sum layout with best overlapping possible.--Layout of a flat type 'ty1' is just [ty1].-Layout of a tuple is just concatenation of layouts of its fields.--For layout of a sum type,--  - We first get layouts of all alternatives.-  - We sort these layouts based on their "slot types".-  - We merge all the alternatives.--For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)--  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]-  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]-  - Merge all alternatives together: [ Ptr, Word, Word ]--We add a slot for the tag to the first position. So our tuple type is--  (# Tag#, Any, Word#, Word# #)-  (we use Any for pointer slots)--Now, any term of this sum type needs to generate a tuple of this type instead.-The translation works by simply putting arguments to first slots that they fit-in. Suppose we had--  (# (# 42#, 'c' #) | | #)--42# fits in Word#, 'c' fits in Any, so we generate this application:--  (# 1#, 'c', 42#, rubbish #)--Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,-3# fits in Word #, so we get:--  (# 2#, rubbish, 2#, 3# #).--Note [Types in StgConApp]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have this unboxed sum term:--  (# 123 | #)--What will be the unboxed tuple representation? We can't tell without knowing the-type of this term. For example, these are all valid tuples for this:--  (# 1#, 123 #)          -- when type is (# Int | String #)-  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)-  (# 1#, 123, rubbish, rubbish #)-                         -- when type is (# Int | (# Int, Int, Int #) #)--So we pass type arguments of the DataCon's TyCon in StgConApp to decide what-layout to use. Note that unlifted values can't be let-bound, so we don't need-types in StgRhsCon.--Note [UnariseEnv can map to literals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To avoid redundant case expressions when unarising unboxed sums, UnariseEnv-needs to map variables to literals too. Suppose we have this Core:--  f (# x | #)--  ==> (CorePrep)--  case (# x | #) of y {-    _ -> f y-  }--  ==> (MultiVal)--  case (# 1#, x #) of [x1, x2] {-    _ -> f x1 x2-  }--To eliminate this case expression we need to map x1 to 1# in UnariseEnv:--  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x--so that `f x1 x2` becomes `f 1# x`.--Note [Unarisation and arity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because of unarisation, the arity that will be recorded in the generated info-table for an Id may be larger than the idArity. Instead we record what we call-the RepArity, which is the Arity taking into account any expanded arguments, and-corresponds to the number of (possibly-void) *registers* arguments will arrive-in.--Note [Post-unarisation invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-STG programs after unarisation have these invariants:--  * No unboxed sums at all.--  * No unboxed tuple binders. Tuples only appear in return position.--  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.-    This means that it's safe to wrap `StgArg`s of DataCon applications with-    `GHC.StgToCmm.Env.NonVoid`, for example.--  * Alt binders (binders in patterns) are always non-void.--  * Binders always have zero (for void arguments) or one PrimRep.--}--{-# LANGUAGE CPP, TupleSections #-}--module UnariseStg (unarise) where--#include "HsVersions.h"--import GhcPrelude--import BasicTypes-import CoreSyn-import DataCon-import FastString (FastString, mkFastString)-import Id-import Literal-import MkCore (aBSENT_SUM_FIELD_ERROR_ID)-import MkId (voidPrimId, voidArgId)-import MonadUtils (mapAccumLM)-import Outputable-import RepType-import StgSyn-import Type-import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)-import TysWiredIn-import UniqSupply-import Util-import VarEnv--import Data.Bifunctor (second)-import Data.Maybe (mapMaybe)-import qualified Data.IntMap as IM-------------------------------------------------------------------------------------- | A mapping from binders to the Ids they were expanded/renamed to.------   x :-> MultiVal [a,b,c] in rho------ iff  x's typePrimRep is not a singleton, or equivalently---      x's type is an unboxed tuple, sum or void.------    x :-> UnaryVal x'------ iff x's RepType is UnaryRep or equivalently---     x's type is not unboxed tuple, sum or void.------ So---     x :-> MultiVal [a] in rho--- means x is represented by singleton tuple.------     x :-> MultiVal [] in rho--- means x is void.------ INVARIANT: OutStgArgs in the range only have NvUnaryTypes---            (i.e. no unboxed tuples, sums or voids)----type UnariseEnv = VarEnv UnariseVal--data UnariseVal-  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).-  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].--instance Outputable UnariseVal where-  ppr (MultiVal args) = text "MultiVal" <+> ppr args-  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg---- | Extend the environment, checking the UnariseEnv invariant.-extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv-extendRho rho x (MultiVal args)-  = ASSERT(all (isNvUnaryType . stgArgType) args)-    extendVarEnv rho x (MultiVal args)-extendRho rho x (UnaryVal val)-  = ASSERT(isNvUnaryType (stgArgType val))-    extendVarEnv rho x (UnaryVal val)------------------------------------------------------------------------------------unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]-unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)--unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding-unariseTopBinding rho (StgTopLifted bind)-  = StgTopLifted <$> unariseBinding rho bind-unariseTopBinding _ bind@StgTopStringLit{} = return bind--unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding-unariseBinding rho (StgNonRec x rhs)-  = StgNonRec x <$> unariseRhs rho rhs-unariseBinding rho (StgRec xrhss)-  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss--unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)-  = do (rho', args1) <- unariseFunArgBinders rho args-       expr' <- unariseExpr rho' expr-       return (StgRhsClosure ext ccs update_flag args1 expr')--unariseRhs rho (StgRhsCon ccs con args)-  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))-    return (StgRhsCon ccs con (unariseConArgs rho args))------------------------------------------------------------------------------------unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr--unariseExpr rho e@(StgApp f [])-  = case lookupVarEnv rho f of-      Just (MultiVal args)  -- Including empty tuples-        -> return (mkTuple args)-      Just (UnaryVal (StgVarArg f'))-        -> return (StgApp f' [])-      Just (UnaryVal (StgLitArg f'))-        -> return (StgLit f')-      Nothing-        -> return e--unariseExpr rho e@(StgApp f args)-  = return (StgApp f' (unariseFunArgs rho args))-  where-    f' = case lookupVarEnv rho f of-           Just (UnaryVal (StgVarArg f')) -> f'-           Nothing -> f-           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)-               -- Can't happen because 'args' is non-empty, and-               -- a tuple or sum cannot be applied to anything--unariseExpr _ (StgLit l)-  = return (StgLit l)--unariseExpr rho (StgConApp dc args ty_args)-  | Just args' <- unariseMulti_maybe rho dc args ty_args-  = return (mkTuple args')--  | otherwise-  , let args' = unariseConArgs rho args-  = return (StgConApp dc args' (map stgArgType args'))--unariseExpr rho (StgOpApp op args ty)-  = return (StgOpApp op (unariseFunArgs rho args) ty)--unariseExpr _ e@StgLam{}-  = pprPanic "unariseExpr: found lambda" (ppr e)--unariseExpr rho (StgCase scrut bndr alt_ty alts)-  -- tuple/sum binders in the scrutinee can always be eliminated-  | StgApp v [] <- scrut-  , Just (MultiVal xs) <- lookupVarEnv rho v-  = elimCase rho xs bndr alt_ty alts--  -- Handle strict lets for tuples and sums:-  --   case (# a,b #) of r -> rhs-  -- and analogously for sums-  | StgConApp dc args ty_args <- scrut-  , Just args' <- unariseMulti_maybe rho dc args ty_args-  = elimCase rho args' bndr alt_ty alts--  -- general case-  | otherwise-  = do scrut' <- unariseExpr rho scrut-       alts'  <- unariseAlts rho alt_ty bndr alts-       return (StgCase scrut' bndr alt_ty alts')-                       -- bndr may have a unboxed sum/tuple type but it will be-                       -- dead after unarise (checked in StgLint)--unariseExpr rho (StgLet ext bind e)-  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e--unariseExpr rho (StgLetNoEscape ext bind e)-  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e--unariseExpr rho (StgTick tick e)-  = StgTick tick <$> unariseExpr rho e---- Doesn't return void args.-unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]-unariseMulti_maybe rho dc args ty_args-  | isUnboxedTupleCon dc-  = Just (unariseConArgs rho args)--  | isUnboxedSumCon dc-  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)-  = Just (mkUbxSum dc ty_args args1)--  | otherwise-  = Nothing------------------------------------------------------------------------------------elimCase :: UnariseEnv-         -> [OutStgArg] -- non-void args-         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr--elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]-  = do let rho1 = extendRho rho bndr (MultiVal args)-           rho2-             | isUnboxedTupleBndr bndr-             = mapTupleIdBinders bndrs args rho1-             | otherwise-             = ASSERT(isUnboxedSumBndr bndr)-               if null bndrs then rho1-                             else mapSumIdBinders bndrs args rho1--       unariseExpr rho2 rhs--elimCase rho args bndr (MultiValAlt _) alts-  | isUnboxedSumBndr bndr-  = do let (tag_arg : real_args) = args-       tag_bndr <- mkId (mkFastString "tag") tagTy-          -- this won't be used but we need a binder anyway-       let rho1 = extendRho rho bndr (MultiVal args)-           scrut' = case tag_arg of-                      StgVarArg v     -> StgApp v []-                      StgLitArg l     -> StgLit l--       alts' <- unariseSumAlts rho1 real_args alts-       return (StgCase scrut' tag_bndr tagAltTy alts')--elimCase _ args bndr alt_ty alts-  = pprPanic "elimCase - unhandled case"-      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)------------------------------------------------------------------------------------unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]-unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]-  | isUnboxedTupleBndr bndr-  = do (rho', ys) <- unariseConArgBinder rho bndr-       e' <- unariseExpr rho' e-       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]--unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]-  | isUnboxedTupleBndr bndr-  = do (rho', ys1) <- unariseConArgBinders rho ys-       MASSERT(ys1 `lengthIs` n)-       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))-       e' <- unariseExpr rho'' e-       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]--unariseAlts _ (MultiValAlt _) bndr alts-  | isUnboxedTupleBndr bndr-  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)---- In this case we don't need to scrutinize the tag bit-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]-  | isUnboxedSumBndr bndr-  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr-       rhs' <- unariseExpr rho_sum_bndrs rhs-       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]--unariseAlts rho (MultiValAlt _) bndr alts-  | isUnboxedSumBndr bndr-  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr-       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts-       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'-       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),-                 scrt_bndrs,-                 inner_case) ]--unariseAlts rho _ _ alts-  = mapM (\alt -> unariseAlt rho alt) alts--unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt-unariseAlt rho (con, xs, e)-  = do (rho', xs') <- unariseConArgBinders rho xs-       (con, xs',) <$> unariseExpr rho' e-------------------------------------------------------------------------------------- | Make alternatives that match on the tag of a sum--- (i.e. generate LitAlts for the tag)-unariseSumAlts :: UnariseEnv-               -> [StgArg] -- sum components _excluding_ the tag bit.-               -> [StgAlt] -- original alternative with sum LHS-               -> UniqSM [StgAlt]-unariseSumAlts env args alts-  = do alts' <- mapM (unariseSumAlt env args) alts-       return (mkDefaultLitAlt alts')--unariseSumAlt :: UnariseEnv-              -> [StgArg] -- sum components _excluding_ the tag bit.-              -> StgAlt   -- original alternative with sum LHS-              -> UniqSM StgAlt-unariseSumAlt rho _ (DEFAULT, _, e)-  = ( DEFAULT, [], ) <$> unariseExpr rho e--unariseSumAlt rho args (DataAlt sumCon, bs, e)-  = do let rho' = mapSumIdBinders bs args rho-       e' <- unariseExpr rho' e-       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )--unariseSumAlt _ scrt alt-  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)------------------------------------------------------------------------------------mapTupleIdBinders-  :: [InId]       -- Un-processed binders of a tuple alternative.-                  -- Can have void binders.-  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).-                  -- Can't have void args.-  -> UnariseEnv-  -> UnariseEnv-mapTupleIdBinders ids args0 rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args0))-    let-      ids_unarised :: [(Id, [PrimRep])]-      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids--      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv-      map_ids rho [] _  = rho-      map_ids rho ((x, x_reps) : xs) args =-        let-          x_arity = length x_reps-          (x_args, args') =-            ASSERT(args `lengthAtLeast` x_arity)-            splitAt x_arity args--          rho'-            | x_arity == 1-            = ASSERT(x_args `lengthIs` 1)-              extendRho rho x (UnaryVal (head x_args))-            | otherwise-            = extendRho rho x (MultiVal x_args)-        in-          map_ids rho' xs args'-    in-      map_ids rho0 ids_unarised args0--mapSumIdBinders-  :: [InId]      -- Binder of a sum alternative (remember that sum patterns-                 -- only have one binder, so this list should be a singleton)-  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).-                 -- Can't have void args.-  -> UnariseEnv-  -> UnariseEnv--mapSumIdBinders [id] args rho0-  = ASSERT(not (any (isVoidTy . stgArgType) args))-    let-      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args-      id_slots  = map primRepSlot $ typePrimRep (idType id)-      layout1   = layoutUbxSum arg_slots id_slots-    in-      if isMultiValBndr id-        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])-        else ASSERT(layout1 `lengthIs` 1)-             extendRho rho0 id (UnaryVal (args !! head layout1))--mapSumIdBinders ids sum_args _-  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)---- | Build a unboxed sum term from arguments of an alternative.------ Example, for (# x | #) :: (# (# #) | Int #) we call------   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]------ which returns------   [ 1#, rubbish ]----mkUbxSum-  :: DataCon      -- Sum data con-  -> [Type]       -- Type arguments of the sum data con-  -> [OutStgArg]  -- Actual arguments of the alternative.-  -> [OutStgArg]  -- Final tuple arguments-mkUbxSum dc ty_args args0-  = let-      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)-        -- drop tag slot--      tag = dataConTag dc--      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)-      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)-      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)--      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]-      mkTupArgs _ [] _-        = []-      mkTupArgs arg_idx (slot : slots_left) arg_map-        | Just stg_arg <- IM.lookup arg_idx arg_map-        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map-        | otherwise-        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map--      slotRubbishArg :: SlotTy -> StgArg-      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID-                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore-      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)-      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)-      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)-      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)-    in-      tag_arg : mkTupArgs 0 sum_slots arg_idxs------------------------------------------------------------------------------------{--For arguments (StgArg) and binders (Id) we have two kind of unarisation:--  - When unarising function arg binders and arguments, we don't want to remove-    void binders and arguments. For example,--      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...-      f x y z = <body>--    Here after unarise we should still get a function with arity 3. Similarly-    in the call site we shouldn't remove void arguments:--      f (# (# #), (# #) #) voidId rw--    When unarising <body>, we extend the environment with these binders:--      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []--    Because their rep types are `MultiRep []` (aka. void). This means that when-    we see `x` in a function argument position, we actually replace it with a-    void argument. When we see it in a DataCon argument position, we just get-    rid of it, because DataCon applications in STG are always saturated.--  - When unarising case alternative binders we remove void binders, but we-    still update the environment the same way, because those binders may be-    used in the RHS. Example:--      case x of y {-        (# x1, x2, x3 #) -> <RHS>-      }--    We know that y can't be void, because we don't scrutinize voids, so x will-    be unarised to some number of arguments, and those arguments will have at-    least one non-void thing. So in the rho we will have something like:--      x :-> MultiVal [xu1, xu2]--    Now, after we eliminate void binders in the pattern, we get exactly the same-    number of binders, and extend rho again with these:--      x1 :-> UnaryVal xu1-      x2 :-> MultiVal [] -- x2 is void-      x3 :-> UnaryVal xu2--    Now when we see x2 in a function argument position or in return position, we-    generate void#. In constructor argument position, we just remove it.--So in short, when we have a void id,--  - We keep it if it's a lambda argument binder or-                       in argument position of an application.--  - We remove it if it's a DataCon field binder or-                         in argument position of a DataCon application.--}--unariseArgBinder-    :: Bool -- data con arg?-    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])-unariseArgBinder is_con_arg rho x =-  case typePrimRep (idType x) of-    []-      | is_con_arg-      -> return (extendRho rho x (MultiVal []), [])-      | otherwise -- fun arg, do not remove void binders-      -> return (extendRho rho x (MultiVal []), [voidArgId])--    [rep]-      -- Arg represented as single variable, but original type may still be an-      -- unboxed sum/tuple, e.g. (# Void# | Void# #).-      ---      -- While not unarising the binder in this case does not break any programs-      -- (because it unarises to a single variable), it triggers StgLint as we-      -- break the the post-unarisation invariant that says unboxed tuple/sum-      -- binders should vanish. See Note [Post-unarisation invariants].-      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)-      -> do x' <- mkId (mkFastString "us") (primRepToType rep)-            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])-      | otherwise-      -> return (rho, [x])--    reps -> do-      xs <- mkIds (mkFastString "us") (map primRepToType reps)-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)-------------------------------------------------------------------------------------- | MultiVal a function argument. Never returns an empty list.-unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]-unariseFunArg rho (StgVarArg x) =-  case lookupVarEnv rho x of-    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args-    Just (MultiVal as)  -> as-    Just (UnaryVal arg) -> [arg]-    Nothing             -> [StgVarArg x]-unariseFunArg _ arg = [arg]--unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]-unariseFunArgs = concatMap . unariseFunArg--unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])-unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs---- Result list of binders is never empty-unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])-unariseFunArgBinder = unariseArgBinder False-------------------------------------------------------------------------------------- | MultiVal a DataCon argument. Returns an empty list when argument is void.-unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]-unariseConArg rho (StgVarArg x) =-  case lookupVarEnv rho x of-    Just (UnaryVal arg) -> [arg]-    Just (MultiVal as) -> as      -- 'as' can be empty-    Nothing-      | isVoidTy (idType x) -> [] -- e.g. C realWorld#-                                  -- Here realWorld# is not in the envt, but-                                  -- is a void, and so should be eliminated-      | otherwise -> [StgVarArg x]-unariseConArg _ arg@(StgLitArg lit) =-    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals-    [arg]--unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]-unariseConArgs = concatMap . unariseConArg--unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])-unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs---- Different from `unariseFunArgBinder`: result list of binders may be empty.--- See DataCon applications case in Note [Post-unarisation invariants].-unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])-unariseConArgBinder = unariseArgBinder True------------------------------------------------------------------------------------mkIds :: FastString -> [UnaryType] -> UniqSM [Id]-mkIds fs tys = mapM (mkId fs) tys--mkId :: FastString -> UnaryType -> UniqSM Id-mkId = mkSysLocalOrCoVarM--isMultiValBndr :: Id -> Bool-isMultiValBndr id-  | [_] <- typePrimRep (idType id)-  = False-  | otherwise-  = True--isUnboxedSumBndr :: Id -> Bool-isUnboxedSumBndr = isUnboxedSumType . idType--isUnboxedTupleBndr :: Id -> Bool-isUnboxedTupleBndr = isUnboxedTupleType . idType--mkTuple :: [StgArg] -> StgExpr-mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)--tagAltTy :: AltType-tagAltTy = PrimAlt IntRep--tagTy :: Type-tagTy = intPrimTy--voidArg :: StgArg-voidArg = StgVarArg voidPrimId--mkDefaultLitAlt :: [StgAlt] -> [StgAlt]--- We have an exhauseive list of literal alternatives---    1# -> e1---    2# -> e2--- Since they are exhaustive, we can replace one with DEFAULT, to avoid--- generating a final test. Remember, the DEFAULT comes first if it exists.-mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")-mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts-mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts-mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
compiler/specialise/SpecConstr.hs view
@@ -699,7 +699,7 @@   = do       dflags <- getDynFlags       us     <- getUniqueSupplyM-      annos  <- getFirstAnnotations deserializeWithData guts+      (_, annos) <- getFirstAnnotations deserializeWithData guts       this_mod <- getModule       let binds' = reverse $ fst $ initUs us $ do                     -- Note [Top-level recursive groups]@@ -1720,8 +1720,8 @@                spec_join_arity | isJoinId fn = Just (length spec_lam_args)                               | otherwise   = Nothing-              spec_id    = mkLocalIdOrCoVar spec_name-                                            (mkLamTypes spec_lam_args body_ty)+              spec_id    = mkLocalId spec_name+                                     (mkLamTypes spec_lam_args body_ty)                              -- See Note [Transfer strictness]                              `setIdStrictness` spec_str                              `setIdArity` count isId spec_lam_args
compiler/specialise/Specialise.hs view
@@ -2378,7 +2378,7 @@     interesting :: InterestingVarFun     interesting v = isLocalVar v || (isId v && isDFunId v)         -- Very important: include DFunIds /even/ if it is imported-        -- Reason: See Note [Avoiding loops], the second exmaple+        -- Reason: See Note [Avoiding loops], the second example         --         involving an imported dfun.  We must know whether         --         a dictionary binding depends on an imported dfun,         --         in case we try to specialise that imported dfun@@ -2635,7 +2635,7 @@ newDictBndr env b = do { uniq <- getUniqueM                        ; let n   = idName b                              ty' = substTy env (idType b)-                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }+                       ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }  newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id     -- Give the new Id a similar occurrence name to the old one@@ -2643,7 +2643,7 @@   = do  { uniq <- getUniqueM         ; let name    = idName old_id               new_occ = mkSpecOcc (nameOccName name)-              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)+              new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)                           `asJoinId_maybe` join_arity_maybe         ; return new_id }
− compiler/stgSyn/CoreToStg.hs 
@@ -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
− compiler/stgSyn/StgFVs.hs 
@@ -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
− compiler/stgSyn/StgLint.hs 
@@ -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)
− compiler/stgSyn/StgSubst.hs 
@@ -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)
− compiler/stgSyn/StgSyn.hs 
@@ -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)]
compiler/stranal/DmdAnal.hs view
@@ -35,7 +35,7 @@ import Maybes           ( isJust ) import TysWiredIn import TysPrim          ( realWorldStatePrimTy )-import ErrUtils         ( dumpIfSet_dyn )+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) ) import Name             ( getName, stableNameCmp ) import Data.Function    ( on ) import UniqSet@@ -53,8 +53,8 @@   = do {         let { binds_plus_dmds = do_prog binds } ;         dumpIfSet_dyn dflags Opt_D_dump_str_signatures-                      "Strictness signatures" $-            dumpStrSig binds_plus_dmds ;+            "Strictness signatures" FormatSTG+            (dumpStrSig binds_plus_dmds) ;         -- See Note [Stamp out space leaks in demand analysis]         seqBinds binds_plus_dmds `seq` return binds_plus_dmds     }
compiler/stranal/WwLib.hs view
@@ -31,7 +31,7 @@ import VarSet           ( VarSet ) import Type import Predicate        ( isClassPred )-import RepType          ( isVoidTy, typePrimRep )+import GHC.Types.RepType          ( isVoidTy, typePrimRep ) import Coercion import FamInstEnv import BasicTypes       ( Boxity(..) )
compiler/typecheck/TcBinds.hs view
@@ -919,7 +919,7 @@          -- do this check; otherwise (#14000) we may report an ambiguity          -- error for a rather bogus type. -       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }+       ; return (mkLocalId poly_name inferred_poly_ty) }   chooseInferredQuantifiers :: TcThetaType   -- inferred
compiler/typecheck/TcClassDcl.hs view
@@ -13,7 +13,7 @@                     findMethodBind, instantiateMethod,                     tcClassMinimalDef,                     HsSigFun, mkHsSigFun,-                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,+                    badMethodErr,                     instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,                     tcATDefault                   ) where@@ -422,14 +422,6 @@ *                                                                      * ************************************************************************ -}--tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc-tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,-                      text "declaration for", quotes (ppr (tcdName decl))]--tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a-tcAddDeclCtxt decl thing_inside-  = addErrCtxt (tcMkDeclCtxt decl) thing_inside  badMethodErr :: Outputable a => a -> Name -> SDoc badMethodErr clas op
compiler/typecheck/TcDeriv.hs view
@@ -235,6 +235,7 @@          ; unless (isEmptyBag inst_info) $              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"+                        FormatHaskell                         (ddump_deriving inst_info rn_binds famInsts))          ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))@@ -1915,7 +1916,7 @@          rdr_env <- lift getGlobalRdrEnv         let data_con_names = map dataConName (tyConDataCons rep_tc)-            hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&+            hidden_data_cons = not (isWiredIn rep_tc) &&                                (isAbstractTyCon rep_tc ||                                 any not_in_scope data_con_names)             not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
compiler/typecheck/TcGenDeriv.hs view
@@ -2369,7 +2369,7 @@ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~-We often want to make a top-level auxiliary binding.  E.g. for comparison we haev+We often want to make a top-level auxiliary binding.  E.g. for comparison we have    instance Ord T where     compare a b = $con2tag a `compare` $con2tag b
compiler/typecheck/TcHsType.hs view
@@ -947,30 +947,34 @@              -> [TcKind]    -- ^ of these kinds              -> TcKind      -- ^ expected kind of the whole tuple              -> TcM TcType-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind-  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)-       ; let arg_tys  = case tup_sort of-                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon-                 UnboxedTuple    -> tau_reps ++ tau_tys-                 BoxedTuple      -> tau_tys-                 ConstraintTuple -> tau_tys-       ; tycon <- case tup_sort of-           ConstraintTuple-             | arity > mAX_CTUPLE_SIZE-                         -> failWith (bigConstraintTuple arity)-             | otherwise -> tcLookupTyCon (cTupleTyConName arity)-           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity-                               ; checkWiredInTyCon tc-                               ; return tc }-           UnboxedTuple  -> return (tupleTyCon Unboxed arity)-       ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do+  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)+  case tup_sort of+    ConstraintTuple+      |  [tau_ty] <- tau_tys+         -- Drop any uses of 1-tuple constraints here.+         -- See Note [Ignore unary constraint tuples]+      -> check_expected_kind tau_ty constraintKind+      |  arity > mAX_CTUPLE_SIZE+      -> failWith (bigConstraintTuple arity)+      |  otherwise+      -> do tycon <- tcLookupTyCon (cTupleTyConName arity)+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    BoxedTuple -> do+      let tycon = tupleTyCon Boxed arity+      checkWiredInTyCon tycon+      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind+    UnboxedTuple ->+      let tycon    = tupleTyCon Unboxed arity+          tau_reps = map kindRep tau_kinds+          -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon+          arg_tys  = tau_reps ++ tau_tys+          res_kind = unboxedTupleKind tau_reps in+      check_expected_kind (mkTyConApp tycon arg_tys) res_kind   where     arity = length tau_tys-    tau_reps = map kindRep tau_kinds-    res_kind = case tup_sort of-                 UnboxedTuple    -> unboxedTupleKind tau_reps-                 BoxedTuple      -> liftedTypeKind-                 ConstraintTuple -> constraintKind+    check_expected_kind ty act_kind =+      checkExpectedKind rn_ty ty act_kind exp_kind  bigConstraintTuple :: Arity -> MsgDoc bigConstraintTuple arity@@ -978,7 +982,47 @@           <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))        2 (text "Instead, use a nested tuple") +{-+Note [Ignore unary constraint tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in+TysWiredIn) but does *not* provide unary constraint tuples. Why? First,+recall the definition of a unary tuple data type: +  data Unit a = Unit a++Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and+lazy. Therefore, the presence of `Unit` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++  class a => Unit% a++This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Unit% for consistency with tuples (Unit) and unboxed+tuples (Unit#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+                       (ConT ''String)))+  -- f :: Unit% (Show Int) => String+  f = "abc"++This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,+and since it is used in a Constraint position, GHC will attempt to treat+it as thought it were a constraint tuple, which can potentially lead to+trouble if one attempts to look up the name of a constraint tuple of arity+1 (as it won't exist). To avoid this trouble, we simply take any unary+constraint tuples discovered when typechecking and drop them—i.e., treat+"Unit% a" as though the user had written "a". This is always safe to do+since the two constraints should be semantically equivalent.+-}+ {- ********************************************************************* *                                                                      *                 Type applications@@ -1941,7 +1985,8 @@                       , hsq_explicit = hs_tvs }) kc_res_ki   -- No standalane kind signature and no CUSK.   -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls-  = do { (scoped_kvs, (tc_tvs, res_kind))+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))            -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?            -- See Note [Inferring kinds for type declarations] in TcTyClsDecls            <- bindImplicitTKBndrs_Q_Tv kv_ns            $
compiler/typecheck/TcInstDcls.hs view
@@ -1918,6 +1918,7 @@                              [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]          ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"+                   FormatHaskell                    (vcat [ppr clas <+> ppr inst_tys,                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
compiler/typecheck/TcMatches.hs view
@@ -514,7 +514,7 @@              -- typically something like [(Int,Bool,Int)]              -- We don't know what tuple_ty is yet, so we use a variable        ; let mk_n_bndr :: Name -> TcId -> TcId-             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`@@ -693,7 +693,7 @@         --------------- Bulding the bindersMap ----------------        ; let mk_n_bndr :: Name -> TcId -> TcId-             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`
compiler/typecheck/TcPat.hs view
@@ -211,7 +211,8 @@ tcPatBndr _ bndr_name pat_ty   = do { pat_ty <- expTypeToType pat_ty        ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)-       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }+       ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) }+               -- We should not have "OrCoVar" here, this is a bug (#17545)                -- Whether or not there is a sig is irrelevant,                -- as this is local
compiler/typecheck/TcRnDriver.hs view
@@ -2711,9 +2711,9 @@ ************************************************************************ -} +-- | Dump, with a banner, if -ddump-rn rnDump :: (Outputable a, Data a) => a -> TcRn ()--- Dump, with a banner, if -ddump-rn-rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }+rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)  tcDump :: TcGblEnv -> TcRn () tcDump env@@ -2721,13 +2721,14 @@          -- Dump short output if -ddump-types or -ddump-tc         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)-          (traceTcRnForUser Opt_D_dump_types short_dump) ;+          (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)+            "" FormatText short_dump) ;          -- Dump bindings if -ddump-tc-        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);+        dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;          -- Dump bindings as an hsSyn AST if -ddump-tc-ast-        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)+        dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump    }   where     short_dump = pprTcGblEnv env
compiler/typecheck/TcRnMonad.hs view
@@ -42,8 +42,8 @@   newTcRef, readTcRef, writeTcRef, updTcRef,    -- * Debugging-  traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,-  traceTcRnWithStyle,+  traceTc, traceRn, traceOptTcRn, dumpOptTcRn,+  dumpTcRn,   getPrintUnqualified,   printForUserTcRn,   traceIf, traceHiDiffs, traceOptIf,@@ -623,12 +623,12 @@ newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId newSysLocalId fs ty   = do  { u <- newUnique-        ; return (mkSysLocalOrCoVar fs u ty) }+        ; return (mkSysLocal fs u ty) }  newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys   = do  { us <- newUniqueSupply-        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }+        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }  instance MonadUnique (IOEnv (Env gbl lcl)) where         getUniqueM = newUnique@@ -684,58 +684,48 @@ formatTraceMsg :: String -> SDoc -> SDoc formatTraceMsg herald doc = hang (text herald) 2 doc --- | Output a doc if the given 'DumpFlag' is set.------ By default this logs to stdout--- However, if the `-ddump-to-file` flag is set,--- then this will dump output to a file------ Just a wrapper for 'dumpSDoc'+-- | Trace if the given 'DumpFlag' is set. traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()-traceOptTcRn flag doc-  = do { dflags <- getDynFlags-       ; when (dopt flag dflags)-              (traceTcRn flag doc)-       }+traceOptTcRn flag doc = do+  dflags <- getDynFlags+  when (dopt flag dflags) $+    dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc +-- | Dump if the given 'DumpFlag' is set.+dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()+dumpOptTcRn flag title fmt doc = do+  dflags <- getDynFlags+  when (dopt flag dflags) $+    dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc++-- | Unconditionally dump some trace output+-- -- Certain tests (T3017, Roles3, T12763 etc.) expect part of the -- output generated by `-ddump-types` to be in 'PprUser' style. However, -- generally we want all other debugging output to use 'PprDump'--- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.---- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.-traceTcRn :: DumpFlag -> SDoc -> TcRn ()-traceTcRn flag doc-  = do { dflags  <- getDynFlags-       ; printer <- getPrintUnqualified dflags-       ; let dump_style = mkDumpStyle dflags printer-       ; traceTcRnWithStyle dump_style dflags flag doc }---- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.-traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()--- Used by 'TcRnDriver.tcDump'.-traceTcRnForUser flag doc-  = do { dflags  <- getDynFlags-       ; printer <- getPrintUnqualified dflags-       ; let user_style = mkUserStyle dflags printer AllTheWay-       ; traceTcRnWithStyle user_style dflags flag doc }--traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()--- ^ Unconditionally dump some trace output+-- style. We 'PprUser' style if 'useUserStyle' is True. ----- The DumpFlag is used only to set the output filename--- for --dump-to-file, not to decide whether or not to output--- That part is done by the caller-traceTcRnWithStyle sty dflags flag doc-  = do { real_doc <- prettyDoc dflags doc-       ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }-  where-    -- Add current location if -dppr-debug-    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc-    prettyDoc dflags doc = if hasPprDebug dflags-       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }-       else return doc -- The full location is usually way too much+dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()+dumpTcRn useUserStyle dumpOpt title fmt doc = do+  dflags <- getDynFlags+  printer <- getPrintUnqualified dflags+  real_doc <- wrapDocLoc doc+  let sty = if useUserStyle+              then mkUserStyle dflags printer AllTheWay+              else mkDumpStyle dflags printer+  liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc +-- | Add current location if -dppr-debug+-- (otherwise the full location is usually way too much)+wrapDocLoc :: SDoc -> TcRn SDoc+wrapDocLoc doc = do+  dflags <- getDynFlags+  if hasPprDebug dflags+    then do+      loc <- getSrcSpanM+      return (mkLocMessage SevOutput loc doc)+    else+      return doc  getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified getPrintUnqualified dflags
compiler/typecheck/TcRules.hs view
@@ -198,7 +198,7 @@ --   error for each out-of-scope type variable used   = do  { let ctxt = RuleSigCtxt name         ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty-        ; let id  = mkLocalIdOrCoVar name id_ty+        ; let id  = mkLocalId name id_ty                     -- See Note [Pattern signature binders] in TcHsType                -- The type variables scope over subsequent bindings; yuk
compiler/typecheck/TcSMonad.hs view
@@ -146,6 +146,7 @@ import Coercion import Unify +import ErrUtils import TcEvidence import Class import TyCon@@ -2733,7 +2734,10 @@        ; when (  dopt Opt_D_dump_cs_trace dflags                   || dopt Opt_D_dump_tc_trace dflags )               ( do { msg <- mk_doc-                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }+                   ; TcM.dumpTcRn False+                       (dumpOptionsFromFlag Opt_D_dump_cs_trace)+                       "" FormatText+                       msg }) }  runTcS :: TcS a                -- What to run        -> TcM (a, EvBindMap)
compiler/typecheck/TcTyClsDecls.hs view
@@ -316,8 +316,8 @@ you can always specify a CUSK directly to make this work out. See tc269 for an example. -Note [Skip decls with CUSKs in kcLTyClDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CUSKs and PolyKinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider      data T (a :: *) = MkT (S a)   -- Has CUSK@@ -530,7 +530,8 @@           --    3. Generalise the inferred kinds           -- See Note [Kind checking for type and class decls] -        ; cusks_enabled <- xoptM LangExt.CUSKs+        ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds+                    -- See Note [CUSKs and PolyKinds]         ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls                get_kind d@@ -559,10 +560,8 @@                     -- NB: the environment extension overrides the tycon                     --     promotion-errors bindings                     --     See Note [Type environment evolution]-                  ; poly_kinds  <- xoptM LangExt.PolyKinds                   ; tcExtendKindEnvWithTyCons mono_tcs $-                    mapM_ kcLTyClDecl (if poly_kinds then kindless_decls else decls)-                    -- See Note [Skip decls with CUSKs in kcLTyClDecl]+                    mapM_ kcLTyClDecl kindless_decls                    ; return mono_tcs } @@ -974,8 +973,40 @@ final TyVars despite the fact that we unified kka:=kkb  zonkRecTyVarBndrs we need to do knot-tying because of the need to-apply this same substitution to the kind of each.  -}+apply this same substitution to the kind of each. +Note [Inferring visible dependent quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data T k :: k -> Type where+    MkT1 :: T Type Int+    MkT2 :: T (Type -> Type) Maybe++This looks like it should work. However, it is polymorphically recursive,+as the uses of T in the constructor types specialize the k in the kind+of T. This trips up our dear users (#17131, #17541), and so we add+a "landmark" context (which cannot be suppressed) whenever we+spot inferred visible dependent quantification (VDQ).++It's hard to know when we've actually been tripped up by polymorphic recursion+specifically, so we just include a note to users whenever we infer VDQ. The+testsuite did not show up a single spurious inclusion of this message.++The context is added in addVDQNote, which looks for a visible TyConBinder+that also appears in the TyCon's kind. (I first looked at the kind for+a visible, dependent quantifier, but Note [No polymorphic recursion] in+TcHsType defeats that approach.) addVDQNote is used in kcTyClDecl,+which is used only when inferring the kind of a tycon (never with a CUSK or+SAK).++Once upon a time, I (Richard E) thought that the tycon-kind could+not be a forall-type. But this is wrong: data T :: forall k. k -> Type+(with -XNoCUSKs) could end up here. And this is all OK.+++-}+ -------------- tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a tcExtendKindEnvWithTyCons tcs@@ -1258,30 +1289,32 @@ ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()   -- See Note [Kind checking for type and class decls]+  -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl)   = setSrcSpan loc $-    tcAddDeclCtxt decl $-    do { traceTc "kcTyClDecl {" (ppr tc_name)-       ; kcTyClDecl decl+    do { tycon <- kcLookupTcTyCon tc_name+       ; traceTc "kcTyClDecl {" (ppr tc_name)+       ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]+         addErrCtxt (tcMkDeclCtxt decl) $+         kcTyClDecl decl tycon        ; traceTc "kcTyClDecl done }" (ppr tc_name) }   where-    tc_name = tyClDeclLName decl+    tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcM ()+kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and --    result kind signature have already been dealt with --    by inferInitialKind, so we can ignore them here.  kcTyClDecl (DataDecl { tcdLName    = (L _ name)-                     , tcdDataDefn = defn })+                     , tcdDataDefn = defn }) tyCon   | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _)                , dd_ctxt = (L _ [])                , dd_ND = new_or_data } <- defn-  = do { tyCon <- kcLookupTcTyCon name-         -- See Note [Implementation of UnliftedNewtypes] STEP 2-       ; kcConDecls new_or_data (tyConResKind tyCon) cons-       }+  = -- See Note [Implementation of UnliftedNewtypes] STEP 2+    kcConDecls new_or_data (tyConResKind tyCon) cons+     -- hs_tvs and dd_kindSig already dealt with in inferInitialKind     -- This must be a GADT-style decl,     --        (see invariants of DataDefn declaration)@@ -1294,18 +1327,17 @@                , dd_ND = new_or_data } <- defn   = bindTyClTyVars name $ \ _ _ ->     do { _ <- tcHsContext ctxt-       ; tyCon <- kcLookupTcTyCon name        ; kcConDecls new_or_data (tyConResKind tyCon) cons        } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs })+kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon   = bindTyClTyVars name $ \ _ res_kind ->     discardResult $ tcCheckLHsType rhs res_kind         -- NB: check against the result kind that we allocated         -- in inferInitialKinds.  kcTyClDecl (ClassDecl { tcdLName = L _ name-                      , tcdCtxt = ctxt, tcdSigs = sigs })+                      , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon   = bindTyClTyVars name $ \ _ _ ->     do  { _ <- tcHsContext ctxt         ; mapM_ (wrapLocM_ kc_sig) sigs }@@ -1315,18 +1347,15 @@      skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = L _ fam_tc_name-                                  , fdInfo   = fd_info }))+kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo   = fd_info })) fam_tc -- closed type families look at their equations, but other families don't -- do anything here   = case fd_info of-      ClosedTypeFamily (Just eqns) ->-        do { fam_tc <- kcLookupTcTyCon fam_tc_name-           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }+      ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns       _ -> return ()-kcTyClDecl (FamDecl _ (XFamilyDecl nec))        = noExtCon nec-kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec-kcTyClDecl (XTyClDecl nec)                      = noExtCon nec+kcTyClDecl (FamDecl _ (XFamilyDecl nec))        _ = noExtCon nec+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec+kcTyClDecl (XTyClDecl nec)                      _ = noExtCon nec  ------------------- @@ -3365,6 +3394,12 @@   | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim   = return () +  | isWiredIn tc     -- validity-checking wired-in tycons is a waste of+                     -- time. More importantly, a wired-in tycon might+                     -- violate assumptions. Example: (~) has a superclass+                     -- mentioning (~#), which is ill-kinded in source Haskell+  = traceTc "Skipping validity check for wired-in" (ppr tc)+   | otherwise   = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))        ; if | Just cl <- tyConClass_maybe tc@@ -3438,7 +3473,7 @@                 -- NB: this check assumes that all the constructors of a given                 -- data type use the same type variables         where-        (_, _, _, res1) = dataConSig con1+        res1 = dataConOrigResTy con1         fty1 = dataConFieldType con1 lbl         lbl = flLabel label @@ -3446,7 +3481,7 @@             = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2                  ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }             where-                (_, _, _, res2) = dataConSig con2+                res2 = dataConOrigResTy con2                 fty2 = dataConFieldType con2 lbl  checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()@@ -3546,12 +3581,12 @@                    user_tvbs_invariant                      =    Set.fromList (filterEqSpec eq_spec univs ++ exs)                        == Set.fromList user_tvs-             ; WARN( not user_tvbs_invariant+             ; MASSERT2( user_tvbs_invariant                        , vcat ([ ppr con                                , ppr univs                                , ppr exs                                , ppr eq_spec-                               , ppr user_tvs ])) return () }+                               , ppr user_tvs ])) }          ; traceTc "Done validity of data con" $           vcat [ ppr con@@ -4156,6 +4191,46 @@ *                                                                      * ************************************************************************ -}++tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,+                      text "declaration for", quotes (ppr (tcdName decl))]++addVDQNote :: TcTyCon -> TcM a -> TcM a+-- See Note [Inferring visible dependent quantification]+-- Only types without a signature (CUSK or SAK) here+addVDQNote tycon thing_inside+  | ASSERT2( isTcTyCon tycon, ppr tycon )+    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )+    has_vdq+  = addLandmarkErrCtxt vdq_warning thing_inside+  | otherwise+  = thing_inside+  where+      -- Check whether a tycon has visible dependent quantification.+      -- This will *always* be a TcTyCon. Furthermore, it will *always*+      -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader.+      -- Thus, all the TyConBinders will be anonymous. Thus, the+      -- free variables of the tycon's kind will be the same as the free+      -- variables from all the binders.+    has_vdq  = any is_vdq_tcb (tyConBinders tycon)+    tc_kind  = tyConKind tycon+    kind_fvs = tyCoVarsOfType tc_kind++    is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) &&+                     isVisibleTyConBinder tcb++    vdq_warning = vcat+      [ text "NB: Type" <+> quotes (ppr tycon) <+>+        text "was inferred to use visible dependent quantification."+      , text "Most types with visible dependent quantification are"+      , text "polymorphically recursive and need a standalone kind"+      , text "signature. Perhaps supply one, with StandaloneKindSignatures."+      ]++tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a+tcAddDeclCtxt decl thing_inside+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside  tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a tcAddTyFamInstCtxt decl
compiler/typecheck/TcValidity.hs view
@@ -1116,15 +1116,14 @@         | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys         | otherwise           -> check_class_pred env dflags ctxt pred cls tys -      EqPred NomEq _ _  -> -- a ~# b-                           check_eq_pred env dflags pred--      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get-                           -- f :: (a ~R# b) => blha-                           -- And we want to treat that like (Coercible a b)-                           -- We should probably check argument shapes, but we-                           -- didn't do so before, so I'm leaving it for now-                           return ()+      EqPred _ _ _      -> pprPanic "check_pred_help" (ppr pred)+              -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint+              -- and should never appear before the '=>' of a type.  Thus+              --     f :: (a ~# b) => blah+              -- is wrong.  For user written signatures, it'll be rejected by kind-checking+              -- well before we get to validity checking.  For inferred types we are careful+              -- to box such constraints in TcType.pickQuantifiablePreds, as described+              -- in Note [Lift equality constraints when quantifying] in TcType        ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head       IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred@@ -1139,13 +1138,18 @@  check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> ThetaType -> PredType -> TcM ()-check_quant_pred env dflags _ctxt pred theta head_pred+check_quant_pred env dflags ctxt pred theta head_pred   = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $     do { -- Check the instance head          case classifyPredType head_pred of-            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys                                  -- SigmaCtxt tells checkValidInstHead that                                  -- this is the head of a quantified constraint+            ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys+                                    ; check_pred_help False env dflags ctxt head_pred }+                               -- need check_pred_help to do extra pred-only validity+                               -- checks, such as for (~). Otherwise, we get #17563+                               -- NB: checks for the context are covered by the check_type+                               -- in check_pred_ty             IrredPred {}      | hasTyVarHead head_pred                               -> return ()             _                 -> failWithTcM (badQuantHeadErr env pred)@@ -1216,10 +1220,9 @@ check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> Class -> [TcType] -> TcM () check_class_pred env dflags ctxt pred cls tys-  |  isEqPredClass cls    -- (~) and (~~) are classified as classes,-                          -- but here we want to treat them as equalities-  = -- pprTrace "check_class" (ppr cls) $-    check_eq_pred env dflags pred+  | isEqPredClass cls    -- (~) and (~~) are classified as classes,+                         -- but here we want to treat them as equalities+  = check_eq_pred env dflags pred    | isIPClass cls   = do { check_arity
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20191201+version: 0.20200102 license: BSD3 license-file: LICENSE category: Development@@ -54,6 +54,7 @@ library     default-language:   Haskell2010     default-extensions: NoImplicitPrelude+    exposed: False     include-dirs:         includes         ghc-lib/stage0/lib@@ -81,7 +82,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20191201+        ghc-lib-parser == 0.20200102     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -127,7 +128,6 @@         compiler/typecheck         libraries/ghc-boot         compiler/backpack-        compiler/simplStg         compiler/coreSyn         compiler/deSugar         compiler/hieFile@@ -135,7 +135,6 @@         compiler/prelude         compiler/stranal         compiler/rename-        compiler/stgSyn         compiler/iface         compiler/utils         libraries/ghci@@ -235,6 +234,7 @@         GHC.PackageDb,         GHC.Platform,         GHC.Serialized,+        GHC.Types.RepType,         GHC.UniqueSubdir,         GHC.Version,         GHCi.BreakArray,@@ -304,7 +304,6 @@         PrimOp,         RdrHsSyn,         RdrName,-        RepType,         Rules,         Settings,         SizedSeq,@@ -385,8 +384,6 @@         CmmUtils         CodeOutput         CoreLint-        CorePrep-        CoreToStg         Coverage         Debug         Debugger@@ -422,6 +419,8 @@         Format         FunDeps         GHC+        GHC.CoreToStg+        GHC.CoreToStg.Prep         GHC.HandleEncoding         GHC.Hs.Dump         GHC.HsToCore.PmCheck@@ -438,6 +437,17 @@         GHC.Platform.X86         GHC.Platform.X86_64         GHC.Settings+        GHC.Stg.CSE+        GHC.Stg.FVs+        GHC.Stg.Lift+        GHC.Stg.Lift.Analysis+        GHC.Stg.Lift.Monad+        GHC.Stg.Lint+        GHC.Stg.Pipeline+        GHC.Stg.Stats+        GHC.Stg.Subst+        GHC.Stg.Syntax+        GHC.Stg.Unarise         GHC.StgToCmm         GHC.StgToCmm.ArgRep         GHC.StgToCmm.Bind@@ -587,23 +597,12 @@         SimplCore         SimplEnv         SimplMonad-        SimplStg         SimplUtils         Simplify         SpecConstr         Specialise         State         StaticPtrTable-        StgCse-        StgFVs-        StgLiftLams-        StgLiftLams.Analysis-        StgLiftLams.LiftM-        StgLiftLams.Transformation-        StgLint-        StgStats-        StgSubst-        StgSyn         Stream         SysTools         SysTools.ExtraObj@@ -659,7 +658,6 @@         TcValidity         TidyPgm         UnVarGraph-        UnariseStg         UniqMap         WorkWrap         WwLib
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -1,6 +1,3 @@-primOpCanFail IntQuotOp = True-primOpCanFail IntRemOp = True-primOpCanFail IntQuotRemOp = True primOpCanFail Int8QuotOp = True primOpCanFail Int8RemOp = True primOpCanFail Int8QuotRemOp = True@@ -13,6 +10,9 @@ primOpCanFail Word16QuotOp = True primOpCanFail Word16RemOp = True primOpCanFail Word16QuotRemOp = True+primOpCanFail IntQuotOp = True+primOpCanFail IntRemOp = True+primOpCanFail IntQuotRemOp = True primOpCanFail WordQuotOp = True primOpCanFail WordRemOp = True primOpCanFail WordQuotRemOp = True
ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -1,5 +1,13 @@ commutableOp CharEqOp = True commutableOp CharNeOp = True+commutableOp Int8AddOp = True+commutableOp Int8MulOp = True+commutableOp Word8AddOp = True+commutableOp Word8MulOp = True+commutableOp Int16AddOp = True+commutableOp Int16MulOp = True+commutableOp Word16AddOp = True+commutableOp Word16MulOp = True commutableOp IntAddOp = True commutableOp IntMulOp = True commutableOp IntMulMayOfloOp = True@@ -9,14 +17,6 @@ commutableOp IntAddCOp = True commutableOp IntEqOp = True commutableOp IntNeOp = True-commutableOp Int8AddOp = True-commutableOp Int8MulOp = True-commutableOp Word8AddOp = True-commutableOp Word8MulOp = True-commutableOp Int16AddOp = True-commutableOp Int16MulOp = True-commutableOp Word16AddOp = True-commutableOp Word16MulOp = True commutableOp WordAddOp = True commutableOp WordAddCOp = True commutableOp WordAdd2Op = True
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -6,35 +6,6 @@    | CharLtOp    | CharLeOp    | OrdOp-   | IntAddOp-   | IntSubOp-   | IntMulOp-   | IntMulMayOfloOp-   | IntQuotOp-   | IntRemOp-   | IntQuotRemOp-   | AndIOp-   | OrIOp-   | XorIOp-   | NotIOp-   | IntNegOp-   | IntAddCOp-   | IntSubCOp-   | IntGtOp-   | IntGeOp-   | IntEqOp-   | IntNeOp-   | IntLtOp-   | IntLeOp-   | ChrOp-   | Int2WordOp-   | Int2FloatOp-   | Int2DoubleOp-   | Word2FloatOp-   | Word2DoubleOp-   | ISllOp-   | ISraOp-   | ISrlOp    | Int8Extend    | Int8Narrow    | Int8NegOp@@ -95,6 +66,36 @@    | Word16LeOp    | Word16LtOp    | Word16NeOp+   | IntAddOp+   | IntSubOp+   | IntMulOp+   | IntMul2Op+   | IntMulMayOfloOp+   | IntQuotOp+   | IntRemOp+   | IntQuotRemOp+   | AndIOp+   | OrIOp+   | XorIOp+   | NotIOp+   | IntNegOp+   | IntAddCOp+   | IntSubCOp+   | IntGtOp+   | IntGeOp+   | IntEqOp+   | IntNeOp+   | IntLtOp+   | IntLeOp+   | ChrOp+   | Int2WordOp+   | Int2FloatOp+   | Int2DoubleOp+   | Word2FloatOp+   | Word2DoubleOp+   | ISllOp+   | ISraOp+   | ISrlOp    | WordAddOp    | WordAddCOp    | WordSubCOp
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -5,35 +5,6 @@    , CharLtOp    , CharLeOp    , OrdOp-   , IntAddOp-   , IntSubOp-   , IntMulOp-   , IntMulMayOfloOp-   , IntQuotOp-   , IntRemOp-   , IntQuotRemOp-   , AndIOp-   , OrIOp-   , XorIOp-   , NotIOp-   , IntNegOp-   , IntAddCOp-   , IntSubCOp-   , IntGtOp-   , IntGeOp-   , IntEqOp-   , IntNeOp-   , IntLtOp-   , IntLeOp-   , ChrOp-   , Int2WordOp-   , Int2FloatOp-   , Int2DoubleOp-   , Word2FloatOp-   , Word2DoubleOp-   , ISllOp-   , ISraOp-   , ISrlOp    , Int8Extend    , Int8Narrow    , Int8NegOp@@ -94,6 +65,36 @@    , Word16LeOp    , Word16LtOp    , Word16NeOp+   , IntAddOp+   , IntSubOp+   , IntMulOp+   , IntMul2Op+   , IntMulMayOfloOp+   , IntQuotOp+   , IntRemOp+   , IntQuotRemOp+   , AndIOp+   , OrIOp+   , XorIOp+   , NotIOp+   , IntNegOp+   , IntAddCOp+   , IntSubCOp+   , IntGtOp+   , IntGeOp+   , IntEqOp+   , IntNeOp+   , IntLtOp+   , IntLeOp+   , ChrOp+   , Int2WordOp+   , Int2FloatOp+   , Int2DoubleOp+   , Word2FloatOp+   , Word2DoubleOp+   , ISllOp+   , ISraOp+   , ISrlOp    , WordAddOp    , WordAddCOp    , WordSubCOp
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -5,35 +5,6 @@ primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)-primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy-primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy-primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy-primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy-primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy-primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy-primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy-primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy-primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy-primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy-primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy-primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy-primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy-primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy-primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy-primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy-primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy-primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)-primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)-primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)-primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)-primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)-primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)-primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy) primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy) primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy@@ -94,6 +65,36 @@ primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy+primOpInfo IntMul2Op = mkGenPrimOp (fsLit "timesInt2#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy]))+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1206 +1,1207 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1203-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag IntAddOp = 8-primOpTag IntSubOp = 9-primOpTag IntMulOp = 10-primOpTag IntMulMayOfloOp = 11-primOpTag IntQuotOp = 12-primOpTag IntRemOp = 13-primOpTag IntQuotRemOp = 14-primOpTag AndIOp = 15-primOpTag OrIOp = 16-primOpTag XorIOp = 17-primOpTag NotIOp = 18-primOpTag IntNegOp = 19-primOpTag IntAddCOp = 20-primOpTag IntSubCOp = 21-primOpTag IntGtOp = 22-primOpTag IntGeOp = 23-primOpTag IntEqOp = 24-primOpTag IntNeOp = 25-primOpTag IntLtOp = 26-primOpTag IntLeOp = 27-primOpTag ChrOp = 28-primOpTag Int2WordOp = 29-primOpTag Int2FloatOp = 30-primOpTag Int2DoubleOp = 31-primOpTag Word2FloatOp = 32-primOpTag Word2DoubleOp = 33-primOpTag ISllOp = 34-primOpTag ISraOp = 35-primOpTag ISrlOp = 36-primOpTag Int8Extend = 37-primOpTag Int8Narrow = 38-primOpTag Int8NegOp = 39-primOpTag Int8AddOp = 40-primOpTag Int8SubOp = 41-primOpTag Int8MulOp = 42-primOpTag Int8QuotOp = 43-primOpTag Int8RemOp = 44-primOpTag Int8QuotRemOp = 45-primOpTag Int8EqOp = 46-primOpTag Int8GeOp = 47-primOpTag Int8GtOp = 48-primOpTag Int8LeOp = 49-primOpTag Int8LtOp = 50-primOpTag Int8NeOp = 51-primOpTag Word8Extend = 52-primOpTag Word8Narrow = 53-primOpTag Word8NotOp = 54-primOpTag Word8AddOp = 55-primOpTag Word8SubOp = 56-primOpTag Word8MulOp = 57-primOpTag Word8QuotOp = 58-primOpTag Word8RemOp = 59-primOpTag Word8QuotRemOp = 60-primOpTag Word8EqOp = 61-primOpTag Word8GeOp = 62-primOpTag Word8GtOp = 63-primOpTag Word8LeOp = 64-primOpTag Word8LtOp = 65-primOpTag Word8NeOp = 66-primOpTag Int16Extend = 67-primOpTag Int16Narrow = 68-primOpTag Int16NegOp = 69-primOpTag Int16AddOp = 70-primOpTag Int16SubOp = 71-primOpTag Int16MulOp = 72-primOpTag Int16QuotOp = 73-primOpTag Int16RemOp = 74-primOpTag Int16QuotRemOp = 75-primOpTag Int16EqOp = 76-primOpTag Int16GeOp = 77-primOpTag Int16GtOp = 78-primOpTag Int16LeOp = 79-primOpTag Int16LtOp = 80-primOpTag Int16NeOp = 81-primOpTag Word16Extend = 82-primOpTag Word16Narrow = 83-primOpTag Word16NotOp = 84-primOpTag Word16AddOp = 85-primOpTag Word16SubOp = 86-primOpTag Word16MulOp = 87-primOpTag Word16QuotOp = 88-primOpTag Word16RemOp = 89-primOpTag Word16QuotRemOp = 90-primOpTag Word16EqOp = 91-primOpTag Word16GeOp = 92-primOpTag Word16GtOp = 93-primOpTag Word16LeOp = 94-primOpTag Word16LtOp = 95-primOpTag Word16NeOp = 96-primOpTag WordAddOp = 97-primOpTag WordAddCOp = 98-primOpTag WordSubCOp = 99-primOpTag WordAdd2Op = 100-primOpTag WordSubOp = 101-primOpTag WordMulOp = 102-primOpTag WordMul2Op = 103-primOpTag WordQuotOp = 104-primOpTag WordRemOp = 105-primOpTag WordQuotRemOp = 106-primOpTag WordQuotRem2Op = 107-primOpTag AndOp = 108-primOpTag OrOp = 109-primOpTag XorOp = 110-primOpTag NotOp = 111-primOpTag SllOp = 112-primOpTag SrlOp = 113-primOpTag Word2IntOp = 114-primOpTag WordGtOp = 115-primOpTag WordGeOp = 116-primOpTag WordEqOp = 117-primOpTag WordNeOp = 118-primOpTag WordLtOp = 119-primOpTag WordLeOp = 120-primOpTag PopCnt8Op = 121-primOpTag PopCnt16Op = 122-primOpTag PopCnt32Op = 123-primOpTag PopCnt64Op = 124-primOpTag PopCntOp = 125-primOpTag Pdep8Op = 126-primOpTag Pdep16Op = 127-primOpTag Pdep32Op = 128-primOpTag Pdep64Op = 129-primOpTag PdepOp = 130-primOpTag Pext8Op = 131-primOpTag Pext16Op = 132-primOpTag Pext32Op = 133-primOpTag Pext64Op = 134-primOpTag PextOp = 135-primOpTag Clz8Op = 136-primOpTag Clz16Op = 137-primOpTag Clz32Op = 138-primOpTag Clz64Op = 139-primOpTag ClzOp = 140-primOpTag Ctz8Op = 141-primOpTag Ctz16Op = 142-primOpTag Ctz32Op = 143-primOpTag Ctz64Op = 144-primOpTag CtzOp = 145-primOpTag BSwap16Op = 146-primOpTag BSwap32Op = 147-primOpTag BSwap64Op = 148-primOpTag BSwapOp = 149-primOpTag BRev8Op = 150-primOpTag BRev16Op = 151-primOpTag BRev32Op = 152-primOpTag BRev64Op = 153-primOpTag BRevOp = 154-primOpTag Narrow8IntOp = 155-primOpTag Narrow16IntOp = 156-primOpTag Narrow32IntOp = 157-primOpTag Narrow8WordOp = 158-primOpTag Narrow16WordOp = 159-primOpTag Narrow32WordOp = 160-primOpTag DoubleGtOp = 161-primOpTag DoubleGeOp = 162-primOpTag DoubleEqOp = 163-primOpTag DoubleNeOp = 164-primOpTag DoubleLtOp = 165-primOpTag DoubleLeOp = 166-primOpTag DoubleAddOp = 167-primOpTag DoubleSubOp = 168-primOpTag DoubleMulOp = 169-primOpTag DoubleDivOp = 170-primOpTag DoubleNegOp = 171-primOpTag DoubleFabsOp = 172-primOpTag Double2IntOp = 173-primOpTag Double2FloatOp = 174-primOpTag DoubleExpOp = 175-primOpTag DoubleExpM1Op = 176-primOpTag DoubleLogOp = 177-primOpTag DoubleLog1POp = 178-primOpTag DoubleSqrtOp = 179-primOpTag DoubleSinOp = 180-primOpTag DoubleCosOp = 181-primOpTag DoubleTanOp = 182-primOpTag DoubleAsinOp = 183-primOpTag DoubleAcosOp = 184-primOpTag DoubleAtanOp = 185-primOpTag DoubleSinhOp = 186-primOpTag DoubleCoshOp = 187-primOpTag DoubleTanhOp = 188-primOpTag DoubleAsinhOp = 189-primOpTag DoubleAcoshOp = 190-primOpTag DoubleAtanhOp = 191-primOpTag DoublePowerOp = 192-primOpTag DoubleDecode_2IntOp = 193-primOpTag DoubleDecode_Int64Op = 194-primOpTag FloatGtOp = 195-primOpTag FloatGeOp = 196-primOpTag FloatEqOp = 197-primOpTag FloatNeOp = 198-primOpTag FloatLtOp = 199-primOpTag FloatLeOp = 200-primOpTag FloatAddOp = 201-primOpTag FloatSubOp = 202-primOpTag FloatMulOp = 203-primOpTag FloatDivOp = 204-primOpTag FloatNegOp = 205-primOpTag FloatFabsOp = 206-primOpTag Float2IntOp = 207-primOpTag FloatExpOp = 208-primOpTag FloatExpM1Op = 209-primOpTag FloatLogOp = 210-primOpTag FloatLog1POp = 211-primOpTag FloatSqrtOp = 212-primOpTag FloatSinOp = 213-primOpTag FloatCosOp = 214-primOpTag FloatTanOp = 215-primOpTag FloatAsinOp = 216-primOpTag FloatAcosOp = 217-primOpTag FloatAtanOp = 218-primOpTag FloatSinhOp = 219-primOpTag FloatCoshOp = 220-primOpTag FloatTanhOp = 221-primOpTag FloatAsinhOp = 222-primOpTag FloatAcoshOp = 223-primOpTag FloatAtanhOp = 224-primOpTag FloatPowerOp = 225-primOpTag Float2DoubleOp = 226-primOpTag FloatDecode_IntOp = 227-primOpTag NewArrayOp = 228-primOpTag SameMutableArrayOp = 229-primOpTag ReadArrayOp = 230-primOpTag WriteArrayOp = 231-primOpTag SizeofArrayOp = 232-primOpTag SizeofMutableArrayOp = 233-primOpTag IndexArrayOp = 234-primOpTag UnsafeFreezeArrayOp = 235-primOpTag UnsafeThawArrayOp = 236-primOpTag CopyArrayOp = 237-primOpTag CopyMutableArrayOp = 238-primOpTag CloneArrayOp = 239-primOpTag CloneMutableArrayOp = 240-primOpTag FreezeArrayOp = 241-primOpTag ThawArrayOp = 242-primOpTag CasArrayOp = 243-primOpTag NewSmallArrayOp = 244-primOpTag SameSmallMutableArrayOp = 245-primOpTag ShrinkSmallMutableArrayOp_Char = 246-primOpTag ReadSmallArrayOp = 247-primOpTag WriteSmallArrayOp = 248-primOpTag SizeofSmallArrayOp = 249-primOpTag SizeofSmallMutableArrayOp = 250-primOpTag GetSizeofSmallMutableArrayOp = 251-primOpTag IndexSmallArrayOp = 252-primOpTag UnsafeFreezeSmallArrayOp = 253-primOpTag UnsafeThawSmallArrayOp = 254-primOpTag CopySmallArrayOp = 255-primOpTag CopySmallMutableArrayOp = 256-primOpTag CloneSmallArrayOp = 257-primOpTag CloneSmallMutableArrayOp = 258-primOpTag FreezeSmallArrayOp = 259-primOpTag ThawSmallArrayOp = 260-primOpTag CasSmallArrayOp = 261-primOpTag NewByteArrayOp_Char = 262-primOpTag NewPinnedByteArrayOp_Char = 263-primOpTag NewAlignedPinnedByteArrayOp_Char = 264-primOpTag MutableByteArrayIsPinnedOp = 265-primOpTag ByteArrayIsPinnedOp = 266-primOpTag ByteArrayContents_Char = 267-primOpTag SameMutableByteArrayOp = 268-primOpTag ShrinkMutableByteArrayOp_Char = 269-primOpTag ResizeMutableByteArrayOp_Char = 270-primOpTag UnsafeFreezeByteArrayOp = 271-primOpTag SizeofByteArrayOp = 272-primOpTag SizeofMutableByteArrayOp = 273-primOpTag GetSizeofMutableByteArrayOp = 274-primOpTag IndexByteArrayOp_Char = 275-primOpTag IndexByteArrayOp_WideChar = 276-primOpTag IndexByteArrayOp_Int = 277-primOpTag IndexByteArrayOp_Word = 278-primOpTag IndexByteArrayOp_Addr = 279-primOpTag IndexByteArrayOp_Float = 280-primOpTag IndexByteArrayOp_Double = 281-primOpTag IndexByteArrayOp_StablePtr = 282-primOpTag IndexByteArrayOp_Int8 = 283-primOpTag IndexByteArrayOp_Int16 = 284-primOpTag IndexByteArrayOp_Int32 = 285-primOpTag IndexByteArrayOp_Int64 = 286-primOpTag IndexByteArrayOp_Word8 = 287-primOpTag IndexByteArrayOp_Word16 = 288-primOpTag IndexByteArrayOp_Word32 = 289-primOpTag IndexByteArrayOp_Word64 = 290-primOpTag IndexByteArrayOp_Word8AsChar = 291-primOpTag IndexByteArrayOp_Word8AsWideChar = 292-primOpTag IndexByteArrayOp_Word8AsAddr = 293-primOpTag IndexByteArrayOp_Word8AsFloat = 294-primOpTag IndexByteArrayOp_Word8AsDouble = 295-primOpTag IndexByteArrayOp_Word8AsStablePtr = 296-primOpTag IndexByteArrayOp_Word8AsInt16 = 297-primOpTag IndexByteArrayOp_Word8AsInt32 = 298-primOpTag IndexByteArrayOp_Word8AsInt64 = 299-primOpTag IndexByteArrayOp_Word8AsInt = 300-primOpTag IndexByteArrayOp_Word8AsWord16 = 301-primOpTag IndexByteArrayOp_Word8AsWord32 = 302-primOpTag IndexByteArrayOp_Word8AsWord64 = 303-primOpTag IndexByteArrayOp_Word8AsWord = 304-primOpTag ReadByteArrayOp_Char = 305-primOpTag ReadByteArrayOp_WideChar = 306-primOpTag ReadByteArrayOp_Int = 307-primOpTag ReadByteArrayOp_Word = 308-primOpTag ReadByteArrayOp_Addr = 309-primOpTag ReadByteArrayOp_Float = 310-primOpTag ReadByteArrayOp_Double = 311-primOpTag ReadByteArrayOp_StablePtr = 312-primOpTag ReadByteArrayOp_Int8 = 313-primOpTag ReadByteArrayOp_Int16 = 314-primOpTag ReadByteArrayOp_Int32 = 315-primOpTag ReadByteArrayOp_Int64 = 316-primOpTag ReadByteArrayOp_Word8 = 317-primOpTag ReadByteArrayOp_Word16 = 318-primOpTag ReadByteArrayOp_Word32 = 319-primOpTag ReadByteArrayOp_Word64 = 320-primOpTag ReadByteArrayOp_Word8AsChar = 321-primOpTag ReadByteArrayOp_Word8AsWideChar = 322-primOpTag ReadByteArrayOp_Word8AsAddr = 323-primOpTag ReadByteArrayOp_Word8AsFloat = 324-primOpTag ReadByteArrayOp_Word8AsDouble = 325-primOpTag ReadByteArrayOp_Word8AsStablePtr = 326-primOpTag ReadByteArrayOp_Word8AsInt16 = 327-primOpTag ReadByteArrayOp_Word8AsInt32 = 328-primOpTag ReadByteArrayOp_Word8AsInt64 = 329-primOpTag ReadByteArrayOp_Word8AsInt = 330-primOpTag ReadByteArrayOp_Word8AsWord16 = 331-primOpTag ReadByteArrayOp_Word8AsWord32 = 332-primOpTag ReadByteArrayOp_Word8AsWord64 = 333-primOpTag ReadByteArrayOp_Word8AsWord = 334-primOpTag WriteByteArrayOp_Char = 335-primOpTag WriteByteArrayOp_WideChar = 336-primOpTag WriteByteArrayOp_Int = 337-primOpTag WriteByteArrayOp_Word = 338-primOpTag WriteByteArrayOp_Addr = 339-primOpTag WriteByteArrayOp_Float = 340-primOpTag WriteByteArrayOp_Double = 341-primOpTag WriteByteArrayOp_StablePtr = 342-primOpTag WriteByteArrayOp_Int8 = 343-primOpTag WriteByteArrayOp_Int16 = 344-primOpTag WriteByteArrayOp_Int32 = 345-primOpTag WriteByteArrayOp_Int64 = 346-primOpTag WriteByteArrayOp_Word8 = 347-primOpTag WriteByteArrayOp_Word16 = 348-primOpTag WriteByteArrayOp_Word32 = 349-primOpTag WriteByteArrayOp_Word64 = 350-primOpTag WriteByteArrayOp_Word8AsChar = 351-primOpTag WriteByteArrayOp_Word8AsWideChar = 352-primOpTag WriteByteArrayOp_Word8AsAddr = 353-primOpTag WriteByteArrayOp_Word8AsFloat = 354-primOpTag WriteByteArrayOp_Word8AsDouble = 355-primOpTag WriteByteArrayOp_Word8AsStablePtr = 356-primOpTag WriteByteArrayOp_Word8AsInt16 = 357-primOpTag WriteByteArrayOp_Word8AsInt32 = 358-primOpTag WriteByteArrayOp_Word8AsInt64 = 359-primOpTag WriteByteArrayOp_Word8AsInt = 360-primOpTag WriteByteArrayOp_Word8AsWord16 = 361-primOpTag WriteByteArrayOp_Word8AsWord32 = 362-primOpTag WriteByteArrayOp_Word8AsWord64 = 363-primOpTag WriteByteArrayOp_Word8AsWord = 364-primOpTag CompareByteArraysOp = 365-primOpTag CopyByteArrayOp = 366-primOpTag CopyMutableByteArrayOp = 367-primOpTag CopyByteArrayToAddrOp = 368-primOpTag CopyMutableByteArrayToAddrOp = 369-primOpTag CopyAddrToByteArrayOp = 370-primOpTag SetByteArrayOp = 371-primOpTag AtomicReadByteArrayOp_Int = 372-primOpTag AtomicWriteByteArrayOp_Int = 373-primOpTag CasByteArrayOp_Int = 374-primOpTag FetchAddByteArrayOp_Int = 375-primOpTag FetchSubByteArrayOp_Int = 376-primOpTag FetchAndByteArrayOp_Int = 377-primOpTag FetchNandByteArrayOp_Int = 378-primOpTag FetchOrByteArrayOp_Int = 379-primOpTag FetchXorByteArrayOp_Int = 380-primOpTag NewArrayArrayOp = 381-primOpTag SameMutableArrayArrayOp = 382-primOpTag UnsafeFreezeArrayArrayOp = 383-primOpTag SizeofArrayArrayOp = 384-primOpTag SizeofMutableArrayArrayOp = 385-primOpTag IndexArrayArrayOp_ByteArray = 386-primOpTag IndexArrayArrayOp_ArrayArray = 387-primOpTag ReadArrayArrayOp_ByteArray = 388-primOpTag ReadArrayArrayOp_MutableByteArray = 389-primOpTag ReadArrayArrayOp_ArrayArray = 390-primOpTag ReadArrayArrayOp_MutableArrayArray = 391-primOpTag WriteArrayArrayOp_ByteArray = 392-primOpTag WriteArrayArrayOp_MutableByteArray = 393-primOpTag WriteArrayArrayOp_ArrayArray = 394-primOpTag WriteArrayArrayOp_MutableArrayArray = 395-primOpTag CopyArrayArrayOp = 396-primOpTag CopyMutableArrayArrayOp = 397-primOpTag AddrAddOp = 398-primOpTag AddrSubOp = 399-primOpTag AddrRemOp = 400-primOpTag Addr2IntOp = 401-primOpTag Int2AddrOp = 402-primOpTag AddrGtOp = 403-primOpTag AddrGeOp = 404-primOpTag AddrEqOp = 405-primOpTag AddrNeOp = 406-primOpTag AddrLtOp = 407-primOpTag AddrLeOp = 408-primOpTag IndexOffAddrOp_Char = 409-primOpTag IndexOffAddrOp_WideChar = 410-primOpTag IndexOffAddrOp_Int = 411-primOpTag IndexOffAddrOp_Word = 412-primOpTag IndexOffAddrOp_Addr = 413-primOpTag IndexOffAddrOp_Float = 414-primOpTag IndexOffAddrOp_Double = 415-primOpTag IndexOffAddrOp_StablePtr = 416-primOpTag IndexOffAddrOp_Int8 = 417-primOpTag IndexOffAddrOp_Int16 = 418-primOpTag IndexOffAddrOp_Int32 = 419-primOpTag IndexOffAddrOp_Int64 = 420-primOpTag IndexOffAddrOp_Word8 = 421-primOpTag IndexOffAddrOp_Word16 = 422-primOpTag IndexOffAddrOp_Word32 = 423-primOpTag IndexOffAddrOp_Word64 = 424-primOpTag ReadOffAddrOp_Char = 425-primOpTag ReadOffAddrOp_WideChar = 426-primOpTag ReadOffAddrOp_Int = 427-primOpTag ReadOffAddrOp_Word = 428-primOpTag ReadOffAddrOp_Addr = 429-primOpTag ReadOffAddrOp_Float = 430-primOpTag ReadOffAddrOp_Double = 431-primOpTag ReadOffAddrOp_StablePtr = 432-primOpTag ReadOffAddrOp_Int8 = 433-primOpTag ReadOffAddrOp_Int16 = 434-primOpTag ReadOffAddrOp_Int32 = 435-primOpTag ReadOffAddrOp_Int64 = 436-primOpTag ReadOffAddrOp_Word8 = 437-primOpTag ReadOffAddrOp_Word16 = 438-primOpTag ReadOffAddrOp_Word32 = 439-primOpTag ReadOffAddrOp_Word64 = 440-primOpTag WriteOffAddrOp_Char = 441-primOpTag WriteOffAddrOp_WideChar = 442-primOpTag WriteOffAddrOp_Int = 443-primOpTag WriteOffAddrOp_Word = 444-primOpTag WriteOffAddrOp_Addr = 445-primOpTag WriteOffAddrOp_Float = 446-primOpTag WriteOffAddrOp_Double = 447-primOpTag WriteOffAddrOp_StablePtr = 448-primOpTag WriteOffAddrOp_Int8 = 449-primOpTag WriteOffAddrOp_Int16 = 450-primOpTag WriteOffAddrOp_Int32 = 451-primOpTag WriteOffAddrOp_Int64 = 452-primOpTag WriteOffAddrOp_Word8 = 453-primOpTag WriteOffAddrOp_Word16 = 454-primOpTag WriteOffAddrOp_Word32 = 455-primOpTag WriteOffAddrOp_Word64 = 456-primOpTag NewMutVarOp = 457-primOpTag ReadMutVarOp = 458-primOpTag WriteMutVarOp = 459-primOpTag SameMutVarOp = 460-primOpTag AtomicModifyMutVar2Op = 461-primOpTag AtomicModifyMutVar_Op = 462-primOpTag CasMutVarOp = 463-primOpTag CatchOp = 464-primOpTag RaiseOp = 465-primOpTag RaiseIOOp = 466-primOpTag MaskAsyncExceptionsOp = 467-primOpTag MaskUninterruptibleOp = 468-primOpTag UnmaskAsyncExceptionsOp = 469-primOpTag MaskStatus = 470-primOpTag AtomicallyOp = 471-primOpTag RetryOp = 472-primOpTag CatchRetryOp = 473-primOpTag CatchSTMOp = 474-primOpTag NewTVarOp = 475-primOpTag ReadTVarOp = 476-primOpTag ReadTVarIOOp = 477-primOpTag WriteTVarOp = 478-primOpTag SameTVarOp = 479-primOpTag NewMVarOp = 480-primOpTag TakeMVarOp = 481-primOpTag TryTakeMVarOp = 482-primOpTag PutMVarOp = 483-primOpTag TryPutMVarOp = 484-primOpTag ReadMVarOp = 485-primOpTag TryReadMVarOp = 486-primOpTag SameMVarOp = 487-primOpTag IsEmptyMVarOp = 488-primOpTag DelayOp = 489-primOpTag WaitReadOp = 490-primOpTag WaitWriteOp = 491-primOpTag ForkOp = 492-primOpTag ForkOnOp = 493-primOpTag KillThreadOp = 494-primOpTag YieldOp = 495-primOpTag MyThreadIdOp = 496-primOpTag LabelThreadOp = 497-primOpTag IsCurrentThreadBoundOp = 498-primOpTag NoDuplicateOp = 499-primOpTag ThreadStatusOp = 500-primOpTag MkWeakOp = 501-primOpTag MkWeakNoFinalizerOp = 502-primOpTag AddCFinalizerToWeakOp = 503-primOpTag DeRefWeakOp = 504-primOpTag FinalizeWeakOp = 505-primOpTag TouchOp = 506-primOpTag MakeStablePtrOp = 507-primOpTag DeRefStablePtrOp = 508-primOpTag EqStablePtrOp = 509-primOpTag MakeStableNameOp = 510-primOpTag EqStableNameOp = 511-primOpTag StableNameToIntOp = 512-primOpTag CompactNewOp = 513-primOpTag CompactResizeOp = 514-primOpTag CompactContainsOp = 515-primOpTag CompactContainsAnyOp = 516-primOpTag CompactGetFirstBlockOp = 517-primOpTag CompactGetNextBlockOp = 518-primOpTag CompactAllocateBlockOp = 519-primOpTag CompactFixupPointersOp = 520-primOpTag CompactAdd = 521-primOpTag CompactAddWithSharing = 522-primOpTag CompactSize = 523-primOpTag ReallyUnsafePtrEqualityOp = 524-primOpTag ParOp = 525-primOpTag SparkOp = 526-primOpTag SeqOp = 527-primOpTag GetSparkOp = 528-primOpTag NumSparks = 529-primOpTag DataToTagOp = 530-primOpTag TagToEnumOp = 531-primOpTag AddrToAnyOp = 532-primOpTag AnyToAddrOp = 533-primOpTag MkApUpd0_Op = 534-primOpTag NewBCOOp = 535-primOpTag UnpackClosureOp = 536-primOpTag ClosureSizeOp = 537-primOpTag GetApStackValOp = 538-primOpTag GetCCSOfOp = 539-primOpTag GetCurrentCCSOp = 540-primOpTag ClearCCSOp = 541-primOpTag TraceEventOp = 542-primOpTag TraceEventBinaryOp = 543-primOpTag TraceMarkerOp = 544-primOpTag SetThreadAllocationCounter = 545-primOpTag (VecBroadcastOp IntVec 16 W8) = 546-primOpTag (VecBroadcastOp IntVec 8 W16) = 547-primOpTag (VecBroadcastOp IntVec 4 W32) = 548-primOpTag (VecBroadcastOp IntVec 2 W64) = 549-primOpTag (VecBroadcastOp IntVec 32 W8) = 550-primOpTag (VecBroadcastOp IntVec 16 W16) = 551-primOpTag (VecBroadcastOp IntVec 8 W32) = 552-primOpTag (VecBroadcastOp IntVec 4 W64) = 553-primOpTag (VecBroadcastOp IntVec 64 W8) = 554-primOpTag (VecBroadcastOp IntVec 32 W16) = 555-primOpTag (VecBroadcastOp IntVec 16 W32) = 556-primOpTag (VecBroadcastOp IntVec 8 W64) = 557-primOpTag (VecBroadcastOp WordVec 16 W8) = 558-primOpTag (VecBroadcastOp WordVec 8 W16) = 559-primOpTag (VecBroadcastOp WordVec 4 W32) = 560-primOpTag (VecBroadcastOp WordVec 2 W64) = 561-primOpTag (VecBroadcastOp WordVec 32 W8) = 562-primOpTag (VecBroadcastOp WordVec 16 W16) = 563-primOpTag (VecBroadcastOp WordVec 8 W32) = 564-primOpTag (VecBroadcastOp WordVec 4 W64) = 565-primOpTag (VecBroadcastOp WordVec 64 W8) = 566-primOpTag (VecBroadcastOp WordVec 32 W16) = 567-primOpTag (VecBroadcastOp WordVec 16 W32) = 568-primOpTag (VecBroadcastOp WordVec 8 W64) = 569-primOpTag (VecBroadcastOp FloatVec 4 W32) = 570-primOpTag (VecBroadcastOp FloatVec 2 W64) = 571-primOpTag (VecBroadcastOp FloatVec 8 W32) = 572-primOpTag (VecBroadcastOp FloatVec 4 W64) = 573-primOpTag (VecBroadcastOp FloatVec 16 W32) = 574-primOpTag (VecBroadcastOp FloatVec 8 W64) = 575-primOpTag (VecPackOp IntVec 16 W8) = 576-primOpTag (VecPackOp IntVec 8 W16) = 577-primOpTag (VecPackOp IntVec 4 W32) = 578-primOpTag (VecPackOp IntVec 2 W64) = 579-primOpTag (VecPackOp IntVec 32 W8) = 580-primOpTag (VecPackOp IntVec 16 W16) = 581-primOpTag (VecPackOp IntVec 8 W32) = 582-primOpTag (VecPackOp IntVec 4 W64) = 583-primOpTag (VecPackOp IntVec 64 W8) = 584-primOpTag (VecPackOp IntVec 32 W16) = 585-primOpTag (VecPackOp IntVec 16 W32) = 586-primOpTag (VecPackOp IntVec 8 W64) = 587-primOpTag (VecPackOp WordVec 16 W8) = 588-primOpTag (VecPackOp WordVec 8 W16) = 589-primOpTag (VecPackOp WordVec 4 W32) = 590-primOpTag (VecPackOp WordVec 2 W64) = 591-primOpTag (VecPackOp WordVec 32 W8) = 592-primOpTag (VecPackOp WordVec 16 W16) = 593-primOpTag (VecPackOp WordVec 8 W32) = 594-primOpTag (VecPackOp WordVec 4 W64) = 595-primOpTag (VecPackOp WordVec 64 W8) = 596-primOpTag (VecPackOp WordVec 32 W16) = 597-primOpTag (VecPackOp WordVec 16 W32) = 598-primOpTag (VecPackOp WordVec 8 W64) = 599-primOpTag (VecPackOp FloatVec 4 W32) = 600-primOpTag (VecPackOp FloatVec 2 W64) = 601-primOpTag (VecPackOp FloatVec 8 W32) = 602-primOpTag (VecPackOp FloatVec 4 W64) = 603-primOpTag (VecPackOp FloatVec 16 W32) = 604-primOpTag (VecPackOp FloatVec 8 W64) = 605-primOpTag (VecUnpackOp IntVec 16 W8) = 606-primOpTag (VecUnpackOp IntVec 8 W16) = 607-primOpTag (VecUnpackOp IntVec 4 W32) = 608-primOpTag (VecUnpackOp IntVec 2 W64) = 609-primOpTag (VecUnpackOp IntVec 32 W8) = 610-primOpTag (VecUnpackOp IntVec 16 W16) = 611-primOpTag (VecUnpackOp IntVec 8 W32) = 612-primOpTag (VecUnpackOp IntVec 4 W64) = 613-primOpTag (VecUnpackOp IntVec 64 W8) = 614-primOpTag (VecUnpackOp IntVec 32 W16) = 615-primOpTag (VecUnpackOp IntVec 16 W32) = 616-primOpTag (VecUnpackOp IntVec 8 W64) = 617-primOpTag (VecUnpackOp WordVec 16 W8) = 618-primOpTag (VecUnpackOp WordVec 8 W16) = 619-primOpTag (VecUnpackOp WordVec 4 W32) = 620-primOpTag (VecUnpackOp WordVec 2 W64) = 621-primOpTag (VecUnpackOp WordVec 32 W8) = 622-primOpTag (VecUnpackOp WordVec 16 W16) = 623-primOpTag (VecUnpackOp WordVec 8 W32) = 624-primOpTag (VecUnpackOp WordVec 4 W64) = 625-primOpTag (VecUnpackOp WordVec 64 W8) = 626-primOpTag (VecUnpackOp WordVec 32 W16) = 627-primOpTag (VecUnpackOp WordVec 16 W32) = 628-primOpTag (VecUnpackOp WordVec 8 W64) = 629-primOpTag (VecUnpackOp FloatVec 4 W32) = 630-primOpTag (VecUnpackOp FloatVec 2 W64) = 631-primOpTag (VecUnpackOp FloatVec 8 W32) = 632-primOpTag (VecUnpackOp FloatVec 4 W64) = 633-primOpTag (VecUnpackOp FloatVec 16 W32) = 634-primOpTag (VecUnpackOp FloatVec 8 W64) = 635-primOpTag (VecInsertOp IntVec 16 W8) = 636-primOpTag (VecInsertOp IntVec 8 W16) = 637-primOpTag (VecInsertOp IntVec 4 W32) = 638-primOpTag (VecInsertOp IntVec 2 W64) = 639-primOpTag (VecInsertOp IntVec 32 W8) = 640-primOpTag (VecInsertOp IntVec 16 W16) = 641-primOpTag (VecInsertOp IntVec 8 W32) = 642-primOpTag (VecInsertOp IntVec 4 W64) = 643-primOpTag (VecInsertOp IntVec 64 W8) = 644-primOpTag (VecInsertOp IntVec 32 W16) = 645-primOpTag (VecInsertOp IntVec 16 W32) = 646-primOpTag (VecInsertOp IntVec 8 W64) = 647-primOpTag (VecInsertOp WordVec 16 W8) = 648-primOpTag (VecInsertOp WordVec 8 W16) = 649-primOpTag (VecInsertOp WordVec 4 W32) = 650-primOpTag (VecInsertOp WordVec 2 W64) = 651-primOpTag (VecInsertOp WordVec 32 W8) = 652-primOpTag (VecInsertOp WordVec 16 W16) = 653-primOpTag (VecInsertOp WordVec 8 W32) = 654-primOpTag (VecInsertOp WordVec 4 W64) = 655-primOpTag (VecInsertOp WordVec 64 W8) = 656-primOpTag (VecInsertOp WordVec 32 W16) = 657-primOpTag (VecInsertOp WordVec 16 W32) = 658-primOpTag (VecInsertOp WordVec 8 W64) = 659-primOpTag (VecInsertOp FloatVec 4 W32) = 660-primOpTag (VecInsertOp FloatVec 2 W64) = 661-primOpTag (VecInsertOp FloatVec 8 W32) = 662-primOpTag (VecInsertOp FloatVec 4 W64) = 663-primOpTag (VecInsertOp FloatVec 16 W32) = 664-primOpTag (VecInsertOp FloatVec 8 W64) = 665-primOpTag (VecAddOp IntVec 16 W8) = 666-primOpTag (VecAddOp IntVec 8 W16) = 667-primOpTag (VecAddOp IntVec 4 W32) = 668-primOpTag (VecAddOp IntVec 2 W64) = 669-primOpTag (VecAddOp IntVec 32 W8) = 670-primOpTag (VecAddOp IntVec 16 W16) = 671-primOpTag (VecAddOp IntVec 8 W32) = 672-primOpTag (VecAddOp IntVec 4 W64) = 673-primOpTag (VecAddOp IntVec 64 W8) = 674-primOpTag (VecAddOp IntVec 32 W16) = 675-primOpTag (VecAddOp IntVec 16 W32) = 676-primOpTag (VecAddOp IntVec 8 W64) = 677-primOpTag (VecAddOp WordVec 16 W8) = 678-primOpTag (VecAddOp WordVec 8 W16) = 679-primOpTag (VecAddOp WordVec 4 W32) = 680-primOpTag (VecAddOp WordVec 2 W64) = 681-primOpTag (VecAddOp WordVec 32 W8) = 682-primOpTag (VecAddOp WordVec 16 W16) = 683-primOpTag (VecAddOp WordVec 8 W32) = 684-primOpTag (VecAddOp WordVec 4 W64) = 685-primOpTag (VecAddOp WordVec 64 W8) = 686-primOpTag (VecAddOp WordVec 32 W16) = 687-primOpTag (VecAddOp WordVec 16 W32) = 688-primOpTag (VecAddOp WordVec 8 W64) = 689-primOpTag (VecAddOp FloatVec 4 W32) = 690-primOpTag (VecAddOp FloatVec 2 W64) = 691-primOpTag (VecAddOp FloatVec 8 W32) = 692-primOpTag (VecAddOp FloatVec 4 W64) = 693-primOpTag (VecAddOp FloatVec 16 W32) = 694-primOpTag (VecAddOp FloatVec 8 W64) = 695-primOpTag (VecSubOp IntVec 16 W8) = 696-primOpTag (VecSubOp IntVec 8 W16) = 697-primOpTag (VecSubOp IntVec 4 W32) = 698-primOpTag (VecSubOp IntVec 2 W64) = 699-primOpTag (VecSubOp IntVec 32 W8) = 700-primOpTag (VecSubOp IntVec 16 W16) = 701-primOpTag (VecSubOp IntVec 8 W32) = 702-primOpTag (VecSubOp IntVec 4 W64) = 703-primOpTag (VecSubOp IntVec 64 W8) = 704-primOpTag (VecSubOp IntVec 32 W16) = 705-primOpTag (VecSubOp IntVec 16 W32) = 706-primOpTag (VecSubOp IntVec 8 W64) = 707-primOpTag (VecSubOp WordVec 16 W8) = 708-primOpTag (VecSubOp WordVec 8 W16) = 709-primOpTag (VecSubOp WordVec 4 W32) = 710-primOpTag (VecSubOp WordVec 2 W64) = 711-primOpTag (VecSubOp WordVec 32 W8) = 712-primOpTag (VecSubOp WordVec 16 W16) = 713-primOpTag (VecSubOp WordVec 8 W32) = 714-primOpTag (VecSubOp WordVec 4 W64) = 715-primOpTag (VecSubOp WordVec 64 W8) = 716-primOpTag (VecSubOp WordVec 32 W16) = 717-primOpTag (VecSubOp WordVec 16 W32) = 718-primOpTag (VecSubOp WordVec 8 W64) = 719-primOpTag (VecSubOp FloatVec 4 W32) = 720-primOpTag (VecSubOp FloatVec 2 W64) = 721-primOpTag (VecSubOp FloatVec 8 W32) = 722-primOpTag (VecSubOp FloatVec 4 W64) = 723-primOpTag (VecSubOp FloatVec 16 W32) = 724-primOpTag (VecSubOp FloatVec 8 W64) = 725-primOpTag (VecMulOp IntVec 16 W8) = 726-primOpTag (VecMulOp IntVec 8 W16) = 727-primOpTag (VecMulOp IntVec 4 W32) = 728-primOpTag (VecMulOp IntVec 2 W64) = 729-primOpTag (VecMulOp IntVec 32 W8) = 730-primOpTag (VecMulOp IntVec 16 W16) = 731-primOpTag (VecMulOp IntVec 8 W32) = 732-primOpTag (VecMulOp IntVec 4 W64) = 733-primOpTag (VecMulOp IntVec 64 W8) = 734-primOpTag (VecMulOp IntVec 32 W16) = 735-primOpTag (VecMulOp IntVec 16 W32) = 736-primOpTag (VecMulOp IntVec 8 W64) = 737-primOpTag (VecMulOp WordVec 16 W8) = 738-primOpTag (VecMulOp WordVec 8 W16) = 739-primOpTag (VecMulOp WordVec 4 W32) = 740-primOpTag (VecMulOp WordVec 2 W64) = 741-primOpTag (VecMulOp WordVec 32 W8) = 742-primOpTag (VecMulOp WordVec 16 W16) = 743-primOpTag (VecMulOp WordVec 8 W32) = 744-primOpTag (VecMulOp WordVec 4 W64) = 745-primOpTag (VecMulOp WordVec 64 W8) = 746-primOpTag (VecMulOp WordVec 32 W16) = 747-primOpTag (VecMulOp WordVec 16 W32) = 748-primOpTag (VecMulOp WordVec 8 W64) = 749-primOpTag (VecMulOp FloatVec 4 W32) = 750-primOpTag (VecMulOp FloatVec 2 W64) = 751-primOpTag (VecMulOp FloatVec 8 W32) = 752-primOpTag (VecMulOp FloatVec 4 W64) = 753-primOpTag (VecMulOp FloatVec 16 W32) = 754-primOpTag (VecMulOp FloatVec 8 W64) = 755-primOpTag (VecDivOp FloatVec 4 W32) = 756-primOpTag (VecDivOp FloatVec 2 W64) = 757-primOpTag (VecDivOp FloatVec 8 W32) = 758-primOpTag (VecDivOp FloatVec 4 W64) = 759-primOpTag (VecDivOp FloatVec 16 W32) = 760-primOpTag (VecDivOp FloatVec 8 W64) = 761-primOpTag (VecQuotOp IntVec 16 W8) = 762-primOpTag (VecQuotOp IntVec 8 W16) = 763-primOpTag (VecQuotOp IntVec 4 W32) = 764-primOpTag (VecQuotOp IntVec 2 W64) = 765-primOpTag (VecQuotOp IntVec 32 W8) = 766-primOpTag (VecQuotOp IntVec 16 W16) = 767-primOpTag (VecQuotOp IntVec 8 W32) = 768-primOpTag (VecQuotOp IntVec 4 W64) = 769-primOpTag (VecQuotOp IntVec 64 W8) = 770-primOpTag (VecQuotOp IntVec 32 W16) = 771-primOpTag (VecQuotOp IntVec 16 W32) = 772-primOpTag (VecQuotOp IntVec 8 W64) = 773-primOpTag (VecQuotOp WordVec 16 W8) = 774-primOpTag (VecQuotOp WordVec 8 W16) = 775-primOpTag (VecQuotOp WordVec 4 W32) = 776-primOpTag (VecQuotOp WordVec 2 W64) = 777-primOpTag (VecQuotOp WordVec 32 W8) = 778-primOpTag (VecQuotOp WordVec 16 W16) = 779-primOpTag (VecQuotOp WordVec 8 W32) = 780-primOpTag (VecQuotOp WordVec 4 W64) = 781-primOpTag (VecQuotOp WordVec 64 W8) = 782-primOpTag (VecQuotOp WordVec 32 W16) = 783-primOpTag (VecQuotOp WordVec 16 W32) = 784-primOpTag (VecQuotOp WordVec 8 W64) = 785-primOpTag (VecRemOp IntVec 16 W8) = 786-primOpTag (VecRemOp IntVec 8 W16) = 787-primOpTag (VecRemOp IntVec 4 W32) = 788-primOpTag (VecRemOp IntVec 2 W64) = 789-primOpTag (VecRemOp IntVec 32 W8) = 790-primOpTag (VecRemOp IntVec 16 W16) = 791-primOpTag (VecRemOp IntVec 8 W32) = 792-primOpTag (VecRemOp IntVec 4 W64) = 793-primOpTag (VecRemOp IntVec 64 W8) = 794-primOpTag (VecRemOp IntVec 32 W16) = 795-primOpTag (VecRemOp IntVec 16 W32) = 796-primOpTag (VecRemOp IntVec 8 W64) = 797-primOpTag (VecRemOp WordVec 16 W8) = 798-primOpTag (VecRemOp WordVec 8 W16) = 799-primOpTag (VecRemOp WordVec 4 W32) = 800-primOpTag (VecRemOp WordVec 2 W64) = 801-primOpTag (VecRemOp WordVec 32 W8) = 802-primOpTag (VecRemOp WordVec 16 W16) = 803-primOpTag (VecRemOp WordVec 8 W32) = 804-primOpTag (VecRemOp WordVec 4 W64) = 805-primOpTag (VecRemOp WordVec 64 W8) = 806-primOpTag (VecRemOp WordVec 32 W16) = 807-primOpTag (VecRemOp WordVec 16 W32) = 808-primOpTag (VecRemOp WordVec 8 W64) = 809-primOpTag (VecNegOp IntVec 16 W8) = 810-primOpTag (VecNegOp IntVec 8 W16) = 811-primOpTag (VecNegOp IntVec 4 W32) = 812-primOpTag (VecNegOp IntVec 2 W64) = 813-primOpTag (VecNegOp IntVec 32 W8) = 814-primOpTag (VecNegOp IntVec 16 W16) = 815-primOpTag (VecNegOp IntVec 8 W32) = 816-primOpTag (VecNegOp IntVec 4 W64) = 817-primOpTag (VecNegOp IntVec 64 W8) = 818-primOpTag (VecNegOp IntVec 32 W16) = 819-primOpTag (VecNegOp IntVec 16 W32) = 820-primOpTag (VecNegOp IntVec 8 W64) = 821-primOpTag (VecNegOp FloatVec 4 W32) = 822-primOpTag (VecNegOp FloatVec 2 W64) = 823-primOpTag (VecNegOp FloatVec 8 W32) = 824-primOpTag (VecNegOp FloatVec 4 W64) = 825-primOpTag (VecNegOp FloatVec 16 W32) = 826-primOpTag (VecNegOp FloatVec 8 W64) = 827-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 828-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 829-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 830-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 831-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 832-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 833-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 834-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 835-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 836-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 837-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 838-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 839-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 840-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 841-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 842-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 843-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 844-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 845-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 846-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 847-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 848-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 849-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 850-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 851-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 852-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 853-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 854-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 855-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 856-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 857-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 858-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 859-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 860-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 861-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 862-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 863-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 864-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 865-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 866-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 867-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 868-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 869-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 870-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 871-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 872-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 873-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 874-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 875-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 876-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 877-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 878-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 879-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 880-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 881-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 882-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 883-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 884-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 885-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 886-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 887-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 888-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 889-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 890-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 891-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 892-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 893-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 894-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 895-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 896-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 897-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 898-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 899-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 900-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 901-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 902-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 903-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 904-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 905-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 906-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 907-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 908-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 909-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 910-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 911-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 912-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 913-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 914-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 915-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 916-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 917-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 918-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 919-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 920-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 921-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 922-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 923-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 924-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 925-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 926-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 927-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 928-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 929-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 930-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 931-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 932-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 933-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 934-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 935-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 936-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 937-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 938-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 939-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 940-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 941-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 942-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 943-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 944-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 945-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 946-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 947-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 948-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 949-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 950-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 951-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 952-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 953-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 954-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 955-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 956-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 957-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 958-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 959-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 960-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 961-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 962-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 963-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 964-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 965-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 966-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 967-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 968-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 969-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 970-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 971-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 972-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 973-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 974-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 975-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 976-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 977-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 978-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 979-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 980-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 981-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 982-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 983-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 984-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 985-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 986-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 987-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 988-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 989-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 990-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 991-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 992-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 993-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 994-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 995-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 996-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 997-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 998-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 999-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1000-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1001-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1002-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1003-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1004-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1005-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1006-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1007-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1008-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1009-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1010-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1018-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1019-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1020-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1021-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1022-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1030-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1031-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1032-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1033-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1034-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1035-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1036-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1037-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1038-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1039-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1040-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1048-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1049-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1050-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1051-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1052-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1060-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1061-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1062-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1063-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1064-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1065-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1066-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1067-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1068-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1069-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1070-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1078-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1079-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1080-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1081-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1082-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1090-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1091-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1092-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1093-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1094-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1095-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1096-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1097-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1098-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1099-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1100-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1108-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1109-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1110-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1111-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1112-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1120-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1121-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1122-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1123-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1124-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1125-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1126-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1127-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1128-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1129-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1130-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1138-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1139-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1140-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1141-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1142-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1150-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1151-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1152-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1153-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1154-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1155-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1156-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1157-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1158-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1159-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1160-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1168-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1169-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1170-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1171-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1172-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1180-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1181-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1182-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1183-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1184-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1185-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1186-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1187-primOpTag PrefetchByteArrayOp3 = 1188-primOpTag PrefetchMutableByteArrayOp3 = 1189-primOpTag PrefetchAddrOp3 = 1190-primOpTag PrefetchValueOp3 = 1191-primOpTag PrefetchByteArrayOp2 = 1192-primOpTag PrefetchMutableByteArrayOp2 = 1193-primOpTag PrefetchAddrOp2 = 1194-primOpTag PrefetchValueOp2 = 1195-primOpTag PrefetchByteArrayOp1 = 1196-primOpTag PrefetchMutableByteArrayOp1 = 1197-primOpTag PrefetchAddrOp1 = 1198-primOpTag PrefetchValueOp1 = 1199-primOpTag PrefetchByteArrayOp0 = 1200-primOpTag PrefetchMutableByteArrayOp0 = 1201-primOpTag PrefetchAddrOp0 = 1202-primOpTag PrefetchValueOp0 = 1203+maxPrimOpTag = 1204+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag Int8Extend = 8+primOpTag Int8Narrow = 9+primOpTag Int8NegOp = 10+primOpTag Int8AddOp = 11+primOpTag Int8SubOp = 12+primOpTag Int8MulOp = 13+primOpTag Int8QuotOp = 14+primOpTag Int8RemOp = 15+primOpTag Int8QuotRemOp = 16+primOpTag Int8EqOp = 17+primOpTag Int8GeOp = 18+primOpTag Int8GtOp = 19+primOpTag Int8LeOp = 20+primOpTag Int8LtOp = 21+primOpTag Int8NeOp = 22+primOpTag Word8Extend = 23+primOpTag Word8Narrow = 24+primOpTag Word8NotOp = 25+primOpTag Word8AddOp = 26+primOpTag Word8SubOp = 27+primOpTag Word8MulOp = 28+primOpTag Word8QuotOp = 29+primOpTag Word8RemOp = 30+primOpTag Word8QuotRemOp = 31+primOpTag Word8EqOp = 32+primOpTag Word8GeOp = 33+primOpTag Word8GtOp = 34+primOpTag Word8LeOp = 35+primOpTag Word8LtOp = 36+primOpTag Word8NeOp = 37+primOpTag Int16Extend = 38+primOpTag Int16Narrow = 39+primOpTag Int16NegOp = 40+primOpTag Int16AddOp = 41+primOpTag Int16SubOp = 42+primOpTag Int16MulOp = 43+primOpTag Int16QuotOp = 44+primOpTag Int16RemOp = 45+primOpTag Int16QuotRemOp = 46+primOpTag Int16EqOp = 47+primOpTag Int16GeOp = 48+primOpTag Int16GtOp = 49+primOpTag Int16LeOp = 50+primOpTag Int16LtOp = 51+primOpTag Int16NeOp = 52+primOpTag Word16Extend = 53+primOpTag Word16Narrow = 54+primOpTag Word16NotOp = 55+primOpTag Word16AddOp = 56+primOpTag Word16SubOp = 57+primOpTag Word16MulOp = 58+primOpTag Word16QuotOp = 59+primOpTag Word16RemOp = 60+primOpTag Word16QuotRemOp = 61+primOpTag Word16EqOp = 62+primOpTag Word16GeOp = 63+primOpTag Word16GtOp = 64+primOpTag Word16LeOp = 65+primOpTag Word16LtOp = 66+primOpTag Word16NeOp = 67+primOpTag IntAddOp = 68+primOpTag IntSubOp = 69+primOpTag IntMulOp = 70+primOpTag IntMul2Op = 71+primOpTag IntMulMayOfloOp = 72+primOpTag IntQuotOp = 73+primOpTag IntRemOp = 74+primOpTag IntQuotRemOp = 75+primOpTag AndIOp = 76+primOpTag OrIOp = 77+primOpTag XorIOp = 78+primOpTag NotIOp = 79+primOpTag IntNegOp = 80+primOpTag IntAddCOp = 81+primOpTag IntSubCOp = 82+primOpTag IntGtOp = 83+primOpTag IntGeOp = 84+primOpTag IntEqOp = 85+primOpTag IntNeOp = 86+primOpTag IntLtOp = 87+primOpTag IntLeOp = 88+primOpTag ChrOp = 89+primOpTag Int2WordOp = 90+primOpTag Int2FloatOp = 91+primOpTag Int2DoubleOp = 92+primOpTag Word2FloatOp = 93+primOpTag Word2DoubleOp = 94+primOpTag ISllOp = 95+primOpTag ISraOp = 96+primOpTag ISrlOp = 97+primOpTag WordAddOp = 98+primOpTag WordAddCOp = 99+primOpTag WordSubCOp = 100+primOpTag WordAdd2Op = 101+primOpTag WordSubOp = 102+primOpTag WordMulOp = 103+primOpTag WordMul2Op = 104+primOpTag WordQuotOp = 105+primOpTag WordRemOp = 106+primOpTag WordQuotRemOp = 107+primOpTag WordQuotRem2Op = 108+primOpTag AndOp = 109+primOpTag OrOp = 110+primOpTag XorOp = 111+primOpTag NotOp = 112+primOpTag SllOp = 113+primOpTag SrlOp = 114+primOpTag Word2IntOp = 115+primOpTag WordGtOp = 116+primOpTag WordGeOp = 117+primOpTag WordEqOp = 118+primOpTag WordNeOp = 119+primOpTag WordLtOp = 120+primOpTag WordLeOp = 121+primOpTag PopCnt8Op = 122+primOpTag PopCnt16Op = 123+primOpTag PopCnt32Op = 124+primOpTag PopCnt64Op = 125+primOpTag PopCntOp = 126+primOpTag Pdep8Op = 127+primOpTag Pdep16Op = 128+primOpTag Pdep32Op = 129+primOpTag Pdep64Op = 130+primOpTag PdepOp = 131+primOpTag Pext8Op = 132+primOpTag Pext16Op = 133+primOpTag Pext32Op = 134+primOpTag Pext64Op = 135+primOpTag PextOp = 136+primOpTag Clz8Op = 137+primOpTag Clz16Op = 138+primOpTag Clz32Op = 139+primOpTag Clz64Op = 140+primOpTag ClzOp = 141+primOpTag Ctz8Op = 142+primOpTag Ctz16Op = 143+primOpTag Ctz32Op = 144+primOpTag Ctz64Op = 145+primOpTag CtzOp = 146+primOpTag BSwap16Op = 147+primOpTag BSwap32Op = 148+primOpTag BSwap64Op = 149+primOpTag BSwapOp = 150+primOpTag BRev8Op = 151+primOpTag BRev16Op = 152+primOpTag BRev32Op = 153+primOpTag BRev64Op = 154+primOpTag BRevOp = 155+primOpTag Narrow8IntOp = 156+primOpTag Narrow16IntOp = 157+primOpTag Narrow32IntOp = 158+primOpTag Narrow8WordOp = 159+primOpTag Narrow16WordOp = 160+primOpTag Narrow32WordOp = 161+primOpTag DoubleGtOp = 162+primOpTag DoubleGeOp = 163+primOpTag DoubleEqOp = 164+primOpTag DoubleNeOp = 165+primOpTag DoubleLtOp = 166+primOpTag DoubleLeOp = 167+primOpTag DoubleAddOp = 168+primOpTag DoubleSubOp = 169+primOpTag DoubleMulOp = 170+primOpTag DoubleDivOp = 171+primOpTag DoubleNegOp = 172+primOpTag DoubleFabsOp = 173+primOpTag Double2IntOp = 174+primOpTag Double2FloatOp = 175+primOpTag DoubleExpOp = 176+primOpTag DoubleExpM1Op = 177+primOpTag DoubleLogOp = 178+primOpTag DoubleLog1POp = 179+primOpTag DoubleSqrtOp = 180+primOpTag DoubleSinOp = 181+primOpTag DoubleCosOp = 182+primOpTag DoubleTanOp = 183+primOpTag DoubleAsinOp = 184+primOpTag DoubleAcosOp = 185+primOpTag DoubleAtanOp = 186+primOpTag DoubleSinhOp = 187+primOpTag DoubleCoshOp = 188+primOpTag DoubleTanhOp = 189+primOpTag DoubleAsinhOp = 190+primOpTag DoubleAcoshOp = 191+primOpTag DoubleAtanhOp = 192+primOpTag DoublePowerOp = 193+primOpTag DoubleDecode_2IntOp = 194+primOpTag DoubleDecode_Int64Op = 195+primOpTag FloatGtOp = 196+primOpTag FloatGeOp = 197+primOpTag FloatEqOp = 198+primOpTag FloatNeOp = 199+primOpTag FloatLtOp = 200+primOpTag FloatLeOp = 201+primOpTag FloatAddOp = 202+primOpTag FloatSubOp = 203+primOpTag FloatMulOp = 204+primOpTag FloatDivOp = 205+primOpTag FloatNegOp = 206+primOpTag FloatFabsOp = 207+primOpTag Float2IntOp = 208+primOpTag FloatExpOp = 209+primOpTag FloatExpM1Op = 210+primOpTag FloatLogOp = 211+primOpTag FloatLog1POp = 212+primOpTag FloatSqrtOp = 213+primOpTag FloatSinOp = 214+primOpTag FloatCosOp = 215+primOpTag FloatTanOp = 216+primOpTag FloatAsinOp = 217+primOpTag FloatAcosOp = 218+primOpTag FloatAtanOp = 219+primOpTag FloatSinhOp = 220+primOpTag FloatCoshOp = 221+primOpTag FloatTanhOp = 222+primOpTag FloatAsinhOp = 223+primOpTag FloatAcoshOp = 224+primOpTag FloatAtanhOp = 225+primOpTag FloatPowerOp = 226+primOpTag Float2DoubleOp = 227+primOpTag FloatDecode_IntOp = 228+primOpTag NewArrayOp = 229+primOpTag SameMutableArrayOp = 230+primOpTag ReadArrayOp = 231+primOpTag WriteArrayOp = 232+primOpTag SizeofArrayOp = 233+primOpTag SizeofMutableArrayOp = 234+primOpTag IndexArrayOp = 235+primOpTag UnsafeFreezeArrayOp = 236+primOpTag UnsafeThawArrayOp = 237+primOpTag CopyArrayOp = 238+primOpTag CopyMutableArrayOp = 239+primOpTag CloneArrayOp = 240+primOpTag CloneMutableArrayOp = 241+primOpTag FreezeArrayOp = 242+primOpTag ThawArrayOp = 243+primOpTag CasArrayOp = 244+primOpTag NewSmallArrayOp = 245+primOpTag SameSmallMutableArrayOp = 246+primOpTag ShrinkSmallMutableArrayOp_Char = 247+primOpTag ReadSmallArrayOp = 248+primOpTag WriteSmallArrayOp = 249+primOpTag SizeofSmallArrayOp = 250+primOpTag SizeofSmallMutableArrayOp = 251+primOpTag GetSizeofSmallMutableArrayOp = 252+primOpTag IndexSmallArrayOp = 253+primOpTag UnsafeFreezeSmallArrayOp = 254+primOpTag UnsafeThawSmallArrayOp = 255+primOpTag CopySmallArrayOp = 256+primOpTag CopySmallMutableArrayOp = 257+primOpTag CloneSmallArrayOp = 258+primOpTag CloneSmallMutableArrayOp = 259+primOpTag FreezeSmallArrayOp = 260+primOpTag ThawSmallArrayOp = 261+primOpTag CasSmallArrayOp = 262+primOpTag NewByteArrayOp_Char = 263+primOpTag NewPinnedByteArrayOp_Char = 264+primOpTag NewAlignedPinnedByteArrayOp_Char = 265+primOpTag MutableByteArrayIsPinnedOp = 266+primOpTag ByteArrayIsPinnedOp = 267+primOpTag ByteArrayContents_Char = 268+primOpTag SameMutableByteArrayOp = 269+primOpTag ShrinkMutableByteArrayOp_Char = 270+primOpTag ResizeMutableByteArrayOp_Char = 271+primOpTag UnsafeFreezeByteArrayOp = 272+primOpTag SizeofByteArrayOp = 273+primOpTag SizeofMutableByteArrayOp = 274+primOpTag GetSizeofMutableByteArrayOp = 275+primOpTag IndexByteArrayOp_Char = 276+primOpTag IndexByteArrayOp_WideChar = 277+primOpTag IndexByteArrayOp_Int = 278+primOpTag IndexByteArrayOp_Word = 279+primOpTag IndexByteArrayOp_Addr = 280+primOpTag IndexByteArrayOp_Float = 281+primOpTag IndexByteArrayOp_Double = 282+primOpTag IndexByteArrayOp_StablePtr = 283+primOpTag IndexByteArrayOp_Int8 = 284+primOpTag IndexByteArrayOp_Int16 = 285+primOpTag IndexByteArrayOp_Int32 = 286+primOpTag IndexByteArrayOp_Int64 = 287+primOpTag IndexByteArrayOp_Word8 = 288+primOpTag IndexByteArrayOp_Word16 = 289+primOpTag IndexByteArrayOp_Word32 = 290+primOpTag IndexByteArrayOp_Word64 = 291+primOpTag IndexByteArrayOp_Word8AsChar = 292+primOpTag IndexByteArrayOp_Word8AsWideChar = 293+primOpTag IndexByteArrayOp_Word8AsAddr = 294+primOpTag IndexByteArrayOp_Word8AsFloat = 295+primOpTag IndexByteArrayOp_Word8AsDouble = 296+primOpTag IndexByteArrayOp_Word8AsStablePtr = 297+primOpTag IndexByteArrayOp_Word8AsInt16 = 298+primOpTag IndexByteArrayOp_Word8AsInt32 = 299+primOpTag IndexByteArrayOp_Word8AsInt64 = 300+primOpTag IndexByteArrayOp_Word8AsInt = 301+primOpTag IndexByteArrayOp_Word8AsWord16 = 302+primOpTag IndexByteArrayOp_Word8AsWord32 = 303+primOpTag IndexByteArrayOp_Word8AsWord64 = 304+primOpTag IndexByteArrayOp_Word8AsWord = 305+primOpTag ReadByteArrayOp_Char = 306+primOpTag ReadByteArrayOp_WideChar = 307+primOpTag ReadByteArrayOp_Int = 308+primOpTag ReadByteArrayOp_Word = 309+primOpTag ReadByteArrayOp_Addr = 310+primOpTag ReadByteArrayOp_Float = 311+primOpTag ReadByteArrayOp_Double = 312+primOpTag ReadByteArrayOp_StablePtr = 313+primOpTag ReadByteArrayOp_Int8 = 314+primOpTag ReadByteArrayOp_Int16 = 315+primOpTag ReadByteArrayOp_Int32 = 316+primOpTag ReadByteArrayOp_Int64 = 317+primOpTag ReadByteArrayOp_Word8 = 318+primOpTag ReadByteArrayOp_Word16 = 319+primOpTag ReadByteArrayOp_Word32 = 320+primOpTag ReadByteArrayOp_Word64 = 321+primOpTag ReadByteArrayOp_Word8AsChar = 322+primOpTag ReadByteArrayOp_Word8AsWideChar = 323+primOpTag ReadByteArrayOp_Word8AsAddr = 324+primOpTag ReadByteArrayOp_Word8AsFloat = 325+primOpTag ReadByteArrayOp_Word8AsDouble = 326+primOpTag ReadByteArrayOp_Word8AsStablePtr = 327+primOpTag ReadByteArrayOp_Word8AsInt16 = 328+primOpTag ReadByteArrayOp_Word8AsInt32 = 329+primOpTag ReadByteArrayOp_Word8AsInt64 = 330+primOpTag ReadByteArrayOp_Word8AsInt = 331+primOpTag ReadByteArrayOp_Word8AsWord16 = 332+primOpTag ReadByteArrayOp_Word8AsWord32 = 333+primOpTag ReadByteArrayOp_Word8AsWord64 = 334+primOpTag ReadByteArrayOp_Word8AsWord = 335+primOpTag WriteByteArrayOp_Char = 336+primOpTag WriteByteArrayOp_WideChar = 337+primOpTag WriteByteArrayOp_Int = 338+primOpTag WriteByteArrayOp_Word = 339+primOpTag WriteByteArrayOp_Addr = 340+primOpTag WriteByteArrayOp_Float = 341+primOpTag WriteByteArrayOp_Double = 342+primOpTag WriteByteArrayOp_StablePtr = 343+primOpTag WriteByteArrayOp_Int8 = 344+primOpTag WriteByteArrayOp_Int16 = 345+primOpTag WriteByteArrayOp_Int32 = 346+primOpTag WriteByteArrayOp_Int64 = 347+primOpTag WriteByteArrayOp_Word8 = 348+primOpTag WriteByteArrayOp_Word16 = 349+primOpTag WriteByteArrayOp_Word32 = 350+primOpTag WriteByteArrayOp_Word64 = 351+primOpTag WriteByteArrayOp_Word8AsChar = 352+primOpTag WriteByteArrayOp_Word8AsWideChar = 353+primOpTag WriteByteArrayOp_Word8AsAddr = 354+primOpTag WriteByteArrayOp_Word8AsFloat = 355+primOpTag WriteByteArrayOp_Word8AsDouble = 356+primOpTag WriteByteArrayOp_Word8AsStablePtr = 357+primOpTag WriteByteArrayOp_Word8AsInt16 = 358+primOpTag WriteByteArrayOp_Word8AsInt32 = 359+primOpTag WriteByteArrayOp_Word8AsInt64 = 360+primOpTag WriteByteArrayOp_Word8AsInt = 361+primOpTag WriteByteArrayOp_Word8AsWord16 = 362+primOpTag WriteByteArrayOp_Word8AsWord32 = 363+primOpTag WriteByteArrayOp_Word8AsWord64 = 364+primOpTag WriteByteArrayOp_Word8AsWord = 365+primOpTag CompareByteArraysOp = 366+primOpTag CopyByteArrayOp = 367+primOpTag CopyMutableByteArrayOp = 368+primOpTag CopyByteArrayToAddrOp = 369+primOpTag CopyMutableByteArrayToAddrOp = 370+primOpTag CopyAddrToByteArrayOp = 371+primOpTag SetByteArrayOp = 372+primOpTag AtomicReadByteArrayOp_Int = 373+primOpTag AtomicWriteByteArrayOp_Int = 374+primOpTag CasByteArrayOp_Int = 375+primOpTag FetchAddByteArrayOp_Int = 376+primOpTag FetchSubByteArrayOp_Int = 377+primOpTag FetchAndByteArrayOp_Int = 378+primOpTag FetchNandByteArrayOp_Int = 379+primOpTag FetchOrByteArrayOp_Int = 380+primOpTag FetchXorByteArrayOp_Int = 381+primOpTag NewArrayArrayOp = 382+primOpTag SameMutableArrayArrayOp = 383+primOpTag UnsafeFreezeArrayArrayOp = 384+primOpTag SizeofArrayArrayOp = 385+primOpTag SizeofMutableArrayArrayOp = 386+primOpTag IndexArrayArrayOp_ByteArray = 387+primOpTag IndexArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_ByteArray = 389+primOpTag ReadArrayArrayOp_MutableByteArray = 390+primOpTag ReadArrayArrayOp_ArrayArray = 391+primOpTag ReadArrayArrayOp_MutableArrayArray = 392+primOpTag WriteArrayArrayOp_ByteArray = 393+primOpTag WriteArrayArrayOp_MutableByteArray = 394+primOpTag WriteArrayArrayOp_ArrayArray = 395+primOpTag WriteArrayArrayOp_MutableArrayArray = 396+primOpTag CopyArrayArrayOp = 397+primOpTag CopyMutableArrayArrayOp = 398+primOpTag AddrAddOp = 399+primOpTag AddrSubOp = 400+primOpTag AddrRemOp = 401+primOpTag Addr2IntOp = 402+primOpTag Int2AddrOp = 403+primOpTag AddrGtOp = 404+primOpTag AddrGeOp = 405+primOpTag AddrEqOp = 406+primOpTag AddrNeOp = 407+primOpTag AddrLtOp = 408+primOpTag AddrLeOp = 409+primOpTag IndexOffAddrOp_Char = 410+primOpTag IndexOffAddrOp_WideChar = 411+primOpTag IndexOffAddrOp_Int = 412+primOpTag IndexOffAddrOp_Word = 413+primOpTag IndexOffAddrOp_Addr = 414+primOpTag IndexOffAddrOp_Float = 415+primOpTag IndexOffAddrOp_Double = 416+primOpTag IndexOffAddrOp_StablePtr = 417+primOpTag IndexOffAddrOp_Int8 = 418+primOpTag IndexOffAddrOp_Int16 = 419+primOpTag IndexOffAddrOp_Int32 = 420+primOpTag IndexOffAddrOp_Int64 = 421+primOpTag IndexOffAddrOp_Word8 = 422+primOpTag IndexOffAddrOp_Word16 = 423+primOpTag IndexOffAddrOp_Word32 = 424+primOpTag IndexOffAddrOp_Word64 = 425+primOpTag ReadOffAddrOp_Char = 426+primOpTag ReadOffAddrOp_WideChar = 427+primOpTag ReadOffAddrOp_Int = 428+primOpTag ReadOffAddrOp_Word = 429+primOpTag ReadOffAddrOp_Addr = 430+primOpTag ReadOffAddrOp_Float = 431+primOpTag ReadOffAddrOp_Double = 432+primOpTag ReadOffAddrOp_StablePtr = 433+primOpTag ReadOffAddrOp_Int8 = 434+primOpTag ReadOffAddrOp_Int16 = 435+primOpTag ReadOffAddrOp_Int32 = 436+primOpTag ReadOffAddrOp_Int64 = 437+primOpTag ReadOffAddrOp_Word8 = 438+primOpTag ReadOffAddrOp_Word16 = 439+primOpTag ReadOffAddrOp_Word32 = 440+primOpTag ReadOffAddrOp_Word64 = 441+primOpTag WriteOffAddrOp_Char = 442+primOpTag WriteOffAddrOp_WideChar = 443+primOpTag WriteOffAddrOp_Int = 444+primOpTag WriteOffAddrOp_Word = 445+primOpTag WriteOffAddrOp_Addr = 446+primOpTag WriteOffAddrOp_Float = 447+primOpTag WriteOffAddrOp_Double = 448+primOpTag WriteOffAddrOp_StablePtr = 449+primOpTag WriteOffAddrOp_Int8 = 450+primOpTag WriteOffAddrOp_Int16 = 451+primOpTag WriteOffAddrOp_Int32 = 452+primOpTag WriteOffAddrOp_Int64 = 453+primOpTag WriteOffAddrOp_Word8 = 454+primOpTag WriteOffAddrOp_Word16 = 455+primOpTag WriteOffAddrOp_Word32 = 456+primOpTag WriteOffAddrOp_Word64 = 457+primOpTag NewMutVarOp = 458+primOpTag ReadMutVarOp = 459+primOpTag WriteMutVarOp = 460+primOpTag SameMutVarOp = 461+primOpTag AtomicModifyMutVar2Op = 462+primOpTag AtomicModifyMutVar_Op = 463+primOpTag CasMutVarOp = 464+primOpTag CatchOp = 465+primOpTag RaiseOp = 466+primOpTag RaiseIOOp = 467+primOpTag MaskAsyncExceptionsOp = 468+primOpTag MaskUninterruptibleOp = 469+primOpTag UnmaskAsyncExceptionsOp = 470+primOpTag MaskStatus = 471+primOpTag AtomicallyOp = 472+primOpTag RetryOp = 473+primOpTag CatchRetryOp = 474+primOpTag CatchSTMOp = 475+primOpTag NewTVarOp = 476+primOpTag ReadTVarOp = 477+primOpTag ReadTVarIOOp = 478+primOpTag WriteTVarOp = 479+primOpTag SameTVarOp = 480+primOpTag NewMVarOp = 481+primOpTag TakeMVarOp = 482+primOpTag TryTakeMVarOp = 483+primOpTag PutMVarOp = 484+primOpTag TryPutMVarOp = 485+primOpTag ReadMVarOp = 486+primOpTag TryReadMVarOp = 487+primOpTag SameMVarOp = 488+primOpTag IsEmptyMVarOp = 489+primOpTag DelayOp = 490+primOpTag WaitReadOp = 491+primOpTag WaitWriteOp = 492+primOpTag ForkOp = 493+primOpTag ForkOnOp = 494+primOpTag KillThreadOp = 495+primOpTag YieldOp = 496+primOpTag MyThreadIdOp = 497+primOpTag LabelThreadOp = 498+primOpTag IsCurrentThreadBoundOp = 499+primOpTag NoDuplicateOp = 500+primOpTag ThreadStatusOp = 501+primOpTag MkWeakOp = 502+primOpTag MkWeakNoFinalizerOp = 503+primOpTag AddCFinalizerToWeakOp = 504+primOpTag DeRefWeakOp = 505+primOpTag FinalizeWeakOp = 506+primOpTag TouchOp = 507+primOpTag MakeStablePtrOp = 508+primOpTag DeRefStablePtrOp = 509+primOpTag EqStablePtrOp = 510+primOpTag MakeStableNameOp = 511+primOpTag EqStableNameOp = 512+primOpTag StableNameToIntOp = 513+primOpTag CompactNewOp = 514+primOpTag CompactResizeOp = 515+primOpTag CompactContainsOp = 516+primOpTag CompactContainsAnyOp = 517+primOpTag CompactGetFirstBlockOp = 518+primOpTag CompactGetNextBlockOp = 519+primOpTag CompactAllocateBlockOp = 520+primOpTag CompactFixupPointersOp = 521+primOpTag CompactAdd = 522+primOpTag CompactAddWithSharing = 523+primOpTag CompactSize = 524+primOpTag ReallyUnsafePtrEqualityOp = 525+primOpTag ParOp = 526+primOpTag SparkOp = 527+primOpTag SeqOp = 528+primOpTag GetSparkOp = 529+primOpTag NumSparks = 530+primOpTag DataToTagOp = 531+primOpTag TagToEnumOp = 532+primOpTag AddrToAnyOp = 533+primOpTag AnyToAddrOp = 534+primOpTag MkApUpd0_Op = 535+primOpTag NewBCOOp = 536+primOpTag UnpackClosureOp = 537+primOpTag ClosureSizeOp = 538+primOpTag GetApStackValOp = 539+primOpTag GetCCSOfOp = 540+primOpTag GetCurrentCCSOp = 541+primOpTag ClearCCSOp = 542+primOpTag TraceEventOp = 543+primOpTag TraceEventBinaryOp = 544+primOpTag TraceMarkerOp = 545+primOpTag SetThreadAllocationCounter = 546+primOpTag (VecBroadcastOp IntVec 16 W8) = 547+primOpTag (VecBroadcastOp IntVec 8 W16) = 548+primOpTag (VecBroadcastOp IntVec 4 W32) = 549+primOpTag (VecBroadcastOp IntVec 2 W64) = 550+primOpTag (VecBroadcastOp IntVec 32 W8) = 551+primOpTag (VecBroadcastOp IntVec 16 W16) = 552+primOpTag (VecBroadcastOp IntVec 8 W32) = 553+primOpTag (VecBroadcastOp IntVec 4 W64) = 554+primOpTag (VecBroadcastOp IntVec 64 W8) = 555+primOpTag (VecBroadcastOp IntVec 32 W16) = 556+primOpTag (VecBroadcastOp IntVec 16 W32) = 557+primOpTag (VecBroadcastOp IntVec 8 W64) = 558+primOpTag (VecBroadcastOp WordVec 16 W8) = 559+primOpTag (VecBroadcastOp WordVec 8 W16) = 560+primOpTag (VecBroadcastOp WordVec 4 W32) = 561+primOpTag (VecBroadcastOp WordVec 2 W64) = 562+primOpTag (VecBroadcastOp WordVec 32 W8) = 563+primOpTag (VecBroadcastOp WordVec 16 W16) = 564+primOpTag (VecBroadcastOp WordVec 8 W32) = 565+primOpTag (VecBroadcastOp WordVec 4 W64) = 566+primOpTag (VecBroadcastOp WordVec 64 W8) = 567+primOpTag (VecBroadcastOp WordVec 32 W16) = 568+primOpTag (VecBroadcastOp WordVec 16 W32) = 569+primOpTag (VecBroadcastOp WordVec 8 W64) = 570+primOpTag (VecBroadcastOp FloatVec 4 W32) = 571+primOpTag (VecBroadcastOp FloatVec 2 W64) = 572+primOpTag (VecBroadcastOp FloatVec 8 W32) = 573+primOpTag (VecBroadcastOp FloatVec 4 W64) = 574+primOpTag (VecBroadcastOp FloatVec 16 W32) = 575+primOpTag (VecBroadcastOp FloatVec 8 W64) = 576+primOpTag (VecPackOp IntVec 16 W8) = 577+primOpTag (VecPackOp IntVec 8 W16) = 578+primOpTag (VecPackOp IntVec 4 W32) = 579+primOpTag (VecPackOp IntVec 2 W64) = 580+primOpTag (VecPackOp IntVec 32 W8) = 581+primOpTag (VecPackOp IntVec 16 W16) = 582+primOpTag (VecPackOp IntVec 8 W32) = 583+primOpTag (VecPackOp IntVec 4 W64) = 584+primOpTag (VecPackOp IntVec 64 W8) = 585+primOpTag (VecPackOp IntVec 32 W16) = 586+primOpTag (VecPackOp IntVec 16 W32) = 587+primOpTag (VecPackOp IntVec 8 W64) = 588+primOpTag (VecPackOp WordVec 16 W8) = 589+primOpTag (VecPackOp WordVec 8 W16) = 590+primOpTag (VecPackOp WordVec 4 W32) = 591+primOpTag (VecPackOp WordVec 2 W64) = 592+primOpTag (VecPackOp WordVec 32 W8) = 593+primOpTag (VecPackOp WordVec 16 W16) = 594+primOpTag (VecPackOp WordVec 8 W32) = 595+primOpTag (VecPackOp WordVec 4 W64) = 596+primOpTag (VecPackOp WordVec 64 W8) = 597+primOpTag (VecPackOp WordVec 32 W16) = 598+primOpTag (VecPackOp WordVec 16 W32) = 599+primOpTag (VecPackOp WordVec 8 W64) = 600+primOpTag (VecPackOp FloatVec 4 W32) = 601+primOpTag (VecPackOp FloatVec 2 W64) = 602+primOpTag (VecPackOp FloatVec 8 W32) = 603+primOpTag (VecPackOp FloatVec 4 W64) = 604+primOpTag (VecPackOp FloatVec 16 W32) = 605+primOpTag (VecPackOp FloatVec 8 W64) = 606+primOpTag (VecUnpackOp IntVec 16 W8) = 607+primOpTag (VecUnpackOp IntVec 8 W16) = 608+primOpTag (VecUnpackOp IntVec 4 W32) = 609+primOpTag (VecUnpackOp IntVec 2 W64) = 610+primOpTag (VecUnpackOp IntVec 32 W8) = 611+primOpTag (VecUnpackOp IntVec 16 W16) = 612+primOpTag (VecUnpackOp IntVec 8 W32) = 613+primOpTag (VecUnpackOp IntVec 4 W64) = 614+primOpTag (VecUnpackOp IntVec 64 W8) = 615+primOpTag (VecUnpackOp IntVec 32 W16) = 616+primOpTag (VecUnpackOp IntVec 16 W32) = 617+primOpTag (VecUnpackOp IntVec 8 W64) = 618+primOpTag (VecUnpackOp WordVec 16 W8) = 619+primOpTag (VecUnpackOp WordVec 8 W16) = 620+primOpTag (VecUnpackOp WordVec 4 W32) = 621+primOpTag (VecUnpackOp WordVec 2 W64) = 622+primOpTag (VecUnpackOp WordVec 32 W8) = 623+primOpTag (VecUnpackOp WordVec 16 W16) = 624+primOpTag (VecUnpackOp WordVec 8 W32) = 625+primOpTag (VecUnpackOp WordVec 4 W64) = 626+primOpTag (VecUnpackOp WordVec 64 W8) = 627+primOpTag (VecUnpackOp WordVec 32 W16) = 628+primOpTag (VecUnpackOp WordVec 16 W32) = 629+primOpTag (VecUnpackOp WordVec 8 W64) = 630+primOpTag (VecUnpackOp FloatVec 4 W32) = 631+primOpTag (VecUnpackOp FloatVec 2 W64) = 632+primOpTag (VecUnpackOp FloatVec 8 W32) = 633+primOpTag (VecUnpackOp FloatVec 4 W64) = 634+primOpTag (VecUnpackOp FloatVec 16 W32) = 635+primOpTag (VecUnpackOp FloatVec 8 W64) = 636+primOpTag (VecInsertOp IntVec 16 W8) = 637+primOpTag (VecInsertOp IntVec 8 W16) = 638+primOpTag (VecInsertOp IntVec 4 W32) = 639+primOpTag (VecInsertOp IntVec 2 W64) = 640+primOpTag (VecInsertOp IntVec 32 W8) = 641+primOpTag (VecInsertOp IntVec 16 W16) = 642+primOpTag (VecInsertOp IntVec 8 W32) = 643+primOpTag (VecInsertOp IntVec 4 W64) = 644+primOpTag (VecInsertOp IntVec 64 W8) = 645+primOpTag (VecInsertOp IntVec 32 W16) = 646+primOpTag (VecInsertOp IntVec 16 W32) = 647+primOpTag (VecInsertOp IntVec 8 W64) = 648+primOpTag (VecInsertOp WordVec 16 W8) = 649+primOpTag (VecInsertOp WordVec 8 W16) = 650+primOpTag (VecInsertOp WordVec 4 W32) = 651+primOpTag (VecInsertOp WordVec 2 W64) = 652+primOpTag (VecInsertOp WordVec 32 W8) = 653+primOpTag (VecInsertOp WordVec 16 W16) = 654+primOpTag (VecInsertOp WordVec 8 W32) = 655+primOpTag (VecInsertOp WordVec 4 W64) = 656+primOpTag (VecInsertOp WordVec 64 W8) = 657+primOpTag (VecInsertOp WordVec 32 W16) = 658+primOpTag (VecInsertOp WordVec 16 W32) = 659+primOpTag (VecInsertOp WordVec 8 W64) = 660+primOpTag (VecInsertOp FloatVec 4 W32) = 661+primOpTag (VecInsertOp FloatVec 2 W64) = 662+primOpTag (VecInsertOp FloatVec 8 W32) = 663+primOpTag (VecInsertOp FloatVec 4 W64) = 664+primOpTag (VecInsertOp FloatVec 16 W32) = 665+primOpTag (VecInsertOp FloatVec 8 W64) = 666+primOpTag (VecAddOp IntVec 16 W8) = 667+primOpTag (VecAddOp IntVec 8 W16) = 668+primOpTag (VecAddOp IntVec 4 W32) = 669+primOpTag (VecAddOp IntVec 2 W64) = 670+primOpTag (VecAddOp IntVec 32 W8) = 671+primOpTag (VecAddOp IntVec 16 W16) = 672+primOpTag (VecAddOp IntVec 8 W32) = 673+primOpTag (VecAddOp IntVec 4 W64) = 674+primOpTag (VecAddOp IntVec 64 W8) = 675+primOpTag (VecAddOp IntVec 32 W16) = 676+primOpTag (VecAddOp IntVec 16 W32) = 677+primOpTag (VecAddOp IntVec 8 W64) = 678+primOpTag (VecAddOp WordVec 16 W8) = 679+primOpTag (VecAddOp WordVec 8 W16) = 680+primOpTag (VecAddOp WordVec 4 W32) = 681+primOpTag (VecAddOp WordVec 2 W64) = 682+primOpTag (VecAddOp WordVec 32 W8) = 683+primOpTag (VecAddOp WordVec 16 W16) = 684+primOpTag (VecAddOp WordVec 8 W32) = 685+primOpTag (VecAddOp WordVec 4 W64) = 686+primOpTag (VecAddOp WordVec 64 W8) = 687+primOpTag (VecAddOp WordVec 32 W16) = 688+primOpTag (VecAddOp WordVec 16 W32) = 689+primOpTag (VecAddOp WordVec 8 W64) = 690+primOpTag (VecAddOp FloatVec 4 W32) = 691+primOpTag (VecAddOp FloatVec 2 W64) = 692+primOpTag (VecAddOp FloatVec 8 W32) = 693+primOpTag (VecAddOp FloatVec 4 W64) = 694+primOpTag (VecAddOp FloatVec 16 W32) = 695+primOpTag (VecAddOp FloatVec 8 W64) = 696+primOpTag (VecSubOp IntVec 16 W8) = 697+primOpTag (VecSubOp IntVec 8 W16) = 698+primOpTag (VecSubOp IntVec 4 W32) = 699+primOpTag (VecSubOp IntVec 2 W64) = 700+primOpTag (VecSubOp IntVec 32 W8) = 701+primOpTag (VecSubOp IntVec 16 W16) = 702+primOpTag (VecSubOp IntVec 8 W32) = 703+primOpTag (VecSubOp IntVec 4 W64) = 704+primOpTag (VecSubOp IntVec 64 W8) = 705+primOpTag (VecSubOp IntVec 32 W16) = 706+primOpTag (VecSubOp IntVec 16 W32) = 707+primOpTag (VecSubOp IntVec 8 W64) = 708+primOpTag (VecSubOp WordVec 16 W8) = 709+primOpTag (VecSubOp WordVec 8 W16) = 710+primOpTag (VecSubOp WordVec 4 W32) = 711+primOpTag (VecSubOp WordVec 2 W64) = 712+primOpTag (VecSubOp WordVec 32 W8) = 713+primOpTag (VecSubOp WordVec 16 W16) = 714+primOpTag (VecSubOp WordVec 8 W32) = 715+primOpTag (VecSubOp WordVec 4 W64) = 716+primOpTag (VecSubOp WordVec 64 W8) = 717+primOpTag (VecSubOp WordVec 32 W16) = 718+primOpTag (VecSubOp WordVec 16 W32) = 719+primOpTag (VecSubOp WordVec 8 W64) = 720+primOpTag (VecSubOp FloatVec 4 W32) = 721+primOpTag (VecSubOp FloatVec 2 W64) = 722+primOpTag (VecSubOp FloatVec 8 W32) = 723+primOpTag (VecSubOp FloatVec 4 W64) = 724+primOpTag (VecSubOp FloatVec 16 W32) = 725+primOpTag (VecSubOp FloatVec 8 W64) = 726+primOpTag (VecMulOp IntVec 16 W8) = 727+primOpTag (VecMulOp IntVec 8 W16) = 728+primOpTag (VecMulOp IntVec 4 W32) = 729+primOpTag (VecMulOp IntVec 2 W64) = 730+primOpTag (VecMulOp IntVec 32 W8) = 731+primOpTag (VecMulOp IntVec 16 W16) = 732+primOpTag (VecMulOp IntVec 8 W32) = 733+primOpTag (VecMulOp IntVec 4 W64) = 734+primOpTag (VecMulOp IntVec 64 W8) = 735+primOpTag (VecMulOp IntVec 32 W16) = 736+primOpTag (VecMulOp IntVec 16 W32) = 737+primOpTag (VecMulOp IntVec 8 W64) = 738+primOpTag (VecMulOp WordVec 16 W8) = 739+primOpTag (VecMulOp WordVec 8 W16) = 740+primOpTag (VecMulOp WordVec 4 W32) = 741+primOpTag (VecMulOp WordVec 2 W64) = 742+primOpTag (VecMulOp WordVec 32 W8) = 743+primOpTag (VecMulOp WordVec 16 W16) = 744+primOpTag (VecMulOp WordVec 8 W32) = 745+primOpTag (VecMulOp WordVec 4 W64) = 746+primOpTag (VecMulOp WordVec 64 W8) = 747+primOpTag (VecMulOp WordVec 32 W16) = 748+primOpTag (VecMulOp WordVec 16 W32) = 749+primOpTag (VecMulOp WordVec 8 W64) = 750+primOpTag (VecMulOp FloatVec 4 W32) = 751+primOpTag (VecMulOp FloatVec 2 W64) = 752+primOpTag (VecMulOp FloatVec 8 W32) = 753+primOpTag (VecMulOp FloatVec 4 W64) = 754+primOpTag (VecMulOp FloatVec 16 W32) = 755+primOpTag (VecMulOp FloatVec 8 W64) = 756+primOpTag (VecDivOp FloatVec 4 W32) = 757+primOpTag (VecDivOp FloatVec 2 W64) = 758+primOpTag (VecDivOp FloatVec 8 W32) = 759+primOpTag (VecDivOp FloatVec 4 W64) = 760+primOpTag (VecDivOp FloatVec 16 W32) = 761+primOpTag (VecDivOp FloatVec 8 W64) = 762+primOpTag (VecQuotOp IntVec 16 W8) = 763+primOpTag (VecQuotOp IntVec 8 W16) = 764+primOpTag (VecQuotOp IntVec 4 W32) = 765+primOpTag (VecQuotOp IntVec 2 W64) = 766+primOpTag (VecQuotOp IntVec 32 W8) = 767+primOpTag (VecQuotOp IntVec 16 W16) = 768+primOpTag (VecQuotOp IntVec 8 W32) = 769+primOpTag (VecQuotOp IntVec 4 W64) = 770+primOpTag (VecQuotOp IntVec 64 W8) = 771+primOpTag (VecQuotOp IntVec 32 W16) = 772+primOpTag (VecQuotOp IntVec 16 W32) = 773+primOpTag (VecQuotOp IntVec 8 W64) = 774+primOpTag (VecQuotOp WordVec 16 W8) = 775+primOpTag (VecQuotOp WordVec 8 W16) = 776+primOpTag (VecQuotOp WordVec 4 W32) = 777+primOpTag (VecQuotOp WordVec 2 W64) = 778+primOpTag (VecQuotOp WordVec 32 W8) = 779+primOpTag (VecQuotOp WordVec 16 W16) = 780+primOpTag (VecQuotOp WordVec 8 W32) = 781+primOpTag (VecQuotOp WordVec 4 W64) = 782+primOpTag (VecQuotOp WordVec 64 W8) = 783+primOpTag (VecQuotOp WordVec 32 W16) = 784+primOpTag (VecQuotOp WordVec 16 W32) = 785+primOpTag (VecQuotOp WordVec 8 W64) = 786+primOpTag (VecRemOp IntVec 16 W8) = 787+primOpTag (VecRemOp IntVec 8 W16) = 788+primOpTag (VecRemOp IntVec 4 W32) = 789+primOpTag (VecRemOp IntVec 2 W64) = 790+primOpTag (VecRemOp IntVec 32 W8) = 791+primOpTag (VecRemOp IntVec 16 W16) = 792+primOpTag (VecRemOp IntVec 8 W32) = 793+primOpTag (VecRemOp IntVec 4 W64) = 794+primOpTag (VecRemOp IntVec 64 W8) = 795+primOpTag (VecRemOp IntVec 32 W16) = 796+primOpTag (VecRemOp IntVec 16 W32) = 797+primOpTag (VecRemOp IntVec 8 W64) = 798+primOpTag (VecRemOp WordVec 16 W8) = 799+primOpTag (VecRemOp WordVec 8 W16) = 800+primOpTag (VecRemOp WordVec 4 W32) = 801+primOpTag (VecRemOp WordVec 2 W64) = 802+primOpTag (VecRemOp WordVec 32 W8) = 803+primOpTag (VecRemOp WordVec 16 W16) = 804+primOpTag (VecRemOp WordVec 8 W32) = 805+primOpTag (VecRemOp WordVec 4 W64) = 806+primOpTag (VecRemOp WordVec 64 W8) = 807+primOpTag (VecRemOp WordVec 32 W16) = 808+primOpTag (VecRemOp WordVec 16 W32) = 809+primOpTag (VecRemOp WordVec 8 W64) = 810+primOpTag (VecNegOp IntVec 16 W8) = 811+primOpTag (VecNegOp IntVec 8 W16) = 812+primOpTag (VecNegOp IntVec 4 W32) = 813+primOpTag (VecNegOp IntVec 2 W64) = 814+primOpTag (VecNegOp IntVec 32 W8) = 815+primOpTag (VecNegOp IntVec 16 W16) = 816+primOpTag (VecNegOp IntVec 8 W32) = 817+primOpTag (VecNegOp IntVec 4 W64) = 818+primOpTag (VecNegOp IntVec 64 W8) = 819+primOpTag (VecNegOp IntVec 32 W16) = 820+primOpTag (VecNegOp IntVec 16 W32) = 821+primOpTag (VecNegOp IntVec 8 W64) = 822+primOpTag (VecNegOp FloatVec 4 W32) = 823+primOpTag (VecNegOp FloatVec 2 W64) = 824+primOpTag (VecNegOp FloatVec 8 W32) = 825+primOpTag (VecNegOp FloatVec 4 W64) = 826+primOpTag (VecNegOp FloatVec 16 W32) = 827+primOpTag (VecNegOp FloatVec 8 W64) = 828+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 829+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 830+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 831+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 832+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 833+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 834+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 835+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 836+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 837+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 838+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 839+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 840+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 841+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 842+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 843+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 844+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 845+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 846+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 847+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 848+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 849+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 850+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 851+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 852+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 853+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 854+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 855+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 856+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 857+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 858+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 859+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 860+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 861+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 862+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 863+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 864+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 865+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 866+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 867+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 868+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 869+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 870+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 871+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 872+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 873+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 874+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 875+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 876+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 877+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 878+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 879+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 880+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 881+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 882+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 883+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 884+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 885+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 886+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 887+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 888+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 889+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 890+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 891+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 892+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 893+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 894+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 895+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 896+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 897+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 898+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 899+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 900+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 901+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 902+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 903+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 904+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 905+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 906+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 907+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 908+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 909+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 910+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 911+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 912+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 913+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 914+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 915+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 916+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 917+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 918+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 919+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 920+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 921+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 922+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 923+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 924+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 925+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 926+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 927+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 928+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 929+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 930+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 931+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 932+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 933+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 934+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 935+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 936+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 937+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 938+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 939+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 940+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 941+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 942+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 943+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 944+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 945+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 946+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 947+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 948+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 949+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 950+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 951+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 952+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 953+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 954+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 955+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 956+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 957+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 958+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 959+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 960+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 961+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 962+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 963+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 964+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 965+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 966+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 967+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 968+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 969+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 970+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 971+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 972+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 973+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 974+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 975+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 976+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 977+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 978+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 979+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 980+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 981+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 982+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 983+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 984+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 985+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 986+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 987+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 988+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 989+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 990+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 991+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 992+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 993+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 994+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 995+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 996+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 997+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 998+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 999+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1000+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1001+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1002+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1003+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1004+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1005+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1006+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1007+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1008+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1009+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1014+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1015+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1017+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1018+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1019+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1020+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1021+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1026+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1027+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1029+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1030+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1031+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1032+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1033+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1034+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1035+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1036+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1037+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1038+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1039+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1044+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1045+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1047+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1048+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1049+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1050+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1051+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1056+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1057+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1059+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1060+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1061+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1062+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1063+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1064+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1065+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1066+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1067+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1068+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1069+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1074+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1075+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1077+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1078+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1079+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1080+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1081+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1086+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1087+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1089+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1090+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1091+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1092+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1093+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1094+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1095+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1096+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1097+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1098+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1099+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1104+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1105+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1107+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1108+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1109+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1110+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1111+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1116+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1117+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1119+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1120+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1121+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1122+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1123+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1124+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1125+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1126+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1127+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1128+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1129+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1134+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1135+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1137+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1138+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1139+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1140+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1141+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1146+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1147+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1149+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1150+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1151+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1152+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1153+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1154+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1155+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1156+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1157+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1158+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1159+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1164+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1165+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1167+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1168+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1169+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1170+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1171+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1176+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1177+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1179+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1180+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1181+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1182+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1183+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1184+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1185+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1186+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1187+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1188+primOpTag PrefetchByteArrayOp3 = 1189+primOpTag PrefetchMutableByteArrayOp3 = 1190+primOpTag PrefetchAddrOp3 = 1191+primOpTag PrefetchValueOp3 = 1192+primOpTag PrefetchByteArrayOp2 = 1193+primOpTag PrefetchMutableByteArrayOp2 = 1194+primOpTag PrefetchAddrOp2 = 1195+primOpTag PrefetchValueOp2 = 1196+primOpTag PrefetchByteArrayOp1 = 1197+primOpTag PrefetchMutableByteArrayOp1 = 1198+primOpTag PrefetchAddrOp1 = 1199+primOpTag PrefetchValueOp1 = 1200+primOpTag PrefetchByteArrayOp0 = 1201+primOpTag PrefetchMutableByteArrayOp0 = 1202+primOpTag PrefetchAddrOp0 = 1203+primOpTag PrefetchValueOp0 = 1204
ghc-lib/stage0/lib/DerivedConstants.h view
@@ -491,22 +491,22 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 277+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 285 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 220+#define OFFSET_RtsFlags_DebugFlags_apply 228 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 215+#define OFFSET_RtsFlags_DebugFlags_sanity 223 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 210+#define OFFSET_RtsFlags_DebugFlags_weak 218 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16 #define REP_RtsFlags_GcFlags_initialStkSize b32 #define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 184+#define OFFSET_RtsFlags_MiscFlags_tickInterval 192 #define REP_RtsFlags_MiscFlags_tickInterval b64 #define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval] #define SIZEOF_StgFunInfoExtraFwd 32
ghc-lib/stage0/lib/ghcversion.h view
@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20191201+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200101  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
libraries/ghci/GHCi/CreateBCO.hs view
@@ -23,6 +23,7 @@ import Control.Monad import Data.Array.Base import Foreign hiding (newArray)+import Unsafe.Coerce (unsafeCoerce) import GHC.Arr          ( Array(..) ) import GHC.Exts import GHC.IO@@ -45,6 +46,8 @@                 ]) createBCO arr bco    = do BCO bco# <- linkBCO' arr bco+        -- Note [Updatable CAF BCOs]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~         -- Why do we need mkApUpd0 here?  Otherwise top-level         -- interpreted CAFs don't get updated after evaluation.  A         -- top-level BCO will evaluate itself and return its value@@ -57,6 +60,7 @@         --   (c) An AP is always fully saturated, so we *can't* wrap         --       non-zero arity BCOs in an AP thunk.         --+        -- See #17424.         if (resolvedBCOArity bco > 0)            then return (HValue (unsafeCoerce# bco#))            else case mkApUpd0# bco# of { (# final_bco #) ->@@ -135,7 +139,6 @@   case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)  data BCO = BCO BCO#- writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->   case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)@@ -146,7 +149,7 @@     (# s1, bco #) -> (# s1, BCO bco #)  {- Note [BCO empty array]-+   ~~~~~~~~~~~~~~~~~~~~~~ Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free: they are 2-word heap objects.  So let's make a single empty array and share it between all BCOs.