From: Simon Peyton Jones Date: Mon, 13 Jun 2011 14:08:15 +0000 (+0100) Subject: Merge branch 'master' of http://darcs.haskell.org/ghc X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c1c2c25355bc462e521b2c5fb41ac79307da22ff;hp=eced7db98b3a8c7050196c619b5f7427a51417fd Merge branch 'master' of darcs.haskell.org/ghc --- diff --git a/boot b/boot index 0b67b17..08d4846 100755 --- a/boot +++ b/boot @@ -58,7 +58,7 @@ sub sanity_check_tree { if (/^#/) { # Comment; do nothing } - elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) { + elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+$/) { $dir = $1; $tag = $2; diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index c130921..3301722 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -332,8 +332,9 @@ Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM. vectsFreeVars :: [CoreVect] -> VarSet vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet where - vectFreeVars (Vect _ Nothing) = noFVs - vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (Vect _ Nothing) = noFVs + vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (NoVect _) = noFVs \end{code} diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index acf17e3..0c954a8 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -714,8 +714,9 @@ substVects subst = map (substVect subst) ------------------ substVect :: Subst -> CoreVect -> CoreVect -substVect _subst (Vect v Nothing) = Vect v Nothing -substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs)) +substVect _subst (Vect v Nothing) = Vect v Nothing +substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs)) +substVect _subst (NoVect v) = NoVect v ------------------ substVarSet :: Subst -> VarSet -> VarSet diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index e754c6d..178d5ca 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -417,14 +417,16 @@ Representation of desugared vectorisation declarations that are fed to the vecto 'ModGuts'). \begin{code} -data CoreVect = Vect Id (Maybe CoreExpr) +data CoreVect = Vect Id (Maybe CoreExpr) + | NoVect Id + \end{code} %************************************************************************ -%* * - Unfoldings -%* * +%* * + Unfoldings +%* * %************************************************************************ The @Unfolding@ type is declared here to avoid numerous loops diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index e9452dc..463f3c9 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -446,7 +446,7 @@ instance Outputable e => Outputable (DFunArg e) where \end{code} ----------------------------------------------------- --- Rules +-- Rules ----------------------------------------------------- \begin{code} @@ -461,11 +461,23 @@ pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) 4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) - ]) + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) + ]) +\end{code} + +----------------------------------------------------- +-- Vectorisation declarations +----------------------------------------------------- + +\begin{code} +instance Outputable CoreVect where + ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var + ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') + 4 (pprCoreExpr e) + ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var \end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 70679fb..af2db36 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -394,16 +394,11 @@ the rule is precisly to optimise them: \begin{code} dsVect :: LVectDecl Id -> DsM CoreVect -dsVect (L loc (HsVect v rhs)) +dsVect (L loc (HsVect (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- fmapMaybeM dsLExpr rhs - ; return $ Vect (unLoc v) rhs' + ; return $ Vect v rhs' } --- dsVect (L loc (HsVect v Nothing)) --- = return $ Vect v Nothing --- dsVect (L loc (HsVect v (Just rhs))) --- = putSrcSpanDs loc $ --- do { rhs' <- dsLExpr rhs --- ; return $ Vect v (Just rhs') --- } +dsVect (L _loc (HsNoVect (L _ v))) + = return $ NoVect v \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c05f26a..3712cbd 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -28,6 +28,7 @@ module HsDecls ( collectRuleBndrSigTys, -- ** @VECTORISE@ declarations VectDecl(..), LVectDecl, + lvectDeclName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Top-level template haskell splice @@ -1005,10 +1006,11 @@ instance OutputableBndr name => Outputable (RuleBndr name) where %* * %************************************************************************ -A vectorisation pragma +A vectorisation pragma, one of - {-# VECTORISE f = closure1 g (scalar_map g) #-} OR + {-# VECTORISE f = closure1 g (scalar_map g) #-} {-# VECTORISE SCALAR f #-} + {-# NOVECTORISE f #-} Note [Typechecked vectorisation pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1029,14 +1031,23 @@ data VectDecl name = HsVect (Located name) (Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration + | HsNoVect + (Located name) deriving (Data, Typeable) - + +lvectDeclName :: LVectDecl name -> name +lvectDeclName (L _ (HsVect (L _ name) _)) = name +lvectDeclName (L _ (HsNoVect (L _ name))) = name + instance OutputableBndr name => Outputable (VectDecl name) where - ppr (HsVect v rhs) + ppr (HsVect v Nothing) + = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ] + ppr (HsVect v (Just rhs)) = sep [text "{-# VECTORISE" <+> ppr v, - nest 4 (case rhs of - Nothing -> text "SCALAR #-}" - Just rhs -> pprExpr (unLoc rhs) <+> text "#-}") ] + nest 4 $ + pprExpr (unLoc rhs) <+> text "#-}" ] + ppr (HsNoVect v) + = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] \end{code} %************************************************************************ diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 76a02d6..43a4004 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -483,6 +483,7 @@ data Token | ITlanguage_prag | ITvect_prag | ITvect_scalar_prag + | ITnovect_prag | ITdotdot -- reserved symbols | ITcolon @@ -2281,7 +2282,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), ("ann", token ITann_prag), - ("vectorize", token ITvect_prag)]) + ("vectorize", token ITvect_prag), + ("novectorize", token ITnovect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), @@ -2307,6 +2309,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) "noinline" -> "notinline" "specialise" -> "specialize" "vectorise" -> "vectorize" + "novectorise" -> "novectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 01d768a..b663ac2 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -252,21 +252,22 @@ incorrect. 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _ _) } - '{-# SPECIALISE' { L _ ITspec_prag } + '{-# INLINE' { L _ (ITinline_prag _ _) } + '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } - '{-# SOURCE' { L _ ITsource_prag } - '{-# RULES' { L _ ITrules_prag } - '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core - '{-# SCC' { L _ ITscc_prag } - '{-# GENERATED' { L _ ITgenerated_prag } - '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } - '{-# UNPACK' { L _ ITunpack_prag } - '{-# ANN' { L _ ITann_prag } + '{-# SOURCE' { L _ ITsource_prag } + '{-# RULES' { L _ ITrules_prag } + '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core + '{-# SCC' { L _ ITscc_prag } + '{-# GENERATED' { L _ ITgenerated_prag } + '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } + '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '{-# VECTORISE' { L _ ITvect_prag } '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } - '#-}' { L _ ITclose_prag } + '{-# NOVECTORISE' { L _ ITnovect_prag } + '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols ':' { L _ ITcolon } @@ -546,33 +547,34 @@ ops :: { Located [Located RdrName] } -- Top-Level Declarations topdecls :: { OrdList (LHsDecl RdrName) } - : topdecls ';' topdecl { $1 `appOL` $3 } - | topdecls ';' { $1 } - | topdecl { $1 } + : topdecls ';' topdecl { $1 `appOL` $3 } + | topdecls ';' { $1 } + | topdecl { $1 } topdecl :: { OrdList (LHsDecl RdrName) } - : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } - | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } + | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } + | 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in + unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } - | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } - | 'foreign' fdecl { unitOL (LL (unLoc $2)) } + | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } + | 'foreign' fdecl { unitOL (LL (unLoc $2)) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } - | '{-# RULES' rules '#-}' { $2 } - | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } - | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } - | annotation { unitOL $1 } - | decl { unLoc $1 } - - -- Template Haskell Extension - -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if - -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } + | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } + | annotation { unitOL $1 } + | decl { unLoc $1 } + + -- Template Haskell Extension + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 54dc378..6b8e5c0 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -666,6 +666,10 @@ rnHsVectDecl (HsVect var (Just rhs)) ; (rhs', fv_rhs) <- rnLExpr rhs ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') } +rnHsVectDecl (HsNoVect var) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsNoVect var', unitFV (unLoc var')) + } \end{code} %********************************************************* diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 23a2472..59aba4b 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -29,7 +29,7 @@ import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import BasicTypes ( CompilerPhase, isDefaultInlinePragma ) +import BasicTypes import VarSet import VarEnv import LiberateCase ( liberateCase ) @@ -356,11 +356,18 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm active_rule rules [] binds } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings tagged_binds); + -- Occurrence analysis + let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure + -- that the right-hand sides of vectorisation declarations are taken into + -- account during occurence analysis. + maybeVects = case sm_phase mode of + InitialPhase -> mg_vect_decls guts + _ -> [] + ; tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm active_rule rules maybeVects binds + } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base -- See Note [Overall plumbing for rules] in Rules.lhs diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 881c304..b5bbeb1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -559,22 +559,29 @@ tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] tcImpPrags prags = do { this_mod <- getModule ; dflags <- getDOpts - ; if not (dopt Opt_Specialise dflags) then - return [] -- Ignore SPECIALISE pragmas for imported things - -- when -O is not on; otherwise we get bogus - -- complaints about lack of INLINABLE pragmas - -- in the imported module (also compiled without -O) - -- Notably, when Haddocking the base library + ; if (not_specialising dflags) then + return [] else mapAndRecoverM (wrapLocM tcImpSpec) [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags , not (nameIsLocalOrFrom this_mod name) ] } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't wnat complaints about lack of INLINABLE pragmas + not_specialising dflags + | not (dopt Opt_Specialise dflags) = True + | otherwise = case hscTarget dflags of + HscNothing -> True + HscInterpreted -> True + _other -> False tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag tcImpSpec (name, prag) = do { id <- tcLookupId name - ; checkTc (isAnyInlinePragma (idInlinePragma id)) - (impSpecErr name) + ; unless (isAnyInlinePragma (idInlinePragma id)) + (addWarnTc (impSpecErr name)) ; tcSpec id prag } impSpecErr :: Name -> SDoc @@ -591,7 +598,7 @@ impSpecErr name tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) tcVectDecls decls = do { decls' <- mapM (wrapLocM tcVect) decls - ; let ids = [unLoc id | L _ (HsVect id _) <- decls'] + ; let ids = map lvectDeclName decls' dups = findDupsEq (==) ids ; mapM_ reportVectDups dups ; traceTcConstraints "End of tcVectDecls" @@ -642,6 +649,11 @@ tcVect (HsVect name@(L loc _) (Just rhs)) -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls ; return $ HsVect (L loc id') (Just rhsWrapped) } +tcVect (HsNoVect name) + = addErrCtxt (vectCtxt name) $ + do { id <- wrapLocM tcLookupId name + ; return $ HsNoVect id + } vectCtxt :: Located Name -> SDoc vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 12b50ac..3b4afae 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1027,6 +1027,10 @@ zonkVect env (HsVect v (Just e)) ; e' <- zonkLExpr env e ; return $ HsVect v' (Just e') } +zonkVect env (HsNoVect v) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsNoVect v' + } \end{code} %************************************************************************ diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 4994e3f..35ddd9d 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} module Vectorise ( vectorise ) where @@ -82,98 +81,124 @@ vectModule guts@(ModGuts { mg_types = types } } --- | Try to vectorise a top-level binding. --- If it doesn't vectorise then return it unharmed. +-- |Try to vectorise a top-level binding. If it doesn't vectorise then return it unharmed. -- --- For example, for the binding +-- For example, for the binding -- --- @ --- foo :: Int -> Int --- foo = \x -> x + x --- @ --- --- we get --- @ --- foo :: Int -> Int --- foo = \x -> vfoo $: x --- --- v_foo :: Closure void vfoo lfoo --- v_foo = closure vfoo lfoo void --- --- vfoo :: Void -> Int -> Int --- vfoo = ... +-- @ +-- foo :: Int -> Int +-- foo = \x -> x + x +-- @ -- --- lfoo :: PData Void -> PData Int -> PData Int --- lfoo = ... --- @ +-- we get +-- @ +-- foo :: Int -> Int +-- foo = \x -> vfoo $: x -- --- @vfoo@ is the "vectorised", or scalar, version that does the same as the original --- function foo, but takes an explicit environment. --- --- @lfoo@ is the "lifted" version that works on arrays. +-- v_foo :: Closure void vfoo lfoo +-- v_foo = closure vfoo lfoo void +-- +-- vfoo :: Void -> Int -> Int +-- vfoo = ... +-- +-- lfoo :: PData Void -> PData Int -> PData Int +-- lfoo = ... +-- @ -- --- @v_foo@ combines both of these into a `Closure` that also contains the --- environment. +-- @vfoo@ is the "vectorised", or scalar, version that does the same as the original +-- function foo, but takes an explicit environment. -- --- The original binding @foo@ is rewritten to call the vectorised version --- present in the closure. +-- @lfoo@ is the "lifted" version that works on arrays. +-- +-- @v_foo@ combines both of these into a `Closure` that also contains the +-- environment. +-- +-- The original binding @foo@ is rewritten to call the vectorised version +-- present in the closure. +-- +-- Vectorisation may be surpressed by annotating a binding with a 'NOVECTORISE' pragma. If this +-- pragma is used in a group of mutually recursive bindings, either all or no binding must have +-- the pragma. If only some bindings are annotated, a fatal error is being raised. +-- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or +-- we may emit a warning and refrain from vectorising the entire group. -- vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) - = do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it to - -- the vectorisation map. - ; (inline, isScalar, expr') <- vectTopRhs [] var expr - ; var' <- vectTopBinder var inline expr' - ; when isScalar $ - addGlobalScalar var - - -- We replace the original top-level binding by a value projected from the vectorised - -- closure and add any newly created hoisted top-level bindings. - ; cexpr <- tryConvert var var' expr - ; hs <- takeHoisted - ; return . Rec $ (var, cexpr) : (var', expr') : hs - } - `orElseV` - return b + = unlessNoVectDecl $ + do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it + -- to the vectorisation map. + ; (inline, isScalar, expr') <- vectTopRhs [] var expr + ; var' <- vectTopBinder var inline expr' + ; when isScalar $ + addGlobalScalar var + + -- We replace the original top-level binding by a value projected from the vectorised + -- closure and add any newly created hoisted top-level bindings. + ; cexpr <- tryConvert var var' expr + ; hs <- takeHoisted + ; return . Rec $ (var, cexpr) : (var', expr') : hs + } + `orElseV` + return b + where + unlessNoVectDecl vectorise + = do { hasNoVectDecl <- noVectDecl var + ; when hasNoVectDecl $ + traceVt "NOVECTORISE" $ ppr var + ; if hasNoVectDecl then return b else vectorise + } vectTopBind b@(Rec bs) - = let (vars, exprs) = unzip bs - in - do { (vars', _, exprs', hs) <- fixV $ - \ ~(_, inlines, rhss, _) -> - do { -- Vectorise the right-hand sides, create an appropriate top-level bindings and - -- add them to the vectorisation map. - ; vars' <- sequence [vectTopBinder var inline rhs - | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] - ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs - ; hs <- takeHoisted - ; if and areScalars - then -- (1) Entire recursive group is scalar - -- => add all variables to the global set of scalars - do { mapM addGlobalScalar vars - ; return (vars', inlines, exprs', hs) - } - else -- (2) At least one binding is not scalar - -- => vectorise again with empty set of local scalars - do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs - ; hs <- takeHoisted - ; return (vars', inlines, exprs', hs) - } - } - - -- Replace the original top-level bindings by a values projected from the vectorised - -- closures and add any newly created hoisted top-level bindings to the group. - ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs - ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs - } - `orElseV` - return b - + = unlessSomeNoVectDecl $ + do { (vars', _, exprs', hs) <- fixV $ + \ ~(_, inlines, rhss, _) -> + do { -- Vectorise the right-hand sides, create an appropriate top-level bindings + -- and add them to the vectorisation map. + ; vars' <- sequence [vectTopBinder var inline rhs + | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] + ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs + ; hs <- takeHoisted + ; if and areScalars + then -- (1) Entire recursive group is scalar + -- => add all variables to the global set of scalars + do { mapM_ addGlobalScalar vars + ; return (vars', inlines, exprs', hs) + } + else -- (2) At least one binding is not scalar + -- => vectorise again with empty set of local scalars + do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs + ; hs <- takeHoisted + ; return (vars', inlines, exprs', hs) + } + } + + -- Replace the original top-level bindings by a values projected from the vectorised + -- closures and add any newly created hoisted top-level bindings to the group. + ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs + ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs + } + `orElseV` + return b + where + (vars, exprs) = unzip bs + + unlessSomeNoVectDecl vectorise + = do { hasNoVectDecls <- mapM noVectDecl vars + ; when (and hasNoVectDecls) $ + traceVt "NOVECTORISE" $ ppr vars + ; if and hasNoVectDecls + then return b -- all bindings have 'NOVECTORISE' + else if or hasNoVectDecls + then cantVectorise noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' + else vectorise -- no binding has a 'NOVECTORISE' decl + } + noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" + -- | Make the vectorised version of this top level binder, and add the mapping -- between it and the original to the state. For some binder @foo@ the vectorised -- version is @$v_foo@ -- --- NOTE: vectTopBinder *MUST* be lazy in inline and expr because of how it is --- used inside of fixV in vectTopBind +-- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is +-- used inside of 'fixV' in 'vectTopBind'. -- vectTopBinder :: Var -- ^ Name of the binding. -> Inline -- ^ Whether it should be inlined, used to annotate it. diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs index 51b3d14..a59f936 100644 --- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs +++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs @@ -27,7 +27,7 @@ preludeVars :: Modules preludeVars (Modules { dph_Combinators = _dph_Combinators , dph_Prelude_Int = dph_Prelude_Int , dph_Prelude_Word8 = dph_Prelude_Word8 - , dph_Prelude_Double = dph_Prelude_Double + -- , dph_Prelude_Double = dph_Prelude_Double , dph_Prelude_Bool = dph_Prelude_Bool }) @@ -50,11 +50,11 @@ preludeVars (Modules { dph_Combinators = _dph_Combinators , mk' dph_Prelude_Word8 "toInt" "toIntV" ] - ++ vars_Ord dph_Prelude_Double - ++ vars_Num dph_Prelude_Double - ++ vars_Fractional dph_Prelude_Double - ++ vars_Floating dph_Prelude_Double - ++ vars_RealFrac dph_Prelude_Double + -- ++ vars_Ord dph_Prelude_Double + -- ++ vars_Num dph_Prelude_Double + -- ++ vars_Fractional dph_Prelude_Double + -- ++ vars_Floating dph_Prelude_Double + -- ++ vars_RealFrac dph_Prelude_Double ++ [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA") , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA") @@ -92,40 +92,40 @@ preludeVars (Modules { dph_Combinators = _dph_Combinators , mk' mod "productP" "productPA" ] - vars_Fractional mod - = [ mk' mod "/" "divideV" - , mk' mod "recip" "recipV" - ] - - vars_Floating mod - = [ mk' mod "pi" "pi" - , mk' mod "exp" "expV" - , mk' mod "sqrt" "sqrtV" - , mk' mod "log" "logV" - , mk' mod "sin" "sinV" - , mk' mod "tan" "tanV" - , mk' mod "cos" "cosV" - , mk' mod "asin" "asinV" - , mk' mod "atan" "atanV" - , mk' mod "acos" "acosV" - , mk' mod "sinh" "sinhV" - , mk' mod "tanh" "tanhV" - , mk' mod "cosh" "coshV" - , mk' mod "asinh" "asinhV" - , mk' mod "atanh" "atanhV" - , mk' mod "acosh" "acoshV" - , mk' mod "**" "powV" - , mk' mod "logBase" "logBaseV" - ] - - vars_RealFrac mod - = [ mk' mod "fromInt" "fromIntV" - , mk' mod "truncate" "truncateV" - , mk' mod "round" "roundV" - , mk' mod "ceiling" "ceilingV" - , mk' mod "floor" "floorV" - ] - + -- vars_Fractional mod + -- = [ mk' mod "/" "divideV" + -- , mk' mod "recip" "recipV" + -- ] + -- + -- vars_Floating mod + -- = [ mk' mod "pi" "pi" + -- , mk' mod "exp" "expV" + -- , mk' mod "sqrt" "sqrtV" + -- , mk' mod "log" "logV" + -- , mk' mod "sin" "sinV" + -- , mk' mod "tan" "tanV" + -- , mk' mod "cos" "cosV" + -- , mk' mod "asin" "asinV" + -- , mk' mod "atan" "atanV" + -- , mk' mod "acos" "acosV" + -- , mk' mod "sinh" "sinhV" + -- , mk' mod "tanh" "tanhV" + -- , mk' mod "cosh" "coshV" + -- , mk' mod "asinh" "asinhV" + -- , mk' mod "atanh" "atanhV" + -- , mk' mod "acosh" "acoshV" + -- , mk' mod "**" "powV" + -- , mk' mod "logBase" "logBaseV" + -- ] + -- + -- vars_RealFrac mod + -- = [ mk' mod "fromInt" "fromIntV" + -- , mk' mod "truncate" "truncateV" + -- , mk' mod "round" "roundV" + -- , mk' mod "ceiling" "ceilingV" + -- , mk' mod "floor" "floorV" + -- ] + -- preludeScalars :: Modules -> [(Module, FastString)] preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int , dph_Prelude_Word8 = dph_Prelude_Word8 diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 780a07f..97bb5ae 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -95,6 +95,10 @@ data GlobalEnv , global_scalar_tycons :: NameSet -- ^Type constructors whose values can only contain scalar data. Scalar code may only -- operate on such data. + + , global_novect_vars :: VarSet + -- ^Variables that are not vectorised. (They may be referenced in the right-hand sides + -- of vectorisation declarations, though.) , global_exported_vars :: VarEnv (Var, Var) -- ^Exported variables which have a vectorised version. @@ -134,6 +138,7 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs , global_vect_decls = mkVarEnv vects , global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars , global_scalar_tycons = vectInfoScalarTyCons info + , global_novect_vars = mkVarSet novects , global_exported_vars = emptyVarEnv , global_tycons = mapNameEnv snd $ vectInfoTyCon info , global_datacons = mapNameEnv snd $ vectInfoDataCon info @@ -147,6 +152,7 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs where vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls] scalars = [var | Vect var Nothing <- vectDecls] + novects = [var | NoVect var <- vectDecls] -- Operators on Global Environments ------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index e2933cd..73cba88 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -81,6 +81,7 @@ initV hsc_env guts info thing_inside ; builtin_pas <- initBuiltinPAs builtins instEnvs -- construct the initial global environment + ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside ; let genv = extendImportedVarsEnv builtin_vars . extendScalars builtin_scalars . extendTyConsEnv builtin_tycons @@ -91,7 +92,7 @@ initV hsc_env guts info thing_inside $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs -- perform vectorisation - ; r <- runVM thing_inside builtins genv emptyLocalEnv + ; r <- runVM thing_inside' builtins genv emptyLocalEnv ; case r of Yes genv _ x -> return $ Just (new_info genv, x) No -> return Nothing diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index 632845f..e471ebb 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -1,34 +1,34 @@ module Vectorise.Monad.Global ( - readGEnv, - setGEnv, - updGEnv, - + readGEnv, + setGEnv, + updGEnv, + -- * Vars defGlobalVar, -- * Vectorisation declarations - lookupVectDecl, + lookupVectDecl, noVectDecl, -- * Scalars globalScalars, isGlobalScalar, - - -- * TyCons - lookupTyCon, - lookupBoxedTyCon, - defTyCon, - - -- * Datacons - lookupDataCon, - defDataCon, - - -- * PA Dictionaries - lookupTyConPA, - defTyConPA, - defTyConPAs, - - -- * PR Dictionaries - lookupTyConPR + + -- * TyCons + lookupTyCon, + lookupBoxedTyCon, + defTyCon, + + -- * Datacons + lookupDataCon, + defDataCon, + + -- * PA Dictionaries + lookupTyConPA, + defTyConPA, + defTyConPAs, + + -- * PR Dictionaries + lookupTyConPR ) where import Vectorise.Monad.Base @@ -45,23 +45,27 @@ import VarSet -- Global Environment --------------------------------------------------------- --- | Project something from the global environment. + +-- |Project something from the global environment. +-- readGEnv :: (GlobalEnv -> a) -> VM a readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv)) - --- | Set the value of the global environment. +-- |Set the value of the global environment. +-- setGEnv :: GlobalEnv -> VM () setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ()) - --- | Update the global environment using the provided function. +-- |Update the global environment using the provided function. +-- updGEnv :: (GlobalEnv -> GlobalEnv) -> VM () updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) -- Vars ----------------------------------------------------------------------- --- | Add a mapping between a global var and its vectorised version to the state. + +-- |Add a mapping between a global var and its vectorised version to the state. +-- defGlobalVar :: Var -> Var -> VM () defGlobalVar v v' = updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' @@ -79,6 +83,11 @@ defGlobalVar v v' = updGEnv $ \env -> lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr)) lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var +-- |Check whether a variable has a 'NOVECTORISE' declaration. +-- +noVectDecl :: Var -> VM Bool +noVectDecl var = readGEnv $ \env -> elemVarSet var (global_novect_vars env) + -- Scalars -------------------------------------------------------------------- @@ -94,7 +103,9 @@ isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalar_vars env) -- TyCons --------------------------------------------------------------------- --- | Lookup the vectorised version of a `TyCon` from the global environment. + +-- |Lookup the vectorised version of a `TyCon` from the global environment. +-- lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc | isUnLiftedTyCon tc || isTupleTyCon tc @@ -103,14 +114,12 @@ lookupTyCon tc | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - -- | Lookup the vectorised version of a boxed `TyCon` from the global environment. lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon) lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env) (tyConName tc) - -- | Add a mapping between plain and vectorised `TyCon`s to the global environment. defTyCon :: TyCon -> TyCon -> VM () defTyCon tc tc' = updGEnv $ \env -> @@ -118,6 +127,7 @@ defTyCon tc tc' = updGEnv $ \env -> -- DataCons ------------------------------------------------------------------- + -- | Lookup the vectorised version of a `DataCon` from the global environment. lookupDataCon :: DataCon -> VM (Maybe DataCon) lookupDataCon dc diff --git a/mk/config.mk.in b/mk/config.mk.in index d4a7cbe..18e60e7 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -120,8 +120,8 @@ SharedLibsPlatformList = i386-unknown-linux x86_64-unknown-linux \ i386-unknown-mingw32 \ i386-apple-darwin powerpc-apple-darwin -ifeq ($(SOLARIS_BROKEN_SHLD), NO) -SharedLibsPlatformList := $(SharedLibsPlatformList) i386-unknown-solaris2 +ifeq "$(SOLARIS_BROKEN_SHLD)" "NO" +SharedLibsPlatformList += i386-unknown-solaris2 endif PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index b7f788b..e250fa6 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -23,7 +23,7 @@ STRIP_CMD = : CHECK_PACKAGES = YES # We want to install DPH when validating, so that we can test it -InstallExtraPackages = YES +InstallExtraPackages = YES # dblatex with miktex under msys/mingw can't build the PS and PDF docs, # and just building the HTML docs is sufficient to check that the diff --git a/packages b/packages index 9720329..923b620 100644 --- a/packages +++ b/packages @@ -1,5 +1,8 @@ # Despite the name "package", this file contains the master list of -# the *repositories* that make up GHC. It is parsed by boot and darcs-all. +# the *repositories* that make up GHC. It is parsed by +# * boot +# * sync-all +# * rules/extra-packages.mk # # Some of this information is duplicated elsewhere in the build system: # See Trac #3896 @@ -17,7 +20,7 @@ # - nofib and testsuite are optional helpers # # The format of the lines in this file is: -# localpath tag remotepath VCS upstream +# localpath tag remotepath VCS # where # * 'localpath' is where to put the repository in a checked out tree. # * 'remotepath' is where the repository is in the central repository. @@ -34,52 +37,45 @@ # deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra' # both give this property # -# * 'upstream' is the URL of the upstream repo, where there is one, or -# "-" if there is no upstream. -# # Lines that start with a '#' are comments. -. - ghc.git git - -ghc-tarballs - ghc-tarballs.git git - -utils/hsc2hs - hsc2hs.git git - -# haddock does have an upstream: -# http://code.haskell.org/haddock/ -# but it stays buildable with the last stable release rather than tracking HEAD, -# and is resynced with the GHC HEAD branch by David Waern when appropriate -utils/haddock - haddock2.git git - -libraries/array - packages/array.git git - -libraries/base - packages/base.git git - -libraries/binary - packages/binary.git git http://code.haskell.org/binary/ -libraries/bytestring - packages/bytestring.git git http://darcs.haskell.org/bytestring/ -libraries/Cabal - packages/Cabal.git git http://darcs.haskell.org/cabal/ -libraries/containers - packages/containers.git git - -libraries/directory - packages/directory.git git - -libraries/extensible-exceptions - packages/extensible-exceptions.git git - -libraries/filepath - packages/filepath.git git - -libraries/ghc-prim - packages/ghc-prim.git git - -libraries/haskeline - packages/haskeline.git git http://code.haskell.org/haskeline/ -libraries/haskell98 - packages/haskell98.git git - -libraries/haskell2010 - packages/haskell2010.git git - -libraries/hoopl - packages/hoopl.git git - -libraries/hpc - packages/hpc.git git - -libraries/integer-gmp - packages/integer-gmp.git git - -libraries/integer-simple - packages/integer-simple.git git - -libraries/mtl - packages/mtl.git git - -libraries/old-locale - packages/old-locale.git git - -libraries/old-time - packages/old-time.git git - -libraries/pretty - packages/pretty.git git - -libraries/process - packages/process.git git - -libraries/random - packages/random.git git - -libraries/template-haskell - packages/template-haskell.git git - -libraries/terminfo - packages/terminfo.git git http://code.haskell.org/terminfo/ -libraries/unix - packages/unix.git git - -libraries/utf8-string - packages/utf8-string.git git http://code.haskell.org/utf8-string/ -libraries/Win32 - packages/Win32.git git - -libraries/xhtml - packages/xhtml.git git - -testsuite testsuite testsuite.git git - -nofib nofib nofib.git git - -libraries/deepseq extra packages/deepseq.git git - -libraries/parallel extra packages/parallel.git git - -libraries/stm extra packages/stm.git git - -libraries/primitive dph packages/primitive.git git http://code.haskell.org/primitive -libraries/vector dph packages/vector.git git http://code.haskell.org/vector -libraries/dph dph packages/dph.git git - +. - ghc.git git +ghc-tarballs - ghc-tarballs.git git +utils/hsc2hs - hsc2hs.git git +utils/haddock - haddock2.git git +libraries/array - packages/array.git git +libraries/base - packages/base.git git +libraries/binary - packages/binary.git git +libraries/bytestring - packages/bytestring.git git +libraries/Cabal - packages/Cabal.git git +libraries/containers - packages/containers.git git +libraries/directory - packages/directory.git git +libraries/extensible-exceptions - packages/extensible-exceptions.git git +libraries/filepath - packages/filepath.git git +libraries/ghc-prim - packages/ghc-prim.git git +libraries/haskeline - packages/haskeline.git git +libraries/haskell98 - packages/haskell98.git git +libraries/haskell2010 - packages/haskell2010.git git +libraries/hoopl - packages/hoopl.git git +libraries/hpc - packages/hpc.git git +libraries/integer-gmp - packages/integer-gmp.git git +libraries/integer-simple - packages/integer-simple.git git +libraries/mtl - packages/mtl.git git +libraries/old-locale - packages/old-locale.git git +libraries/old-time - packages/old-time.git git +libraries/pretty - packages/pretty.git git +libraries/process - packages/process.git git +libraries/random - packages/random.git git +libraries/template-haskell - packages/template-haskell.git git +libraries/terminfo - packages/terminfo.git git +libraries/unix - packages/unix.git git +libraries/utf8-string - packages/utf8-string.git git +libraries/Win32 - packages/Win32.git git +libraries/xhtml - packages/xhtml.git git +testsuite testsuite testsuite.git git +nofib nofib nofib.git git +libraries/deepseq extra packages/deepseq.git git +libraries/parallel extra packages/parallel.git git +libraries/stm extra packages/stm.git git +libraries/primitive dph packages/primitive.git git +libraries/vector dph packages/vector.git git +libraries/dph dph packages/dph.git git diff --git a/rules/extra-packages.mk b/rules/extra-packages.mk index 1cef9ad..e3af94f 100644 --- a/rules/extra-packages.mk +++ b/rules/extra-packages.mk @@ -27,7 +27,7 @@ # add P to the list of packages define extra-packages -$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+ \+[^ ]\+' packages | sed 's/ .*//'))),\ +$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+$$$$' packages | sed 's/ .*//'))),\ $$(if $$(wildcard libraries/$$p/ghc-packages),\ $$(eval BUILD_DIRS += libraries/$$p) \ $$(foreach q,$$(shell cat libraries/$$p/ghc-packages2),$$(eval $$(call extra-package,$$p,$$p/$$q))),\ diff --git a/sync-all b/sync-all index 8b41c97..ac06af1 100755 --- a/sync-all +++ b/sync-all @@ -142,13 +142,12 @@ sub parsePackages { foreach (@repos) { chomp; $lineNum++; - if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) { + if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) { my %line; $line{"localpath"} = $1; $line{"tag"} = $2; $line{"remotepath"} = $3; $line{"vcs"} = $4; - $line{"upstream"} = $5; push @packages, \%line; } elsif (! /^(#.*)?$/) { @@ -198,7 +197,6 @@ sub scmall { my $tag; my $remotepath; my $scm; - my $upstream; my $line; my $branch_name; my $subcommand; @@ -252,7 +250,6 @@ sub scmall { $tag = $$line{"tag"}; $remotepath = $$line{"remotepath"}; $scm = $$line{"vcs"}; - $upstream = $$line{"upstream"}; # Check the SCM is OK as early as possible die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));