Commit d5744ef5 authored by benl@ouroborus.net's avatar benl@ouroborus.net
Browse files

Break out hoisting utils into their own module

parent 170a6564
......@@ -464,6 +464,7 @@ Library
Vectorise.Type.TyConDecl
Vectorise.Type.Classify
Vectorise.Utils.Closure
Vectorise.Utils.Hoisting
Vectorise.Builtins.Base
Vectorise.Builtins.Initialise
Vectorise.Builtins.Modules
......
......@@ -15,6 +15,7 @@ import Vectorise.Type.Type
import Vectorise.Type.TyConDecl
import Vectorise.Type.Classify
import Vectorise.Utils.Closure
import Vectorise.Utils.Hoisting
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import BasicTypes
......
......@@ -16,37 +16,27 @@ module VectUtils (
combinePD,
liftPD,
zipScalars, scalarClosure,
polyAbstract, polyApply, polyVApply, polyArity,
Inline(..), addInlineArity, inlineMe,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
polyAbstract, polyApply, polyVApply, polyArity
) where
import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
import Vectorise.Builtins
import CoreSyn
import CoreUtils
import CoreUnfold ( mkInlineRule )
import Coercion
import Type
import TypeRep
import TyCon
import DataCon
import Var
import MkId ( unwrapFamInstScrut )
import Id ( setIdUnfolding )
import BasicTypes
import Literal ( Literal, mkMachInt )
import MkId
import Literal
import Outputable
import FastString
import Control.Monad
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
where
......@@ -363,62 +353,6 @@ polyVApply expr tys
= do Just dicts <- liftM sequence $ mapM paDictOfType tys
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
-- Inline ---------------------------------------------------------------------
-- | Records whether we should inline a particular binding.
data Inline
= Inline Arity
| DontInline
-- | 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.
inlineMe :: Inline
inlineMe = Inline 0
-- Hoising --------------------------------------------------------------------
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
var <- mk_inline `liftM` newLocalVar fs (exprType expr)
hoistBinding var expr
return var
where
mk_inline var = case inl of
Inline arity -> var `setIdUnfolding`
mkInlineRule expr (Just arity)
DontInline -> var
hoistVExpr :: VExpr -> Inline -> VM VVar
hoistVExpr (ve, le) inl
= do
fs <- getBindName
vv <- hoistExpr ('v' `consFS` fs) ve inl
lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
return (vv, lv)
hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
hoistPolyVExpr tvs inline p
= do
inline' <- liftM (addInlineArity inline) (polyArity tvs)
expr <- closedV . polyAbstract tvs $ \args ->
liftM (mapVect (mkLams $ tvs ++ args)) p
fn <- hoistVExpr expr inline'
polyVApply (vVar fn) (mkTyVarTys tvs)
takeHoisted :: VM [(Var, CoreExpr)]
takeHoisted
= do
env <- readGEnv id
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
{-
boxExpr :: Type -> VExpr -> VM VExpr
......
......@@ -3,8 +3,8 @@
module Vectorise( vectorise )
where
import VectUtils
import VectType
import Vectorise.Utils.Hoisting
import Vectorise.Exp
import Vectorise.Vect
import Vectorise.Env
......
......@@ -6,6 +6,7 @@ where
import VectUtils
import VectType
import Vectorise.Utils.Closure
import Vectorise.Utils.Hoisting
import Vectorise.Var
import Vectorise.Vect
import Vectorise.Env
......
......@@ -8,6 +8,7 @@ module Vectorise.Utils.Closure (
)
where
import VectUtils
import Vectorise.Utils.Hoisting
import Vectorise.Builtins
import Vectorise.Vect
import Vectorise.Monad
......
module Vectorise.Utils.Hoisting (
Inline(..),
addInlineArity,
inlineMe,
hoistBinding,
hoistExpr,
hoistVExpr,
hoistPolyVExpr,
takeHoisted
)
where
import VectUtils
import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
import CoreSyn
import CoreUtils
import CoreUnfold
import Type
import Var
import Id
import BasicTypes
import FastString
import Control.Monad
-- Inline ---------------------------------------------------------------------
-- | Records whether we should inline a particular binding.
data Inline
= Inline Arity
| DontInline
-- | 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.
inlineMe :: Inline
inlineMe = Inline 0
-- Hoising --------------------------------------------------------------------
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
var <- mk_inline `liftM` newLocalVar fs (exprType expr)
hoistBinding var expr
return var
where
mk_inline var = case inl of
Inline arity -> var `setIdUnfolding`
mkInlineRule expr (Just arity)
DontInline -> var
hoistVExpr :: VExpr -> Inline -> VM VVar
hoistVExpr (ve, le) inl
= do
fs <- getBindName
vv <- hoistExpr ('v' `consFS` fs) ve inl
lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
return (vv, lv)
hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
hoistPolyVExpr tvs inline p
= do
inline' <- liftM (addInlineArity inline) (polyArity tvs)
expr <- closedV . polyAbstract tvs $ \args ->
liftM (mapVect (mkLams $ tvs ++ args)) p
fn <- hoistVExpr expr inline'
polyVApply (vVar fn) (mkTyVarTys tvs)
takeHoisted :: VM [(Var, CoreExpr)]
takeHoisted
= do
env <- readGEnv id
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
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