Commit ae37bd82 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents 402a1daa 7d9dfd53
......@@ -88,7 +88,7 @@ readSections r w = go B.empty [] []
| infoSec `B.isInfixOf` hdr =
cts `seq` return $ (hdr, cts):ss
| otherwise =
writeSection w (hdr, fixupStack cts B.empty) >> return ss
writeSection w (hdr, cts) >> return ss
case e_l of
Right l | l == syntaxUnified
......@@ -110,7 +110,7 @@ writeSection w (hdr, cts) = do
-- | Reorder and convert sections so info tables end up next to the
-- code. Also does stack fixups.
fixTables :: [Section] -> [Section]
fixTables ss = fixed
fixTables ss = map strip sorted
where
-- Resort sections: We only assign a non-zero number to all
-- sections having the "STRIP ME" marker. As sortBy is stable,
......@@ -120,7 +120,9 @@ fixTables ss = fixed
| B.null a = 0
| otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
where (_,a) = B.breakSubstring infoSec hdr
indexed = zip (map (extractIx . fst) ss) ss
sorted = map snd $ sortBy (compare `on` fst) indexed
-- Turn all the "STRIP ME" sections into normal text sections, as
......@@ -128,11 +130,6 @@ fixTables ss = fixed
strip (hdr, cts)
| infoSec `B.isInfixOf` hdr = (textStmt, cts)
| otherwise = (hdr, cts)
stripped = map strip sorted
-- Do stack fixup
fix (hdr, cts) = (hdr, fixupStack cts B.empty)
fixed = map fix stripped
{-|
Mac OS X requires that the stack be 16 byte aligned when making a function
......@@ -147,41 +144,6 @@ fixTables ss = fixed
has the correct alignment since we keep the stack 16+8 aligned throughout
STG land for 64-bit targets.
-}
fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
#if !darwin_TARGET_OS || x86_64_TARGET_ARCH
fixupStack = const
#else
fixupStack f f' | B.null f' =
let -- fixup sub op
(a, c) = B.breakSubstring spInst f
(b, n) = B.breakEnd dollarPred a
num = B.pack $ show $ readInt n + spFix
in if B.null c
then f' `B.append` f
else fixupStack c $ f' `B.append` b `B.append` num
fixupStack f f' =
let -- fixup add ops
(a, c) = B.breakSubstring jmpInst f
-- we matched on a '\n' so go past it
(l', b) = B.break eolPred $ B.tail c
l = (B.head c) `B.cons` l'
(a', n) = B.breakEnd dollarPred a
(n', x) = B.break commaPred n
num = B.pack $ show $ readInt n' + spFix
-- We need to avoid processing jumps to labels, they are of the form:
-- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L...
targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
B.drop labelStart c
in if B.null c
then f' `B.append` f
else if B.head targ == 'L'
then fixupStack b $ f' `B.append` a `B.append` l
else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
x `B.append` l
#endif
-- | Read an int or error
readInt :: B.ByteString -> Int
......
......@@ -1678,9 +1678,9 @@ genCCall32 target dest_regs args =
_ -> do
let
sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args)
raw_arg_size = sum sizes
tot_arg_size = roundTo 16 raw_arg_size
arg_pad_size = tot_arg_size - raw_arg_size
raw_arg_size = sum sizes + 4
arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size
tot_arg_size = raw_arg_size + arg_pad_size - 4
delta0 <- getDeltaNat
setDeltaNat (delta0 - arg_pad_size)
......
......@@ -86,10 +86,11 @@ vectModule guts@(ModGuts { mg_tcs = tycons
; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
-- NB: Need to vectorise the imported bindings first (local bindings may depend on them).
; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++
[imp_id | VectInst True imp_id <- vect_decls, isGlobalId imp_id]
; binds_top <- mapM vectTopBind binds
; binds_imp <- mapM vectImpBind impBinds
; binds_top <- mapM vectTopBind binds
; return $ guts { mg_tcs = tycons ++ new_tycons
-- we produce no new classes or instances, only new class type constructors
......@@ -301,7 +302,8 @@ vectTopBinder var inline expr
-- => generate vectorised code according to the the "Note [Scalar dfuns]" below
--
-- (4) There is no vectorisation declaration for the variable
-- => perform automatic vectorisation of the RHS
-- => perform automatic vectorisation of the RHS (the definition may or may not be a dfun;
-- vectorisation proceeds differently depending on which it is)
--
-- Note [Scalar dfuns]
-- ~~~~~~~~~~~~~~~~~~~
......@@ -342,7 +344,8 @@ vectTopRhs recFs var expr
; vectDecl <- lookupVectDecl var
; let isDFun = isDFunId var
; traceVt ("vectTopRhs of " ++ show var ++ info globalScalar isDFun vectDecl) $ ppr expr
; traceVt ("vectTopRhs of " ++ show var ++ info globalScalar isDFun vectDecl ++ ":") $
ppr expr
; rhs globalScalar isDFun vectDecl
}
......@@ -357,14 +360,18 @@ vectTopRhs recFs var expr
= do { expr' <- vectScalarDFun var recFs
; return (DontInline, True, expr')
}
rhs False _isDFun Nothing -- Case (4)
= do { let fvs = freeVars expr
rhs False False Nothing -- Case (4) — not a dfun
= do { let exprFvs = freeVars expr
; (inline, isScalar, vexpr)
<- inBind var $
vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs fvs
vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs exprFvs
; return (inline, isScalar, vectorised vexpr)
}
rhs False True Nothing -- Case (4) — is a dfun
= do { expr' <- vectDictExpr expr
; return (DontInline, True, expr')
}
info True False _ = " [VECTORISE SCALAR]"
info True True _ = " [VECTORISE SCALAR instance]"
info False _ vectDecl | isJust vectDecl = " [VECTORISE]"
......
This diff is collapsed.
......@@ -13,8 +13,7 @@ module Vectorise.Monad (
-- * Variables
lookupVar,
maybeCantVectoriseVarM,
dumpVar,
lookupVar_maybe,
addGlobalScalar,
) where
......@@ -41,7 +40,6 @@ import Name
import ErrUtils
import Outputable
import Control.Monad
import System.IO
......@@ -142,32 +140,31 @@ builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
-- Var ------------------------------------------------------------------------
-- |Lookup the vectorised, and if local, also the lifted versions of a variable.
-- |Lookup the vectorised, and if local, also the lifted version of a variable.
--
-- * If it's in the global environment we get the vectorised version.
-- * If it's in the local environment we get both the vectorised and lifted version.
--
lookupVar :: Var -> VM (Scope Var (Var, Var))
lookupVar v
= do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
case r of
Just e -> return (Local e)
Nothing -> liftM Global
. maybeCantVectoriseVarM v
. readGEnv $ \env -> lookupVarEnv (global_vars env) v
maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
maybeCantVectoriseVarM v p
= do r <- p
case r of
Just x -> return x
Nothing -> dumpVar v
= do { mb_res <- lookupVar_maybe v
; case mb_res of
Just x -> return x
Nothing -> dumpVar v
}
lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var)))
lookupVar_maybe v
= do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
; case r of
Just e -> return $ Just (Local e)
Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
}
dumpVar :: Var -> a
dumpVar var
| Just _ <- isClassOpId_maybe var
= cantVectorise "ClassOpId not vectorised:" (ppr var)
| otherwise
= cantVectorise "Variable not vectorised:" (ppr var)
......
......@@ -60,6 +60,10 @@ instance Monad VM where
Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
No reason -> return $ No reason
instance Applicative VM where
pure = return
(<*>) = ap
instance Functor VM where
fmap = liftM
......
......@@ -308,7 +308,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
. inBind orig_worker
. polyAbstract tyvars $ \args ->
liftM (mkLams (tyvars ++ args) . vectorised)
$ buildClosures tyvars [] arg_tys res_ty mk_body
$ buildClosures tyvars [] [] arg_tys res_ty mk_body
raw_worker <- mkVectId orig_worker (exprType body)
let vect_worker = raw_worker `setIdUnfolding`
......
-- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM.
module Vectorise.Type.Type (
vectTyCon,
vectAndLiftType,
vectType
) where
module Vectorise.Type.Type
( vectTyCon
, vectAndLiftType
, vectType
)
where
import Vectorise.Utils
import Vectorise.Monad
import Vectorise.Builtins
import TypeRep
import TcType
import Type
import TypeRep
import TyCon
import Outputable
import Control.Monad
import Data.List
import Control.Applicative
import Data.Maybe
-- | Vectorise a type constructor.
......@@ -30,55 +32,53 @@ vectTyCon tc
-- |Produce the vectorised and lifted versions of a type.
--
-- NB: Here we are limited to properly handle predicates at the toplevel only. Anything embedded
-- in what is called the 'body_ty' below will end up as an argument to the type family 'PData'.
--
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
vectAndLiftType ty
= do
mdicts <- mapM paDictArgType (reverse tyvars)
let dicts = [dict | Just dict <- mdicts]
vmono_ty <- vectType mono_ty
lmono_ty <- mkPDataType vmono_ty
return (abstractType tyvars dicts vmono_ty,
abstractType tyvars dicts lmono_ty)
= do { padicts <- liftM catMaybes $ mapM paDictArgType tyvars
; vmono_ty <- vectType mono_ty
; lmono_ty <- mkPDataType vmono_ty
; return (abstractType tyvars (padicts ++ theta) vmono_ty,
abstractType tyvars (padicts ++ theta) lmono_ty)
}
where
(tyvars, mono_ty) = splitForAllTys ty
(tyvars, phiTy) = splitForAllTys ty
(theta, mono_ty) = tcSplitPhiTy phiTy
-- |Vectorise a type.
--
-- For each quantified var we need to add a PA dictionary out the front of the type.
-- So forall a. C a => a -> a
-- turns into forall a. PA a => Cv a => a :-> a
--
vectType :: Type -> VM Type
vectType ty
| Just ty' <- coreView ty
= vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon) (mapM vectType [ty1,ty2])
-- For each quantified var we need to add a PA dictionary out the front of the type.
-- So forall a. C a => a -> a
-- turns into forall a. Cv a => PA a => a :-> a
vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2
vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys
vectType (FunTy ty1 ty2)
| isPredTy ty1
= FunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction
| otherwise
= TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2]
vectType ty@(ForAllTy _ _)
= do
-- split the type into the quantified vars, its dictionaries and the body.
let (tyvars, tyBody) = splitForAllTys ty
let (tyArgs, tyResult) = splitFunTys tyBody
let (tyArgs_dict, tyArgs_regular)
= partition isDictTy tyArgs
-- vectorise the body.
let tyBody' = mkFunTys tyArgs_regular tyResult
tyBody'' <- vectType tyBody'
= do { -- strip off consecutive foralls
; let (tyvars, tyBody) = splitForAllTys ty
-- vectorise the dictionary parameters.
dictsVect <- mapM vectType tyArgs_dict
-- vectorise the body
; vtyBody <- vectType tyBody
-- make a PA dictionary for each of the type variables.
dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars
-- make a PA dictionary for each of the type variables
; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars
-- pack it all back together.
return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody''
-- add the PA dictionaries after the foralls
; return $ abstractType tyvars dictsPA vtyBody
}
-- |Add quantified vars and dictionary parameters to the front of a type.
--
......
......@@ -7,6 +7,7 @@ module Vectorise.Utils (
-- * Annotated Exprs
collectAnnTypeArgs,
collectAnnDictArgs,
collectAnnTypeBinders,
collectAnnValBinders,
isAnnTypeArg,
......@@ -31,6 +32,7 @@ import Vectorise.Monad
import Vectorise.Builtins
import CoreSyn
import CoreUtils
import Id
import Type
import Control.Monad
......@@ -43,17 +45,28 @@ collectAnnTypeArgs expr = go expr []
go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
go e tys = (e, tys)
collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann])
collectAnnDictArgs expr = go expr []
where
go e@(_, AnnApp f arg) dicts
| isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts)
| otherwise = (e, dicts)
go e dicts = (e, dicts)
collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
collectAnnTypeBinders expr = go [] expr
where
go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e
go bs e = (reverse bs, e)
-- |Collect all consecutive value binders that are not dictionaries.
--
collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
collectAnnValBinders expr = go [] expr
where
go bs (_, AnnLam b e) | isId b = go (b:bs) e
go bs e = (reverse bs, e)
go bs (_, AnnLam b e) | isId b
&& (not . isPredTy . idType $ b) = go (b : bs) e
go bs e = (reverse bs, e)
isAnnTypeArg :: AnnExpr b ann -> Bool
isAnnTypeArg (_, AnnType _) = True
......
-- |Utils concerning closure construction and application.
module Vectorise.Utils.Closure (
mkClosure,
mkClosureApp,
buildClosure,
buildClosures,
buildEnv
) where
module Vectorise.Utils.Closure
( mkClosure
, mkClosureApp
, buildClosures
)
where
import Vectorise.Builtins
import Vectorise.Vect
......@@ -56,51 +55,72 @@ mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
buildClosures :: [TyVar]
-> [VVar]
-> [Type] -- ^ Type of the arguments.
-> Type -- ^ Type of result.
-- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function. The length of
-- the list of types of arguments determines the arity.
--
-- In addition to a set of type variables, a set of value variables is passed during closure
-- /construction/. In contrast, the closure environment and the arguments are passed during closure
-- application.
--
buildClosures :: [TyVar] -- ^ Type variables passed during closure construction.
-> [Var] -- ^ Variables passed during closure construction.
-> [VVar] -- ^ Variables in the environment.
-> [Type] -- ^ Type of the arguments.
-> Type -- ^ Type of result.
-> VM VExpr
-> VM VExpr
buildClosures _ _ [] _ mk_body
buildClosures _tvs _vars _env [] _res_ty mk_body
= mk_body
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 vars arg_ty res_ty'
. hoistPolyVExpr tvs (Inline (length vars + 1))
$ do
lc <- builtin liftingContext
clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body
return $ vLams lc (vars ++ [arg]) clo
buildClosures tvs vars env [arg_ty] res_ty mk_body
= buildClosure tvs vars env arg_ty res_ty mk_body
buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body
= do { res_ty' <- mkClosureTypes arg_tys res_ty
; arg <- newLocalVVar (fsLit "x") arg_ty
; buildClosure tvs vars env arg_ty res_ty'
. hoistPolyVExpr tvs vars (Inline (length env + 1))
$ do { lc <- builtin liftingContext
; clo <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body
; return $ vLams lc (env ++ [arg]) clo
}
}
-- Build a closure taking one extra argument during closure application.
--
-- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)
-- where
-- 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] -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr
buildClosure tvs vars arg_ty res_ty mk_body
= do
(env_ty, env, bind) <- buildEnv vars
env_bndr <- newLocalVVar (fsLit "env") env_ty
arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
fn <- hoistPolyVExpr tvs (Inline 2)
$ do
lc <- builtin liftingContext
body <- mk_body
return . vLams lc [env_bndr, arg_bndr]
$ bind (vVar env_bndr)
(vVarApps lc body (vars ++ [arg_bndr]))
mkClosure arg_ty res_ty env_ty fn env
-- Environments ---------------------------------------------------------------
-- In addition to a set of type variables, a set of value variables is passed during closure
-- /construction/. In contrast, the closure environment and the closure argument are passed during
-- closure application.
--
buildClosure :: [TyVar] -- ^Type variables passed during closure construction.
-> [Var] -- ^Variables passed during closure construction.
-> [VVar] -- ^Variables in the environment.
-> Type -- ^Type of the closure argument.
-> Type -- ^Type of the result.
-> VM VExpr
-> VM VExpr
buildClosure tvs vars vvars arg_ty res_ty mk_body
= do { (env_ty, env, bind) <- buildEnv vvars
; env_bndr <- newLocalVVar (fsLit "env") env_ty
; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
-- generate the closure function as a hoisted binding
; fn <- hoistPolyVExpr tvs vars (Inline 2) $
do { lc <- builtin liftingContext
; body <- mk_body
; return . vLams lc [env_bndr, arg_bndr]
$ bind (vVar env_bndr)
(vVarApps lc body (vvars ++ [arg_bndr]))
}
; mkClosure arg_ty res_ty env_ty fn env
}
-- Build the environment for a single closure.
--
buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr)
buildEnv []
= do
......
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module Vectorise.Utils.Hoisting (
Inline(..),
addInlineArity,
inlineMe,
hoistBinding,
hoistExpr,
hoistVExpr,
hoistPolyVExpr,
takeHoisted
)
module Vectorise.Utils.Hoisting
( Inline(..)
, addInlineArity
, inlineMe
, hoistBinding
, hoistExpr
, hoistVExpr
, hoistPolyVExpr
, takeHoisted
)
where
import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
......@@ -28,33 +21,38 @@ import CoreUtils
import CoreUnfold
import Type
import Id
import BasicTypes( Arity )
import BasicTypes (Arity)
import FastString
import Control.Monad
import Control.Applicative
-- Inline ---------------------------------------------------------------------
-- | Records whether we should inline a particular binding.
-- |Records whether we should inline a particular binding.
--
data Inline
= Inline Arity
| DontInline
-- | Add to the arity contained within an `Inline`, if any.
-- |Add to the arity contained within an `Inline`, if any.
--
addInlineArity :: Inline -> Int -> Inline
addInlineArity (Inline m) n = Inline (m+n)
addInlineArity DontInline _ = DontInline
-- | Says to always inline a binding.
-- |Says to always inline a binding.
--
inlineMe :: Inline
inlineMe = Inline 0
-- Hoising --------------------------------------------------------------------
-- Hoisting --------------------------------------------------------------------
hoistBinding :: Var -> CoreExpr -> VM ()
hoistBinding v e = updGEnv $ \env ->
env { global_bindings = (v,e) : global_bindings env }
hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
hoistExpr fs expr inl
= do
......@@ -67,7 +65,6 @@ hoistExpr fs expr inl
mkInlineUnfolding (Just arity) expr
DontInline -> var
hoistVExpr :: VExpr -> Inline -> VM VVar
hoistVExpr (ve, le) inl
= do
......@@ -76,16 +73,22 @@ hoistVExpr (ve, le) inl
lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
return (vv, lv)