diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CoreToStg.hs @@ -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 "") -- XXX do better + all_cafs_cc = mkAllCafsCC this_mod span + all_cafs_ccs = mkSingletonCCS all_cafs_cc + in + (all_cafs_cc, all_cafs_ccs) + +-- Misc. + +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs = filter isId bndrs + +myCollectBinders :: Expr Var -> ([Var], Expr Var) +myCollectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs (Cast e _) = go bs e + go bs e = (reverse bs, e) + +-- | Precondition: argument expression is an 'App', and there is a 'Var' at the +-- head of the 'App' chain. +myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) +myCollectArgs expr + = go expr [] [] + where + go (Var v) as ts = (v, as, ts) + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts = ASSERT( all isTypeArg as ) + go e as (t:ts) -- ticks can appear in type apps + go (Cast e _) as ts = go e as ts + go (Lam b e) as ts + | isTyVar b = go e as ts -- Note [Collect args] + go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) + +-- Note [Collect args] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- This big-lambda case occurred following a rather obscure eta expansion. +-- It all seems a bit yukky to me. + +stgArity :: Id -> HowBound -> Arity +stgArity _ (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity _ LambdaBound = 0 diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -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@). diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/CSE.hs @@ -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. +-} diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/FVs.hs @@ -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 diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Lift.hs @@ -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 +-- 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 diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -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 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 +-- . + +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 diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -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 "" + 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 diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Lint.hs @@ -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) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Stats.hs @@ -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" diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Subst.hs @@ -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) diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Syntax.hs @@ -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 = 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 = +-- 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)] diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Stg/Unarise.hs @@ -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 = + + 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 , 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 #) -> + } + + 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) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Bind.hs-boot b/compiler/GHC/StgToCmm/Bind.hs-boot --- a/compiler/GHC/StgToCmm/Bind.hs-boot +++ b/compiler/GHC/StgToCmm/Bind.hs-boot @@ -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 () diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -41,7 +41,7 @@ import MkGraph import Name import Outputable -import StgSyn +import GHC.Stg.Syntax import Type import TysPrim import UniqFM diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -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) diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -22,7 +22,7 @@ import GhcPrelude hiding ((<*>)) -import StgSyn +import GHC.Stg.Syntax import CLabel import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -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 ) diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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: -- diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -111,7 +111,7 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad -import StgSyn +import GHC.Stg.Syntax import CmmExpr import MkGraph import CmmUtils diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -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 diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -583,6 +583,7 @@ | MO_UF_Conv Width + | MO_S_Mul2 Width | MO_S_QuotRem Width | MO_U_QuotRem Width | MO_U_QuotRem2 Width diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -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 diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -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 diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -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) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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 diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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, diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs deleted file mode 100644 --- a/compiler/coreSyn/CorePrep.hs +++ /dev/null @@ -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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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) } diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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) diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -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 diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -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 diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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) ---------------------------------------------------------- diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -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. diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -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 = diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -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 diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -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']) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -33,7 +33,7 @@ import DataCon import Type -import RepType +import GHC.Types.RepType import qualified Unify as U import Var import TcRnMonad diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -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 diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -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 = diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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, diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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" diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -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. diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -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 \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 diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs --- a/compiler/main/Elf.hs +++ b/compiler/main/Elf.hs @@ -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"] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -196,7 +196,7 @@ -- ** Data constructors DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConType, dataConTyCon, dataConFieldLabels, dataConIsInfix, isVanillaDataCon, dataConUserType, dataConSrcBangs, StrictnessMark(..), isMarkedStrict, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -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]) diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs --- a/compiler/main/SysTools/Info.hs +++ b/compiler/main/SysTools/Info.hs @@ -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. diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -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) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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. diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs --- a/compiler/nativeGen/BlockLayout.hs +++ b/compiler/nativeGen/BlockLayout.hs @@ -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 diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -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 diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -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 diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -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 diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -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 diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -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@. diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -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 diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -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"]); diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -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]) diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -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 diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -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) } {- diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -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! diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -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 = diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs deleted file mode 100644 --- a/compiler/simplStg/SimplStg.hs +++ /dev/null @@ -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 diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs deleted file mode 100644 --- a/compiler/simplStg/StgCse.hs +++ /dev/null @@ -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. --} diff --git a/compiler/simplStg/StgLiftLams.hs b/compiler/simplStg/StgLiftLams.hs deleted file mode 100644 --- a/compiler/simplStg/StgLiftLams.hs +++ /dev/null @@ -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 --- 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 --- @ diff --git a/compiler/simplStg/StgLiftLams/Analysis.hs b/compiler/simplStg/StgLiftLams/Analysis.hs deleted file mode 100644 --- a/compiler/simplStg/StgLiftLams/Analysis.hs +++ /dev/null @@ -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 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 --- . - -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 diff --git a/compiler/simplStg/StgLiftLams/LiftM.hs b/compiler/simplStg/StgLiftLams/LiftM.hs deleted file mode 100644 --- a/compiler/simplStg/StgLiftLams/LiftM.hs +++ /dev/null @@ -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 "" - 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 diff --git a/compiler/simplStg/StgLiftLams/Transformation.hs b/compiler/simplStg/StgLiftLams/Transformation.hs deleted file mode 100644 --- a/compiler/simplStg/StgLiftLams/Transformation.hs +++ /dev/null @@ -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 diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs deleted file mode 100644 --- a/compiler/simplStg/StgStats.hs +++ /dev/null @@ -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" diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs deleted file mode 100644 --- a/compiler/simplStg/UnariseStg.hs +++ /dev/null @@ -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 = - - 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 , 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 #) -> - } - - 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) diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -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 diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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 } diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs deleted file mode 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ /dev/null @@ -1,939 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} - --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 --- - --------------------------------------------------------------- --- Converting Core to STG Syntax --------------------------------------------------------------- - --- And, as we have the info in hand, we may convert some lets to --- let-no-escapes. - -module CoreToStg ( coreToStg ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn -import CoreUtils ( exprType, findDefault, isJoinBind - , exprIsTickedString_maybe ) -import CoreArity ( manifestArity ) -import StgSyn - -import Type -import RepType -import TyCon -import MkId ( coercionTokenId ) -import Id -import IdInfo -import DataCon -import CostCentre -import VarEnv -import Module -import Name ( isExternalName, nameOccName, nameModule_maybe ) -import OccName ( occNameFS ) -import BasicTypes ( Arity ) -import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) -import Literal -import Outputable -import MonadUtils -import FastString -import Util -import DynFlags -import ForeignCall -import Demand ( isUsedOnce ) -import PrimOp ( PrimCall(..), primOpWrapperId ) -import SrcLoc ( mkGeneralSrcSpan ) - -import Data.List.NonEmpty (nonEmpty, toList) -import Data.Maybe (fromMaybe) -import Control.Monad (ap) - --- Note [Live vs free] --- ~~~~~~~~~~~~~~~~~~~ --- --- The two are not the same. Liveness is an operational property rather --- than a semantic one. A variable is live at a particular execution --- point if it can be referred to directly again. In particular, a dead --- variable's stack slot (if it has one): --- --- - should be stubbed to avoid space leaks, and --- - may be reused for something else. --- --- There ought to be a better way to say this. Here are some examples: --- --- let v = [q] \[x] -> e --- in --- ...v... (but no q's) --- --- Just after the `in', v is live, but q is dead. If the whole of that --- let expression was enclosed in a case expression, thus: --- --- case (let v = [q] \[x] -> e in ...v...) of --- alts[...q...] --- --- (ie `alts' mention `q'), then `q' is live even after the `in'; because --- we'll return later to the `alts' and need it. --- --- Let-no-escapes make this a bit more interesting: --- --- let-no-escape v = [q] \ [x] -> e --- in --- ...v... --- --- Here, `q' is still live at the `in', because `v' is represented not by --- a closure but by the current stack state. In other words, if `v' is --- live then so is `q'. Furthermore, if `e' mentions an enclosing --- let-no-escaped variable, then its free variables are also live if `v' is. - --- Note [What are these SRTs all about?] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Consider the Core program, --- --- fibs = go 1 1 --- where go a b = let c = a + c --- in c : go b c --- add x = map (\y -> x*y) fibs --- --- In this case we have a CAF, 'fibs', which is quite large after evaluation and --- has only one possible user, 'add'. Consequently, we want to ensure that when --- all references to 'add' die we can garbage collect any bit of 'fibs' that we --- have evaluated. --- --- However, how do we know whether there are any references to 'fibs' still --- around? Afterall, the only reference to it is buried in the code generated --- for 'add'. The answer is that we record the CAFs referred to by a definition --- in its info table, namely a part of it known as the Static Reference Table --- (SRT). --- --- Since SRTs are so common, we use a special compact encoding for them in: we --- produce one table containing a list of CAFs in a module and then include a --- bitmap in each info table describing which entries of this table the closure --- references. --- --- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki. - --- Note [What is a non-escaping let] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- NB: Nowadays this is recognized by the occurrence analyser by turning a --- "non-escaping let" into a join point. The following is then an operational --- account of join points. --- --- Consider: --- --- let x = fvs \ args -> e --- in --- if ... then x else --- if ... then x else ... --- --- `x' is used twice (so we probably can't unfold it), but when it is --- entered, the stack is deeper than it was when the definition of `x' --- happened. Specifically, if instead of allocating a closure for `x', --- we saved all `x's fvs on the stack, and remembered the stack depth at --- that moment, then whenever we enter `x' we can simply set the stack --- pointer(s) to these remembered (compile-time-fixed) values, and jump --- to the code for `x'. --- --- All of this is provided x is: --- 1. non-updatable; --- 2. guaranteed to be entered before the stack retreats -- ie x is not --- buried in a heap-allocated closure, or passed as an argument to --- something; --- 3. all the enters have exactly the right number of arguments, --- no more no less; --- 4. all the enters are tail calls; that is, they return to the --- caller enclosing the definition of `x'. --- --- Under these circumstances we say that `x' is non-escaping. --- --- An example of when (4) does not hold: --- --- let x = ... --- in case x of ...alts... --- --- Here, `x' is certainly entered only when the stack is deeper than when --- `x' is defined, but here it must return to ...alts... So we can't just --- adjust the stack down to `x''s recalled points, because that would lost --- alts' context. --- --- Things can get a little more complicated. Consider: --- --- let y = ... --- in let x = fvs \ args -> ...y... --- in ...x... --- --- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a --- non-escaping way in ...y..., then `y' is non-escaping. --- --- `x' can even be recursive! Eg: --- --- letrec x = [y] \ [v] -> if v then x True else ... --- in --- ...(x b)... - --- Note [Cost-centre initialization plan] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`, --- and the fields were then fixed by a separate pass `stgMassageForProfiling`. --- We now initialize these correctly. The initialization works like this: --- --- - For non-top level bindings always use `currentCCS`. --- --- - For top-level bindings, check if the binding is a CAF --- --- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF --- and use it. Note that these new cost centres need to be --- collected to be able to generate cost centre initialization --- code, so `coreToTopStgRhs` now returns `CollectedCCs`. --- --- If -fcaf-all is not enabled, use "all CAFs" cost centre. --- --- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor --- do we set CCCS from it; so we just slam in --- dontCareCostCentre. - --- -------------------------------------------------------------- --- Setting variable info: top-level, binds, RHSs --- -------------------------------------------------------------- - -coreToStg :: DynFlags -> Module -> CoreProgram - -> ([StgTopBinding], CollectedCCs) -coreToStg dflags this_mod pgm - = (pgm', final_ccs) - where - (_, (local_ccs, local_cc_stacks), pgm') - = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm - - prof = WayProf `elem` ways dflags - - final_ccs - | prof && gopt Opt_AutoSccsOnIndividualCafs dflags - = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC - | prof - = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) - | otherwise - = emptyCollectedCCs - - (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod - -coreTopBindsToStg - :: DynFlags - -> Module - -> IdEnv HowBound -- environment for the bindings - -> CollectedCCs - -> CoreProgram - -> (IdEnv HowBound, CollectedCCs, [StgTopBinding]) - -coreTopBindsToStg _ _ env ccs [] - = (env, ccs, []) -coreTopBindsToStg dflags this_mod env ccs (b:bs) - = (env2, ccs2, b':bs') - where - (env1, ccs1, b' ) = - coreTopBindToStg dflags this_mod env ccs b - (env2, ccs2, bs') = - coreTopBindsToStg dflags this_mod env1 ccs1 bs - -coreTopBindToStg - :: DynFlags - -> Module - -> IdEnv HowBound - -> CollectedCCs - -> CoreBind - -> (IdEnv HowBound, CollectedCCs, StgTopBinding) - -coreTopBindToStg _ _ env ccs (NonRec id e) - | Just str <- exprIsTickedString_maybe e - -- top-level string literal - -- See Note [CoreSyn top-level string literals] in CoreSyn - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet 0 - in (env', ccs, StgTopStringLit id str) - -coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) - = let - env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet $! manifestArity rhs - - (stg_rhs, ccs') = - initCts dflags env $ - coreToTopStgRhs dflags ccs this_mod (id,rhs) - - bind = StgTopLifted $ StgNonRec id stg_rhs - in - assertConsistentCafInfo dflags id bind (ppr bind) - -- NB: previously the assertion printed 'rhs' and 'bind' - -- as well as 'id', but that led to a black hole - -- where printing the assertion error tripped the - -- assertion again! - (env', ccs', bind) - -coreTopBindToStg dflags this_mod env ccs (Rec pairs) - = ASSERT( not (null pairs) ) - let - binders = map fst pairs - - extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) - | (b, rhs) <- pairs ] - env' = extendVarEnvList env extra_env' - - -- generate StgTopBindings and CAF cost centres created for CAFs - (ccs', stg_rhss) - = initCts dflags env' $ do - mapAccumLM (\ccs rhs -> do - (rhs', ccs') <- - coreToTopStgRhs dflags ccs this_mod rhs - return (ccs', rhs')) - ccs - pairs - - bind = StgTopLifted $ StgRec (zip binders stg_rhss) - in - assertConsistentCafInfo dflags (head binders) bind (ppr binders) - (env', ccs', bind) - --- | CAF consistency issues will generally result in segfaults and are quite --- difficult to debug (see #16846). We enable checking of the --- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that --- we catch these issues. -assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a -assertConsistentCafInfo dflags id bind err_doc result - | gopt Opt_DoStgLinting dflags || debugIsOn - , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc - | otherwise = result - --- Assertion helper: this checks that the CafInfo on the Id matches --- what CoreToStg has figured out about the binding's SRT. The --- CafInfo will be exact in all cases except when CorePrep has --- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> StgTopBinding -> Bool -consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) - safe - where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = topStgBindHasCafRefs bind - is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" - -coreToTopStgRhs - :: DynFlags - -> CollectedCCs - -> Module - -> (Id,CoreExpr) - -> CtsM (StgRhs, CollectedCCs) - -coreToTopStgRhs dflags ccs this_mod (bndr, rhs) - = do { new_rhs <- coreToStgExpr rhs - - ; let (stg_rhs, ccs') = - mkTopStgRhs dflags this_mod ccs bndr new_rhs - stg_arity = - stgRhsArity stg_rhs - - ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, - ccs') } - where - -- It's vital that the arity on a top-level Id matches - -- the arity of the generated STG binding, else an importing - -- module will use the wrong calling convention - -- (#2844 was an example where this happened) - -- NB1: we can't move the assertion further out without - -- blocking the "knot" tied in coreTopBindsToStg - -- NB2: the arity check is only needed for Ids with External - -- Names, because they are externally visible. The CorePrep - -- pass introduces "sat" things with Local Names and does - -- not bother to set their Arity info, so don't fail for those - arity_ok stg_arity - | isExternalName (idName bndr) = id_arity == stg_arity - | otherwise = True - id_arity = idArity bndr - mk_arity_msg stg_arity - = vcat [ppr bndr, - text "Id arity:" <+> ppr id_arity, - text "STG arity:" <+> ppr stg_arity] - --- --------------------------------------------------------------------------- --- Expressions --- --------------------------------------------------------------------------- - -coreToStgExpr - :: CoreExpr - -> CtsM StgExpr - --- The second and third components can be derived in a simple bottom up pass, not --- dependent on any decisions about which variables will be let-no-escaped or --- not. The first component, that is, the decorated expression, may then depend --- on these components, but it in turn is not scrutinised as the basis for any --- decisions. Hence no black holes. - --- No LitInteger's or LitNatural's should be left by the time this is called. --- CorePrep should have converted them all to a real core representation. -coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger" -coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural" -coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) - -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in - -- a STG to Cmm pass. - = coreToStgExpr (Var unitDataConId) -coreToStgExpr (Var v) = coreToStgApp v [] [] -coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] [] - -coreToStgExpr expr@(App _ _) - = coreToStgApp f args ticks - where - (f, args, ticks) = myCollectArgs expr - -coreToStgExpr expr@(Lam _ _) - = let - (args, body) = myCollectBinders expr - args' = filterStgBinders args - in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - let - result_expr = case nonEmpty args' of - Nothing -> body' - Just args'' -> StgLam args'' body' - - return result_expr - -coreToStgExpr (Tick tick expr) - = do case tick of - HpcTick{} -> return () - ProfNote{} -> return () - SourceNote{} -> return () - Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" - expr2 <- coreToStgExpr expr - return (StgTick tick expr2) - -coreToStgExpr (Cast expr _) - = coreToStgExpr expr - --- Cases require a little more real work. - -coreToStgExpr (Case scrut _ _ []) - = coreToStgExpr scrut - -- See Note [Empty case alternatives] in CoreSyn If the case - -- alternatives are empty, the scrutinee must diverge or raise an - -- exception, so we can just dive into it. - -- - -- Of course this may seg-fault if the scrutinee *does* return. A - -- belt-and-braces approach would be to move this case into the - -- code generator, and put a return point anyway that calls a - -- runtime system error function. - - -coreToStgExpr (Case scrut bndr _ alts) = do - alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) - scrut2 <- coreToStgExpr scrut - return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) - where - vars_alt (con, binders, rhs) - | DataAlt c <- con, c == unboxedUnitDataCon - = -- This case is a bit smelly. - -- See Note [Nullary unboxed tuple] in Type.hs - -- where a nullary tuple is mapped to (State# World#) - ASSERT( null binders ) - do { rhs2 <- coreToStgExpr rhs - ; return (DEFAULT, [], rhs2) } - | otherwise - = let -- Remove type variables - binders' = filterStgBinders binders - in - extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do - rhs2 <- coreToStgExpr rhs - return (con, binders', rhs2) - -coreToStgExpr (Let bind body) = do - coreToStgLet bind body - -coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) - -mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty - = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples - - | otherwise - = case prim_reps of - [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of - Just tc - | isAbstractTyCon tc -> look_for_better_tycon - | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) - PolyAlt - Nothing -> PolyAlt - [unlifted] -> PrimAlt unlifted - not_unary -> MultiValAlt (length not_unary) - where - bndr_ty = idType bndr - prim_reps = typePrimRep bndr_ty - - _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict - -- function application where argument has a - -- type-family type - - -- Sometimes, the TyCon is a AbstractTyCon which may not have any - -- constructors inside it. Then we may get a better TyCon by - -- grabbing the one from a constructor alternative - -- if one exists. - look_for_better_tycon - | ((DataAlt con, _, _) : _) <- data_alts = - AlgAlt (dataConTyCon con) - | otherwise = - ASSERT(null data_alts) - PolyAlt - where - (data_alts, _deflt) = findDefault alts - --- --------------------------------------------------------------------------- --- Applications --- --------------------------------------------------------------------------- - -coreToStgApp :: Id -- Function - -> [CoreArg] -- Arguments - -> [Tickish Id] -- Debug ticks - -> CtsM StgExpr -coreToStgApp f args ticks = do - (args', ticks') <- coreToStgArgs args - how_bound <- lookupVarCts f - - let - n_val_args = valArgCount args - - -- Mostly, the arity info of a function is in the fn's IdInfo - -- But new bindings introduced by CoreSat may not have no - -- arity info; it would do us no good anyway. For example: - -- let f = \ab -> e in f - -- No point in having correct arity info for f! - -- Hence the hasArity stuff below. - -- NB: f_arity is only consulted for LetBound things - f_arity = stgArity f how_bound - saturated = f_arity <= n_val_args - - res_ty = exprType (mkApps (Var f) args) - app = case idDetails f of - DataConWorkId dc - | saturated -> StgConApp dc args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) - - -- Some primitive operator that might be implemented as a library call. - -- As described in Note [Primop wrappers] in PrimOp.hs, here we - -- turn unsaturated primop applications into applications of - -- the primop's wrapper. - PrimOpId op - | saturated -> StgOpApp (StgPrimOp op) args' res_ty - | otherwise -> StgApp (primOpWrapperId op) args' - - -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) - PrimCallConv _)) - -> ASSERT( saturated ) - StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty - - -- A regular foreign call. - FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idType f)) args' res_ty - - TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') - _other -> StgApp f args' - - tapp = foldr StgTick app (ticks ++ ticks') - - -- Forcing these fixes a leak in the code generator, noticed while - -- profiling for trac #4367 - app `seq` return tapp - --- --------------------------------------------------------------------------- --- Argument lists --- This is the guy that turns applications into A-normal form --- --------------------------------------------------------------------------- - -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id]) -coreToStgArgs [] - = return ([], []) - -coreToStgArgs (Type _ : args) = do -- Type argument - (args', ts) <- coreToStgArgs args - return (args', ts) - -coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder - = do { (args', ts) <- coreToStgArgs args - ; return (StgVarArg coercionTokenId : args', ts) } - -coreToStgArgs (Tick t e : args) - = ASSERT( not (tickishIsCode t) ) - do { (args', ts) <- coreToStgArgs (e : args) - ; return (args', t:ts) } - -coreToStgArgs (arg : args) = do -- Non-type argument - (stg_args, ticks) <- coreToStgArgs args - arg' <- coreToStgExpr arg - let - (aticks, arg'') = stripStgTicksTop tickishFloatable arg' - stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con [] _ -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) - - -- WARNING: what if we have an argument like (v `cast` co) - -- where 'co' changes the representation type? - -- (This really only happens if co is unsafe.) - -- Then all the getArgAmode stuff in CgBindery will set the - -- cg_rep of the CgIdInfo based on the type of v, rather - -- than the type of 'co'. - -- This matters particularly when the function is a primop - -- or foreign call. - -- Wanted: a better solution than this hacky warning - - dflags <- getDynFlags - let - arg_rep = typePrimRep (exprType arg) - stg_arg_rep = typePrimRep (stgArgType stg_arg) - bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep) - - WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) - return (stg_arg : stg_args, ticks ++ aticks) - - --- --------------------------------------------------------------------------- --- The magic for lets: --- --------------------------------------------------------------------------- - -coreToStgLet - :: CoreBind -- bindings - -> CoreExpr -- body - -> CtsM StgExpr -- new let - -coreToStgLet bind body = do - (bind2, body2) - <- do - - ( bind2, env_ext) - <- vars_bind bind - - -- Do the body - extendVarEnvCts env_ext $ do - body2 <- coreToStgExpr body - - return (bind2, body2) - - -- Compute the new let-expression - let - new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2 - | otherwise = StgLet noExtFieldSilent bind2 body2 - - return new_let - where - mk_binding binder rhs - = (binder, LetBound NestedLet (manifestArity rhs)) - - vars_bind :: CoreBind - -> CtsM (StgBinding, - [(Id, HowBound)]) -- extension to environment - - vars_bind (NonRec binder rhs) = do - rhs2 <- coreToStgRhs (binder,rhs) - let - env_ext_item = mk_binding binder rhs - - return (StgNonRec binder rhs2, [env_ext_item]) - - vars_bind (Rec pairs) - = let - binders = map fst pairs - env_ext = [ mk_binding b rhs - | (b,rhs) <- pairs ] - in - extendVarEnvCts env_ext $ do - rhss2 <- mapM coreToStgRhs pairs - return (StgRec (binders `zip` rhss2), env_ext) - -coreToStgRhs :: (Id,CoreExpr) - -> CtsM StgRhs - -coreToStgRhs (bndr, rhs) = do - new_rhs <- coreToStgExpr rhs - return (mkStgRhs bndr new_rhs) - --- Generate a top-level RHS. Any new cost centres generated for CAFs will be --- appended to `CollectedCCs` argument. -mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> Id -> StgExpr -> (StgRhs, CollectedCCs) - -mkTopStgRhs dflags this_mod ccs bndr rhs - | StgLam bndrs body <- rhs - = -- StgLam can't have empty arguments, so not CAF - ( StgRhsClosure noExtFieldSilent - dontCareCCS - ReEntrant - (toList bndrs) body - , ccs ) - - | StgConApp con args _ <- unticked_rhs - , -- Dynamic StgConApps are updatable - not (isDllConApp dflags this_mod con args) - = -- CorePrep does this right, but just to make sure - ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con) - , ppr bndr $$ ppr con $$ ppr args) - ( StgRhsCon dontCareCCS con args, ccs ) - - -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. - | gopt Opt_AutoSccsOnIndividualCafs dflags - = ( StgRhsClosure noExtFieldSilent - caf_ccs - upd_flag [] rhs - , collectCC caf_cc caf_ccs ccs ) - - | otherwise - = ( StgRhsClosure noExtFieldSilent - all_cafs_ccs - upd_flag [] rhs - , ccs ) - - where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable - - -- CAF cost centres generated for -fcaf-all - caf_cc = mkAutoCC bndr modl - caf_ccs = mkSingletonCCS caf_cc - -- careful: the binder might be :Main.main, - -- which doesn't belong to module mod_name. - -- bug #249, tests prof001, prof002 - modl | Just m <- nameModule_maybe (idName bndr) = m - | otherwise = this_mod - - -- default CAF cost centre - (_, all_cafs_ccs) = getAllCAFsCC this_mod - --- Generate a non-top-level RHS. Cost-centre is always currentCCS, --- see Note [Cost-centre initialzation plan]. -mkStgRhs :: Id -> StgExpr -> StgRhs -mkStgRhs bndr rhs - | StgLam bndrs body <- rhs - = StgRhsClosure noExtFieldSilent - currentCCS - ReEntrant - (toList bndrs) body - - | isJoinId bndr -- must be a nullary join point - = ASSERT(idJoinArity bndr == 0) - StgRhsClosure noExtFieldSilent - currentCCS - ReEntrant -- ignored for LNE - [] rhs - - | StgConApp con args _ <- unticked_rhs - = StgRhsCon currentCCS con args - - | otherwise - = StgRhsClosure noExtFieldSilent - currentCCS - upd_flag [] rhs - where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable - - {- - SDM: disabled. Eval/Apply can't handle functions with arity zero very - well; and making these into simple non-updatable thunks breaks other - assumptions (namely that they will be entered only once). - - upd_flag | isPAP env rhs = ReEntrant - | otherwise = Updatable - --- Detect thunks which will reduce immediately to PAPs, and make them --- non-updatable. This has several advantages: --- --- - the non-updatable thunk behaves exactly like the PAP, --- --- - the thunk is more efficient to enter, because it is --- specialised to the task. --- --- - we save one update frame, one stg_update_PAP, one update --- and lots of PAP_enters. --- --- - in the case where the thunk is top-level, we save building --- a black hole and furthermore the thunk isn't considered to --- be a CAF any more, so it doesn't appear in any SRTs. --- --- We do it here, because the arity information is accurate, and we need --- to do it before the SRT pass to save the SRT entries associated with --- any top-level PAPs. - -isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args - where - arity = stgArity f (lookupBinding env f) -isPAP env _ = False - --} - -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else - (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} - --- --------------------------------------------------------------------------- --- A monad for the core-to-STG pass --- --------------------------------------------------------------------------- - --- There's a lot of stuff to pass around, so we use this CtsM --- ("core-to-STG monad") monad to help. All the stuff here is only passed --- *down*. - -newtype CtsM a = CtsM - { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs - -> IdEnv HowBound - -> a - } - deriving (Functor) - -data HowBound - = ImportBound -- Used only as a response to lookupBinding; never - -- exists in the range of the (IdEnv HowBound) - - | LetBound -- A let(rec) in this module - LetInfo -- Whether top level or nested - Arity -- Its arity (local Ids don't have arity info at this point) - - | LambdaBound -- Used for both lambda and case - deriving (Eq) - -data LetInfo - = TopLet -- top level things - | NestedLet - deriving (Eq) - --- For a let(rec)-bound variable, x, we record LiveInfo, the set of --- variables that are live if x is live. This LiveInfo comprises --- (a) dynamic live variables (ones with a non-top-level binding) --- (b) static live variabes (CAFs or things that refer to CAFs) --- --- For "normal" variables (a) is just x alone. If x is a let-no-escaped --- variable then x is represented by a code pointer and a stack pointer --- (well, one for each stack). So all of the variables needed in the --- execution of x are live if x is, and are therefore recorded in the --- LetBound constructor; x itself *is* included. --- --- The set of dynamic live variables is guaranteed ot have no further --- let-no-escaped variables in it. - --- The std monad functions: - -initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a -initCts dflags env m = unCtsM m dflags env - - - -{-# INLINE thenCts #-} -{-# INLINE returnCts #-} - -returnCts :: a -> CtsM a -returnCts e = CtsM $ \_ _ -> e - -thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b -thenCts m k = CtsM $ \dflags env - -> unCtsM (k (unCtsM m dflags env)) dflags env - -instance Applicative CtsM where - pure = returnCts - (<*>) = ap - -instance Monad CtsM where - (>>=) = thenCts - -instance HasDynFlags CtsM where - getDynFlags = CtsM $ \dflags _ -> dflags - --- Functions specific to this monad: - -extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a -extendVarEnvCts ids_w_howbound expr - = CtsM $ \dflags env - -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound) - -lookupVarCts :: Id -> CtsM HowBound -lookupVarCts v = CtsM $ \_ env -> lookupBinding env v - -lookupBinding :: IdEnv HowBound -> Id -> HowBound -lookupBinding env v = case lookupVarEnv env v of - Just xx -> xx - Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound - -getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) -getAllCAFsCC this_mod = - let - span = mkGeneralSrcSpan (mkFastString "") -- XXX do better - all_cafs_cc = mkAllCafsCC this_mod span - all_cafs_ccs = mkSingletonCCS all_cafs_cc - in - (all_cafs_cc, all_cafs_ccs) - --- Misc. - -filterStgBinders :: [Var] -> [Var] -filterStgBinders bndrs = filter isId bndrs - -myCollectBinders :: Expr Var -> ([Var], Expr Var) -myCollectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs (Cast e _) = go bs e - go bs e = (reverse bs, e) - --- | Precondition: argument expression is an 'App', and there is a 'Var' at the --- head of the 'App' chain. -myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) -myCollectArgs expr - = go expr [] [] - where - go (Var v) as ts = (v, as, ts) - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts = ASSERT( all isTypeArg as ) - go e as (t:ts) -- ticks can appear in type apps - go (Cast e _) as ts = go e as ts - go (Lam b e) as ts - | isTyVar b = go e as ts -- Note [Collect args] - go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - --- Note [Collect args] --- ~~~~~~~~~~~~~~~~~~~ --- --- This big-lambda case occurred following a rather obscure eta expansion. --- It all seems a bit yukky to me. - -stgArity :: Id -> HowBound -> Arity -stgArity _ (LetBound _ arity) = arity -stgArity f ImportBound = idArity f -stgArity _ LambdaBound = 0 diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs deleted file mode 100644 --- a/compiler/stgSyn/StgFVs.hs +++ /dev/null @@ -1,130 +0,0 @@ --- | Free variable analysis on STG terms. -module StgFVs ( - annTopBindingsFreeVars, - annBindingFreeVars - ) where - -import GhcPrelude - -import StgSyn -import Id -import VarSet -import CoreSyn ( Tickish(Breakpoint) ) -import Outputable -import Util - -import Data.Maybe ( mapMaybe ) - -newtype Env - = Env - { locals :: IdSet - } - -emptyEnv :: Env -emptyEnv = Env emptyVarSet - -addLocals :: [Id] -> Env -> Env -addLocals bndrs env - = env { locals = extendVarSetList (locals env) bndrs } - --- | Annotates a top-level STG binding group with its free variables. -annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding] -annTopBindingsFreeVars = map go - where - go (StgTopStringLit id bs) = StgTopStringLit id bs - go (StgTopLifted bind) - = StgTopLifted (annBindingFreeVars bind) - --- | Annotates an STG binding with its free variables. -annBindingFreeVars :: StgBinding -> CgStgBinding -annBindingFreeVars = fst . binding emptyEnv emptyDVarSet - -boundIds :: StgBinding -> [Id] -boundIds (StgNonRec b _) = [b] -boundIds (StgRec pairs) = map fst pairs - --- Note [Tracking local binders] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- 'locals' contains non-toplevel, non-imported binders. --- We maintain the set in 'expr', 'alt' and 'rhs', which are the only --- places where new local binders are introduced. --- Why do it there rather than in 'binding'? Two reasons: --- --- 1. We call 'binding' from 'annTopBindingsFreeVars', which would --- add top-level bindings to the 'locals' set. --- 2. In the let(-no-escape) case, we need to extend the environment --- prior to analysing the body, but we also need the fvs from the --- body to analyse the RHSs. No way to do this without some --- knot-tying. - --- | This makes sure that only local, non-global free vars make it into the set. -mkFreeVarSet :: Env -> [Id] -> DIdSet -mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env) - -args :: Env -> [StgArg] -> DIdSet -args env = mkFreeVarSet env . mapMaybe f - where - f (StgVarArg occ) = Just occ - f _ = Nothing - -binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet) -binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs) - where - -- See Note [Tracking local binders] - (r', rhs_fvs) = rhs env r - fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs -binding env body_fv (StgRec pairs) = (StgRec pairs', fvs) - where - -- See Note [Tracking local binders] - bndrs = map fst pairs - (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs - pairs' = zip bndrs rhss - fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs - -expr :: Env -> StgExpr -> (CgStgExpr, DIdSet) -expr env = go - where - go (StgApp occ as) - = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ])) - go (StgLit lit) = (StgLit lit, emptyDVarSet) - go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) - go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) - go StgLam{} = pprPanic "StgFVs: StgLam" empty - go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) - where - (scrut', scrut_fvs) = go scrut - -- See Note [Tracking local binders] - (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts - alt_fvs = unionDVarSets alt_fvss - fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr - go (StgLet ext bind body) = go_bind (StgLet ext) bind body - go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body - go (StgTick tick e) = (StgTick tick e', fvs') - where - (e', fvs) = go e - fvs' = unionDVarSet (tickish tick) fvs - tickish (Breakpoint _ ids) = mkDVarSet ids - tickish _ = emptyDVarSet - - go_bind dc bind body = (dc bind' body', fvs) - where - -- See Note [Tracking local binders] - env' = addLocals (boundIds bind) env - (body', body_fvs) = expr env' body - (bind', fvs) = binding env' body_fvs bind - -rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet) -rhs env (StgRhsClosure _ ccs uf bndrs body) - = (StgRhsClosure fvs ccs uf bndrs body', fvs) - where - -- See Note [Tracking local binders] - (body', body_fvs) = expr (addLocals bndrs env) body - fvs = delDVarSetList body_fvs bndrs -rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) - -alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) -alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) - where - -- See Note [Tracking local binders] - (e', rhs_fvs) = expr (addLocals bndrs env) e - fvs = delDVarSetList rhs_fvs bndrs diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs deleted file mode 100644 --- a/compiler/stgSyn/StgLint.hs +++ /dev/null @@ -1,396 +0,0 @@ -{- | -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -A lint pass to check basic STG invariants: - -- Variables should be defined before used. - -- Let bindings should not have unboxed types (unboxed bindings should only - appear in case), except when they're join points (see Note [CoreSyn let/app - invariant] and #14117). - -- If linting after unarisation, invariants listed in Note [Post-unarisation - invariants]. - -Because we don't have types and coercions in STG we can't really check types -here. - -Some history: - -StgLint used to check types, but it never worked and so it was disabled in 2000 -with this note: - - WARNING: - ~~~~~~~~ - - This module has suffered bit-rot; it is likely to yield lint errors - for Stg code that is currently perfectly acceptable for code - generation. Solution: don't use it! (KSW 2000-05). - -Since then there were some attempts at enabling it again, as summarised in -#14787. It's finally decided that we remove all type checking and only look for -basic properties listed above. --} - -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, - DeriveFunctor #-} - -module StgLint ( lintStgTopBindings ) where - -import GhcPrelude - -import StgSyn - -import DynFlags -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) -import CostCentre ( isCurrentCCS ) -import Id ( Id, idType, isJoinId, idName ) -import VarSet -import DataCon -import CoreSyn ( AltCon(..) ) -import Name ( getSrcLoc, nameIsLocalOrFrom ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) -import Type -import RepType -import SrcLoc -import Outputable -import Module ( Module ) -import qualified ErrUtils as Err -import Control.Applicative ((<|>)) -import Control.Monad - -lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) - => DynFlags - -> Module -- ^ module being compiled - -> Bool -- ^ have we run Unarise yet? - -> String -- ^ who produced the STG? - -> [GenStgTopBinding a] - -> IO () - -lintStgTopBindings dflags this_mod unarised whodunnit binds - = {-# SCC "StgLint" #-} - case initL this_mod unarised top_level_binds (lint_binds binds) of - Nothing -> - return () - Just msg -> do - putLogMsg dflags NoReason Err.SevDump noSrcSpan - (defaultDumpStyle dflags) - (vcat [ text "*** Stg Lint ErrMsgs: in" <+> - text whodunnit <+> text "***", - msg, - text "*** Offending Program ***", - pprGenStgTopBindings binds, - text "*** End of Offense ***"]) - Err.ghcExit dflags 1 - where - -- Bring all top-level binds into scope because CoreToStg does not generate - -- bindings in dependency order (so we may see a use before its definition). - top_level_binds = mkVarSet (bindersOfTopBinds binds) - - lint_binds :: [GenStgTopBinding a] -> LintM () - - lint_binds [] = return () - lint_binds (bind:binds) = do - binders <- lint_bind bind - addInScopeVars binders $ - lint_binds binds - - lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind - lint_bind (StgTopStringLit v _) = return [v] - -lintStgArg :: StgArg -> LintM () -lintStgArg (StgLitArg _) = return () -lintStgArg (StgVarArg v) = lintStgVar v - -lintStgVar :: Id -> LintM () -lintStgVar id = checkInScope id - -lintStgBinds - :: (OutputablePass a, BinderP a ~ Id) - => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders -lintStgBinds top_lvl (StgNonRec binder rhs) = do - lint_binds_help top_lvl (binder,rhs) - return [binder] - -lintStgBinds top_lvl (StgRec pairs) - = addInScopeVars binders $ do - mapM_ (lint_binds_help top_lvl) pairs - return binders - where - binders = [b | (b,_) <- pairs] - -lint_binds_help - :: (OutputablePass a, BinderP a ~ Id) - => TopLevelFlag - -> (Id, GenStgRhs a) - -> LintM () -lint_binds_help top_lvl (binder, rhs) - = addLoc (RhsOf binder) $ do - when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) - lintStgRhs rhs - -- Check binder doesn't have unlifted type or it's a join point - checkL (isJoinId binder || not (isUnliftedType (idType binder))) - (mkUnliftedTyMsg binder rhs) - --- | Top-level bindings can't inherit the cost centre stack from their --- (static) allocation site. -checkNoCurrentCCS - :: (OutputablePass a, BinderP a ~ Id) - => GenStgRhs a - -> LintM () -checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _) - | isCurrentCCS ccs - = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs) -checkNoCurrentCCS rhs@(StgRhsCon ccs _ _) - | isCurrentCCS ccs - = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs) -checkNoCurrentCCS _ - = return () - -lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () - -lintStgRhs (StgRhsClosure _ _ _ [] expr) - = lintStgExpr expr - -lintStgRhs (StgRhsClosure _ _ _ binders expr) - = addLoc (LambdaBodyOf binders) $ - addInScopeVars binders $ - lintStgExpr expr - -lintStgRhs rhs@(StgRhsCon _ con args) = do - when (isUnboxedTupleCon con || isUnboxedSumCon con) $ - addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ - ppr rhs) - mapM_ lintStgArg args - mapM_ checkPostUnariseConArg args - -lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () - -lintStgExpr (StgLit _) = return () - -lintStgExpr (StgApp fun args) = do - lintStgVar fun - mapM_ lintStgArg args - -lintStgExpr app@(StgConApp con args _arg_tys) = do - -- unboxed sums should vanish during unarise - lf <- getLintFlags - when (lf_unarised lf && isUnboxedSumCon con) $ - addErrL (text "Unboxed sum after unarise:" $$ - ppr app) - mapM_ lintStgArg args - mapM_ checkPostUnariseConArg args - -lintStgExpr (StgOpApp _ args _) = - mapM_ lintStgArg args - -lintStgExpr lam@(StgLam _ _) = - addErrL (text "Unexpected StgLam" <+> ppr lam) - -lintStgExpr (StgLet _ binds body) = do - binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgLetNoEscape _ binds body) = do - binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ - addInScopeVars binders $ - lintStgExpr body - -lintStgExpr (StgTick _ expr) = lintStgExpr expr - -lintStgExpr (StgCase scrut bndr alts_type alts) = do - lintStgExpr scrut - - lf <- getLintFlags - let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf) - - addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) - -lintAlt - :: (OutputablePass a, BinderP a ~ Id) - => (AltCon, [Id], GenStgExpr a) -> LintM () - -lintAlt (DEFAULT, _, rhs) = - lintStgExpr rhs - -lintAlt (LitAlt _, _, rhs) = - lintStgExpr rhs - -lintAlt (DataAlt _, bndrs, rhs) = do - mapM_ checkPostUnariseBndr bndrs - addInScopeVars bndrs (lintStgExpr rhs) - -{- -************************************************************************ -* * -Utilities -* * -************************************************************************ --} - -bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] -bindersOf (StgNonRec binder _) = [binder] -bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] - -bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] -bindersOfTop (StgTopLifted bind) = bindersOf bind -bindersOfTop (StgTopStringLit binder _) = [binder] - -bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] -bindersOfTopBinds = foldr ((++) . bindersOfTop) [] - -{- -************************************************************************ -* * -The Lint monad -* * -************************************************************************ --} - -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> [LintLocInfo] -- Locations - -> IdSet -- Local vars in scope - -> Bag MsgDoc -- Error messages so far - -> (a, Bag MsgDoc) -- Result and error messages (if any) - } - deriving (Functor) - -data LintFlags = LintFlags { lf_unarised :: !Bool - -- ^ have we run the unariser yet? - } - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf [Id] -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - -dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) -dumpLoc (RhsOf v) = - (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) -dumpLoc (LambdaBodyOf bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) - -dumpLoc (BodyOfLetRec bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) - - -pp_binders :: [Id] -> SDoc -pp_binders bs - = sep (punctuate comma (map pp_binder bs)) - where - pp_binder b - = hsep [ppr b, dcolon, ppr (idType b)] - -initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc -initL this_mod unarised locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag - if isEmptyBag errs then - Nothing - else - Just (vcat (punctuate blankLine (bagToList errs))) - -instance Applicative LintM where - pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs) - (<*>) = ap - (*>) = thenL_ - -instance Monad LintM where - (>>=) = thenL - (>>) = (*>) - -thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf loc scope errs - -> case unLintM m mod lf loc scope errs of - (r, errs') -> unLintM (k r) mod lf loc scope errs' - -thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf loc scope errs - -> case unLintM m mod lf loc scope errs of - (_, errs') -> unLintM k mod lf loc scope errs' - -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = addErrL msg - --- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders. -checkPostUnariseBndr :: Id -> LintM () -checkPostUnariseBndr bndr = do - lf <- getLintFlags - when (lf_unarised lf) $ - forM_ (checkPostUnariseId bndr) $ \unexpected -> - addErrL $ - text "After unarisation, binder " <> - ppr bndr <> text " has " <> text unexpected <> text " type " <> - ppr (idType bndr) - --- Arguments shouldn't have sum, tuple, or void types. -checkPostUnariseConArg :: StgArg -> LintM () -checkPostUnariseConArg arg = case arg of - StgLitArg _ -> - return () - StgVarArg id -> do - lf <- getLintFlags - when (lf_unarised lf) $ - forM_ (checkPostUnariseId id) $ \unexpected -> - addErrL $ - text "After unarisation, arg " <> - ppr id <> text " has " <> text unexpected <> text " type " <> - ppr (idType id) - --- Post-unarisation args and case alt binders should not have unboxed tuple, --- unboxed sum, or void types. Return what the binder is if it is one of these. -checkPostUnariseId :: Id -> Maybe String -checkPostUnariseId id = - let - id_ty = idType id - is_sum, is_tuple, is_void :: Maybe String - is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" - is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" - is_void = guard (isVoidTy id_ty) >> return "void" - in - is_sum <|> is_tuple <|> is_void - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc) - -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc -addErr errs_so_far msg locs - = errs_so_far `snocBag` mk_msg locs - where - mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage SevWarning l (hdr $$ msg) - mk_msg [] = msg - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf loc scope errs - -> unLintM m mod lf (extra_loc:loc) scope errs - -addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf loc scope errs - -> let - new_set = mkVarSet ids - in unLintM m mod lf loc (scope `unionVarSet` new_set) errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs) - -checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf loc scope errs - -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then - ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), - text "is out of scope"]) loc) - else - ((), errs) - -mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc -mkUnliftedTyMsg binder rhs - = (text "Let(rec) binder" <+> quotes (ppr binder) <+> - text "has unlifted type" <+> quotes (ppr (idType binder))) - $$ - (text "RHS:" <+> ppr rhs) diff --git a/compiler/stgSyn/StgSubst.hs b/compiler/stgSyn/StgSubst.hs deleted file mode 100644 --- a/compiler/stgSyn/StgSubst.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE CPP #-} - -module StgSubst where - -#include "HsVersions.h" - -import GhcPrelude - -import Id -import VarEnv -import Control.Monad.Trans.State.Strict -import Outputable -import Util - --- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not --- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but --- with the domain being 'Id's instead of entire 'CoreExpr'. -data Subst = Subst InScopeSet IdSubstEnv - -type IdSubstEnv = IdEnv Id - --- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@ -emptySubst :: Subst -emptySubst = mkEmptySubst emptyInScopeSet - --- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet' --- are in scope. -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv - --- | Substitutes an 'Id' for another one according to the 'Subst' given in a way --- that avoids shadowing the 'InScopeSet', returning the result and an updated --- 'Subst' that should be used by subsequent substitutions. -substBndr :: Id -> Subst -> (Id, Subst) -substBndr id (Subst in_scope env) - = (new_id, Subst new_in_scope new_env) - where - new_id = uniqAway in_scope id - no_change = new_id == id -- in case nothing shadowed - new_in_scope = in_scope `extendInScopeSet` new_id - new_env - | no_change = delVarEnv env id - | otherwise = extendVarEnv env id new_id - --- | @substBndrs = runState . traverse (state . substBndr)@ -substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst) -substBndrs = runState . traverse (state . substBndr) - --- | Substitutes an occurrence of an identifier for its counterpart recorded --- in the 'Subst'. -lookupIdSubst :: HasCallStack => Id -> Subst -> Id -lookupIdSubst id (Subst in_scope env) - | not (isLocalId id) = id - | Just id' <- lookupVarEnv env id = id' - | Just id' <- lookupInScope in_scope id = id' - | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) - id - --- | Substitutes an occurrence of an identifier for its counterpart recorded --- in the 'Subst'. Does not generate a debug warning if the identifier to --- to substitute wasn't in scope. -noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id -noWarnLookupIdSubst id (Subst in_scope env) - | not (isLocalId id) = id - | Just id' <- lookupVarEnv env id = id' - | Just id' <- lookupInScope in_scope id = id' - | otherwise = id - --- | Add the 'Id' to the in-scope set and remove any existing substitutions for --- it. -extendInScope :: Id -> Subst -> Subst -extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env - --- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the --- in-scope set is such that TyCoSubst Note [The substitution invariant] --- holds after extending the substitution like this. -extendSubst :: Id -> Id -> Subst -> Subst -extendSubst id new_id (Subst in_scope env) - = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope ) - Subst in_scope (extendVarEnv env id new_id) diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs deleted file mode 100644 --- a/compiler/stgSyn/StgSyn.hs +++ /dev/null @@ -1,871 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Shared term graph (STG) syntax for spineless-tagless code generation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This data type represents programs just before code generation (conversion to -@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style -being one that happens to be ideally suited to spineless tagless code -generation. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} - -module StgSyn ( - StgArg(..), - - GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgAlt, AltType(..), - - StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, - NoExtFieldSilent, noExtFieldSilent, - OutputablePass, - - UpdateFlag(..), isUpdatable, - - -- a set of synonyms for the vanilla parameterisation - StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, - - -- a set of synonyms for the code gen parameterisation - CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt, - - -- a set of synonyms for the lambda lifting parameterisation - LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, - - -- a set of synonyms to distinguish in- and out variants - InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, - OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, - - -- StgOp - StgOp(..), - - -- utils - topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, - isDllConApp, - stgArgType, - stripStgTicksTop, stripStgTicksTopE, - stgCaseBndrInScope, - - pprStgBinding, pprGenStgTopBindings, pprStgTopBindings - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import CoreSyn ( AltCon, Tickish ) -import CostCentre ( CostCentreStack ) -import Data.ByteString ( ByteString ) -import Data.Data ( Data ) -import Data.List ( intersperse ) -import DataCon -import DynFlags -import ForeignCall ( ForeignCall ) -import Id -import IdInfo ( mayHaveCafRefs ) -import VarSet -import Literal ( Literal, literalType ) -import Module ( Module ) -import Outputable -import Packages ( isDllName ) -import GHC.Platform -import PprCore ( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..), TyCon ) -import Type ( Type ) -import RepType ( typePrimRep1 ) -import Util - -import Data.List.NonEmpty ( NonEmpty, toList ) - -{- -************************************************************************ -* * -GenStgBinding -* * -************************************************************************ - -As usual, expressions are interesting; other things are boring. Here are the -boring things (except note the @GenStgRhs@), parameterised with respect to -binder and occurrence information (just as in @CoreSyn@): --} - --- | A top-level binding. -data GenStgTopBinding pass --- See Note [CoreSyn top-level string literals] - = StgTopLifted (GenStgBinding pass) - | StgTopStringLit Id ByteString - -data GenStgBinding pass - = StgNonRec (BinderP pass) (GenStgRhs pass) - | StgRec [(BinderP pass, GenStgRhs pass)] - -{- -************************************************************************ -* * -StgArg -* * -************************************************************************ --} - -data StgArg - = StgVarArg Id - | StgLitArg Literal - --- | Does this constructor application refer to anything in a different --- *Windows* DLL? --- If so, we can't allocate it statically -isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool -isDllConApp dflags this_mod con args - | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName dflags this_mod (dataConName con) || any is_dll_arg args - | otherwise = False - where - -- NB: typePrimRep1 is legit because any free variables won't have - -- unlifted type (there are no unlifted things at top level) - is_dll_arg :: StgArg -> Bool - is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v)) - && isDllName dflags this_mod (idName v) - is_dll_arg _ = False - --- True of machine addresses; these are the things that don't work across DLLs. --- The key point here is that VoidRep comes out False, so that a top level --- nullary GADT constructor is False for isDllConApp --- --- data T a where --- T1 :: T Int --- --- gives --- --- T1 :: forall a. (a~Int) -> T a --- --- and hence the top-level binding --- --- $WT1 :: T Int --- $WT1 = T1 Int (Coercion (Refl Int)) --- --- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep LiftedRep = True -isAddrRep UnliftedRep = True -isAddrRep _ = False - --- | Type of an @StgArg@ --- --- Very half baked because we have lost the type arguments. -stgArgType :: StgArg -> Type -stgArgType (StgVarArg v) = idType v -stgArgType (StgLitArg lit) = literalType lit - - --- | Strip ticks of a given type from an STG expression. -stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) -stripStgTicksTop p = go [] - where go ts (StgTick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - --- | Strip ticks of a given type from an STG expression returning only the expression. -stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p -stripStgTicksTopE p = go - where go (StgTick t e) | p t = go e - go other = other - --- | Given an alt type and whether the program is unarised, return whether the --- case binder is in scope. --- --- Case binders of unboxed tuple or unboxed sum type always dead after the --- unariser has run. See Note [Post-unarisation invariants]. -stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool -stgCaseBndrInScope alt_ty unarised = - case alt_ty of - AlgAlt _ -> True - PrimAlt _ -> True - MultiValAlt _ -> not unarised - PolyAlt -> True - -{- -************************************************************************ -* * -STG expressions -* * -************************************************************************ - -The @GenStgExpr@ data type is parameterised on binder and occurrence info, as -before. - -************************************************************************ -* * -GenStgExpr -* * -************************************************************************ - -An application is of a function to a list of atoms (not expressions). -Operationally, we want to push the arguments on the stack and call the function. -(If the arguments were expressions, we would have to build their closures -first.) - -There is no constructor for a lone variable; it would appear as @StgApp var []@. --} - -data GenStgExpr pass - = StgApp - Id -- function - [StgArg] -- arguments; may be empty - -{- -************************************************************************ -* * -StgConApp and StgPrimApp --- saturated applications -* * -************************************************************************ - -There are specialised forms of application, for constructors, primitives, and -literals. --} - - | StgLit Literal - - -- StgConApp is vital for returning unboxed tuples or sums - -- which can't be let-bound - | StgConApp DataCon - [StgArg] -- Saturated - [Type] -- See Note [Types in StgConApp] in UnariseStg - - | StgOpApp StgOp -- Primitive op or foreign call - [StgArg] -- Saturated. - Type -- Result type - -- We need to know this so that we can - -- assign result registers - -{- -************************************************************************ -* * -StgLam -* * -************************************************************************ - -StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it -encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension -to GenStgExpr à la TTG. --} - - | StgLam - (NonEmpty (BinderP pass)) - StgExpr -- Body of lambda - -{- -************************************************************************ -* * -GenStgExpr: case-expressions -* * -************************************************************************ - -This has the same boxed/unboxed business as Core case expressions. --} - - | StgCase - (GenStgExpr pass) -- the thing to examine - (BinderP pass) -- binds the result of evaluating the scrutinee - AltType - [GenStgAlt pass] - -- The DEFAULT case is always *first* - -- if it is there at all - -{- -************************************************************************ -* * -GenStgExpr: let(rec)-expressions -* * -************************************************************************ - -The various forms of let(rec)-expression encode most of the interesting things -we want to do. - -- let-closure x = [free-vars] [args] expr in e - - is equivalent to - - let x = (\free-vars -> \args -> expr) free-vars - - @args@ may be empty (and is for most closures). It isn't under circumstances - like this: - - let x = (\y -> y+z) - - This gets mangled to - - let-closure x = [z] [y] (y+z) - - The idea is that we compile code for @(y+z)@ in an environment in which @z@ is - bound to an offset from Node, and `y` is bound to an offset from the stack - pointer. - - (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) - -- let-constructor x = Constructor [args] in e - - (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) - -- Letrec-expressions are essentially the same deal as let-closure/ - let-constructor, so we use a common structure and distinguish between them - with an @is_recursive@ boolean flag. - -- let-unboxed u = 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 = --- 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)] diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -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 } diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -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(..) ) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -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 diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -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 diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -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) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -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 $ diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -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)])) diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -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` diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -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 diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -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 diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -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])) diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -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 diff --git a/ghc-lib/stage0/lib/DerivedConstants.h b/ghc-lib/stage0/lib/DerivedConstants.h --- a/ghc-lib/stage0/lib/DerivedConstants.h +++ b/ghc-lib/stage0/lib/DerivedConstants.h @@ -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 diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h --- a/ghc-lib/stage0/lib/ghcversion.h +++ b/ghc-lib/stage0/lib/ghcversion.h @@ -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__ || \ diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -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.