Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
817f93ea
Commit
817f93ea
authored
Feb 24, 2020
by
Sylvain Henry
Committed by
Marge Bot
Feb 26, 2020
Browse files
Modules: Core (#13009)
Update haddock submodule
parent
b2b49a0a
Pipeline
#16263
failed with stages
in 366 minutes and 56 seconds
Changes
151
Pipelines
2
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/GHC.hs
View file @
817f93ea
...
...
@@ -301,7 +301,7 @@ import GHC.Runtime.Eval.Types
import
GHC.Runtime.Interpreter
import
GHCi.RemoteTypes
import
PprTyThing
(
pprFamInst
)
import
GHC.Core.
Ppr
.
TyThing
(
pprFamInst
)
import
GHC.Driver.Main
import
GHC.Driver.Make
import
GHC.Driver.Pipeline
(
compileOne'
)
...
...
@@ -327,7 +327,7 @@ import Avail
import
InstEnv
import
FamInstEnv
(
FamInst
)
import
SrcLoc
import
Core
Syn
import
GHC.
Core
import
GHC.Iface.Tidy
import
GHC.Driver.Phases
(
Phase
(
..
),
isHaskellSrcFilename
)
import
GHC.Driver.Finder
...
...
@@ -353,7 +353,7 @@ import Lexer
import
ApiAnnotation
import
qualified
GHC.LanguageExtensions
as
LangExt
import
NameEnv
import
CoreFVs
(
orphNamesOfFamInst
)
import
GHC.
Core
.
FVs
(
orphNamesOfFamInst
)
import
FamInstEnv
(
famInstEnvElts
)
import
TcRnDriver
import
Inst
...
...
compiler/GHC/ByteCode/Instr.hs
View file @
817f93ea
...
...
@@ -17,13 +17,13 @@ import GHC.ByteCode.Types
import
GHCi.RemoteTypes
import
GHCi.FFI
(
C_ffi_cif
)
import
GHC.StgToCmm.Layout
(
ArgRep
(
..
)
)
import
PprCore
import
GHC.Core.Ppr
import
Outputable
import
FastString
import
Name
import
Unique
import
Id
import
Core
Syn
import
GHC.
Core
import
Literal
import
DataCon
import
VarSet
...
...
compiler/GHC/Cmm/CLabel.hs
View file @
817f93ea
...
...
@@ -130,7 +130,7 @@ import GHC.Driver.Session
import
GHC.Platform
import
UniqSet
import
Util
import
PprCore
(
{- instances -}
)
import
GHC.Core.Ppr
(
{- instances -}
)
-- -----------------------------------------------------------------------------
-- The CLabel type
...
...
compiler/GHC/Cmm/CommonBlockElim.hs
View file @
817f93ea
...
...
@@ -300,7 +300,7 @@ copyTicks env g
foldr
blockCons
code
(
map
CmmTick
ticks
)
-- Group by [Label]
-- See Note [Compressed TrieMap] in
coreSyn/Trie
Map about the usage of GenMap.
-- See Note [Compressed TrieMap] in
GHC.Core.
Map about the usage of GenMap.
groupByLabel
::
[(
Key
,
DistinctBlocks
)]
->
[(
Key
,
[
DistinctBlocks
])]
groupByLabel
=
go
(
TM
.
emptyTM
::
TM
.
ListMap
(
TM
.
GenMap
LabelMap
)
(
Key
,
[
DistinctBlocks
]))
...
...
compiler/GHC/Cmm/DebugBlock.hs
View file @
817f93ea
...
...
@@ -31,7 +31,7 @@ import GHC.Cmm.BlockId
import
GHC.Cmm.CLabel
import
GHC.Cmm
import
GHC.Cmm.Utils
import
Core
Syn
import
GHC.
Core
import
FastString
(
nilFS
,
mkFastString
)
import
Module
import
Outputable
...
...
compiler/GHC/Cmm/Node.hs
View file @
817f93ea
...
...
@@ -36,7 +36,7 @@ import FastString
import
ForeignCall
import
Outputable
import
GHC.Runtime.Heap.Layout
import
Core
Syn
(
Tickish
)
import
GHC.
Core
(
Tickish
)
import
qualified
Unique
as
U
import
GHC.Cmm.Dataflow.Block
...
...
compiler/GHC/Cmm/Parser.y
View file @
817f93ea
...
...
@@ -219,7 +219,7 @@ import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout hiding (ArgRep(..))
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
import Core
Syn
( Tickish(SourceNote) )
import
GHC.
Core ( Tickish(SourceNote) )
import GHC.Cmm.Opt
import GHC.Cmm.Graph
...
...
compiler/GHC/CmmToAsm/Dwarf.hs
View file @
817f93ea
...
...
@@ -7,7 +7,7 @@ import GhcPrelude
import
GHC.Cmm.CLabel
import
GHC.Cmm.Expr
(
GlobalReg
(
..
)
)
import
Config
(
cProjectName
,
cProjectVersion
)
import
Core
Syn
(
Tickish
(
..
)
)
import
GHC.
Core
(
Tickish
(
..
)
)
import
GHC.Cmm.DebugBlock
import
GHC.Driver.Session
import
Module
...
...
compiler/GHC/CmmToAsm/X86/CodeGen.hs
View file @
817f93ea
...
...
@@ -75,7 +75,7 @@ import GHC.Cmm.Dataflow.Collections
import
GHC.Cmm.Dataflow.Graph
import
GHC.Cmm.Dataflow.Label
import
GHC.Cmm.CLabel
import
Core
Syn
(
Tickish
(
..
)
)
import
GHC.
Core
(
Tickish
(
..
)
)
import
SrcLoc
(
srcSpanFile
,
srcSpanStartLine
,
srcSpanStartCol
)
-- The rest:
...
...
compiler/
coreSyn
/Core
Syn
.hs
→
compiler/
GHC
/Core.hs
View file @
817f93ea
This diff is collapsed.
Click to expand it.
compiler/
coreSyn
/CoreArity.hs
→
compiler/
GHC
/Core
/
Arity.hs
View file @
817f93ea
...
...
@@ -11,21 +11,22 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-- | Arity and eta expansion
module
CoreArity
(
manifestArity
,
joinRhsArity
,
exprArity
,
typeArity
,
exprEtaExpandArity
,
findRhsArity
,
etaExpand
,
etaExpandToJoinPoint
,
etaExpandToJoinPointRule
,
exprBotStrictness_maybe
)
where
module
GHC.Core.Arity
(
manifestArity
,
joinRhsArity
,
exprArity
,
typeArity
,
exprEtaExpandArity
,
findRhsArity
,
etaExpand
,
etaExpandToJoinPoint
,
etaExpandToJoinPointRule
,
exprBotStrictness_maybe
)
where
#
include
"HsVersions.h"
import
GhcPrelude
import
Core
Syn
import
CoreFVs
import
CoreUtils
import
CoreSubst
import
GHC.
Core
import
GHC.
Core
.
FVs
import
GHC.
Core
.
Utils
import
GHC.
Core
.
Subst
import
Demand
import
Var
import
VarEnv
...
...
@@ -992,19 +993,19 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
-- ((substExpr s e) `appliedto` eis)
etaInfoApp
subst
(
Lam
v1
e
)
(
EtaVar
v2
:
eis
)
=
etaInfoApp
(
CoreSubst
.
extendSubstWithVar
subst
v1
v2
)
e
eis
=
etaInfoApp
(
GHC
.
Core
.
Subst
.
extendSubstWithVar
subst
v1
v2
)
e
eis
etaInfoApp
subst
(
Cast
e
co1
)
eis
=
etaInfoApp
subst
e
(
pushCoercion
co'
eis
)
where
co'
=
CoreSubst
.
substCo
subst
co1
co'
=
GHC
.
Core
.
Subst
.
substCo
subst
co1
etaInfoApp
subst
(
Case
e
b
ty
alts
)
eis
=
Case
(
subst_expr
subst
e
)
b1
ty'
alts'
where
(
subst1
,
b1
)
=
substBndr
subst
b
alts'
=
map
subst_alt
alts
ty'
=
etaInfoAppTy
(
CoreSubst
.
substTy
subst
ty
)
eis
ty'
=
etaInfoAppTy
(
GHC
.
Core
.
Subst
.
substTy
subst
ty
)
eis
subst_alt
(
con
,
bs
,
rhs
)
=
(
con
,
bs'
,
etaInfoApp
subst2
rhs
eis
)
where
(
subst2
,
bs'
)
=
substBndrs
subst1
bs
...
...
@@ -1095,7 +1096,7 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
----------- Function types (t1 -> t2)
|
Just
(
arg_ty
,
res_ty
)
<-
splitFunTy_maybe
ty
,
not
(
isTypeLevPoly
arg_ty
)
-- See Note [Levity polymorphism invariants] in Core
Syn
-- See Note [Levity polymorphism invariants] in
GHC.
Core
-- See also test case typecheck/should_run/EtaExpandLevPoly
,
let
(
subst'
,
eta_id'
)
=
freshEtaId
n
subst
arg_ty
...
...
@@ -1135,7 +1136,7 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
-- TODO Check if we actually *are* changing any join points' types
subst_expr
::
Subst
->
CoreExpr
->
CoreExpr
subst_expr
=
substExpr
(
text
"CoreArity:substExpr"
)
subst_expr
=
substExpr
(
text
"
GHC.
Core
.
Arity:substExpr"
)
--------------
...
...
compiler/
coreSyn
/CoreFVs.hs
→
compiler/
GHC
/Core
/
FVs.hs
View file @
817f93ea
...
...
@@ -8,7 +8,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
{-# LANGUAGE CPP #-}
-- | A module concerned with finding the free variables of an expression.
module
CoreFVs
(
module
GHC.
Core
.
FVs
(
-- * Free variables of expressions and binding groups
exprFreeVars
,
exprFreeVarsDSet
,
...
...
@@ -61,7 +61,7 @@ module CoreFVs (
import
GhcPrelude
import
Core
Syn
import
GHC.
Core
import
Id
import
IdInfo
import
NameSet
...
...
compiler/
coreSyn
/CoreLint.hs
→
compiler/
GHC
/Core
/
Lint.hs
View file @
817f93ea
...
...
@@ -10,7 +10,7 @@ See Note [Core Lint guarantee].
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
module
CoreLint
(
module
GHC.
Core
.
Lint
(
lintCoreBindings
,
lintUnfolding
,
lintPassResult
,
lintInteractiveExpr
,
lintExpr
,
lintAnnots
,
lintTypes
,
...
...
@@ -18,17 +18,17 @@ module CoreLint (
-- ** Debug output
endPass
,
endPassIO
,
dumpPassResult
,
CoreLint
.
dumpIfSet
,
GHC
.
Core
.
Lint
.
dumpIfSet
,
)
where
#
include
"HsVersions.h"
import
GhcPrelude
import
Core
Syn
import
CoreFVs
import
CoreUtils
import
CoreStats
(
coreBindsStats
)
import
GHC.
Core
import
GHC.
Core
.
FVs
import
GHC.
Core
.
Utils
import
GHC.
Core
.
Stats
(
coreBindsStats
)
import
CoreMonad
import
Bag
import
Literal
...
...
@@ -42,7 +42,7 @@ import VarSet
import
Name
import
Id
import
IdInfo
import
PprCore
import
GHC.Core.Ppr
import
ErrUtils
import
Coercion
import
SrcLoc
...
...
@@ -63,7 +63,7 @@ import FastString
import
Util
import
InstEnv
(
instanceDFunId
)
import
OptCoercion
(
checkAxInstCo
)
import
CoreArity
(
typeArity
)
import
GHC.
Core
.
Arity
(
typeArity
)
import
Demand
(
splitStrictSig
,
isBotDiv
)
import
GHC.Driver.Types
...
...
@@ -92,7 +92,7 @@ then running the compiled program will not seg-fault, assuming no bugs downstrea
to decouple the safety of the resulting program from the type inference algorithm.
However, do note point (4) above. Core Lint does not check for incomplete case-matches;
see Note [Case expression invariants] in Core
Syn
, invariant (4). As explained there,
see Note [Case expression invariants] in
GHC.
Core, invariant (4). As explained there,
an incomplete case-match might slip by Core Lint and cause trouble at runtime.
Note [GHC Formalism]
...
...
@@ -162,7 +162,7 @@ Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
In the desugarer, it's very very convenient to be able to say (in effect)
let a = Type Int in <body>
That is, use a type let. See Note [Type let] in Core
Syn
.
That is, use a type let. See Note [Type let] in
GHC.
Core.
However, when linting <body> we need to remember that a=Int, else we might
reject a correct program. So we carry a type substitution (in this example
...
...
@@ -197,7 +197,7 @@ different types, called bad coercions. Following coercions are forbidden:
Note [Join points]
~~~~~~~~~~~~~~~~~~
We check the rules listed in Note [Invariants on join points] in Core
Syn
. The
We check the rules listed in Note [Invariants on join points] in
GHC.
Core. The
only one that causes any difficulty is the first: All occurrences must be tail
calls. To this end, along with the in-scope set, we remember in le_joins the
subset of in-scope Ids that are valid join ids. For example:
...
...
@@ -549,7 +549,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
;
ensureEqTys
binder_ty
ty
(
mkRhsMsg
binder
(
text
"RHS"
)
ty
)
-- If the binding is for a CoVar, the RHS should be (Coercion co)
-- See Note [Core
Syn
type and coercion invariant] in Core
Syn
-- See Note [Core type and coercion invariant] in
GHC.
Core
;
checkL
(
not
(
isCoVar
binder
)
||
isCoArg
rhs
)
(
mkLetErr
binder
rhs
)
...
...
@@ -561,7 +561,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
(
badBndrTyMsg
binder
(
text
"levity-polymorphic"
))
-- Check the let/app invariant
-- See Note [Core
Syn
let/app invariant] in Core
Syn
-- See Note [Core let/app invariant] in
GHC.
Core
;
checkL
(
isJoinId
binder
||
not
(
isUnliftedType
binder_ty
)
||
(
isNonRec
rec_flag
&&
exprOkForSpeculation
rhs
)
...
...
@@ -570,7 +570,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check that if the binder is top-level or recursive, it's not
-- demanded. Primitive string literals are exempt as there is no
-- computation to perform, see Note [Core
Syn
top-level string literals].
-- computation to perform, see Note [Core top-level string literals].
;
checkL
(
not
(
isStrictId
binder
)
||
(
isNonRec
rec_flag
&&
not
(
isTopLevel
top_lvl_flag
))
||
exprIsTickedString
rhs
)
...
...
@@ -578,7 +578,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check that if the binder is at the top level and has type Addr#,
-- that it is a string literal, see
-- Note [Core
Syn
top-level string literals].
-- Note [Core top-level string literals].
;
checkL
(
not
(
isTopLevel
top_lvl_flag
&&
binder_ty
`
eqType
`
addrPrimTy
)
||
exprIsTickedString
rhs
)
(
mkTopNonLitStrMsg
binder
)
...
...
@@ -687,7 +687,7 @@ lintIdUnfolding bndr bndr_ty uf
;
ensureEqTys
bndr_ty
ty
(
mkRhsMsg
bndr
(
text
"unfolding"
)
ty
)
}
lintIdUnfolding
_
_
_
=
return
()
-- Do not Lint unstable unfoldings, because that leads
-- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
-- to exponential behaviour; c.f.
GHC.
Core
.
FVs.idUnfoldingVars
{-
Note [Checking for INLINE loop breakers]
...
...
@@ -702,7 +702,7 @@ the desugarer.
Note [Checking for levity polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We ordinarily want to check for bad levity polymorphism. See
Note [Levity polymorphism invariants] in Core
Syn
. However, we do *not*
Note [Levity polymorphism invariants] in
GHC.
Core. However, we do *not*
want to do this in a compulsory unfolding. Compulsory unfoldings arise
only internally, for things like newtype wrappers, dictionaries, and
(notably) unsafeCoerce#. These might legitimately be levity-polymorphic;
...
...
@@ -838,7 +838,7 @@ lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
lintVarOcc
var
nargs
=
do
{
checkL
(
isNonCoVarId
var
)
(
text
"Non term variable"
<+>
ppr
var
)
-- See Core
Syn
Note [Variable occurrences in Core]
-- See
GHC.
Core Note [Variable occurrences in Core]
-- Cneck that the type of the occurrence is the same
-- as the type of the binding site
...
...
@@ -971,7 +971,7 @@ Consider:
This is clearly ill-typed, since the jump is inside both an application and a
lambda, either of which is enough to disqualify it as a tail call (see Note
[Invariants on join points] in Core
Syn
). However, strictly from a
[Invariants on join points] in
GHC.
Core). However, strictly from a
lambda-calculus perspective, the term doesn't go wrong---after the two beta
reductions, the jump *is* a tail call and everything is fine.
...
...
@@ -981,10 +981,10 @@ rules: naively reducing the above example using lets will capture any free
occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
such as Float Out, tacitly assume that the incoming program's type lets have
all been dealt with by the simplifier. Thus we don't want to let-bind any types
in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately
in, say,
GHC.
Core
.
Subst.simpleOptPgm, which in some circumstances can run immediately
before Float Out.
All that said, currently CoreSubst.simpleOptPgm is the only thing using this
All that said, currently
GHC.
Core
.
Subst.simpleOptPgm is the only thing using this
loophole, doing so to avoid re-traversing large functions (beta-reducing a type
lambda without introducing a type let requires a substitution). TODO: Improve
simpleOptPgm so that we can forget all this ever happened.
...
...
@@ -1013,7 +1013,7 @@ lintCoreArg fun_ty (Type arg_ty)
lintCoreArg
fun_ty
arg
=
do
{
arg_ty
<-
markAllJoinsBad
$
lintCoreExpr
arg
-- See Note [Levity polymorphism invariants] in Core
Syn
-- See Note [Levity polymorphism invariants] in
GHC.
Core
;
flags
<-
getLintFlags
;
lintL
(
not
(
lf_check_levity_poly
flags
)
||
not
(
isTypeLevPoly
arg_ty
))
(
text
"Levity-polymorphic argument:"
<+>
...
...
@@ -1094,7 +1094,7 @@ lintCaseExpr scrut var alt_ty alts =
-- Check the scrutinee
;
scrut_ty
<-
markAllJoinsBad
$
lintCoreExpr
scrut
-- See Note [Join points are less general than the paper]
-- in Core
Syn
-- in
GHC.
Core
;
(
alt_ty
,
_
)
<-
addLoc
(
CaseTy
scrut
)
$
lintInTy
alt_ty
...
...
@@ -1107,7 +1107,7 @@ lintCaseExpr scrut var alt_ty alts =
-- Check that the scrutinee is not a floating-point type
-- if there are any literal alternatives
-- See Core
Syn
Note [Case expression invariants] item (5)
-- See
GHC.
Core Note [Case expression invariants] item (5)
-- See Note [Rules for floating-point comparisons] in PrelRules
;
let
isLitPat
(
LitAlt
_
,
_
,
_
)
=
True
isLitPat
_
=
False
...
...
@@ -1133,7 +1133,7 @@ lintCaseExpr scrut var alt_ty alts =
;
subst
<-
getTCvSubst
;
ensureEqTys
var_ty
scrut_ty
(
mkScrutMsg
var
var_ty
scrut_ty
subst
)
-- See Core
Syn
Note [Case expression invariants] item (7)
-- See
GHC.
Core Note [Case expression invariants] item (7)
;
lintBinder
CaseBind
var
$
\
_
->
do
{
-- Check the alternatives
...
...
@@ -1152,14 +1152,14 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
checkCaseAlts
e
ty
alts
=
do
{
checkL
(
all
non_deflt
con_alts
)
(
mkNonDefltMsg
e
)
-- See Core
Syn
Note [Case expression invariants] item (2)
-- See
GHC.
Core Note [Case expression invariants] item (2)
;
checkL
(
increasing_tag
con_alts
)
(
mkNonIncreasingAltsMsg
e
)
-- See Core
Syn
Note [Case expression invariants] item (3)
-- See
GHC.
Core Note [Case expression invariants] item (3)
-- For types Int#, Word# with an infinite (well, large!) number of
-- possible values, there should usually be a DEFAULT case
-- But (see Note [Empty case alternatives] in Core
Syn
) it's ok to
-- But (see Note [Empty case alternatives] in
GHC.
Core) it's ok to
-- have *no* case alternatives.
-- In effect, this is a kind of partial test. I suppose it's possible
-- that we might *know* that 'x' was 1 or 2, in which case
...
...
@@ -1185,7 +1185,7 @@ lintAltExpr :: CoreExpr -> OutType -> LintM ()
lintAltExpr
expr
ann_ty
=
do
{
actual_ty
<-
lintCoreExpr
expr
;
ensureEqTys
actual_ty
ann_ty
(
mkCaseAltMsg
expr
actual_ty
ann_ty
)
}
-- See Core
Syn
Note [Case expression invariants] item (6)
-- See
GHC.
Core Note [Case expression invariants] item (6)
lintCoreAlt
::
OutType
-- Type of scrutinee
->
OutType
-- Type of the alternative
...
...
@@ -1299,7 +1299,7 @@ lintIdBndr top_lvl bind_site id linterF
;
(
ty
,
k
)
<-
addLoc
(
IdTy
id
)
$
lintInTy
(
idType
id
)
-- See Note [Levity polymorphism invariants] in Core
Syn
-- See Note [Levity polymorphism invariants] in
GHC.
Core
;
lintL
(
isJoinId
id
||
not
(
lf_check_levity_poly
flags
)
||
not
(
isKindLevPoly
k
))
(
text
"Levity-polymorphic binder:"
<+>
(
ppr
id
<+>
dcolon
<+>
parens
(
ppr
ty
<+>
dcolon
<+>
ppr
k
)))
...
...
@@ -1455,7 +1455,7 @@ Here 'cls' appears free in b's kind, which would usually be illegal
#in this case (Alg cls *) = *, so all is well. Currently we allow
this, and make Lint expand synonyms where necessary to make it so.
c.f. TcUnify.occCheckExpand and CoreUtils.coreAltsType which deal
c.f. TcUnify.occCheckExpand and
GHC.
Core
.
Utils.coreAltsType which deal
with the same problem. A single systematic solution eludes me.
-}
...
...
@@ -1612,7 +1612,7 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
rhs_fvs
=
exprFreeVars
rhs
is_bad_bndr
::
Var
->
Bool
-- See Note [Unbound RULE binders] in Rules
-- See Note [Unbound RULE binders] in
GHC.Core.
Rules
is_bad_bndr
bndr
=
not
(
bndr
`
elemVarSet
`
lhs_fvs
)
&&
bndr
`
elemVarSet
`
rhs_fvs
&&
isNothing
(
isReflCoVar_maybe
bndr
)
...
...
@@ -1659,7 +1659,7 @@ argument to be made for allowing a situation like this:
Applying this rule can't turn a well-typed program into an ill-typed one, so
conceivably we could allow it. But we can always eta-expand such an
"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact
"undersaturated" rule (see '
GHC.
Core
.
Arity.etaExpandToJoinPointRule'), and in fact
the simplifier would have to in order to deal with the RHS. So we take a
conservative view and don't allow undersaturated rules for join points. See
Note [Rules and join points] in OccurAnal for further discussion.
...
...
compiler/
coreSyn/MkCor
e.hs
→
compiler/
GHC/Core/Mak
e.hs
View file @
817f93ea
...
...
@@ -3,7 +3,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Handy functions for creating much Core syntax
module
MkCor
e
(
module
GHC.Core.Mak
e
(
-- * Constructing normal syntax
mkCoreLet
,
mkCoreLets
,
mkCoreApp
,
mkCoreApps
,
mkCoreConApps
,
...
...
@@ -59,8 +59,8 @@ import GhcPrelude
import
Id
import
Var
(
EvVar
,
setTyVarUnique
)
import
Core
Syn
import
CoreUtils
(
exprType
,
needsCaseBinding
,
mkSingleAltCase
,
bindNonRec
)
import
GHC.
Core
import
GHC.
Core
.
Utils
(
exprType
,
needsCaseBinding
,
mkSingleAltCase
,
bindNonRec
)
import
Literal
import
GHC.Driver.Types
...
...
@@ -92,7 +92,7 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
{-
************************************************************************
* *
\subsection{Basic Core
Syn
construction}
\subsection{Basic
GHC.
Core construction}
* *
************************************************************************
-}
...
...
@@ -108,9 +108,9 @@ sortQuantVars vs = sorted_tcvs ++ ids
sorted_tcvs
=
scopedSort
tcvs
-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "GHC.Core#let_app_invariant")
mkCoreLet
::
CoreBind
->
CoreExpr
->
CoreExpr
mkCoreLet
(
NonRec
bndr
rhs
)
body
-- See Note [Core let/app invariant]
=
bindNonRec
bndr
rhs
body
mkCoreLet
bind
body
=
Let
bind
body
...
...
@@ -135,7 +135,7 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
-- Respects the let/app invariant by building a case expression where necessary
-- See
CoreSyn
Note [Core
Syn
let/app invariant]
-- See Note [Core let/app invariant]
in GHC.Core
mkCoreApps
::
CoreExpr
->
[
CoreExpr
]
->
CoreExpr
mkCoreApps
fun
args
=
fst
$
...
...
@@ -147,7 +147,7 @@ mkCoreApps fun args
-- | Construct an expression which represents the application of one expression
-- to the other
-- Respects the let/app invariant by building a case expression where necessary
-- See
CoreSyn
Note [Core
Syn
let/app invariant]
-- See Note [Core let/app invariant]
in GHC.Core
mkCoreApp
::
SDoc
->
CoreExpr
->
CoreExpr
->
CoreExpr
mkCoreApp
s
fun
arg
=
fst
$
mkCoreAppTyped
s
(
fun
,
exprType
fun
)
arg
...
...
@@ -157,7 +157,7 @@ mkCoreApp s fun arg
-- function is not exported and used in the definition of 'mkCoreApp' and
-- 'mkCoreApps'.
-- Respects the let/app invariant by building a case expression where necessary
-- See
CoreSyn
Note [Core
Syn
let/app invariant]
-- See Note [Core let/app invariant]
in GHC.Core
mkCoreAppTyped
::
SDoc
->
(
CoreExpr
,
Type
)
->
CoreExpr
->
(
CoreExpr
,
Type
)
mkCoreAppTyped
_
(
fun
,
fun_ty
)
(
Type
ty
)
=
(
App
fun
(
Type
ty
),
piResultTy
fun_ty
ty
)
...
...
@@ -173,7 +173,7 @@ mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
-- Build an application (e1 e2),
-- or a strict binding (case e2 of x -> e1 x)
-- using the latter when necessary to respect the let/app invariant
-- See Note [Core
Syn
let/app invariant]
-- See Note [Core let/app invariant]
in GHC.Core
mkValApp
fun
arg
arg_ty
res_ty
|
not
(
needsCaseBinding
arg_ty
arg
)
=
App
fun
arg
-- The vastly common case
...
...
@@ -234,7 +234,7 @@ mkIfThenElse guard then_expr else_expr
castBottomExpr
::
CoreExpr
->
Type
->
CoreExpr
-- (castBottomExpr e ty), assuming that 'e' diverges,
-- return an expression of type 'ty'
-- See Note [Empty case alternatives] in Core
Syn
-- See Note [Empty case alternatives] in
GHC.
Core
castBottomExpr
e
res_ty
|
e_ty
`
eqType
`
res_ty
=
e
|
otherwise
=
Case
e
(
mkWildValBinder
e_ty
)
res_ty
[]
...
...
compiler/
coreSyn
/CoreMap.hs
→
compiler/
GHC
/Core
/
Map.hs
View file @
817f93ea
...
...
@@ -11,7 +11,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module
CoreMap
(
module
GHC.
Core
.
Map
(
-- * Maps over Core expressions
CoreMap
,
emptyCoreMap
,
extendCoreMap
,
lookupCoreMap
,
foldCoreMap
,
-- * Maps over 'Type's
...
...
@@ -40,7 +40,7 @@ module CoreMap(
import
GhcPrelude
import
TrieMap
import
Core
Syn
import
GHC.
Core
import
Coercion
import
Name
import
Type
...
...
@@ -139,7 +139,7 @@ We could compare the return type regardless, but the wildly common case
is that it's unnecessary, so we have two fields (cm_case and cm_ecase)
for the two possibilities. Only cm_ecase looks at the type.
See also Note [Empty case alternatives] in Core
Syn
.
See also Note [Empty case alternatives] in
GHC.
Core.
-}
-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this
...
...
compiler/
coreSyn
/CoreTidy.hs
→
compiler/
GHC
/Core
/Op/
Tidy.hs
View file @
817f93ea
...
...
@@ -9,7 +9,7 @@ The code for *top-level* bindings is in GHC.Iface.Tidy.
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module
Core
Tidy
(
module
GHC.Core.Op.
Tidy
(
tidyExpr
,
tidyRules
,
tidyUnfolding
)
where
...
...
@@ -17,8 +17,8 @@ module CoreTidy (
import
GhcPrelude
import
Core
Syn
import
CoreSeq
(
seqUnfolding
)
import
GHC.
Core
import
GHC.
Core
.
Seq
(
seqUnfolding
)
import
Id
import
IdInfo
import
Demand
(
zapUsageEnvSig
)
...
...
compiler/
coreSyn/PprCore
.hs
→
compiler/
GHC/Core/Ppr
.hs
View file @
817f93ea
...
...
@@ -10,7 +10,7 @@ Printing of Core syntax
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module
PprCore
(
module
GHC.Core.Ppr
(
pprCoreExpr
,
pprParendExpr
,
pprCoreBinding
,
pprCoreBindings
,
pprCoreAlt
,
pprCoreBindingWithSize
,
pprCoreBindingsWithSize
,
...
...
@@ -19,8 +19,8 @@ module PprCore (
import
GhcPrelude
import
Core
Syn
import
CoreStats
(
exprStats
)
import
GHC.
Core
import
GHC.
Core
.
Stats
(
exprStats
)
import
Literal
(
pprLiteral
)
import
Name
(
pprInfixName
,
pprPrefixName
)
import
Var
...
...
@@ -517,7 +517,7 @@ ppIdInfo id info
,
(
not
(
null
rules
),
text
"RULES:"
<+>
vcat
(
map
pprRule
rules
))
]
-- Inline pragma, occ, demand, one-shot info
-- printed out with all binders (when debug is on);
-- see
PprCore
.pprIdBndr
-- see
GHC.Core.Ppr
.pprIdBndr
where
pp_scope
|
isGlobalId
id
=
text
"GblId"
|
isExportedId
id
=
text
"LclIdX"
...
...
compiler/
main
/PprTyThing.hs
→
compiler/
GHC/Core
/Ppr
/
TyThing.hs
View file @
817f93ea
...
...
@@ -7,7 +7,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module
PprTyThing
(
module
GHC.Core.
Ppr
.
TyThing
(
pprTyThing
,
pprTyThingInContext
,
pprTyThingLoc
,
...
...
compiler/
specialis
e/Rules.hs
→
compiler/
GHC/Cor
e/Rules.hs
View file @
817f93ea
...
...
@@ -8,7 +8,7 @@