Skip to content
GitLab
Menu
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
fb12748e
Commit
fb12748e
authored
Sep 08, 2010
by
benl@ouroborus.net
Browse files
Break out vectorisation of TyConDecls into own module
parent
099ead5c
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/ghc.cabal.in
View file @
fb12748e
...
...
@@ -460,6 +460,7 @@ Library
Vectorise.Env
Vectorise.Vect
Vectorise.Type.Type
Vectorise.Type.TyConDecl
Vectorise.Builtins.Base
Vectorise.Builtins.Initialise
Vectorise.Builtins.Modules
...
...
compiler/vectorise/VectType.hs
View file @
fb12748e
...
...
@@ -12,6 +12,7 @@ import Vectorise.Vect
import
Vectorise.Monad
import
Vectorise.Builtins
import
Vectorise.Type.Type
import
Vectorise.Type.TyConDecl
import
HscTypes
(
TypeEnv
,
extendTypeEnvList
,
typeEnvTyCons
)
import
BasicTypes
...
...
@@ -22,7 +23,6 @@ import MkCore ( mkWildCase )
import
BuildTyCl
import
DataCon
import
TyCon
import
Class
import
Type
import
TypeRep
import
Coercion
...
...
@@ -73,15 +73,11 @@ vectTypeEnv env
let
(
conv_tcs
,
keep_tcs
)
=
classifyTyCons
cs
groups
keep_dcs
=
concatMap
tyConDataCons
keep_tcs
dtrace
(
text
"conv_tcs = "
<>
ppr
conv_tcs
)
$
return
()
zipWithM_
defTyCon
keep_tcs
keep_tcs
zipWithM_
defDataCon
keep_dcs
keep_dcs
new_tcs
<-
vectTyConDecls
conv_tcs
dtrace
(
text
"new_tcs = "
<>
ppr
new_tcs
)
$
return
()
let
orig_tcs
=
keep_tcs
++
conv_tcs
-- We don't need to make new representation types for dictionary
...
...
@@ -91,11 +87,6 @@ vectTypeEnv env
let
vect_tcs
=
filter
(
not
.
isClassTyCon
)
$
keep_tcs
++
new_tcs
dtrace
(
text
"vect_tcs = "
<>
ppr
vect_tcs
)
$
return
()
mapM_
dumpTycon
$
new_tcs
(
_
,
binds
,
inst_tcs
)
<-
fixV
$
\
~
(
dfuns'
,
_
,
_
)
->
do
defTyConPAs
(
zipLazy
vect_tcs
dfuns'
)
...
...
@@ -129,162 +120,6 @@ vectTypeEnv env
mk_map
env
=
listToUFM_Directly
[(
u
,
getUnique
n
/=
u
)
|
(
u
,
n
)
<-
nameEnvUniqueElts
env
]
-- | Vectorise some (possibly recursively defined) type constructors.
vectTyConDecls
::
[
TyCon
]
->
VM
[
TyCon
]
vectTyConDecls
tcs
=
fixV
$
\
tcs'
->
do
mapM_
(
uncurry
defTyCon
)
(
zipLazy
tcs
tcs'
)
mapM
vectTyConDecl
tcs
dumpTycon
::
TyCon
->
VM
()
dumpTycon
tycon
|
Just
cls
<-
tyConClass_maybe
tycon
=
dtrace
(
vcat
[
ppr
tycon
,
ppr
[(
m
,
varType
m
)
|
m
<-
classMethods
cls
]])
$
return
()
|
otherwise
=
return
()
-- | Vectorise a single type construcrtor.
vectTyConDecl
::
TyCon
->
VM
TyCon
vectTyConDecl
tycon
-- a type class constructor.
-- TODO: check for no stupid theta, fds, assoc types.
|
isClassTyCon
tycon
,
Just
cls
<-
tyConClass_maybe
tycon
=
do
-- make the name of the vectorised class tycon.
name'
<-
cloneName
mkVectTyConOcc
(
tyConName
tycon
)
-- vectorise right of definition.
rhs'
<-
vectAlgTyConRhs
tycon
(
algTyConRhs
tycon
)
-- vectorise method selectors.
-- This also adds a mapping between the original and vectorised method selector
-- to the state.
methods'
<-
mapM
vectMethod
$
[(
id
,
defMethSpecOfDefMeth
meth
)
|
(
id
,
meth
)
<-
classOpItems
cls
]
-- keep the original recursiveness flag.
let
rec_flag
=
boolToRecFlag
(
isRecursiveTyCon
tycon
)
-- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
cls'
<-
liftDs
$
buildClass
False
-- include unfoldings on dictionary selectors.
name'
-- new name V_T:Class
(
tyConTyVars
tycon
)
-- keep original type vars
[]
-- no stupid theta
[]
-- no functional dependencies
[]
-- no associated types
methods'
-- method info
rec_flag
-- whether recursive
let
tycon'
=
mkClassTyCon
name'
(
tyConKind
tycon
)
(
tyConTyVars
tycon
)
rhs'
cls'
rec_flag
return
$
tycon'
-- a regular algebraic type constructor.
-- TODO: check for stupid theta, generaics, GADTS etc
|
isAlgTyCon
tycon
=
do
name'
<-
cloneName
mkVectTyConOcc
(
tyConName
tycon
)
rhs'
<-
vectAlgTyConRhs
tycon
(
algTyConRhs
tycon
)
let
rec_flag
=
boolToRecFlag
(
isRecursiveTyCon
tycon
)
liftDs
$
buildAlgTyCon
name'
-- new name
(
tyConTyVars
tycon
)
-- keep original type vars.
[]
-- no stupid theta.
rhs'
-- new constructor defs.
rec_flag
-- FIXME: is this ok?
False
-- FIXME: no generics
False
-- not GADT syntax
Nothing
-- not a family instance
-- some other crazy thing that we don't handle.
|
otherwise
=
cantVectorise
"Can't vectorise type constructor: "
(
ppr
tycon
)
-- | Vectorise a class method.
vectMethod
::
(
Id
,
DefMethSpec
)
->
VM
(
Name
,
DefMethSpec
,
Type
)
vectMethod
(
id
,
defMeth
)
=
do
-- Vectorise the method type.
typ'
<-
vectType
(
varType
id
)
-- Create a name for the vectorised method.
id'
<-
cloneId
mkVectOcc
id
typ'
defGlobalVar
id
id'
-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-- to the types of each method. However, the types we get back from vectType
-- above already already have these, so we need to chop them off here otherwise
-- we'll get two copies in the final version.
let
(
_tyvars
,
tyBody
)
=
splitForAllTys
typ'
let
(
_dict
,
tyRest
)
=
splitFunTy
tyBody
return
(
Var
.
varName
id'
,
defMeth
,
tyRest
)
-- | Vectorise the RHS of an algebraic type.
vectAlgTyConRhs
::
TyCon
->
AlgTyConRhs
->
VM
AlgTyConRhs
vectAlgTyConRhs
_
(
DataTyCon
{
data_cons
=
data_cons
,
is_enum
=
is_enum
})
=
do
data_cons'
<-
mapM
vectDataCon
data_cons
zipWithM_
defDataCon
data_cons
data_cons'
return
$
DataTyCon
{
data_cons
=
data_cons'
,
is_enum
=
is_enum
}
vectAlgTyConRhs
tc
_
=
cantVectorise
"Can't vectorise type definition:"
(
ppr
tc
)
-- | Vectorise a data constructor.
-- Vectorises its argument and return types.
vectDataCon
::
DataCon
->
VM
DataCon
vectDataCon
dc
|
not
.
null
$
dataConExTyVars
dc
=
cantVectorise
"Can't vectorise constructor (existentials):"
(
ppr
dc
)
|
not
.
null
$
dataConEqSpec
dc
=
cantVectorise
"Can't vectorise constructor (eq spec):"
(
ppr
dc
)
|
otherwise
=
do
name'
<-
cloneName
mkVectDataConOcc
name
tycon'
<-
vectTyCon
tycon
arg_tys
<-
mapM
vectType
rep_arg_tys
liftDs
$
buildDataCon
name'
False
-- not infix
(
map
(
const
HsNoBang
)
arg_tys
)
-- strictness annots on args.
[]
-- no labelled fields
univ_tvs
-- universally quantified vars
[]
-- no existential tvs for now
[]
-- no eq spec for now
[]
-- no context
arg_tys
-- argument types
(
mkFamilyTyConApp
tycon'
(
mkTyVarTys
univ_tvs
))
-- return type
tycon'
-- representation tycon
where
name
=
dataConName
dc
univ_tvs
=
dataConUnivTyVars
dc
rep_arg_tys
=
dataConRepArgTys
dc
tycon
=
dataConTyCon
dc
mk_fam_inst
::
TyCon
->
TyCon
->
(
TyCon
,
[
Type
])
mk_fam_inst
fam_tc
arg_tc
=
(
fam_tc
,
[
mkTyConApp
arg_tc
.
mkTyVarTys
$
tyConTyVars
arg_tc
])
...
...
compiler/vectorise/Vectorise/Type/TyConDecl.hs
0 → 100644
View file @
fb12748e
module
Vectorise.Type.TyConDecl
(
vectTyConDecls
)
where
import
Vectorise.Type.Type
import
Vectorise.Monad
import
BuildTyCl
import
Class
import
Type
import
TyCon
import
DataCon
import
BasicTypes
import
Var
import
Name
import
Outputable
import
Util
import
Control.Monad
-- | Vectorise some (possibly recursively defined) type constructors.
vectTyConDecls
::
[
TyCon
]
->
VM
[
TyCon
]
vectTyConDecls
tcs
=
fixV
$
\
tcs'
->
do
mapM_
(
uncurry
defTyCon
)
(
zipLazy
tcs
tcs'
)
mapM
vectTyConDecl
tcs
-- | Vectorise a single type construcrtor.
vectTyConDecl
::
TyCon
->
VM
TyCon
vectTyConDecl
tycon
-- a type class constructor.
-- TODO: check for no stupid theta, fds, assoc types.
|
isClassTyCon
tycon
,
Just
cls
<-
tyConClass_maybe
tycon
=
do
-- make the name of the vectorised class tycon.
name'
<-
cloneName
mkVectTyConOcc
(
tyConName
tycon
)
-- vectorise right of definition.
rhs'
<-
vectAlgTyConRhs
tycon
(
algTyConRhs
tycon
)
-- vectorise method selectors.
-- This also adds a mapping between the original and vectorised method selector
-- to the state.
methods'
<-
mapM
vectMethod
$
[(
id
,
defMethSpecOfDefMeth
meth
)
|
(
id
,
meth
)
<-
classOpItems
cls
]
-- keep the original recursiveness flag.
let
rec_flag
=
boolToRecFlag
(
isRecursiveTyCon
tycon
)
-- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
cls'
<-
liftDs
$
buildClass
False
-- include unfoldings on dictionary selectors.
name'
-- new name V_T:Class
(
tyConTyVars
tycon
)
-- keep original type vars
[]
-- no stupid theta
[]
-- no functional dependencies
[]
-- no associated types
methods'
-- method info
rec_flag
-- whether recursive
let
tycon'
=
mkClassTyCon
name'
(
tyConKind
tycon
)
(
tyConTyVars
tycon
)
rhs'
cls'
rec_flag
return
$
tycon'
-- a regular algebraic type constructor.
-- TODO: check for stupid theta, generaics, GADTS etc
|
isAlgTyCon
tycon
=
do
name'
<-
cloneName
mkVectTyConOcc
(
tyConName
tycon
)
rhs'
<-
vectAlgTyConRhs
tycon
(
algTyConRhs
tycon
)
let
rec_flag
=
boolToRecFlag
(
isRecursiveTyCon
tycon
)
liftDs
$
buildAlgTyCon
name'
-- new name
(
tyConTyVars
tycon
)
-- keep original type vars.
[]
-- no stupid theta.
rhs'
-- new constructor defs.
rec_flag
-- FIXME: is this ok?
False
-- FIXME: no generics
False
-- not GADT syntax
Nothing
-- not a family instance
-- some other crazy thing that we don't handle.
|
otherwise
=
cantVectorise
"Can't vectorise type constructor: "
(
ppr
tycon
)
-- | Vectorise a class method.
vectMethod
::
(
Id
,
DefMethSpec
)
->
VM
(
Name
,
DefMethSpec
,
Type
)
vectMethod
(
id
,
defMeth
)
=
do
-- Vectorise the method type.
typ'
<-
vectType
(
varType
id
)
-- Create a name for the vectorised method.
id'
<-
cloneId
mkVectOcc
id
typ'
defGlobalVar
id
id'
-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-- to the types of each method. However, the types we get back from vectType
-- above already already have these, so we need to chop them off here otherwise
-- we'll get two copies in the final version.
let
(
_tyvars
,
tyBody
)
=
splitForAllTys
typ'
let
(
_dict
,
tyRest
)
=
splitFunTy
tyBody
return
(
Var
.
varName
id'
,
defMeth
,
tyRest
)
-- | Vectorise the RHS of an algebraic type.
vectAlgTyConRhs
::
TyCon
->
AlgTyConRhs
->
VM
AlgTyConRhs
vectAlgTyConRhs
_
(
DataTyCon
{
data_cons
=
data_cons
,
is_enum
=
is_enum
})
=
do
data_cons'
<-
mapM
vectDataCon
data_cons
zipWithM_
defDataCon
data_cons
data_cons'
return
$
DataTyCon
{
data_cons
=
data_cons'
,
is_enum
=
is_enum
}
vectAlgTyConRhs
tc
_
=
cantVectorise
"Can't vectorise type definition:"
(
ppr
tc
)
-- | Vectorise a data constructor.
-- Vectorises its argument and return types.
vectDataCon
::
DataCon
->
VM
DataCon
vectDataCon
dc
|
not
.
null
$
dataConExTyVars
dc
=
cantVectorise
"Can't vectorise constructor (existentials):"
(
ppr
dc
)
|
not
.
null
$
dataConEqSpec
dc
=
cantVectorise
"Can't vectorise constructor (eq spec):"
(
ppr
dc
)
|
otherwise
=
do
name'
<-
cloneName
mkVectDataConOcc
name
tycon'
<-
vectTyCon
tycon
arg_tys
<-
mapM
vectType
rep_arg_tys
liftDs
$
buildDataCon
name'
False
-- not infix
(
map
(
const
HsNoBang
)
arg_tys
)
-- strictness annots on args.
[]
-- no labelled fields
univ_tvs
-- universally quantified vars
[]
-- no existential tvs for now
[]
-- no eq spec for now
[]
-- no context
arg_tys
-- argument types
(
mkFamilyTyConApp
tycon'
(
mkTyVarTys
univ_tvs
))
-- return type
tycon'
-- representation tycon
where
name
=
dataConName
dc
univ_tvs
=
dataConUnivTyVars
dc
rep_arg_tys
=
dataConRepArgTys
dc
tycon
=
dataConTyCon
dc
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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