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
ea810102
Commit
ea810102
authored
Jul 25, 2007
by
rl@cse.unsw.edu.au
Browse files
PA dictionary generation
parent
76fb3390
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/vectorise/VectMonad.hs
View file @
ea810102
...
...
@@ -5,7 +5,7 @@ module VectMonad (
noV
,
tryV
,
maybeV
,
orElseV
,
fixV
,
localV
,
closedV
,
initV
,
cloneName
,
newLocalVar
,
newTyVar
,
Builtins
(
..
),
paDictTyCon
,
Builtins
(
..
),
paDictTyCon
,
paDictDataCon
,
builtin
,
GlobalEnv
(
..
),
...
...
@@ -71,6 +71,9 @@ data Builtins = Builtins {
paDictTyCon
::
Builtins
->
TyCon
paDictTyCon
=
classTyCon
.
paClass
paDictDataCon
::
Builtins
->
DataCon
paDictDataCon
=
classDataCon
.
paClass
initBuiltins
::
DsM
Builtins
initBuiltins
=
do
...
...
compiler/vectorise/VectType.hs
View file @
ea810102
...
...
@@ -8,6 +8,7 @@ import VectUtils
import
HscTypes
(
TypeEnv
,
extendTypeEnvList
,
typeEnvTyCons
)
import
CoreSyn
import
CoreUtils
import
DataCon
import
TyCon
import
Type
...
...
@@ -18,6 +19,7 @@ import InstEnv ( Instance )
import
OccName
import
MkId
import
BasicTypes
(
StrictnessMark
(
..
),
boolToRecFlag
)
import
Var
(
Var
)
import
Id
(
mkWildId
)
import
Name
(
Name
)
import
NameEnv
...
...
@@ -253,8 +255,33 @@ buildPArrayDataCon orig_name vect_tc repr_tc
types
=
[
ty
|
dc
<-
tyConDataCons
vect_tc
,
ty
<-
dataConRepArgTys
dc
]
buildLengthPA
::
TyCon
->
VM
CoreExpr
buildLengthPA
repr_tc
buildPADict
::
Var
->
TyCon
->
TyCon
->
VM
[(
Var
,
CoreExpr
)]
buildPADict
var
vect_tc
arr_tc
=
localV
.
abstractOverTyVars
(
tyConTyVars
arr_tc
)
$
\
abstract
->
do
meth_binds
<-
mapM
(
mk_method
abstract
)
paMethods
let
meth_vars
=
map
(
Var
.
fst
)
meth_binds
meth_exprs
<-
mapM
(`
applyToTypes
`
arg_tys
)
meth_vars
pa_dc
<-
builtin
paDictDataCon
let
dict
=
mkConApp
pa_dc
(
Type
(
mkTyConApp
vect_tc
arg_tys
)
:
meth_exprs
)
return
$
(
var
,
dict
)
:
meth_binds
where
tvs
=
tyConTyVars
arr_tc
arg_tys
=
mkTyVarTys
tvs
mk_method
abstract
(
name
,
build
)
=
localV
$
do
body
<-
liftM
abstract
$
build
vect_tc
arr_tc
var
<-
newLocalVar
name
(
exprType
body
)
return
(
var
,
mkInlineMe
body
)
paMethods
=
[(
FSLIT
(
"lengthPA"
),
buildLengthPA
),
(
FSLIT
(
"replicatePA"
),
buildReplicatePA
)]
buildLengthPA
::
TyCon
->
TyCon
->
VM
CoreExpr
buildLengthPA
_
arr_tc
=
do
arg
<-
newLocalVar
FSLIT
(
"xs"
)
arg_ty
shape
<-
newLocalVar
FSLIT
(
"sel"
)
shape_ty
...
...
@@ -263,8 +290,8 @@ buildLengthPA repr_tc
$
Case
(
Var
arg
)
(
mkWildId
arg_ty
)
intPrimTy
[(
DataAlt
repr_dc
,
shape
:
map
mkWildId
repr_tys
,
body
)]
where
arg_ty
=
mkTyConApp
r
ep
r_tc
.
mkTyVarTys
$
tyConTyVars
r
ep
r_tc
[
repr_dc
]
=
tyConDataCons
r
ep
r_tc
arg_ty
=
mkTyConApp
a
rr_tc
.
mkTyVarTys
$
tyConTyVars
a
rr_tc
[
repr_dc
]
=
tyConDataCons
a
rr_tc
shape_ty
:
repr_tys
=
dataConRepArgTys
repr_dc
...
...
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