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
675aada9
Commit
675aada9
authored
Aug 24, 2007
by
rl@cse.unsw.edu.au
Browse files
Change buildToPRepr to work with the new representation scheme
parent
255f46e1
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/vectorise/VectType.hs
View file @
675aada9
...
...
@@ -211,26 +211,26 @@ buildPReprTyCon orig_tc vect_tc
buildPReprType
::
TyCon
->
VM
Type
buildPReprType
=
liftM
repr_type
.
mkTyConRepr
buildToPRepr
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildToPRepr
_
vect_tc
prepr_tc
_
buildToPRepr
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildToPRepr
repr
vect_tc
prepr_tc
_
=
do
arg
<-
newLocalVar
FSLIT
(
"x"
)
arg_ty
bndrss
<-
mapM
(
mapM
(
newLocalVar
FSLIT
(
"x"
)))
rep_tys
(
alt_bodies
,
res_ty
)
<-
mkToPRepr
$
map
(
map
Var
)
bndrss
bndrss
<-
mapM
(
mapM
(
newLocalVar
FSLIT
(
"x"
)))
(
repr_tys
repr
)
return
.
Lam
arg
.
wrapFamInstBody
prepr_tc
var_tys
.
Case
(
Var
arg
)
(
mkWildId
arg_ty
)
res_ty
$
zipWith3
mk_alt
data_cons
bndrss
alt_bodies
.
Case
(
Var
arg
)
(
mkWildId
arg_ty
)
(
repr_type
repr
)
.
zipWith3
mk_alt
data_cons
bndrss
.
mkToPRepr
repr
$
map
(
map
Var
)
bndrss
where
var_tys
=
mkTyVarTys
$
tyConTyVars
vect_tc
arg_ty
=
mkTyConApp
vect_tc
var_tys
data_cons
=
tyConDataCons
vect_tc
rep_tys
=
map
dataConRepArgTys
data_cons
mk_alt
data_con
bndrs
body
=
(
DataAlt
data_con
,
bndrs
,
body
)
buildToArrPRepr
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildToArrPRepr
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildToArrPRepr
_
vect_tc
prepr_tc
arr_tc
=
do
arg_ty
<-
mkPArrayType
el_ty
...
...
@@ -267,7 +267,7 @@ buildToArrPRepr _ vect_tc prepr_tc arr_tc
|
otherwise
=
True
buildFromPRepr
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildFromPRepr
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildFromPRepr
_
vect_tc
prepr_tc
_
=
do
arg_ty
<-
mkPReprType
res_ty
...
...
@@ -285,11 +285,11 @@ buildFromPRepr _ vect_tc prepr_tc _
bndrs
<-
mapM
(
newLocalVar
FSLIT
(
"x"
))
$
dataConRepArgTys
dc
return
(
bndrs
,
mkConApp
dc
(
map
Type
var_tys
++
map
Var
bndrs
))
buildFromArrPRepr
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildFromArrPRepr
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildFromArrPRepr
_
vect_tc
prepr_tc
arr_tc
=
mkFromArrPRepr
undefined
undefined
undefined
undefined
undefined
undefined
buildPRDict
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildPRDict
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
VM
CoreExpr
buildPRDict
_
vect_tc
prepr_tc
_
=
prCoerce
prepr_tc
var_tys
=<<
prDictOfType
(
mkTyConApp
prepr_tc
var_tys
)
...
...
@@ -382,12 +382,13 @@ buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var
buildTyConBindings
orig_tc
vect_tc
prepr_tc
arr_tc
dfun
=
do
shape
<-
tyConShape
vect_tc
repr
<-
mkTyConRepr
vect_tc
sequence_
(
zipWith4
(
vectDataConWorker
shape
vect_tc
arr_tc
arr_dc
)
orig_dcs
vect_dcs
(
inits
repr_tys
)
(
tails
repr_tys
))
dict
<-
buildPADict
shape
vect_tc
prepr_tc
arr_tc
dfun
dict
<-
buildPADict
repr
vect_tc
prepr_tc
arr_tc
dfun
binds
<-
takeHoisted
return
$
(
dfun
,
dict
)
:
binds
where
...
...
@@ -439,11 +440,11 @@ vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post
++
map
Var
args
++
empty_post
buildPADict
::
Shape
->
TyCon
->
TyCon
->
TyCon
->
Var
->
VM
CoreExpr
buildPADict
shape
vect_tc
prepr_tc
arr_tc
dfun
buildPADict
::
TyConRepr
->
TyCon
->
TyCon
->
TyCon
->
Var
->
VM
CoreExpr
buildPADict
repr
vect_tc
prepr_tc
arr_tc
dfun
=
polyAbstract
tvs
$
\
abstract
->
do
meth_binds
<-
mapM
(
mk_method
shape
)
paMethods
meth_binds
<-
mapM
(
mk_method
repr
)
paMethods
let
meth_exprs
=
map
(
Var
.
fst
)
meth_binds
pa_dc
<-
builtin
paDataCon
...
...
@@ -454,10 +455,10 @@ buildPADict shape vect_tc prepr_tc arr_tc dfun
tvs
=
tyConTyVars
arr_tc
arg_tys
=
mkTyVarTys
tvs
mk_method
shape
(
name
,
build
)
mk_method
repr
(
name
,
build
)
=
localV
$
do
body
<-
build
shape
vect_tc
prepr_tc
arr_tc
body
<-
build
repr
vect_tc
prepr_tc
arr_tc
var
<-
newLocalVar
name
(
exprType
body
)
return
(
var
,
mkInlineMe
body
)
...
...
compiler/vectorise/VectUtils.hs
View file @
675aada9
...
...
@@ -142,7 +142,6 @@ mkTyConRepr vect_tc
let
prod_tys
=
zipWith
mk_tc_app_maybe
prod_tycons
rep_tys
sum_tycon
<-
mk_tycon
sumTyCon
prod_tys
return
$
TyConRepr
{
repr_tyvars
=
tyvars
,
repr_tys
=
rep_tys
...
...
@@ -189,31 +188,30 @@ mkPRepr tys
$ tys
-}
mkToPRepr
::
[[
CoreExpr
]]
->
VM
([
CoreExpr
],
Type
)
mkToPRepr
ess
=
do
sum_tcs
<-
builtins
sumTyCon
prod_tcs
<-
builtins
prodTyCon
mkToPRepr
::
TyConRepr
->
[[
CoreExpr
]]
->
[
CoreExpr
]
mkToPRepr
(
TyConRepr
{
repr_tys
=
repr_tys
,
repr_prod_tycons
=
prod_tycons
,
repr_prod_tys
=
prod_tys
,
repr_sum_tycon
=
repr_sum_tycon
})
=
mk_sum
.
zipWith3
mk_prod
prod_tycons
repr_tys
where
Just
sum_tycon
=
repr_sum_tycon
let
mk_sum
[]
=
([
Var
unitDataConId
],
unitTy
)
mk_sum
[(
expr
,
ty
)]
=
([
expr
],
ty
)
mk_sum
es
=
(
zipWith
mk_alt
(
tyConDataCons
sum_tc
)
exprs
,
mkTyConApp
sum_tc
tys
)
where
(
exprs
,
tys
)
=
unzip
es
sum_tc
=
sum_tcs
(
length
es
)
mk_alt
dc
expr
=
mkConApp
dc
(
map
Type
tys
++
[
expr
])
mk_prod
[]
=
(
Var
unitDataConId
,
unitTy
)
mk_prod
[
expr
]
=
(
expr
,
exprType
expr
)
mk_prod
exprs
=
(
mkConApp
prod_dc
(
map
Type
tys
++
exprs
),
mkTyConApp
prod_tc
tys
)
where
tys
=
map
exprType
exprs
prod_tc
=
prod_tcs
(
length
exprs
)
[
prod_dc
]
=
tyConDataCons
prod_tc
mk_sum
[]
=
[
Var
unitDataConId
]
mk_sum
[
expr
]
=
[
expr
]
mk_sum
exprs
=
zipWith
(
mk_alt
prod_tys
)
(
tyConDataCons
sum_tycon
)
exprs
mk_alt
tys
dc
expr
=
mk_con_app
dc
tys
[
expr
]
mk_prod
_
_
[]
=
Var
unitDataConId
mk_prod
_
_
[
expr
]
=
expr
mk_prod
(
Just
tc
)
tys
exprs
=
mk_con_app
dc
tys
exprs
where
[
dc
]
=
tyConDataCons
tc
return
.
mk_sum
.
map
mk_prod
$
ess
mk_con_app
dc
tys
exprs
=
mkConApp
dc
(
map
Type
tys
++
exprs
)
mkToArrPRepr
::
CoreExpr
->
CoreExpr
->
[[
CoreExpr
]]
->
VM
CoreExpr
mkToArrPRepr
len
sel
ess
...
...
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