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

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]"
......
{-# LANGUAGE TupleSections #-}
-- |Vectorisation of expressions.
module Vectorise.Exp
( -- * Vectorise polymorphic expressions with special cases for right-hand sides of particular
-- variable bindings
vectPolyExpr
, vectDictExpr
, vectScalarFun
, vectScalarDFun
)
......@@ -42,50 +45,45 @@ import Outputable
import FastString
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List
-- | Vectorise a polymorphic expression.
-- |Vectorise a polymorphic expression.
--
vectPolyExpr :: Bool -- ^ When vectorising the RHS of a
-- binding, whether that binding is a
-- loop breaker.
vectPolyExpr :: Bool -- ^ When vectorising the RHS of a binding: is that binding a loop breaker?
-> [Var]
-> CoreExprWithFVs
-> VM (Inline, Bool, VExpr)
vectPolyExpr loop_breaker recFns (_, AnnTick tickish expr)
= do (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr
return (inline, isScalarFn, vTick tickish expr')
= do { (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr
; return (inline, isScalarFn, vTick tickish expr')
}
vectPolyExpr loop_breaker recFns expr
= do
arity <- polyArity tvs
polyAbstract tvs $ \args ->
do
(inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono
return (addInlineArity inline arity, isScalarFn,
mapVect (mkLams $ tvs ++ args) mono')
= do { arity <- polyArity tvs
; polyAbstract tvs $ \args -> do
{ (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono
; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono')
} }
where
(tvs, mono) = collectAnnTypeBinders expr
-- |Vectorise an expression.
--
vectExpr :: CoreExprWithFVs -> VM VExpr
vectExpr (_, AnnType ty)
= liftM vType (vectType ty)
vectExpr (_, AnnVar v)
= vectVar v
vectExpr (_, AnnLit lit)
= vectLiteral lit
= vectConst $ Lit lit
vectExpr (_, AnnTick tickish expr)
= liftM (vTick tickish) (vectExpr expr)
vectExpr e@(_, AnnLam bndr _)
| isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e
-- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
-- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
-- happy.
-- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
-- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
-- happy.
-- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now?
vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
| v == pAT_ERROR_ID
......@@ -95,12 +93,14 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
where
err' = deAnnotate err
-- type application (handle multiple consecutive type applications simultaneously to ensure the
-- PA dictionaries are put at the right places)
vectExpr e@(_, AnnApp _ arg)
| isAnnTypeArg arg
= vectTyAppExpr fn tys
where
(fn, tys) = collectAnnTypeArgs e
= vectPolyApp e
-- 'Int', 'Float', or 'Double' literal
-- FIXME: this needs to be generalised
vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
| Just con <- isDataConId_maybe v
, is_special_con con
......@@ -111,25 +111,22 @@ vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
where
is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon]
-- TODO: Avoid using closure application for dictionaries.
-- vectExpr (_, AnnApp fn arg)
-- | if is application of dictionary
-- just use regular app instead of closure app.
-- for lifted version.
-- do liftPD (sub a dNumber)
-- lift the result of the selection, not sub and dNumber seprately.
vectExpr (_, AnnApp fn arg)
= do
arg_ty' <- vectType arg_ty
res_ty' <- vectType res_ty
fn' <- vectExpr fn
arg' <- vectExpr arg
mkClosureApp arg_ty' res_ty' fn' arg'
-- value application (dictionary or user value)
vectExpr e@(_, AnnApp fn arg)
| isPredTy arg_ty -- dictionary application (whose result is not a dictionary)
= vectPolyApp e
| otherwise -- user value
= do { -- vectorise the types
; varg_ty <- vectType arg_ty
; vres_ty <- vectType res_ty
-- vectorise the function and argument expression
; vfn <- vectExpr fn
; varg <- vectExpr arg
-- the vectorised function is a closure; apply it to the vectorised argument
; mkClosureApp varg_ty vres_ty vfn varg
}
where
(arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn
......@@ -162,18 +159,19 @@ vectExpr (_, AnnLet (AnnRec bs) body)
. liftM (\(_,_,z)->z)
$ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs
vectExpr e@(_, AnnLam bndr _)
| isId bndr = liftM (\(_,_,z) ->z) $ vectFnExpr True False [] e
{-
onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
`orElseV` vectLam True fvs bs body
where
(bs,body) = collectAnnValBinders e
-}
vectExpr (_, AnnTick tickish expr)
= liftM (vTick tickish) (vectExpr expr)
vectExpr (_, AnnType ty)
= liftM vType (vectType ty)
vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e)
-- |Vectorise an expression with an outer lambda abstraction.
-- |Vectorise an expression that *may* have an outer lambda abstraction.
--
-- We do not handle type variables at this point, as they will already have been stripped off by
-- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only
-- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere.
--
vectFnExpr :: Bool -- ^ If we process the RHS of a binding, whether that binding should
-- be inlined
......@@ -181,15 +179,138 @@ vectFnExpr :: Bool -- ^ If we process the RHS of a binding, whether
-> [Var] -- ^ Names of function in same recursive binding group
-> CoreExprWithFVs -- ^ Expression to vectorise; must have an outer `AnnLam`
-> VM (Inline, Bool, VExpr)
vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr _)
| isId bndr = mark DontInline True (vectScalarFun False recFns (deAnnotate expr))
`orElseV`
mark inlineMe False (vectLam inline loop_breaker expr)
vectFnExpr _ _ _ e = mark DontInline False $ vectExpr e
vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr body)
-- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type
| isId bndr
&& isPredTy (idType bndr)
= do { vBndr <- vectBndr bndr
; (inline, isScalarFn, vbody) <- vectFnExpr inline loop_breaker recFns body
; return (inline, isScalarFn, mapVect (mkLams [vectorised vBndr]) vbody)
}
-- non-predicate abstraction: vectorise (try to vectorise as a scalar computation)
| isId bndr
= mark DontInline True (vectScalarFun False recFns (deAnnotate expr))
`orElseV`
mark inlineMe False (vectLam inline loop_breaker expr)
vectFnExpr _ _ _ e
-- not an abstraction: vectorise as a vanilla expression
= mark DontInline False $ vectExpr e
mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a)
mark b isScalarFn p = do { x <- p; return (b, isScalarFn, x) }
-- |Vectorise type and dictionary applications.
--
-- These are always headed by a variable (as we don't support higher-rank polymorphism), but may
-- involve two sets of type variables and dictionaries. Consider,
--
-- > class C a where
-- > m :: D b => b -> a
--
-- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'.
--
vectPolyApp :: CoreExprWithFVs -> VM VExpr
vectPolyApp e0
= case e4 of
(_, AnnVar var)
-> do { -- get the vectorised form of the variable
; vVar <- lookupVar var
; traceVt "vectPolyApp of" (ppr var)
-- vectorise type and dictionary arguments
; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter)
; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner)
; vTysOuter <- mapM vectType tysOuter
; vTysInner <- mapM vectType tysInner
; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter
; case vVar of
Local (vv, lv)
-> do { MASSERT( null dictsInner ) -- local vars cannot be class selectors
; traceVt " LOCAL" (text "")
; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv)
}
Global vv
| isDictComp var -- dictionary computation
-> do { -- in a dictionary computation, the innermost, non-empty set of
-- arguments are non-vectorised arguments, where no 'PA'dictionaries
-- are needed for the type variables
; ve <- if null dictsInner
then
return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter
else
reconstructOuter
(Var vv `mkTyApps` vTysInner `mkApps` vDictsInner)
; traceVt " GLOBAL (dict):" (ppr ve)
; vectConst ve
}
| otherwise -- non-dictionary computation
-> do { MASSERT( null dictsInner )
; ve <- reconstructOuter (Var vv)
; traceVt " GLOBAL (non-dict):" (ppr ve)
; vectConst ve
}
}
_ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0)
where
-- if there is only one set of variables or dictionaries, it will be the outer set
(e1, dictsOuter) = collectAnnDictArgs e0
(e2, tysOuter) = collectAnnTypeArgs e1
(e3, dictsInner) = collectAnnDictArgs e2
(e4, tysInner) = collectAnnTypeArgs e3
--
isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var
-- |Vectorise the body of a dfun.
--
-- Dictionary computations are special for the following reasons. The application of dictionary
-- functions are always saturated, so there is no need to create closures. Dictionary computations
-- don't depend on array values, so they are always scalar computations whose result we can
-- replicate (instead of executing them in parallel).
--
-- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary
-- computation. Consequently, the variable case needs to deal with cases where binders are
-- in the vectoriser environments and where that is not the case.
--
vectDictExpr :: CoreExpr -> VM CoreExpr
vectDictExpr (Var var)
= do { mb_scope <- lookupVar_maybe var
; case mb_scope of
Nothing -> return $ Var var -- binder from within the dict. computation
Just (Local (vVar, _)) -> return $ Var vVar -- local vectorised variable
Just (Global vVar) -> return $ Var vVar -- global vectorised variable
}
vectDictExpr (Lit lit)
= pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit)
vectDictExpr (Lam bndr e)
= Lam bndr <$> vectDictExpr e
vectDictExpr (App fn arg)
= App <$> vectDictExpr fn <*> vectDictExpr arg
vectDictExpr (Case e bndr ty alts)
= Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts
where
vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e
--
vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon)
where
dataConErr = ptext (sLit "Cannot vectorise data constructor:") <+> ppr datacon
vectDictAltCon (LitAlt lit) = return $ LitAlt lit
vectDictAltCon DEFAULT = return DEFAULT
vectDictExpr (Let bnd body)
= Let <$> vectDictBind bnd <*> vectDictExpr body
where
vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e
vectDictBind (Rec bnds) = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds
vectDictExpr e@(Cast _e _coe)
= pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e)
vectDictExpr (Tick tickish e)
= Tick tickish <$> vectDictExpr e
vectDictExpr (Type ty)
= Type <$> vectType ty
vectDictExpr (Coercion coe)
= pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe)
-- |Vectorise an expression of functional type, where all arguments and the result are of scalar
-- type (i.e., 'Int', 'Float', 'Double' etc.) and which does not contain any subcomputations that
-- involve parallel arrays. Such functionals do not requires the full blown vectorisation
......@@ -398,53 +519,68 @@ unVectDict ty e
Nothing -> panic "Vectorise.Exp.unVectDict: no class"
selIds = classAllSelIds cls
-- | Vectorise a lambda abstraction.
-- |Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
--
-- All non-dictionary free variables go into the closure's environment, whereas the dictionary
-- variables are passed explicit (as conventional arguments) into the body during closure construction.
--
vectLam :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined.
-> Bool -- ^ Whether the binding is a loop breaker.
-> CoreExprWithFVs -- ^ Body of abstraction.
-> VM VExpr
vectLam inline loop_breaker expr@(fvs, AnnLam _ _)
= do let (bs, body) = collectAnnValBinders expr
tyvars <- localTyVars
(vs, vvs) <- readLEnv $ \env ->
unzip [(var, vv) | var <- varSetElems fvs
, Just vv <- [lookupVarEnv (local_vars env) var]]
arg_tys <- mapM (vectType . idType) bs
res_ty <- vectType (exprType $ deAnnotate body)
buildClosures tyvars vvs arg_tys res_ty
. hoistPolyVExpr tyvars (maybe_inline (length vs + length bs))
$ do
lc <- builtin liftingContext
(vbndrs, vbody) <- vectBndrsIn (vs ++ bs) (vectExpr body)
vbody' <- break_loop lc res_ty vbody
return $ vLams lc vbndrs vbody'
= do { let (bndrs, body) = collectAnnValBinders expr
-- grab the in-scope type variables
; tyvars <- localTyVars
-- collect and vectorise all /local/ free variables
; vfvs <- readLEnv $ \env ->
[ (var, fromJust mb_vv)
| var <- varSetElems fvs
, let mb_vv = lookupVarEnv (local_vars env) var
, isJust mb_vv -- its local == is in local var env
]
-- separate dictionary from non-dictionary variables in the free variable set
; let (vvs_dict, vvs_nondict) = partition (isPredTy . varType . fst) vfvs
(_fvs_dict, vfvs_dict) = unzip vvs_dict
(fvs_nondict, vfvs_nondict) = unzip vvs_nondict
-- compute the type of the vectorised closure
; arg_tys <- mapM (vectType . idType) bndrs
; res_ty <- vectType (exprType $ deAnnotate body)
; let arity = length fvs_nondict + length bndrs
vfvs_dict' = map vectorised vfvs_dict
; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty
. hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity)
$ do { -- generate the vectorised body of the lambda abstraction
; lc <- builtin liftingContext
; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) (vectExpr body)
; vbody' <- break_loop lc res_ty vbody
; return $ vLams lc vbndrs vbody'
}
}
where
maybe_inline n | inline = Inline n
| otherwise = DontInline
-- If this is the body of a binding marked as a loop breaker, add a recursion termination test
-- to the /lifted/ version of the function body. The termination tests checks if the lifting
-- context is empty. If so, it returns an empty array of the (lifted) result type instead of
-- executing the function body. This is the test from the last line (defining \mathcal{L}')
-- in Figure 6 of HtM.
break_loop lc ty (ve, le)
| loop_breaker
= do
empty <- emptyPD ty
lty <- mkPDataType ty
return (ve, mkWildCase (Var lc) intPrimTy lty
[(DEFAULT, [], le),
(LitAlt (mkMachInt 0), [], empty)])
= do { empty <- emptyPD ty
; lty <- mkPDataType ty
; return (ve, mkWildCase (Var lc) intPrimTy lty
[(DEFAULT, [], le),
(LitAlt (mkMachInt 0), [], empty)])
}
| otherwise = return (ve, le)
vectLam _ _ _ = panic "vectLam"
vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
vectTyAppExpr e tys = cantVectorise "Can't vectorise expression (vectTyExpr)"
(ppr $ deAnnotate e `mkTyApps` tys)
-- | Vectorise an algebraic case expression.
-- We convert
......
......@@ -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