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
8bae3512
Commit
8bae3512
authored
Aug 02, 2007
by
rl@cse.unsw.edu.au
Browse files
Thread lifting context implicitly in the vectorisation monad
parent
6ed5e6a3
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/vectorise/VectMonad.hs
View file @
8bae3512
...
...
@@ -39,6 +39,7 @@ import Id
import
OccName
import
Name
import
NameEnv
import
TysPrim
(
intPrimTy
)
import
DsMonad
import
PrelNames
...
...
@@ -69,6 +70,7 @@ data Builtins = Builtins {
,
lengthPAVar
::
Var
,
replicatePAVar
::
Var
,
emptyPAVar
::
Var
,
liftingContext
::
Var
}
paDictTyCon
::
Builtins
->
TyCon
...
...
@@ -92,6 +94,9 @@ initBuiltins
replicatePAVar
<-
dsLookupGlobalId
replicatePAName
emptyPAVar
<-
dsLookupGlobalId
emptyPAName
liftingContext
<-
liftM
(
\
u
->
mkSysLocal
FSLIT
(
"lc"
)
u
intPrimTy
)
newUnique
return
$
Builtins
{
parrayTyCon
=
parrayTyCon
,
paClass
=
paClass
...
...
@@ -103,6 +108,7 @@ initBuiltins
,
lengthPAVar
=
lengthPAVar
,
replicatePAVar
=
replicatePAVar
,
emptyPAVar
=
emptyPAVar
,
liftingContext
=
liftingContext
}
data
GlobalEnv
=
GlobalEnv
{
...
...
compiler/vectorise/VectUtils.hs
View file @
8bae3512
...
...
@@ -4,7 +4,7 @@ module VectUtils (
splitClosureTy
,
mkPADictType
,
mkPArrayType
,
paDictArgType
,
paDictOfType
,
paMethod
,
lengthPA
,
replicatePA
,
emptyPA
,
paMethod
,
lengthPA
,
replicatePA
,
emptyPA
,
liftPA
,
polyAbstract
,
polyApply
,
polyVApply
,
lookupPArrayFamInst
,
hoistExpr
,
hoistPolyVExpr
,
takeHoisted
,
...
...
@@ -170,6 +170,12 @@ replicatePA len x = liftM (`mkApps` [len,x])
emptyPA
::
Type
->
VM
CoreExpr
emptyPA
=
paMethod
emptyPAVar
liftPA
::
CoreExpr
->
VM
CoreExpr
liftPA
x
=
do
lc
<-
builtin
liftingContext
replicatePA
(
Var
lc
)
x
newLocalVVar
::
FastString
->
Type
->
VM
VVar
newLocalVVar
fs
vty
=
do
...
...
@@ -259,17 +265,18 @@ mkClosureApp (vclo, lclo) (varg, larg)
where
(
arg_ty
,
res_ty
)
=
splitClosureTy
(
exprType
vclo
)
buildClosures
::
[
TyVar
]
->
Var
->
[
VVar
]
->
[
Type
]
->
Type
->
VM
VExpr
->
VM
VExpr
buildClosures
tvs
lc
vars
[
arg_ty
]
res_ty
mk_body
=
buildClosure
tvs
lc
vars
arg_ty
res_ty
mk_body
buildClosures
tvs
lc
vars
(
arg_ty
:
arg_tys
)
res_ty
mk_body
buildClosures
::
[
TyVar
]
->
[
VVar
]
->
[
Type
]
->
Type
->
VM
VExpr
->
VM
VExpr
buildClosures
tvs
vars
[
arg_ty
]
res_ty
mk_body
=
buildClosure
tvs
vars
arg_ty
res_ty
mk_body
buildClosures
tvs
vars
(
arg_ty
:
arg_tys
)
res_ty
mk_body
=
do
res_ty'
<-
mkClosureTypes
arg_tys
res_ty
arg
<-
newLocalVVar
FSLIT
(
"x"
)
arg_ty
buildClosure
tvs
lc
vars
arg_ty
res_ty'
buildClosure
tvs
vars
arg_ty
res_ty'
.
hoistPolyVExpr
tvs
$
do
clo
<-
buildClosures
tvs
lc
(
vars
++
[
arg
])
arg_tys
res_ty
mk_body
lc
<-
builtin
liftingContext
clo
<-
buildClosures
tvs
(
vars
++
[
arg
])
arg_tys
res_ty
mk_body
return
$
vLams
lc
(
vars
++
[
arg
])
clo
-- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)
...
...
@@ -277,27 +284,29 @@ buildClosures tvs lc vars (arg_ty : arg_tys) res_ty mk_body
-- f = \env v -> case env of <x1,...,xn> -> e x1 ... xn v
-- f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v
--
buildClosure
::
[
TyVar
]
->
Var
->
[
VVar
]
->
Type
->
Type
->
VM
VExpr
->
VM
VExpr
buildClosure
tvs
lv
vars
arg_ty
res_ty
mk_body
buildClosure
::
[
TyVar
]
->
[
VVar
]
->
Type
->
Type
->
VM
VExpr
->
VM
VExpr
buildClosure
tvs
vars
arg_ty
res_ty
mk_body
=
do
(
env_ty
,
env
,
bind
)
<-
buildEnv
lv
vars
(
env_ty
,
env
,
bind
)
<-
buildEnv
vars
env_bndr
<-
newLocalVVar
FSLIT
(
"env"
)
env_ty
arg_bndr
<-
newLocalVVar
FSLIT
(
"arg"
)
arg_ty
fn
<-
hoistPolyVExpr
tvs
$
do
lc
<-
builtin
liftingContext
body
<-
mk_body
body'
<-
bind
(
vVar
env_bndr
)
(
vVarApps
l
v
body
(
vars
++
[
arg_bndr
]))
(
vVarApps
l
c
body
(
vars
++
[
arg_bndr
]))
return
(
vLamsWithoutLC
[
env_bndr
,
arg_bndr
]
body'
)
mkClosure
arg_ty
res_ty
env_ty
fn
env
buildEnv
::
Var
->
[
VVar
]
->
VM
(
Type
,
VExpr
,
VExpr
->
VExpr
->
VM
VExpr
)
buildEnv
lv
vvs
buildEnv
::
[
VVar
]
->
VM
(
Type
,
VExpr
,
VExpr
->
VExpr
->
VM
VExpr
)
buildEnv
vvs
=
do
lc
<-
builtin
liftingContext
let
(
ty
,
venv
,
vbind
)
=
mkVectEnv
tys
vs
(
lenv
,
lbind
)
<-
mkLiftEnv
l
v
tys
ls
(
lenv
,
lbind
)
<-
mkLiftEnv
l
c
tys
ls
return
(
ty
,
(
venv
,
lenv
),
\
(
venv
,
lenv
)
(
vbody
,
lbody
)
->
do
...
...
@@ -318,28 +327,28 @@ mkVectEnv tys vs = (ty, mkCoreTup (map Var vs),
ty
=
mkCoreTupTy
tys
mkLiftEnv
::
Var
->
[
Type
]
->
[
Var
]
->
VM
(
CoreExpr
,
CoreExpr
->
CoreExpr
->
VM
CoreExpr
)
mkLiftEnv
l
v
[
ty
]
[
v
]
mkLiftEnv
l
c
[
ty
]
[
v
]
=
return
(
Var
v
,
\
env
body
->
do
len
<-
lengthPA
(
Var
v
)
return
.
Let
(
NonRec
v
env
)
$
Case
len
l
v
(
exprType
body
)
[(
DEFAULT
,
[]
,
body
)])
$
Case
len
l
c
(
exprType
body
)
[(
DEFAULT
,
[]
,
body
)])
-- NOTE: this transparently deals with empty environments
mkLiftEnv
l
v
tys
vs
mkLiftEnv
l
c
tys
vs
=
do
(
env_tc
,
env_tyargs
)
<-
lookupPArrayFamInst
vty
let
[
env_con
]
=
tyConDataCons
env_tc
env
=
Var
(
dataConWrapId
env_con
)
`
mkTyApps
`
env_tyargs
`
mkVarApps
`
(
l
v
:
vs
)
`
mkVarApps
`
(
l
c
:
vs
)
bind
env
body
=
let
scrut
=
unwrapFamInstScrut
env_tc
env_tyargs
env
in
return
$
Case
scrut
(
mkWildId
(
exprType
scrut
))
(
exprType
body
)
[(
DataAlt
env_con
,
l
v
:
bndrs
,
body
)]
[(
DataAlt
env_con
,
l
c
:
bndrs
,
body
)]
return
(
env
,
bind
)
where
vty
=
mkCoreTupTy
tys
...
...
compiler/vectorise/Vectorise.hs
View file @
8bae3512
...
...
@@ -111,10 +111,9 @@ vectTopBinder var
vectTopRhs
::
Var
->
CoreExpr
->
VM
CoreExpr
vectTopRhs
var
expr
=
do
lc
<-
newLocalVar
FSLIT
(
"lc"
)
intPrimTy
closedV
.
liftM
vectorised
.
inBind
var
$
vectPolyExpr
lc
(
freeVars
expr
)
$
vectPolyExpr
(
freeVars
expr
)
-- ----------------------------------------------------------------------------
-- Bindings
...
...
@@ -150,19 +149,19 @@ vectBndrsIn vs p
-- ----------------------------------------------------------------------------
-- Expressions
vectVar
::
Var
->
Var
->
VM
VExpr
vectVar
lc
v
vectVar
::
Var
->
VM
VExpr
vectVar
v
=
do
r
<-
lookupVar
v
case
r
of
Local
(
vv
,
lv
)
->
return
(
Var
vv
,
Var
lv
)
Global
vv
->
do
let
vexpr
=
Var
vv
lexpr
<-
replicatePA
(
Var
lc
)
vexpr
lexpr
<-
liftPA
vexpr
return
(
vexpr
,
lexpr
)
vectPolyVar
::
Var
->
Var
->
[
Type
]
->
VM
VExpr
vectPolyVar
lc
v
tys
vectPolyVar
::
Var
->
[
Type
]
->
VM
VExpr
vectPolyVar
v
tys
=
do
vtys
<-
mapM
vectType
tys
r
<-
lookupVar
v
...
...
@@ -171,79 +170,78 @@ vectPolyVar lc v tys
(
polyApply
(
Var
lv
)
vtys
)
Global
poly
->
do
vexpr
<-
polyApply
(
Var
poly
)
vtys
lexpr
<-
replicatePA
(
Var
lc
)
vexpr
lexpr
<-
liftPA
vexpr
return
(
vexpr
,
lexpr
)
vectLiteral
::
Var
->
Literal
->
VM
VExpr
vectLiteral
lc
lit
vectLiteral
::
Literal
->
VM
VExpr
vectLiteral
lit
=
do
lexpr
<-
replicatePA
(
Var
lc
)
(
Lit
lit
)
lexpr
<-
liftPA
(
Lit
lit
)
return
(
Lit
lit
,
lexpr
)
vectPolyExpr
::
Var
->
CoreExprWithFVs
->
VM
VExpr
vectPolyExpr
lc
expr
vectPolyExpr
::
CoreExprWithFVs
->
VM
VExpr
vectPolyExpr
expr
=
polyAbstract
tvs
$
\
abstract
->
-- FIXME: shadowing (tvs in lc)
do
mono'
<-
vectExpr
lc
mono
mono'
<-
vectExpr
mono
return
$
mapVect
abstract
mono'
where
(
tvs
,
mono
)
=
collectAnnTypeBinders
expr
vectExpr
::
Var
->
CoreExprWithFVs
->
VM
VExpr
vectExpr
lc
(
_
,
AnnType
ty
)
vectExpr
::
CoreExprWithFVs
->
VM
VExpr
vectExpr
(
_
,
AnnType
ty
)
=
liftM
vType
(
vectType
ty
)
vectExpr
lc
(
_
,
AnnVar
v
)
=
vectVar
lc
v
vectExpr
(
_
,
AnnVar
v
)
=
vectVar
v
vectExpr
lc
(
_
,
AnnLit
lit
)
=
vectLiteral
lc
lit
vectExpr
(
_
,
AnnLit
lit
)
=
vectLiteral
lit
vectExpr
lc
(
_
,
AnnNote
note
expr
)
=
liftM
(
vNote
note
)
(
vectExpr
lc
expr
)
vectExpr
(
_
,
AnnNote
note
expr
)
=
liftM
(
vNote
note
)
(
vectExpr
expr
)
vectExpr
lc
e
@
(
_
,
AnnApp
_
arg
)
vectExpr
e
@
(
_
,
AnnApp
_
arg
)
|
isAnnTypeArg
arg
=
vectTyAppExpr
lc
fn
tys
=
vectTyAppExpr
fn
tys
where
(
fn
,
tys
)
=
collectAnnTypeArgs
e
vectExpr
lc
(
_
,
AnnApp
fn
arg
)
vectExpr
(
_
,
AnnApp
fn
arg
)
=
do
fn'
<-
vectExpr
lc
fn
arg'
<-
vectExpr
lc
arg
fn'
<-
vectExpr
fn
arg'
<-
vectExpr
arg
mkClosureApp
fn'
arg'
vectExpr
lc
(
_
,
AnnCase
expr
bndr
ty
alts
)
vectExpr
(
_
,
AnnCase
expr
bndr
ty
alts
)
=
panic
"vectExpr: case"
vectExpr
lc
(
_
,
AnnLet
(
AnnNonRec
bndr
rhs
)
body
)
vectExpr
(
_
,
AnnLet
(
AnnNonRec
bndr
rhs
)
body
)
=
do
vrhs
<-
localV
.
inBind
bndr
$
vectPolyExpr
lc
rhs
(
vbndr
,
vbody
)
<-
vectBndrIn
bndr
(
vectExpr
lc
body
)
vrhs
<-
localV
.
inBind
bndr
$
vectPolyExpr
rhs
(
vbndr
,
vbody
)
<-
vectBndrIn
bndr
(
vectExpr
body
)
return
$
vLet
(
vNonRec
vbndr
vrhs
)
vbody
vectExpr
lc
(
_
,
AnnLet
(
AnnRec
bs
)
body
)
vectExpr
(
_
,
AnnLet
(
AnnRec
bs
)
body
)
=
do
(
vbndrs
,
(
vrhss
,
vbody
))
<-
vectBndrsIn
bndrs
$
liftM2
(,)
(
zipWithM
vect_rhs
bndrs
rhss
)
(
vectPolyExpr
lc
body
)
(
vectPolyExpr
body
)
return
$
vLet
(
vRec
vbndrs
vrhss
)
vbody
where
(
bndrs
,
rhss
)
=
unzip
bs
vect_rhs
bndr
rhs
=
localV
.
inBind
bndr
$
vectExpr
lc
rhs
$
vectExpr
rhs
vectExpr
lc
e
@
(
fvs
,
AnnLam
bndr
_
)
vectExpr
e
@
(
fvs
,
AnnLam
bndr
_
)
|
not
(
isId
bndr
)
=
pprPanic
"vectExpr"
(
ppr
$
deAnnotate
e
)
|
otherwise
=
vectLam
lc
fvs
bs
body
|
otherwise
=
vectLam
fvs
bs
body
where
(
bs
,
body
)
=
collectAnnValBinders
e
vectLam
::
Var
->
VarSet
->
[
Var
]
->
CoreExprWithFVs
->
VM
VExpr
vectLam
lc
fvs
bs
body
vectLam
::
VarSet
->
[
Var
]
->
CoreExprWithFVs
->
VM
VExpr
vectLam
fvs
bs
body
=
do
tyvars
<-
localTyVars
(
vs
,
vvs
)
<-
readLEnv
$
\
env
->
...
...
@@ -253,14 +251,15 @@ vectLam lc fvs bs body
arg_tys
<-
mapM
(
vectType
.
idType
)
bs
res_ty
<-
vectType
(
exprType
$
deAnnotate
body
)
buildClosures
tyvars
lc
vvs
arg_tys
res_ty
buildClosures
tyvars
vvs
arg_tys
res_ty
.
hoistPolyVExpr
tyvars
$
do
lc
<-
builtin
liftingContext
(
vbndrs
,
vbody
)
<-
vectBndrsIn
(
vs
++
bs
)
(
vectExpr
lc
body
)
(
vectExpr
body
)
return
$
vLams
lc
vbndrs
vbody
vectTyAppExpr
::
Var
->
CoreExprWithFVs
->
[
Type
]
->
VM
VExpr
vectTyAppExpr
lc
(
_
,
AnnVar
v
)
tys
=
vectPolyVar
lc
v
tys
vectTyAppExpr
lc
e
tys
=
pprPanic
"vectTyAppExpr"
(
ppr
$
deAnnotate
e
)
vectTyAppExpr
::
CoreExprWithFVs
->
[
Type
]
->
VM
VExpr
vectTyAppExpr
(
_
,
AnnVar
v
)
tys
=
vectPolyVar
v
tys
vectTyAppExpr
e
tys
=
pprPanic
"vectTyAppExpr"
(
ppr
$
deAnnotate
e
)
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