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
fe5405d4
Commit
fe5405d4
authored
Aug 07, 2007
by
rl@cse.unsw.edu.au
Browse files
PA is now an explicit record instead of a typeclass
parent
5b2d1420
Changes
5
Hide whitespace changes
Inline
Side-by-side
compiler/prelude/PrelNames.lhs
View file @
fe5405d4
...
...
@@ -217,7 +217,7 @@ genericTyConNames :: [Name]
genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
ndpNames :: [Name]
ndpNames = [ parrayTyConName, pa
Class
Name, closureTyConName
ndpNames = [ parrayTyConName, pa
TyCon
Name, closureTyConName
, mkClosureName, applyClosureName
, mkClosurePName, applyClosurePName
, lengthPAName, replicatePAName, emptyPAName ]
...
...
@@ -691,7 +691,7 @@ checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNam
-- NDP stuff
parrayTyConName = tcQual nDP_PARRAY FSLIT("PArray") parrayTyConKey
pa
Class
Name = c
ls
Qual nDP_PARRAY FSLIT("PA") pa
Class
Key
pa
TyCon
Name =
t
cQual
nDP_PARRAY FSLIT("PA") pa
TyCon
Key
lengthPAName = methName nDP_PARRAY FSLIT("lengthPA") lengthPAClassOpKey
replicatePAName = methName nDP_PARRAY FSLIT("replicatePA") replicatePAClassOpKey
emptyPAName = varQual nDP_PARRAY FSLIT("emptyPA") emptyPAClassOpKey
...
...
@@ -769,8 +769,6 @@ randomClassKey = mkPreludeClassUnique 31
randomGenClassKey = mkPreludeClassUnique 32
isStringClassKey = mkPreludeClassUnique 33
paClassKey = mkPreludeClassUnique 34
\end{code}
%************************************************************************
...
...
@@ -883,6 +881,7 @@ stringTyConKey = mkPreludeTyConUnique 134
parrayTyConKey = mkPreludeTyConUnique 135
closureTyConKey = mkPreludeTyConUnique 136
paTyConKey = mkPreludeTyConUnique 137
---------------- Template Haskell -------------------
...
...
compiler/vectorise/VectMonad.hs
View file @
fe5405d4
...
...
@@ -6,11 +6,11 @@ module VectMonad (
cloneName
,
cloneId
,
newExportedVar
,
newLocalVar
,
newDummyVar
,
newTyVar
,
Builtins
(
..
),
paDictTyCon
,
paDictDataCon
,
Builtins
(
..
),
builtin
,
GlobalEnv
(
..
),
setInstEnv
s
,
set
Fam
InstEnv
,
readGEnv
,
setGEnv
,
updGEnv
,
LocalEnv
(
..
),
...
...
@@ -24,14 +24,13 @@ module VectMonad (
lookupTyConPA
,
defTyConPA
,
defTyConRdrPAs
,
lookupTyVarPA
,
defLocalTyVar
,
defLocalTyVarWithPA
,
localTyVars
,
lookupInst
,
lookupFamInst
{-
lookupInst,
-}
lookupFamInst
)
where
#
include
"HsVersions.h"
import
HscTypes
import
CoreSyn
import
Class
import
TyCon
import
DataCon
import
Type
...
...
@@ -64,7 +63,8 @@ data Scope a b = Global a | Local b
data
Builtins
=
Builtins
{
parrayTyCon
::
TyCon
,
paClass
::
Class
,
paTyCon
::
TyCon
,
paDataCon
::
DataCon
,
closureTyCon
::
TyCon
,
mkClosureVar
::
Var
,
applyClosureVar
::
Var
...
...
@@ -76,17 +76,12 @@ data Builtins = Builtins {
,
liftingContext
::
Var
}
paDictTyCon
::
Builtins
->
TyCon
paDictTyCon
=
classTyCon
.
paClass
paDictDataCon
::
Builtins
->
DataCon
paDictDataCon
=
classDataCon
.
paClass
initBuiltins
::
DsM
Builtins
initBuiltins
=
do
parrayTyCon
<-
dsLookupTyCon
parrayTyConName
paClass
<-
dsLookupClass
paClassName
paTyCon
<-
dsLookupTyCon
paTyConName
let
paDataCon
=
case
tyConDataCons
paTyCon
of
[
dc
]
->
dc
closureTyCon
<-
dsLookupTyCon
closureTyConName
mkClosureVar
<-
dsLookupGlobalId
mkClosureName
...
...
@@ -102,7 +97,8 @@ initBuiltins
return
$
Builtins
{
parrayTyCon
=
parrayTyCon
,
paClass
=
paClass
,
paTyCon
=
paTyCon
,
paDataCon
=
paDataCon
,
closureTyCon
=
closureTyCon
,
mkClosureVar
=
mkClosureVar
,
applyClosureVar
=
applyClosureVar
...
...
@@ -190,12 +186,11 @@ initGlobalEnv info instEnvs famInstEnvs bi rdr_env
,
global_rdr_env
=
rdr_env
}
setInstEnvs
::
InstEnv
->
FamInstEnv
->
GlobalEnv
->
GlobalEnv
setInstEnvs
l_inst
l_fam_inst
genv
|
(
g_inst
,
_
)
<-
global_inst_env
genv
,
(
g_fam_inst
,
_
)
<-
global_fam_inst_env
genv
=
genv
{
global_inst_env
=
(
g_inst
,
l_inst
)
,
global_fam_inst_env
=
(
g_fam_inst
,
l_fam_inst
)
}
setFamInstEnv
::
FamInstEnv
->
GlobalEnv
->
GlobalEnv
setFamInstEnv
l_fam_inst
genv
=
genv
{
global_fam_inst_env
=
(
g_fam_inst
,
l_fam_inst
)
}
where
(
g_fam_inst
,
_
)
=
global_fam_inst_env
genv
emptyLocalEnv
=
LocalEnv
{
local_vars
=
emptyVarEnv
...
...
@@ -450,6 +445,7 @@ localTyVars = readLEnv (reverse . local_tyvars)
-- instances head (i.e., no flexi vars); for details for what this means,
-- see the docs at InstEnv.lookupInstEnv.
--
{-
lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
lookupInst cls tys
= do { instEnv <- getInstEnv
...
...
@@ -466,6 +462,7 @@ lookupInst cls tys
where
isRight (Left _) = False
isRight (Right _) = True
-}
-- Look up the representation tycon of a family instance.
--
...
...
compiler/vectorise/VectType.hs
View file @
fe5405d4
module
VectType
(
vectTyCon
,
vectType
,
vectTypeEnv
,
PAInstance
,
painstInstance
,
buildPADict
,
PAInstance
,
buildPADict
,
vectDataConWorkers
)
where
...
...
@@ -78,13 +78,13 @@ vectType ty = pprPanic "vectType:" (ppr ty)
type
TyConGroup
=
([
TyCon
],
UniqSet
TyCon
)
data
PAInstance
=
PAInstance
{
painst
Instance
::
Instance
painst
DFun
::
Var
,
painstOrigTyCon
::
TyCon
,
painstVectTyCon
::
TyCon
,
painstArrTyCon
::
TyCon
}
vectTypeEnv
::
TypeEnv
->
VM
(
TypeEnv
,
[
FamInst
]
,
[
PAInstance
]
)
vectTypeEnv
::
TypeEnv
->
VM
(
TypeEnv
,
[
FamInst
])
vectTypeEnv
env
=
do
cs
<-
readGEnv
$
mk_map
.
global_tycons
...
...
@@ -107,7 +107,7 @@ vectTypeEnv env
++
[
ADataCon
dc
|
tc
<-
all_new_tcs
,
dc
<-
tyConDataCons
tc
])
return
(
new_env
,
map
mkLocalFamInst
parr_tcs
,
pa_insts
)
return
(
new_env
,
map
mkLocalFamInst
parr_tcs
)
where
tycons
=
typeEnvTyCons
env
groups
=
tyConGroups
tycons
...
...
@@ -362,26 +362,19 @@ buildPArrayDataCon orig_name vect_tc repr_tc
buildPAInstance
::
TyCon
->
TyCon
->
TyCon
->
VM
PAInstance
buildPAInstance
orig_tc
vect_tc
arr_tc
=
do
pa
<-
builtin
paClass
let
inst_ty
=
mkForAllTys
tvs
.
(
mkFunTys
$
mkPredTys
[
ClassP
pa
[
ty
]
|
ty
<-
arg_tys
])
$
mkPredTy
(
ClassP
pa
[
mkTyConApp
vect_tc
arg_tys
])
dfun
<-
newExportedVar
(
mkPADFunOcc
$
getOccName
vect_tc
)
inst_ty
dfun_ty
<-
paDFunType
vect_tc
dfun
<-
newExportedVar
(
mkPADFunOcc
$
getOccName
vect_tc
)
dfun_ty
return
$
PAInstance
{
painst
Instance
=
mkLocalInstance
dfun
NoOverlap
painst
DFun
=
dfun
,
painstOrigTyCon
=
orig_tc
,
painstVectTyCon
=
vect_tc
,
painstArrTyCon
=
arr_tc
}
where
tvs
=
tyConTyVars
arr_tc
arg_tys
=
mkTyVarTys
tvs
buildPADict
::
PAInstance
->
VM
[(
Var
,
CoreExpr
)]
buildPADict
(
PAInstance
{
painst
Instance
=
inst
painst
DFun
=
dfun
,
painstVectTyCon
=
vect_tc
,
painstArrTyCon
=
arr_tc
})
=
polyAbstract
(
tyConTyVars
arr_tc
)
$
\
abstract
->
...
...
@@ -390,10 +383,10 @@ buildPADict (PAInstance {
meth_binds
<-
mapM
(
mk_method
shape
)
paMethods
let
meth_exprs
=
map
(
Var
.
fst
)
meth_binds
pa_dc
<-
builtin
paD
ictD
ataCon
pa_dc
<-
builtin
paDataCon
let
dict
=
mkConApp
pa_dc
(
Type
(
mkTyConApp
vect_tc
arg_tys
)
:
meth_exprs
)
body
=
Let
(
Rec
meth_binds
)
dict
return
[(
instanceDFunId
inst
,
mkInlineMe
$
abstract
body
)]
return
[(
dfun
,
mkInlineMe
$
abstract
body
)]
where
tvs
=
tyConTyVars
arr_tc
arg_tys
=
mkTyVarTys
tvs
...
...
compiler/vectorise/VectUtils.hs
View file @
fe5405d4
...
...
@@ -3,7 +3,7 @@ module VectUtils (
collectAnnValBinders
,
splitClosureTy
,
mkPADictType
,
mkPArrayType
,
paDictArgType
,
paDictOfType
,
paDictArgType
,
paDictOfType
,
paDFunType
,
paMethod
,
lengthPA
,
replicatePA
,
emptyPA
,
liftPA
,
polyAbstract
,
polyApply
,
polyVApply
,
lookupPArrayFamInst
,
...
...
@@ -97,7 +97,7 @@ mkClosureTypes arg_tys res_ty
mkPADictType
::
Type
->
VM
Type
mkPADictType
ty
=
do
tc
<-
builtin
pa
Dict
TyCon
tc
<-
builtin
paTyCon
return
$
TyConApp
tc
[
ty
]
mkPArrayType
::
Type
->
VM
Type
...
...
@@ -140,11 +140,21 @@ paDictOfTyApp (TyVarTy tv) ty_args
paDFunApply
dfun
ty_args
paDictOfTyApp
(
TyConApp
tc
_
)
ty_args
=
do
pa_class
<-
builtin
paClass
(
dfun
,
ty_args'
)
<-
lookupInst
pa_class
[
TyConApp
tc
ty_args
]
paDFunApply
(
Var
dfun
)
ty_args'
dfun
<-
maybeV
(
lookupTyConPA
tc
)
paDFunApply
(
Var
dfun
)
ty_args
paDictOfTyApp
ty
ty_args
=
pprPanic
"paDictOfTyApp"
(
ppr
ty
)
paDFunType
::
TyCon
->
VM
Type
paDFunType
tc
=
do
margs
<-
mapM
paDictArgType
tvs
res
<-
mkPADictType
(
mkTyConApp
tc
arg_tys
)
return
.
mkForAllTys
tvs
$
mkFunTys
[
arg
|
Just
arg
<-
margs
]
res
where
tvs
=
tyConTyVars
tc
arg_tys
=
mkTyVarTys
tvs
paDFunApply
::
CoreExpr
->
[
Type
]
->
VM
CoreExpr
paDFunApply
dfun
tys
=
do
...
...
compiler/vectorise/Vectorise.hs
View file @
fe5405d4
...
...
@@ -69,21 +69,18 @@ vectModule :: ModGuts -> VM ModGuts
vectModule
guts
=
do
defTyConRdrPAs
builtin_PAs
(
types'
,
fam_insts
,
pa_insts
)
<-
vectTypeEnv
(
mg_types
guts
)
(
types'
,
fam_insts
)
<-
vectTypeEnv
(
mg_types
guts
)
let
insts
=
map
painstInstance
pa_insts
fam_inst_env'
=
extendFamInstEnvList
(
mg_fam_inst_env
guts
)
fam_insts
inst_env'
=
extendInstEnvList
(
mg_inst_env
guts
)
insts
updGEnv
(
setInstEnvs
inst_env'
fam_inst_env'
)
let
fam_inst_env'
=
extendFamInstEnvList
(
mg_fam_inst_env
guts
)
fam_insts
updGEnv
(
setFamInstEnv
fam_inst_env'
)
dicts
<-
mapM
buildPADict
pa_insts
workers
<-
mapM
vectDataConWorkers
pa_insts
--
dicts <- mapM buildPADict pa_insts
--
workers <- mapM vectDataConWorkers pa_insts
binds'
<-
mapM
vectTopBind
(
mg_binds
guts
)
return
$
guts
{
mg_types
=
types'
,
mg_binds
=
Rec
(
concat
workers
++
concat
dicts
)
:
binds'
,
mg_inst_env
=
inst_env
'
,
mg_binds
=
--
Rec (concat workers ++ concat dicts) :
binds
'
,
mg_fam_inst_env
=
fam_inst_env'
,
mg_insts
=
mg_insts
guts
++
insts
,
mg_fam_insts
=
mg_fam_insts
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