Commit 488e21c8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Make a new type synonym CoreProgram = [CoreBind]

and comment its invariants in Note [CoreProgram] in CoreSyn

I'm not totally convinced that CoreProgram is the right name
(perhaps CoreTopBinds might better), but it is useful to have
a clue that you are looking at the top-level bindings.

This is only a matter of a type synonym change; no deep
refactoring here.
parent f3c7ed72
......@@ -99,7 +99,7 @@ find an occurence of an Id, we fetch it from the in-scope set.
\begin{code}
lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message)
-- Returns (warnings, errors)
lintCoreBindings binds
= initL $
......
......@@ -144,7 +144,7 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs'
%************************************************************************
\begin{code}
corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
corePrepPgm :: DynFlags -> CoreProgram -> [TyCon] -> IO CoreProgram
corePrepPgm dflags binds data_tycons = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
......
......@@ -436,7 +436,7 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
--
-- [Aug 09] This function is not used in GHC at the moment, but seems so
-- short and simple that I'm going to leave it here
deShadowBinds :: [CoreBind] -> [CoreBind]
deShadowBinds :: CoreProgram -> CoreProgram
deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
\end{code}
......@@ -860,8 +860,8 @@ simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
----------------------
simpleOptPgm :: DynFlags -> Module
-> [CoreBind] -> [CoreRule] -> [CoreVect]
-> IO ([CoreBind], [CoreRule], [CoreVect])
-> CoreProgram -> [CoreRule] -> [CoreVect]
-> IO (CoreProgram, [CoreRule], [CoreVect])
simpleOptPgm dflags this_mod binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings occ_anald_binds $$ pprRules rules );
......
......@@ -10,7 +10,7 @@
module CoreSyn (
-- * Main data types
Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
-- ** 'Expr' construction
......@@ -831,7 +831,29 @@ cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
%* *
%************************************************************************
Note [CoreProgram]
~~~~~~~~~~~~~~~~~~
The top level bindings of a program, a CoreProgram, are represented as
a list of CoreBind
* Later bindings in the list can refer to earlier ones, but not vice
versa. So this is OK
NonRec { x = 4 }
Rec { p = ...q...x...
; q = ...p...x }
Rec { f = ...p..x..f.. }
NonRec { g = ..f..q...x.. }
But it would NOT be ok for 'f' to refer to 'g'.
* The occurrence analyser does strongly-connected component analysis
on each Rec binding, and splits it into a sequence of smaller
bindings where possible. So the program typically starts life as a
single giant Rec, which is then dependency-analysed into smaller
chunks.
\begin{code}
type CoreProgram = [CoreBind] -- See Note [CoreProgram]
-- | The common case for the type of binders and variables when
-- we are manipulating the Core language within GHC
type CoreBndr = Var
......
......@@ -65,7 +65,7 @@ import qualified FiniteMap as Map
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
-> CoreProgram
-> [TyCon]
-> ModBreaks
-> IO CompiledByteCode
......
......@@ -1028,7 +1028,7 @@ tcIfaceDataAlt con inst_tys arg_strs rhs
\begin{code}
tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram -- Used for external core
tcExtCoreBindings [] = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
......
......@@ -769,7 +769,7 @@ data CoreModule
-- | Type environment for types declared in this module
cm_types :: !TypeEnv,
-- | Declarations
cm_binds :: [CoreBind]
cm_binds :: CoreProgram
}
instance Outputable CoreModule where
......
......@@ -1211,7 +1211,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
; return prog' }
myCoreToStg :: DynFlags -> Module -> [CoreBind]
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [(StgBinding,[(Id,[Id])])] -- output program
, CollectedCCs) -- cost centre info (declared and used)
......@@ -1473,7 +1473,7 @@ hscParseThingWithLocation source linenumber parser str
hscCompileCore :: HscEnv
-> Bool
-> ModSummary
-> [CoreBind]
-> CoreProgram
-> IO ()
hscCompileCore hsc_env simplify mod_summary binds
......@@ -1487,7 +1487,7 @@ hscCompileCore hsc_env simplify mod_summary binds
return ()
-- Makes a "vanilla" ModGuts.
mkModGuts :: Module -> [CoreBind] -> ModGuts
mkModGuts :: Module -> CoreProgram -> ModGuts
mkModGuts mod binds = ModGuts {
mg_module = mod,
mg_boot = False,
......
......@@ -121,7 +121,7 @@ import Module
import InstEnv ( InstEnv, Instance )
import FamInstEnv
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import CoreSyn ( CoreProgram )
import VarEnv
import VarSet
import Var
......@@ -757,7 +757,7 @@ data ModGuts
mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module
mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains
-- See Note [Overall plumbing for rules] in Rules.lhs
mg_binds :: ![CoreBind], -- ^ Bindings for this module
mg_binds :: !CoreProgram, -- ^ Bindings for this module
mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
......@@ -813,7 +813,7 @@ data CgGuts
-- tables. Includes newtypes, just for the benefit of
-- External Core
cg_binds :: [CoreBind],
cg_binds :: CoreProgram,
-- ^ The tidied main bindings, including
-- previously-implicit bindings for record and class
-- selectors, and data construtor wrappers. But *not*
......
......@@ -997,8 +997,8 @@ rules are externalised (see init_ext_ids in function
tidyTopBinds :: HscEnv
-> UnfoldEnv
-> TidyOccEnv
-> [CoreBind]
-> (TidyEnv, [CoreBind])
-> CoreProgram
-> (TidyEnv, CoreProgram)
tidyTopBinds hsc_env unfold_env init_occ_env binds
= tidy init_env binds
......
......@@ -185,7 +185,7 @@ happen now that we don't look inside INLINEs (which wrappers are).
%************************************************************************
\begin{code}
cseProgram :: [CoreBind] -> [CoreBind]
cseProgram :: CoreProgram -> CoreProgram
cseProgram binds = cseBinds emptyCSEnv binds
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
......
......@@ -128,7 +128,7 @@ stuff before and after core passes, and do Core Lint when necessary.
showPass :: DynFlags -> CoreToDo -> IO ()
showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPass dflags pass binds rules
= do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
; lintPassResult dflags pass binds }
......@@ -147,7 +147,7 @@ dumpPassResult :: DynFlags
-- name is specified by df
-> SDoc -- Header
-> SDoc -- Extra info to appear after header
-> [CoreBind] -> [CoreRule]
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags mb_flag hdr extra_info binds rules
| Just dflag <- mb_flag
......@@ -169,7 +169,7 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
, ptext (sLit "------ Local rules for imported ids --------")
, pprRules rules ]
lintPassResult :: DynFlags -> CoreToDo -> [CoreBind] -> IO ()
lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
lintPassResult dflags pass binds
= when (dopt Opt_DoCoreLinting dflags) $
do { let (warns, errs) = lintCoreBindings binds
......@@ -177,7 +177,7 @@ lintPassResult dflags pass binds
; displayLintResults dflags pass warns errs binds }
displayLintResults :: DynFlags -> CoreToDo
-> Bag Err.Message -> Bag Err.Message -> [CoreBind]
-> Bag Err.Message -> Bag Err.Message -> CoreProgram
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
......@@ -444,7 +444,7 @@ defaultPlugin = Plugin {
-- | A description of the plugin pass itself
type PluginPass = ModGuts -> CoreM ModGuts
bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass pass guts
= do { binds' <- pass (mg_binds guts)
; return (guts { mg_binds = binds' }) }
......
......@@ -32,7 +32,7 @@ Top-level interface function, @floatInwards@. Note that we do not
actually float any bindings downwards from the top-level.
\begin{code}
floatInwards :: [CoreBind] -> [CoreBind]
floatInwards :: CoreProgram -> CoreProgram
floatInwards = map fi_top_bind
where
fi_top_bind (NonRec binder rhs)
......
......@@ -114,7 +114,7 @@ Well, maybe. We don't do this at the moment.
floatOutwards :: FloatOutSwitches
-> DynFlags
-> UniqSupply
-> [CoreBind] -> IO [CoreBind]
-> CoreProgram -> IO CoreProgram
floatOutwards float_sws dflags us pgm
= do {
......
......@@ -117,7 +117,7 @@ and the level of @h@ is zero (NB not one).
%************************************************************************
\begin{code}
liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
liberateCase :: DynFlags -> CoreProgram -> CoreProgram
liberateCase dflags binds = do_prog (initEnv dflags) binds
where
do_prog _ [] = []
......
......@@ -55,7 +55,7 @@ Here's the externally-callable interface:
occurAnalysePgm :: Module -- Used only in debug output
-> (Activation -> Bool)
-> [CoreRule] -> [CoreVect]
-> [CoreBind] -> [CoreBind]
-> CoreProgram -> CoreProgram
occurAnalysePgm this_mod active_rule imp_rules vects binds
| isEmptyVarEnv final_usage
= binds'
......
......@@ -75,7 +75,7 @@ import FastString
\end{code}
\begin{code}
doStaticArgs :: UniqSupply -> [CoreBind] -> [CoreBind]
doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
where
sat_bind_threaded_us us bind =
......
......@@ -206,7 +206,7 @@ instance Eq Level where
\begin{code}
setLevels :: FloatOutSwitches
-> [CoreBind]
-> CoreProgram
-> UniqSupply
-> [LevelledBind]
......
......@@ -409,7 +409,7 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass)
%************************************************************************
\begin{code}
printCore :: a -> [CoreBind] -> IO ()
printCore :: a -> CoreProgram -> IO ()
printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
......@@ -421,36 +421,36 @@ ruleCheckPass current_phase pat guts = do
return guts
doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDUM do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
us <- getUniqueSupplyM
liftIO $ do_pass dflags us binds
doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassU do_pass = doPassDU (const do_pass)
-- Most passes return no stats and don't change rules: these combinators
-- let us lift them to the full blown ModGuts+CoreM world
doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
doPassM bind_f guts = do
binds' <- bind_f (mg_binds guts)
return (guts { mg_binds = binds' })
doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
-- Observer passes just peek; don't modify the bindings at all
observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
observe do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
_ <- liftIO $ do_pass dflags binds
......@@ -559,7 +559,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
do_iteration :: UniqSupply
-> Int -- Counts iterations
-> [SimplCount] -- Counts from earlier iterations, reversed
-> [CoreBind] -- Bindings in
-> CoreProgram -- Bindings in
-> [CoreRule] -- and orphan rules
-> IO (String, Int, SimplCount, ModGuts)
......@@ -664,7 +664,7 @@ simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
-------------------
end_iteration :: DynFlags -> CoreToDo -> Int
-> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
-> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
end_iteration dflags pass iteration_no counts binds rules
= do { dumpPassResult dflags mb_flag hdr pp_counts binds rules
; lintPassResult dflags pass binds }
......@@ -807,7 +807,7 @@ unfolding for something.
\begin{code}
type IndEnv = IdEnv Id -- Maps local_id -> exported_id
shortOutIndirections :: [CoreBind] -> [CoreBind]
shortOutIndirections :: CoreProgram -> CoreProgram
shortOutIndirections binds
| isEmptyVarEnv ind_env = binds
| no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
......
......@@ -1014,7 +1014,7 @@ is so important.
ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern
-> RuleBase -- ^ Database of rules
-> [CoreBind] -- ^ Bindings to check in
-> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
ruleCheckProgram phase rule_pat rule_base binds
| isEmptyBag results
......
......@@ -140,7 +140,7 @@ for x, solely to put in the SRTs lower down.
%************************************************************************
\begin{code}
coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
coreToStg :: PackageId -> CoreProgram -> IO [StgBinding]
coreToStg this_pkg pgm
= return pgm'
where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
......@@ -153,7 +153,7 @@ coreExprToStg expr
coreTopBindsToStg
:: PackageId
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> CoreProgram
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
......
......@@ -62,14 +62,14 @@ To think about
%************************************************************************
\begin{code}
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
dmdAnalPgm :: DynFlags -> CoreProgram -> IO CoreProgram
dmdAnalPgm _ binds
= do {
let { binds_plus_dmds = do_prog binds } ;
return binds_plus_dmds
}
where
do_prog :: [CoreBind] -> [CoreBind]
do_prog :: CoreProgram -> CoreProgram
do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
dmdAnalTopBind :: SigEnv
......
......@@ -54,7 +54,7 @@ info for exported values).
\end{enumerate}
\begin{code}
wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
wwTopBinds :: UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds us top_binds
= initUs_ us $ do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment