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
Shayne Fletcher
Glasgow Haskell Compiler
Commits
c5452cc1
Commit
c5452cc1
authored
Jan 06, 2017
by
Facundo Domínguez
Browse files
Revert "Have addModFinalizer expose the local type environment."
This reverts commit
e5d1ed9c
.
parent
54227a45
Changes
14
Hide whitespace changes
Inline
Side-by-side
compiler/coreSyn/CoreLint.hs
View file @
c5452cc1
...
...
@@ -67,6 +67,7 @@ import Control.Monad
import
qualified
Control.Monad.Fail
as
MonadFail
#
endif
import
MonadUtils
import
Data.Function
(
fix
)
import
Data.Maybe
import
Pair
import
qualified
GHC.LanguageExtensions
as
LangExt
...
...
@@ -389,12 +390,12 @@ lintCoreBindings dflags pass local_in_scope binds
_
->
True
-- See Note [Checking StaticPtrs]
check_static_ptrs
|
not
(
xopt
LangExt
.
StaticPointers
dflags
)
=
AllowAnywhere
|
otherwise
=
case
pass
of
CoreDoFloatOutwards
_
->
AllowAtTopLevel
CoreTidy
->
RejectEverywher
e
CorePrep
->
AllowAtTopLevel
_
->
AllowAnywher
e
check_static_ptrs
=
xopt
LangExt
.
StaticPointers
dflags
&&
case
pass
of
CoreDoFloatOutwards
_
->
True
CoreTidy
->
Tru
e
CorePrep
->
True
_
->
Fals
e
binders
=
bindersOfBinds
binds
(
_
,
dups
)
=
removeDups
compare
binders
...
...
@@ -535,32 +536,28 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
|
otherwise
=
return
()
-- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr'
-- in that it doesn't reject
occurrences of the function 'makeStatic' when they
-- appear at the top level
and @lf_check_static_ptrs == AllowAtTopLevel@
.
-- in that it doesn't reject
applications of the data constructor @StaticPtr@
--
when they
appear at the top level.
--
-- See Note [Checking StaticPtrs].
lintRhs
::
CoreExpr
->
LintM
OutType
lintRhs
rhs
=
fmap
lf_check_static_ptrs
getLintFlags
>>=
go
where
-- Allow occurrences of 'makeStatic' at the top-level but produce errors
-- otherwise.
go
AllowAtTopLevel
|
(
binders0
,
rhs'
)
<-
collectTyBinders
rhs
,
Just
(
fun
,
t
,
info
,
e
)
<-
collectMakeStaticArgs
rhs'
=
foldr
-- Allow applications of the data constructor @StaticPtr@ at the top
-- but produce errors otherwise.
lintRhs
rhs
|
(
binders0
,
rhs'
)
<-
collectTyBinders
rhs
,
Just
(
fun
,
args
)
<-
collectStaticPtrSatArgs
rhs'
=
flip
fix
binders0
$
\
loopBinders
binders
->
case
binders
of
-- imitate @lintCoreExpr (Lam ...)@
(
\
var
loopBinders
->
addLoc
(
LambdaBodyOf
var
)
$
lintBinder
var
$
\
var'
->
do
{
body_ty
<-
loopBinders
;
return
$
mkLamType
var'
body_ty
}
)
var
:
vars
->
addLoc
(
LambdaBodyOf
var
)
$
lintBinder
var
$
\
var'
->
do
{
body_ty
<-
loopBinders
vars
;
return
$
mkLamType
var'
body_ty
}
-- imitate @lintCoreExpr (App ...)@
(
do
fun_ty
<-
lintCoreExpr
fun
addLoc
(
AnExpr
rhs'
)
$
lintCoreArgs
fun_ty
[
Type
t
,
info
,
e
]
)
binders0
go
_
=
lintCoreExpr
rhs
[]
->
do
fun_ty
<-
lintCoreExpr
fun
addLoc
(
AnExpr
rhs'
)
$
lintCoreArgs
fun_ty
args
-- Rejects applications of the data constructor @StaticPtr@ if it finds any.
lintRhs
rhs
=
lintCoreExpr
rhs
lintIdUnfolding
::
Id
->
Type
->
Unfolding
->
LintM
()
lintIdUnfolding
bndr
bndr_ty
(
CoreUnfolding
{
uf_tmpl
=
rhs
,
uf_src
=
src
})
...
...
@@ -676,10 +673,11 @@ lintCoreExpr e@(App _ _)
-- Check for a nested occurrence of the StaticPtr constructor.
-- See Note [Checking StaticPtrs].
case
fun
of
Var
b
|
lf_check_static_ptrs
lf
/=
AllowAnywhere
,
idName
b
==
makeStaticName
Var
b
|
lf_check_static_ptrs
lf
,
Just
con
<-
isDataConId_maybe
b
,
dataConName
con
==
staticPtrDataConName
->
do
failWithL
$
text
"Found
make
Static nested in an expression: "
<+>
failWithL
$
text
"Found Static
Ptr
nested in an expression: "
<+>
ppr
e
_
->
go
where
...
...
@@ -1611,24 +1609,13 @@ data LintEnv
data
LintFlags
=
LF
{
lf_check_global_ids
::
Bool
-- See Note [Checking for global Ids]
,
lf_check_inline_loop_breakers
::
Bool
-- See Note [Checking for INLINE loop breakers]
,
lf_check_static_ptrs
::
StaticPtrCheck
-- ^ See Note [Checking StaticPtrs]
,
lf_check_static_ptrs
::
Bool
-- See Note [Checking StaticPtrs]
}
-- See Note [Checking StaticPtrs]
data
StaticPtrCheck
=
AllowAnywhere
-- ^ Allow 'makeStatic' to occur anywhere.
|
AllowAtTopLevel
-- ^ Allow 'makeStatic' calls at the top-level only.
|
RejectEverywhere
-- ^ Reject any 'makeStatic' occurrence.
deriving
Eq
defaultLintFlags
::
LintFlags
defaultLintFlags
=
LF
{
lf_check_global_ids
=
False
,
lf_check_inline_loop_breakers
=
True
,
lf_check_static_ptrs
=
AllowAnywher
e
,
lf_check_static_ptrs
=
Fals
e
}
newtype
LintM
a
=
...
...
@@ -1648,17 +1635,30 @@ Note [Checking StaticPtrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
See SimplCore Note [Grand plan for static forms] for an overview.
Every occurrence of the
function 'make
Static
'
should be moved
to the
top level by the FloatOut pass. It's vital that we don't have
nested
'makeStatic' occurrenc
es after CorePrep, because we populate the Static
Every occurrence of the
data constructor @
Static
Ptr@
should be moved
to the
top level by the FloatOut pass. It's vital that we don't have
nested StaticPtr us
es after CorePrep, because we populate the Static
Pointer Table from the top-level bindings. See SimplCore Note [Grand
plan for static forms].
The linter checks that no occurrence is left behind, nested within an
expression. The check is enabled only after the FloatOut, CorePrep,
and CoreTidy passes and only if the module uses the StaticPointers
language extension. Checking more often doesn't help since the condition
doesn't hold until after the first FloatOut pass.
expression. The check is enabled only:
* After the FloatOut, CorePrep, and CoreTidy passes.
We could check more often, but the condition doesn't hold until
after the first FloatOut pass.
* When the module uses the StaticPointers language extension. This is
a little hack. This optimization arose from the need to compile
GHC.StaticPtr, which otherwise would be rejected because of the
following binding for the StaticPtr data constructor itself:
StaticPtr = \a b1 b2 b3 b4 -> StaticPtr a b1 b2 b3 b4
which contains an application of `StaticPtr` nested within the
lambda abstractions. This binding is injected by CorePrep.
Note that GHC.StaticPtr is itself compiled without -XStaticPointers.
Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
...
...
compiler/coreSyn/CoreUtils.hs
View file @
c5452cc1
...
...
@@ -48,13 +48,13 @@ module CoreUtils (
stripTicksE
,
stripTicksT
,
-- * StaticPtr
collect
Make
StaticArgs
collectStatic
PtrSat
Args
)
where
#
include
"HsVersions.h"
import
CoreSyn
import
PrelNames
(
makeStatic
Name
)
import
PrelNames
(
staticPtrDataCon
Name
)
import
PprCore
import
CoreFVs
(
exprFreeVars
)
import
Var
...
...
@@ -2217,13 +2217,16 @@ isEmptyTy ty
*****************************************************
-}
-- | @collect
Make
Static
Args (makeStatic t info e)@ yields
--
@Just (makeStatic, t, info, e)@
.
-- | @collectStatic
PtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
--
and @s = StaticPtr@ and the application of @StaticPtr@ is saturated
.
--
-- Returns @Nothing@ for every other expression.
collectMakeStaticArgs
::
CoreExpr
->
Maybe
(
CoreExpr
,
Type
,
CoreExpr
,
CoreExpr
)
collectMakeStaticArgs
e
|
(
fun
@
(
Var
b
),
[
Type
t
,
info
,
arg
],
_
)
<-
collectArgsTicks
(
const
True
)
e
,
idName
b
==
makeStaticName
=
Just
(
fun
,
t
,
info
,
arg
)
collectMakeStaticArgs
_
=
Nothing
-- Yields @Nothing@ otherwise.
collectStaticPtrSatArgs
::
Expr
b
->
Maybe
(
Expr
b
,
[
Arg
b
])
collectStaticPtrSatArgs
e
|
(
fun
@
(
Var
b
),
args
,
_
)
<-
collectArgsTicks
(
const
True
)
e
,
Just
con
<-
isDataConId_maybe
b
,
dataConName
con
==
staticPtrDataConName
,
length
args
==
5
=
Just
(
fun
,
args
)
collectStaticPtrSatArgs
_
=
Nothing
compiler/deSugar/DsExpr.hs
View file @
c5452cc1
...
...
@@ -27,6 +27,7 @@ import FamInstEnv( topNormaliseType )
import
DsMeta
import
HsSyn
import
Platform
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import
TcType
...
...
@@ -55,7 +56,11 @@ import Bag
import
Outputable
import
PatSyn
import
Data.List
(
intercalate
)
import
Data.IORef
(
atomicModifyIORef'
)
import
Control.Monad
import
GHC.Fingerprint
{-
************************************************************************
...
...
@@ -418,17 +423,24 @@ dsExpr (PArrSeq _ _)
Static Pointers
~~~~~~~~~~~~~~~
See Note [Grand plan for static forms] in SimplCore for an overview.
g = ... static f ...
==>
g = ... makeStatic (StaticPtrInfo "pkg key" "module" loc) f ...
g = ... StaticPtr
w0 w1
(StaticPtrInfo "current pkg key" "current module" "N")
f
...
Where we obtain w0 and w1 from
Fingerprint w0 w1 = fingerprintString "pkgKey:module:N"
-}
dsExpr
(
HsStatic
_
expr
@
(
L
loc
_
))
=
do
expr_ds
<-
dsLExpr
expr
let
ty
=
exprType
expr_ds
makeStaticId
<-
dsLookupGlobalId
makeStaticName
staticPtrInfoDataCon
<-
dsLookupDataCon
staticPtrInfoDataConName
staticPtrDataCon
<-
dsLookupDataCon
staticPtrDataConName
dflags
<-
getDynFlags
let
(
line
,
col
)
=
case
loc
of
...
...
@@ -440,18 +452,48 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
[
Type
intTy
,
Type
intTy
,
mkIntExprInt
dflags
line
,
mkIntExprInt
dflags
col
]
this_mod
<-
getModule
staticPtrInfoDataCon
<-
dsLookupDataCon
staticPtrInfoDataConName
info
<-
mkConApp
staticPtrInfoDataCon
<$>
(
++
[
srcLoc
])
<$>
mapM
mkStringExprFS
[
unitIdFS
$
moduleUnitId
this_mod
,
moduleNameFS
$
moduleName
this_mod
]
Fingerprint
w0
w1
<-
mkStaticPtrFingerprint
this_mod
putSrcSpanDs
loc
$
return
$
mkCoreApps
(
Var
makeStaticId
)
[
Type
ty
,
info
,
expr_ds
]
mkConApp
staticPtrDataCon
[
Type
ty
,
mkWord64LitWordRep
dflags
w0
,
mkWord64LitWordRep
dflags
w1
,
info
,
expr_ds
]
where
-- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
-- 'Fingerprint' data constructor.
mkWord64LitWordRep
dflags
|
platformWordSize
(
targetPlatform
dflags
)
<
8
=
mkWord64LitWord64
|
otherwise
=
mkWordLit
dflags
.
toInteger
mkStaticPtrFingerprint
::
Module
->
DsM
Fingerprint
mkStaticPtrFingerprint
this_mod
=
do
n
<-
mkGenPerModuleNum
this_mod
return
$
fingerprintString
$
intercalate
":"
[
unitIdString
$
moduleUnitId
this_mod
,
moduleNameString
$
moduleName
this_mod
,
show
n
]
mkGenPerModuleNum
::
Module
->
DsM
Int
mkGenPerModuleNum
this_mod
=
do
dflags
<-
getDynFlags
let
-- Note [Generating fresh names for ccall wrapper]
-- in compiler/typecheck/TcEnv.hs
wrapperRef
=
nextWrapperNum
dflags
wrapperNum
<-
liftIO
$
atomicModifyIORef'
wrapperRef
$
\
mod_env
->
let
num
=
lookupWithDefaultModuleEnv
mod_env
0
this_mod
in
(
extendModuleEnv
mod_env
this_mod
(
num
+
1
),
num
)
return
wrapperNum
{-
\noindent
...
...
compiler/main/StaticPtrTable.hs
View file @
c5452cc1
...
...
@@ -46,146 +46,79 @@
--
{-# LANGUAGE ViewPatterns #-}
module
StaticPtrTable
(
spt
CreateStaticBinds
)
where
module
StaticPtrTable
(
spt
ModuleInitCode
)
where
-- See SimplCore Note [Grand plan for static forms]
for an overview.
-- See SimplCore Note [Grand plan for static forms]
import
CLabel
import
CoreSyn
import
CoreUtils
(
collectMakeStaticArgs
)
import
DataCon
import
DynFlags
import
HscTypes
import
Id
import
Literal
import
Module
import
Name
import
Outputable
import
Platform
import
PrelNames
import
Type
import
Control.Monad.Trans.Class
(
lift
)
import
Control.Monad.Trans.State
import
Data.List
import
Data.Maybe
import
GHC.Fingerprint
-- | Replaces all bindings of the form
-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
-- found in @binds@ of @module@ into the static pointer table.
--
-- > b = /\ ... -> makeStatic info value
-- A bind is considered a static entry if it is an application of the
-- data constructor @StaticPtr@.
--
-- with
--
-- > b = /\ ... -> StaticPtr key info value
--
-- where a distinct key is generated for each binding.
--
-- It also yields the C stub that inserts these bindings into the static
-- pointer table.
sptCreateStaticBinds
::
HscEnv
->
Module
->
CoreProgram
->
IO
(
SDoc
,
CoreProgram
)
sptCreateStaticBinds
hsc_env
this_mod
binds
=
do
(
fps
,
binds'
)
<-
evalStateT
(
go
[]
[]
binds
)
0
return
(
sptModuleInitCode
this_mod
fps
,
binds'
)
sptModuleInitCode
::
Module
->
CoreProgram
->
SDoc
sptModuleInitCode
this_mod
binds
=
sptInitCode
$
catMaybes
$
map
(
\
(
b
,
e
)
->
((,)
b
)
<$>
staticPtrFp
e
)
$
flattenBinds
binds
where
go
fps
bs
xs
=
case
xs
of
[]
->
return
(
reverse
fps
,
reverse
bs
)
bnd
:
xs'
->
do
(
fps'
,
bnd'
)
<-
replaceStaticBind
bnd
go
(
reverse
fps'
++
fps
)
(
bnd'
:
bs
)
xs'
-- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
--
-- The 'Int' state is used to produce a different key for each binding.
replaceStaticBind
::
CoreBind
->
StateT
Int
IO
([(
Id
,
Fingerprint
)],
CoreBind
)
replaceStaticBind
(
NonRec
b
e
)
=
do
(
mfp
,
(
b'
,
e'
))
<-
replaceStatic
b
e
return
(
maybeToList
mfp
,
NonRec
b'
e'
)
replaceStaticBind
(
Rec
rbs
)
=
do
(
mfps
,
rbs'
)
<-
unzip
<$>
mapM
(
uncurry
replaceStatic
)
rbs
return
(
catMaybes
mfps
,
Rec
rbs'
)
replaceStatic
::
Id
->
CoreExpr
->
StateT
Int
IO
(
Maybe
(
Id
,
Fingerprint
),
(
Id
,
CoreExpr
))
replaceStatic
b
e
@
(
collectTyBinders
->
(
tvs
,
e0
))
=
case
collectMakeStaticArgs
e0
of
Nothing
->
return
(
Nothing
,
(
b
,
e
))
Just
(
_
,
t
,
info
,
arg
)
->
do
(
fp
,
e'
)
<-
mkStaticBind
t
info
arg
return
(
Just
(
b
,
fp
),
(
b
,
foldr
Lam
e'
tvs
))
mkStaticBind
::
Type
->
CoreExpr
->
CoreExpr
->
StateT
Int
IO
(
Fingerprint
,
CoreExpr
)
mkStaticBind
t
info
e
=
do
i
<-
get
put
(
i
+
1
)
let
fp
@
(
Fingerprint
w0
w1
)
=
mkStaticPtrFingerprint
i
dflags
=
hsc_dflags
hsc_env
staticPtrFp
::
CoreExpr
->
Maybe
Fingerprint
staticPtrFp
(
collectTyBinders
->
(
_
,
e
))
|
(
Var
v
,
_
:
Lit
lit0
:
Lit
lit1
:
_
)
<-
collectArgs
e
,
Just
con
<-
isDataConId_maybe
v
,
dataConName
con
==
staticPtrDataConName
,
Just
w0
<-
fromPlatformWord64Rep
lit0
,
Just
w1
<-
fromPlatformWord64Rep
lit1
=
Just
$
Fingerprint
(
fromInteger
w0
)
(
fromInteger
w1
)
staticPtrFp
_
=
Nothing
staticPtrDataCon
<-
lift
$
lookupDataCon
staticPtrDataConName
return
(
fp
,
mkConApp
staticPtrDataCon
[
Type
t
,
mkWord64LitWordRep
dflags
w0
,
mkWord64LitWordRep
dflags
w1
,
info
,
e
])
fromPlatformWord64Rep
(
MachWord
w
)
=
Just
w
fromPlatformWord64Rep
(
MachWord64
w
)
=
Just
w
fromPlatformWord64Rep
_
=
Nothing
mkStaticPtrFingerprint
::
Int
->
Fingerprint
mkStaticPtrFingerprint
n
=
fingerprintString
$
intercalate
":"
[
unitIdString
$
moduleUnitId
this_mod
,
moduleNameString
$
moduleName
this_mod
,
show
n
]
sptInitCode
::
[(
Id
,
Fingerprint
)]
->
SDoc
sptInitCode
[]
=
Outputable
.
empty
sptInitCode
entries
=
vcat
[
text
"static void hs_spt_init_"
<>
ppr
this_mod
<>
text
"(void) __attribute__((constructor));"
,
text
"static void hs_spt_init_"
<>
ppr
this_mod
<>
text
"(void)"
,
braces
$
vcat
$
[
text
"static StgWord64 k"
<>
int
i
<>
text
"[2] = "
<>
pprFingerprint
fp
<>
semi
$$
text
"extern StgPtr "
<>
(
ppr
$
mkClosureLabel
(
idName
n
)
(
idCafInfo
n
))
<>
semi
$$
text
"hs_spt_insert"
<>
parens
(
hcat
$
punctuate
comma
[
char
'k'
<>
int
i
,
char
'&'
<>
ppr
(
mkClosureLabel
(
idName
n
)
(
idCafInfo
n
))
]
)
<>
semi
|
(
i
,
(
n
,
fp
))
<-
zip
[
0
..
]
entries
]
,
text
"static void hs_spt_fini_"
<>
ppr
this_mod
<>
text
"(void) __attribute__((destructor));"
,
text
"static void hs_spt_fini_"
<>
ppr
this_mod
<>
text
"(void)"
,
braces
$
vcat
$
[
text
"StgWord64 k"
<>
int
i
<>
text
"[2] = "
<>
pprFingerprint
fp
<>
semi
$$
text
"hs_spt_remove"
<>
parens
(
char
'k'
<>
int
i
)
<>
semi
|
(
i
,
(
_
,
fp
))
<-
zip
[
0
..
]
entries
]
]
-- Choose either 'Word64#' or 'Word#' to represent the arguments of the
-- 'Fingerprint' data constructor.
mkWord64LitWordRep
dflags
|
platformWordSize
(
targetPlatform
dflags
)
<
8
=
mkWord64LitWord64
|
otherwise
=
mkWordLit
dflags
.
toInteger
lookupDataCon
::
Name
->
IO
DataCon
lookupDataCon
n
=
lookupTypeHscEnv
hsc_env
n
>>=
maybe
(
getError
n
)
(
return
.
tyThingDataCon
)
getError
n
=
pprPanic
"sptCreateStaticBinds.get: not found"
$
text
"Couldn't find"
<+>
ppr
n
-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
-- of @module@ into the static pointer table.
--
-- @fps@ is a list associating each binding corresponding to a static entry with
-- its fingerprint.
sptModuleInitCode
::
Module
->
[(
Id
,
Fingerprint
)]
->
SDoc
sptModuleInitCode
_
[]
=
Outputable
.
empty
sptModuleInitCode
this_mod
entries
=
vcat
[
text
"static void hs_spt_init_"
<>
ppr
this_mod
<>
text
"(void) __attribute__((constructor));"
,
text
"static void hs_spt_init_"
<>
ppr
this_mod
<>
text
"(void)"
,
braces
$
vcat
$
[
text
"static StgWord64 k"
<>
int
i
<>
text
"[2] = "
<>
pprFingerprint
fp
<>
semi
$$
text
"extern StgPtr "
<>
(
ppr
$
mkClosureLabel
(
idName
n
)
(
idCafInfo
n
))
<>
semi
$$
text
"hs_spt_insert"
<>
parens
(
hcat
$
punctuate
comma
[
char
'k'
<>
int
i
,
char
'&'
<>
ppr
(
mkClosureLabel
(
idName
n
)
(
idCafInfo
n
))
]
)
<>
semi
|
(
i
,
(
n
,
fp
))
<-
zip
[
0
..
]
entries
]
,
text
"static void hs_spt_fini_"
<>
ppr
this_mod
<>
text
"(void) __attribute__((destructor));"
,
text
"static void hs_spt_fini_"
<>
ppr
this_mod
<>
text
"(void)"
,
braces
$
vcat
$
[
text
"StgWord64 k"
<>
int
i
<>
text
"[2] = "
<>
pprFingerprint
fp
<>
semi
$$
text
"hs_spt_remove"
<>
parens
(
char
'k'
<>
int
i
)
<>
semi
|
(
i
,
(
_
,
fp
))
<-
zip
[
0
..
]
entries
]
]
where
pprFingerprint
::
Fingerprint
->
SDoc
pprFingerprint
(
Fingerprint
w1
w2
)
=
braces
$
hcat
$
punctuate
comma
...
...
compiler/main/TidyPgm.hs
View file @
c5452cc1
...
...
@@ -20,7 +20,7 @@ import CoreFVs
import
CoreTidy
import
CoreMonad
import
CorePrep
import
CoreUtils
(
rhsIsStatic
)
import
CoreUtils
(
rhsIsStatic
,
collectStaticPtrSatArgs
)
import
CoreStats
(
coreBindsStats
,
CoreStats
(
..
))
import
CoreLint
import
Literal
...
...
@@ -373,12 +373,12 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
;
type_env2
=
extendTypeEnvWithPatSyns
tidy_patsyns
type_env1
;
tidy_type_env
=
tidyTypeEnv
omit_prags
type_env2
}
-- See
SimplCore Note [Grand plan for static form
s]
;
(
spt_init_code
,
tidy_binds
'
)
<-
sptCreateStaticBinds
hsc_env
mod
tidy_binds
;
let
{
-- See
Note [Injecting implicit binding
s]
all_tidy_binds
=
implicit_binds
++
tidy_binds
'
-- See
Note [Injecting implicit binding
s]
;
all_tidy_binds
=
implicit_binds
++
tidy_binds
-- See
SimplCore Note [Grand plan for static form
s]
;
spt_init_code
=
sptModuleInitCode
mod
all_
tidy_binds
-- Get the TyCons to generate code for. Careful! We must use
-- the untidied TypeEnv here, because we need
...
...
@@ -638,19 +638,27 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
-- same list every time this module is compiled), in contrast to the
-- bindings, which are ordered non-deterministically.
init_work_list
=
zip
init_ext_ids
init_ext_ids
init_ext_ids
=
sortBy
(
compare
`
on
`
getOccName
)
$
filter
is_external
binders
init_ext_ids
=
sortBy
(
compare
`
on
`
getOccName
)
$
map
fst
$
filter
is_external
flatten_binds
-- An Id should be external if either (a) it is exported,
-- (b) it appears in the RHS of a local rule for an imported Id, or
-- (c) it is the vectorised version of an imported Id.
-- (c) it is the vectorised version of an imported Id, or
-- (d) it is a static pointer (see notes in StaticPtrTable.hs).
-- See Note [Which rules to expose]
is_external
id
=
isExportedId
id
||
id
`
elemVarSet
`
rule_rhs_vars
||
id
`
elemVarSet
`
vect_var_vs
is_external
(
id
,
e
)
=
isExportedId
id
||
id
`
elemVarSet
`
rule_rhs_vars
||
id
`
elemVarSet
`
vect_var_vs
||
isStaticPtrApp
e
isStaticPtrApp
::
CoreExpr
->
Bool
isStaticPtrApp
(
collectTyBinders
->
(
_
,
e
))
=
isJust
$
collectStaticPtrSatArgs
e
rule_rhs_vars
=
mapUnionVarSet
ruleRhsFreeVars
imp_id_rules
vect_var_vs
=
mkVarSet
[
var_v
|
(
var
,
var_v
)
<-
eltsUDFM
vect_vars
,
isGlobalId
var
]
binders
=
map
fst
$
flattenBinds
binds
flatten_binds
=
flattenBinds
binds
binders
=
map
fst
flatten_binds
implicit_binders
=
bindersOfBinds
implicit_binds
binder_set
=
mkVarSet
binders
...
...
compiler/prelude/PrelNames.hs
View file @
c5452cc1
...
...
@@ -383,7 +383,6 @@ basicKnownKeyNames
,
ghciIoClassName
,
ghciStepIoMName
-- StaticPtr
,
makeStaticName
,
staticPtrTyConName
,
staticPtrDataConName
,
staticPtrInfoDataConName
,
fromStaticPtrName
...
...
@@ -522,9 +521,6 @@ gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")
gHC_STATICPTR
::
Module
gHC_STATICPTR
=
mkBaseModule
(
fsLit
"GHC.StaticPtr"
)
gHC_STATICPTR_INTERNAL
::
Module
gHC_STATICPTR_INTERNAL
=
mkBaseModule
(
fsLit
"GHC.StaticPtr.Internal"
)
gHC_FINGERPRINT_TYPE
::
Module
gHC_FINGERPRINT_TYPE
=
mkBaseModule
(
fsLit
"GHC.Fingerprint.Type"
)
...
...
@@ -1390,10 +1386,6 @@ frontendPluginTyConName :: Name
frontendPluginTyConName
=
tcQual
pLUGINS
(
fsLit
"FrontendPlugin"
)
frontendPluginTyConKey
-- Static pointers
makeStaticName
::
Name
makeStaticName
=
varQual
gHC_STATICPTR_INTERNAL
(
fsLit
"makeStatic"
)
makeStaticKey
staticPtrInfoTyConName
::
Name
staticPtrInfoTyConName
=
tcQual
gHC_STATICPTR
(
fsLit
"StaticPtrInfo"
)
staticPtrInfoTyConKey
...
...
@@ -2228,9 +2220,6 @@ pushCallStackKey = mkPreludeMiscIdUnique 518
fromStaticPtrClassOpKey
::
Unique
fromStaticPtrClassOpKey
=
mkPreludeMiscIdUnique
519
makeStaticKey
::
Unique
makeStaticKey
=
mkPreludeMiscIdUnique
520
{-
************************************************************************
* *
...
...
compiler/simplCore/SetLevels.hs
View file @
c5452cc1
...
...
@@ -66,7 +66,7 @@ import CoreSyn
import
CoreMonad
(
FloatOutSwitches
(
..
)
)
import
CoreUtils
(
exprType
,
exprOkForSpeculation
,
collect
Make
StaticArgs
,
collectStatic
PtrSat
Args
)