Commit a1d58865 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org//ghc

parents c492e50b f542da48
......@@ -178,8 +178,8 @@ emitCostCentreDecl cc = do
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
......
......@@ -223,14 +223,14 @@ emitCostCentreDecl cc = do
-- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages.
-- Hence don't emit the package name in the module here.
; let lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
; let lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
......
......@@ -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
......
......@@ -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 = mapM 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
......
......@@ -74,19 +74,11 @@ class Monad m => ExceptionMonad m where
_ <- sequel
return r
#if __GLASGOW_HASKELL__ < 613
instance ExceptionMonad IO where
gcatch = catch
gmask f = block $ f unblock
gblock = block
gunblock = unblock
#else
instance ExceptionMonad IO where
gcatch = catch
gmask f = mask (\x -> f x)
gblock = block
gunblock = unblock
#endif
gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
gtry act = gcatch (act >>= \a -> return (Right a))
......
......@@ -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
......
......@@ -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.
--
......
......@@ -37,8 +37,8 @@ typedef struct _CostCentre {
char * srcloc;
// used for accumulating costs at the end of the run...
StgWord time_ticks;
StgWord64 mem_alloc; // align 8 (Note [struct alignment])
StgWord time_ticks;
StgInt is_caf; // non-zero for a CAF cost centre
......
......@@ -29,12 +29,24 @@
#include "PosixSource.h"
#include "ghcconfig.h"
#ifdef sparc_HOST_ARCH
/* include Stg.h first because we want real machine regs in here: we
* have to get the value of R1 back from Stg land to C land intact.
*/
#define IN_STGCRUN 1
#include "Stg.h"
#include "Rts.h"
#else
/* The other architectures do not require the actual register macro definitions
* here because they use hand written assembly to implement the StgRun
* function. Including Stg.h first will define the R1 values using GCC specific
* techniques, which we don't want for LLVM based C compilers. Since we don't
* actually need the real machine register definitions here, we include the
* headers in the opposite order to allow LLVM-based C compilers to work.
*/
#include "Rts.h"
#include "Stg.h"
#endif
#include "StgRun.h"
#include "Capability.h"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment