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
24b31376
Commit
24b31376
authored
Dec 18, 2011
by
Ian Lynagh
Browse files
Merge branch 'master' of
http://darcs.haskell.org/ghc
parents
40ef62f6
0c41d677
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/typecheck/TcCanonical.lhs
View file @
24b31376
...
...
@@ -1296,7 +1296,7 @@ canEqLeafTyVarLeft d fl eqv tv s2 -- eqv : tv ~ s2
; if no_flattening_happened then
if isNothing occ_check_result then
canEqFailure d fl
eqv
canEqFailure d fl
(setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2'))
else
continueWith $ CTyEqCan { cc_id = eqv
, cc_flavor = fl
...
...
compiler/typecheck/TcSplice.lhs
View file @
24b31376
...
...
@@ -32,6 +32,7 @@ import TcHsSyn
import TcSimplify
import TcUnify
import Type
import Kind
import TcType
import TcEnv
import TcMType
...
...
@@ -1188,29 +1189,30 @@ reifyTyCon tc
= do { let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
kind = tyConKind tc
kind'
| isLiftedTypeKind kind = Nothing
| otherwise = Just $ reifyKind kind
; kind' <- if isLiftedTypeKind kind then return Nothing
else fmap Just (reifyKind kind)
; fam_envs <- tcGetFamInstEnvs
; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc)
; tvs' <- reifyTyVars tvs
; return (TH.FamilyI
(TH.FamilyD flavour (reifyName tc)
(reifyTyVars
tvs
)
kind')
(TH.FamilyD flavour (reifyName tc) tvs
'
kind')
instances) }
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; tvs' <- reifyTyVars tvs
; return (TH.TyConI
(TH.TySynD (reifyName tc)
(reifyTyVars
tvs
)
rhs'))
(TH.TySynD (reifyName tc) tvs
'
rhs'))
}
| otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
; r_tvs <- reifyTyVars tvs
; let name = reifyName tc
r_tvs = reifyTyVars tvs
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
| otherwise = TH.DataD cxt name r_tvs cons deriv
...
...
@@ -1245,7 +1247,8 @@ reifyDataCon tys dc
return main_con
else do
{ cxt <- reifyCxt theta'
; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
; ex_tvs'' <- reifyTyVars ex_tvs'
; return (TH.ForallC ex_tvs'' cxt main_con) } }
------------------------------
reifyClass :: Class -> TcM TH.Info
...
...
@@ -1254,7 +1257,8 @@ reifyClass cls
; inst_envs <- tcGetInstEnvs
; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
; ops <- mapM reify_op op_stuff
; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
; tvs' <- reifyTyVars tvs
; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
; return (TH.ClassI dec insts ) }
where
(tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
...
...
@@ -1307,24 +1311,23 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type
reify_for_all ty
= do { cxt' <- reifyCxt cxt;
; tau' <- reifyType tau
; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
; tvs' <- reifyTyVars tvs
; return (TH.ForallT tvs' cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
reifyKind :: Kind -> TH.Kind
reifyKind :: Kind ->
TcM
TH.Kind
reifyKind ki
= let (kis, ki') = splitKindFunTys ki
kis_rep = map reifyKind kis
ki'_rep = reifyNonArrowKind ki'
in
foldr TH.ArrowK ki'_rep kis_rep
= do { let (kis, ki') = splitKindFunTys ki
; ki'_rep <- reifyNonArrowKind ki'
; kis_rep <- mapM reifyKind kis
; return (foldr TH.ArrowK ki'_rep kis_rep) }
where
reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
| otherwise = pprPanic "Exotic form of kind"
(ppr k)
reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarK
| otherwise = noTH (sLit "this kind") (ppr k)
reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
...
...
@@ -1338,11 +1341,12 @@ reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
reifyTyVars = map reifyTyVar
reifyTyVars :: [TyVar] ->
TcM
[TH.TyVarBndr]
reifyTyVars = map
M
reifyTyVar
where
reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
| otherwise = TH.KindedTV name (reifyKind kind)
reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV name)
| otherwise = do kind' <- reifyKind kind
return (TH.KindedTV name kind')
where
kind = tyVarKind tv
name = reifyName tv
...
...
compiler/vectorise/Vectorise.hs
View file @
24b31376
...
...
@@ -218,15 +218,23 @@ vectTopBind b@(Rec bs)
-- Add a vectorised binding to an imported top-level variable that has a VECTORISE [SCALAR] pragma
-- in this module.
--
-- RESTIRCTION: Currently, we cannot use the pragma vor mutually recursive definitions.
--
vectImpBind
::
Id
->
VM
CoreBind
vectImpBind
var
=
do
{
-- Vectorise the right-hand side, create an appropriate top-level binding and add it
-- to the vectorisation map. For the non-lifted version, we refer to the original
-- definition — i.e., 'Var var'.
;
(
inline
,
isScalar
,
expr'
)
<-
vectTopRhs
[]
var
(
Var
var
)
;
var'
<-
vectTopBinder
var
inline
expr'
;
when
isScalar
$
addGlobalScalarVar
var
-- NB: To support recursive definitions, we tie a lazy knot.
;
(
var'
,
_
,
expr'
)
<-
fixV
$
\
~
(
_
,
inline
,
rhs
)
->
do
{
var'
<-
vectTopBinder
var
inline
rhs
;
(
inline
,
isScalar
,
expr'
)
<-
vectTopRhs
[]
var
(
Var
var
)
;
when
isScalar
$
addGlobalScalarVar
var
;
return
(
var'
,
inline
,
expr'
)
}
-- We add any newly created hoisted top-level bindings.
;
hs
<-
takeHoisted
...
...
compiler/vectorise/Vectorise/Exp.hs
View file @
24b31376
...
...
@@ -318,6 +318,10 @@ vectDictExpr (Coercion coe)
-- requires the full blown vectorisation transformation; instead, they can be lifted by application
-- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.)
--
-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised,
-- instead they become dictionaries of vectorised methods). We treat them differently, though see
-- "Note [Scalar dfuns]" in 'Vectorise'.
--
vectScalarFun
::
Bool
-- ^ Was the function marked as scalar by the user?
->
[
Var
]
-- ^ Functions names in same recursive binding group
->
CoreExpr
-- ^ Expression to be vectorised
...
...
@@ -344,14 +348,20 @@ vectScalarFun forceScalar recFns expr
-- need to be members of the 'Scalar' class (that in its current form would better
-- be called 'Primitive'). *ALSO* the hardcoded list of types is ugly!
is_primitive_ty
ty
|
isPredTy
ty
-- dictionaries never get into the environment
=
True
|
Just
(
tycon
,
_
)
<-
splitTyConApp_maybe
ty
=
tyConName
tycon
`
elem
`
[
boolTyConName
,
intTyConName
,
word8TyConName
,
doubleTyConName
]
|
otherwise
=
False
|
otherwise
=
False
is_scalar_ty
scalarTyCons
ty
|
isPredTy
ty
-- dictionaries never get into the environment
=
True
|
Just
(
tycon
,
_
)
<-
splitTyConApp_maybe
ty
=
tyConName
tycon
`
elemNameSet
`
scalarTyCons
|
otherwise
=
False
|
otherwise
=
False
-- Checks whether an expression contain a non-scalar subexpression.
--
...
...
@@ -427,9 +437,17 @@ vectScalarFun forceScalar recFns expr
uses_alt
funs
(
_
,
_bs
,
e
)
=
uses
funs
e
-- Generate code for a scalar function by generating a scalar closure. If the function is a
-- dictionary function, vectorise it as dictionary code.
--
mkScalarFun
::
[
Type
]
->
Type
->
CoreExpr
->
VM
VExpr
mkScalarFun
arg_tys
res_ty
expr
=
do
{
traceVt
"mkScalarFun: "
$
ppr
expr
|
isPredTy
res_ty
=
do
{
vExpr
<-
vectDictExpr
expr
;
return
(
vExpr
,
unused
)
}
|
otherwise
=
do
{
traceVt
"mkScalarFun: "
$
ppr
expr
$$
ptext
(
sLit
" ::"
)
<+>
ppr
(
mkFunTys
arg_tys
res_ty
)
;
fn_var
<-
hoistExpr
(
fsLit
"fn"
)
expr
DontInline
;
zipf
<-
zipScalars
arg_tys
res_ty
...
...
@@ -438,6 +456,8 @@ mkScalarFun arg_tys res_ty expr
;
lclo
<-
liftPD
(
Var
clo_var
)
;
return
(
Var
clo_var
,
lclo
)
}
where
unused
=
error
"Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions"
-- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma.
--
...
...
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