Skip to content
GitLab
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
21d9b432
Commit
21d9b432
authored
Aug 23, 2007
by
rl@cse.unsw.edu.au
Browse files
Move all vectorisation built-ins to VectBuiltIn
parent
135a48ab
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/vectorise/VectBuiltIn.hs
View file @
21d9b432
module
VectBuiltIn
(
Builtins
(
..
),
initBuiltins
Builtins
(
..
),
initBuiltins
,
initBuiltinTyCons
,
initBuiltinPAs
)
where
#
include
"HsVersions.h"
import
DsMonad
import
IfaceEnv
(
lookupOrig
)
import
Module
(
Module
)
import
DataCon
(
DataCon
)
import
TyCon
(
TyCon
,
tyConDataCons
)
import
TyCon
(
TyCon
,
tyConName
,
tyConDataCons
)
import
Var
(
Var
)
import
Id
(
mkSysLocal
)
import
Name
(
Name
)
import
OccName
(
mkVarOccFS
)
import
TypeRep
(
funTyCon
)
import
TysPrim
(
intPrimTy
)
import
TysWiredIn
(
unitTyCon
,
tupleTyCon
,
intTyConName
)
import
PrelNames
import
BasicTypes
(
Boxity
(
..
)
)
import
Control.Monad
(
liftM
)
import
FastString
import
Control.Monad
(
liftM
,
zipWithM
)
data
Builtins
=
Builtins
{
parrayTyCon
::
TyCon
...
...
@@ -103,4 +113,43 @@ initBuiltins
,
liftingContext
=
liftingContext
}
initBuiltinTyCons
::
DsM
[(
Name
,
TyCon
)]
initBuiltinTyCons
=
do
vects
<-
sequence
vs
return
(
zip
origs
vects
)
where
(
origs
,
vs
)
=
unzip
builtinTyCons
builtinTyCons
::
[(
Name
,
DsM
TyCon
)]
builtinTyCons
=
[(
tyConName
funTyCon
,
dsLookupTyCon
closureTyConName
)]
initBuiltinPAs
::
DsM
[(
Name
,
Var
)]
initBuiltinPAs
=
do
pas
<-
zipWithM
lookupExternalVar
mods
fss
return
$
zip
tcs
pas
where
(
tcs
,
mods
,
fss
)
=
unzip3
builtinPAs
builtinPAs
::
[(
Name
,
Module
,
FastString
)]
builtinPAs
=
[
mk
closureTyConName
nDP_CLOSURE
FSLIT
(
"dPA_Clo"
)
,
mk
(
tyConName
unitTyCon
)
nDP_PARRAY
FSLIT
(
"dPA_Unit"
)
,
temporary
intTyConName
FSLIT
(
"dPA_Int"
)
]
++
tups
where
mk
name
mod
fs
=
(
name
,
mod
,
fs
)
temporary
name
fs
=
(
name
,
nDP_INSTANCES
,
fs
)
tups
=
map
mk_tup
[
2
..
3
]
mk_tup
n
=
temporary
(
tyConName
$
tupleTyCon
Boxed
n
)
(
mkFastString
$
"dPA_"
++
show
n
)
lookupExternalVar
::
Module
->
FastString
->
DsM
Var
lookupExternalVar
mod
fs
=
dsLookupGlobalId
=<<
lookupOrig
mod
(
mkVarOccFS
fs
)
compiler/vectorise/VectMonad.hs
View file @
21d9b432
...
...
@@ -22,7 +22,7 @@ module VectMonad (
lookupVar
,
defGlobalVar
,
lookupTyCon
,
defTyCon
,
lookupDataCon
,
defDataCon
,
lookupTyConPA
,
defTyConPA
,
defTyConPAs
,
defTyConBuiltinPAs
,
lookupTyConPA
,
defTyConPA
,
defTyConPAs
,
lookupTyVarPA
,
defLocalTyVar
,
defLocalTyVarWithPA
,
localTyVars
,
{-lookupInst,-}
lookupFamInst
...
...
@@ -119,17 +119,13 @@ data LocalEnv = LocalEnv {
-- Local binding name
,
local_bind_name
::
FastString
}
initGlobalEnv
::
VectInfo
->
(
InstEnv
,
InstEnv
)
->
FamInstEnvs
->
Builtins
->
GlobalEnv
initGlobalEnv
info
instEnvs
famInstEnvs
bi
initGlobalEnv
::
VectInfo
->
(
InstEnv
,
InstEnv
)
->
FamInstEnvs
->
GlobalEnv
initGlobalEnv
info
instEnvs
famInstEnvs
=
GlobalEnv
{
global_vars
=
mapVarEnv
snd
$
vectInfoVar
info
,
global_exported_vars
=
emptyVarEnv
,
global_tycons
=
extendNameEnv
(
mapNameEnv
snd
(
vectInfoTyCon
info
))
(
tyConName
funTyCon
)
(
closureTyCon
bi
)
,
global_tycons
=
mapNameEnv
snd
$
vectInfoTyCon
info
,
global_datacons
=
mapNameEnv
snd
$
vectInfoDataCon
info
,
global_pa_funs
=
mapNameEnv
snd
$
vectInfoPADFun
info
,
global_inst_env
=
instEnvs
...
...
@@ -143,6 +139,14 @@ setFamInstEnv l_fam_inst genv
where
(
g_fam_inst
,
_
)
=
global_fam_inst_env
genv
extendTyConsEnv
::
[(
Name
,
TyCon
)]
->
GlobalEnv
->
GlobalEnv
extendTyConsEnv
ps
genv
=
genv
{
global_tycons
=
extendNameEnvList
(
global_tycons
genv
)
ps
}
extendPAFunsEnv
::
[(
Name
,
Var
)]
->
GlobalEnv
->
GlobalEnv
extendPAFunsEnv
ps
genv
=
genv
{
global_pa_funs
=
extendNameEnvList
(
global_pa_funs
genv
)
ps
}
emptyLocalEnv
=
LocalEnv
{
local_vars
=
emptyVarEnv
,
local_tyvars
=
[]
...
...
@@ -258,11 +262,6 @@ inBind id p
=
do
updLEnv
$
\
env
->
env
{
local_bind_name
=
occNameFS
(
getOccName
id
)
}
p
lookupExternalVar
::
Module
->
FastString
->
VM
Var
lookupExternalVar
mod
fs
=
liftDs
$
dsLookupGlobalId
=<<
lookupOrig
mod
(
mkVarOccFS
fs
)
cloneName
::
(
OccName
->
OccName
)
->
Name
->
VM
Name
cloneName
mk_occ
name
=
liftM
make
(
liftDs
newUnique
)
where
...
...
@@ -354,16 +353,6 @@ defTyConPAs ps = updGEnv $ \env ->
env
{
global_pa_funs
=
extendNameEnvList
(
global_pa_funs
env
)
[(
tyConName
tc
,
pa
)
|
(
tc
,
pa
)
<-
ps
]
}
defTyConBuiltinPAs
::
[(
Name
,
Module
,
FastString
)]
->
VM
()
defTyConBuiltinPAs
ps
=
do
pas
<-
zipWithM
lookupExternalVar
mods
fss
updGEnv
$
\
env
->
env
{
global_pa_funs
=
extendNameEnvList
(
global_pa_funs
env
)
(
zip
tcs
pas
)
}
where
(
tcs
,
mods
,
fss
)
=
unzip3
ps
lookupTyVarPA
::
Var
->
VM
(
Maybe
CoreExpr
)
lookupTyVarPA
tv
=
readLEnv
$
\
env
->
lookupVarEnv
(
local_tyvar_pa
env
)
tv
...
...
@@ -454,11 +443,14 @@ initV hsc_env guts info p
go
instEnvs
famInstEnvs
=
do
builtins
<-
initBuiltins
r
<-
runVM
p
builtins
(
initGlobalEnv
info
instEnvs
famInstEnvs
builtins
)
emptyLocalEnv
builtin_tycons
<-
initBuiltinTyCons
builtin_pas
<-
initBuiltinPAs
let
genv
=
extendTyConsEnv
builtin_tycons
.
extendPAFunsEnv
builtin_pas
$
initGlobalEnv
info
instEnvs
famInstEnvs
r
<-
runVM
p
builtins
genv
emptyLocalEnv
case
r
of
Yes
genv
_
x
->
return
$
Just
(
new_info
genv
,
x
)
No
->
return
Nothing
...
...
compiler/vectorise/Vectorise.hs
View file @
21d9b432
...
...
@@ -45,19 +45,6 @@ import Outputable
import
FastString
import
Control.Monad
(
liftM
,
liftM2
,
zipWithM
,
mapAndUnzipM
)
builtin_PAs
::
[(
Name
,
Module
,
FastString
)]
builtin_PAs
=
[
(
closureTyConName
,
nDP_CLOSURE
,
FSLIT
(
"dPA_Clo"
))
,
mk
intTyConName
FSLIT
(
"dPA_Int"
)
]
++
tups
where
mk
name
fs
=
(
name
,
nDP_INSTANCES
,
fs
)
tups
=
mk_tup
0
:
map
mk_tup
[
2
..
3
]
mk_tup
n
=
(
getName
$
tupleTyCon
Boxed
n
,
nDP_INSTANCES
,
mkFastString
$
"dPA_"
++
show
n
)
vectorise
::
HscEnv
->
UniqSupply
->
RuleBase
->
ModGuts
->
IO
(
SimplCount
,
ModGuts
)
vectorise
hsc_env
_
_
guts
...
...
@@ -74,7 +61,6 @@ vectorise hsc_env _ _ guts
vectModule
::
ModGuts
->
VM
ModGuts
vectModule
guts
=
do
defTyConBuiltinPAs
builtin_PAs
(
types'
,
fam_insts
,
tc_binds
)
<-
vectTypeEnv
(
mg_types
guts
)
let
fam_inst_env'
=
extendFamInstEnvList
(
mg_fam_inst_env
guts
)
fam_insts
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment