summaryrefslogtreecommitdiff
path: root/compiler/simplStg
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/simplStg')
-rw-r--r--compiler/simplStg/RepType.hs2
-rw-r--r--compiler/simplStg/SimplStg.hs70
-rw-r--r--compiler/simplStg/StgCse.hs38
-rw-r--r--compiler/simplStg/StgStats.hs2
-rw-r--r--compiler/simplStg/UnariseStg.hs77
5 files changed, 101 insertions, 88 deletions
diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
index 2acc815125..694aa4ebf7 100644
--- a/compiler/simplStg/RepType.hs
+++ b/compiler/simplStg/RepType.hs
@@ -23,6 +23,8 @@ module RepType
#include "HsVersions.h"
+import GhcPrelude
+
import BasicTypes (Arity, RepArity)
import DataCon
import Outputable
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 4943f525af..36bf5101d6 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -10,93 +10,67 @@ module SimplStg ( stg2stg ) where
#include "HsVersions.h"
+import GhcPrelude
+
import StgSyn
-import CostCentre ( CollectedCCs )
-import SCCfinal ( stgMassageForProfiling )
import StgLint ( lintStgTopBindings )
import StgStats ( showStgStats )
import UnariseStg ( unarise )
import StgCse ( stgCse )
import DynFlags
-import Module ( Module )
import ErrUtils
-import SrcLoc
-import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
+import UniqSupply ( mkSplitUniqSupply )
import Outputable
import Control.Monad
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
- -> Module -- module name (profiling only)
-> [StgTopBinding] -- input...
- -> IO ( [StgTopBinding] -- output program...
- , CollectedCCs) -- cost centre information (declared and used)
+ -> IO [StgTopBinding] -- output program
-stg2stg dflags module_name binds
+stg2stg dflags binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
- ; when (dopt Opt_D_verbose_stg2stg dflags)
- (putLogMsg dflags NoReason SevDump noSrcSpan
- (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
-
- ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
-
-- Do the main business!
- ; let (us0, us1) = splitUniqSupply us'
- ; (processed_binds, _, cost_centres)
- <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
-
; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
- (pprStgTopBindings processed_binds)
+ (pprStgTopBindings binds)
- ; let un_binds = unarise us1 processed_binds
+ ; stg_linter False "Pre-unarise" binds
+ ; let un_binds = unarise us binds
+ ; stg_linter True "Unarise" un_binds
; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
(pprStgTopBindings un_binds)
- ; return (un_binds, cost_centres)
- }
+ ; foldM do_stg_pass un_binds (getStgToDo dflags)
+ }
where
- stg_linter = if gopt Opt_DoStgLinting dflags
- then lintStgTopBindings
- else ( \ _whodunnit binds -> binds )
+ stg_linter unarised
+ | gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
+ | otherwise = \ _whodunnit _binds -> return ()
-------------------------------------------
- do_stg_pass (binds, us, ccs) to_do
+ do_stg_pass binds to_do
= case to_do of
D_stg_stats ->
- trace (showStgStats binds)
- end_pass us "StgStats" ccs binds
-
- StgDoMassageForProfiling ->
- {-# SCC "ProfMassage" #-}
- let
- (us1, us2) = splitUniqSupply us
- (collected_CCs, binds3)
- = stgMassageForProfiling dflags module_name us1 binds
- in
- end_pass us2 "ProfMassage" collected_CCs binds3
+ trace (showStgStats binds) (return binds)
StgCSE ->
{-# SCC "StgCse" #-}
let
binds' = stgCse binds
in
- end_pass us "StgCse" ccs binds'
+ end_pass "StgCse" binds'
- end_pass us2 what ccs binds2
+ end_pass what binds2
= do -- report verbosely, if required
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
- (vcat (map ppr binds2))
- let linted_binds = stg_linter what binds2
- return (linted_binds, us2, ccs)
- -- return: processed binds
- -- UniqueSupply for the next guy to use
- -- cost-centres to be declared/registered (specialised)
- -- add to description of what's happened (reverse order)
+ (pprStgTopBindings binds2)
+ stg_linter True what binds2
+ return binds2
-- -----------------------------------------------------------------------------
-- StgToDo: abstraction of stg-to-stg passes to run.
@@ -104,14 +78,12 @@ stg2stg dflags module_name binds
-- | Optional Stg-to-Stg passes.
data StgToDo
= StgCSE
- | StgDoMassageForProfiling -- should be (next to) last
| D_stg_stats
-- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
= [ StgCSE | gopt Opt_StgCSE dflags] ++
- [ StgDoMassageForProfiling | WayProf `elem` ways dflags] ++
[ D_stg_stats | stg_stats ]
where
stg_stats = gopt Opt_StgStats dflags
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 6bd6adc7ec..1ae1213960 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -5,9 +5,9 @@ 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 operational equivalent), but that we cannot common up in Core, because
+they are operationally equivalent), but that we cannot common up in Core, because
their types differ.
-This was original reported as #9291.
+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
@@ -16,7 +16,7 @@ note [Case 2: CSEing case binders] below.
Note [Case 1: CSEing allocated closures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The fist kind of CSE opportunity we aim for is generated by this Haskell code:
+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)
@@ -70,6 +70,8 @@ and nothing stops us from transforming that to
-}
module StgCse (stgCse) where
+import GhcPrelude
+
import DataCon
import Id
import StgSyn
@@ -78,7 +80,7 @@ import VarEnv
import CoreSyn (AltCon(..))
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe)
-import TrieMap
+import CoreMap
import NameEnv
import Control.Monad( (>=>) )
@@ -137,7 +139,7 @@ data CseEnv = CseEnv
-- * 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
+ -- ^ 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]
@@ -217,7 +219,7 @@ substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
-- Functions to enter binders
--- This is much simpler than the requivalent code in CoreSubst:
+-- 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.
@@ -300,7 +302,7 @@ stgCseExpr env (StgCase scrut bndr ty alts)
env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1
-- See Note [Trivial case scrutinee]
| otherwise = env1
- alts' = map (stgCseAlt env2 bndr') alts
+ alts' = map (stgCseAlt env2 ty bndr') alts
-- A constructor application.
@@ -327,14 +329,24 @@ stgCseExpr env (StgLetNoEscape binds body)
-- Case alternatives
-- Extend the CSE environment
-stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt
-stgCseAlt env case_bndr (DataAlt dataCon, args, rhs)
+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
= let (env1, args') = substBndrs env args
- env2 = addDataCon case_bndr dataCon (map StgVarArg args') env1
+ 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)
+stgCseAlt env _ _ (altCon, args, rhs)
= let (env1, args') = substBndrs env args
rhs' = stgCseExpr env1 rhs
in (altCon, args', rhs')
@@ -362,7 +374,7 @@ stgCsePairs env0 ((b,e):pairs)
mbCons = maybe id (:)
-- The RHS of a binding.
--- If it is an constructor application, either short-cut it or extend the environment
+-- 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
@@ -438,7 +450,7 @@ 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 subsitution before looking Right r2 up in ce_conAppMap, and everything
+this substitution before looking Right r2 up in ce_conAppMap, and everything
works out.
Note [Free variables of an StgClosure]
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 3f75ae23fa..712ec2d22e 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -27,6 +27,8 @@ module StgStats ( showStgStats ) where
#include "HsVersions.h"
+import GhcPrelude
+
import StgSyn
import Id (Id)
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 2e8fbda02b..5c271c2ea0 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -196,20 +196,22 @@ module UnariseStg (unarise) where
#include "HsVersions.h"
+import GhcPrelude
+
import BasicTypes
import CoreSyn
import DataCon
import FastString (FastString, mkFastString)
import Id
-import Literal (Literal (..))
-import MkCore (aBSENT_ERROR_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)
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
import TysWiredIn
import UniqSupply
import Util
@@ -332,7 +334,7 @@ unariseExpr _ e@StgLam{}
= pprPanic "unariseExpr: found lambda" (ppr e)
unariseExpr rho (StgCase scrut bndr alt_ty alts)
- -- a tuple/sum binders in the scrutinee can always be eliminated
+ -- 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
@@ -349,7 +351,8 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
= do scrut' <- unariseExpr rho scrut
alts' <- unariseAlts rho alt_ty bndr alts
return (StgCase scrut' bndr alt_ty alts')
- -- bndr will be dead after unarise
+ -- bndr may have a unboxed sum/tuple type but it will be
+ -- dead after unarise (checked in StgLint)
unariseExpr rho (StgLet bind e)
= StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
@@ -475,7 +478,7 @@ unariseSumAlt rho _ (DEFAULT, _, e)
unariseSumAlt rho args (DataAlt sumCon, bs, e)
= do let rho' = mapSumIdBinders bs args rho
e' <- unariseExpr rho' e
- return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+ return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
unariseSumAlt _ scrt alt
= pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
@@ -561,7 +564,7 @@ mkUbxSum dc ty_args args0
tag = dataConTag dc
layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
- tag_arg = StgLitArg (MachInt (fromIntegral tag))
+ tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
@@ -574,9 +577,10 @@ mkUbxSum dc ty_args args0
= slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
slotRubbishArg :: SlotTy -> StgArg
- slotRubbishArg PtrSlot = StgVarArg aBSENT_ERROR_ID
- slotRubbishArg WordSlot = StgLitArg (MachWord 0)
- slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
+ 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 (MachFloat 0)
slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
in
@@ -640,6 +644,35 @@ So in short, when we have a void id,
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.
@@ -658,16 +691,9 @@ unariseFunArgs = concatMap . unariseFunArg
unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
-unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-- Result list of binders is never empty
-unariseFunArgBinder rho x =
- case typePrimRep (idType x) of
- [] -> return (extendRho rho x (MultiVal []), [voidArgId])
- -- NB: do not remove void binders
- [_] -> return (rho, [x])
- reps -> do
- xs <- mkIds (mkFastString "us") (map primRepToType reps)
- return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
--------------------------------------------------------------------------------
@@ -682,7 +708,9 @@ unariseConArg rho (StgVarArg x) =
-- Here realWorld# is not in the envt, but
-- is a void, and so should be eliminated
| otherwise -> [StgVarArg x]
-unariseConArg _ arg = [arg] -- We have no void literals
+unariseConArg _ arg@(StgLitArg lit) =
+ ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals
+ [arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
unariseConArgs = concatMap . unariseConArg
@@ -690,13 +718,10 @@ 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 rho x =
- case typePrimRep (idType x) of
- [_] -> return (rho, [x])
- reps -> do
- xs <- mkIds (mkFastString "us") (map primRepToType reps)
- return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseConArgBinder = unariseArgBinder True
unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
unariseFreeVars rho fvs
View Lorry Controller Status