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

Break out conversion functions to own module

parent c2beb20b
......@@ -457,6 +457,7 @@ Library
VectType
VectUtils
Vectorise.Var
Vectorise.Convert
Vectorise.Env
Vectorise.Vect
Vectorise.Exp
......
......@@ -8,6 +8,7 @@ where
import VectUtils
import Vectorise.Env
import Vectorise.Convert
import Vectorise.Vect
import Vectorise.Monad
import Vectorise.Builtins
......@@ -27,7 +28,6 @@ import BuildTyCl
import DataCon
import TyCon
import Type
import TypeRep
import Coercion
import FamInstEnv ( FamInst, mkLocalFamInst )
import OccName
......@@ -52,13 +52,14 @@ debug = False
dtrace s x = if debug then pprTrace "VectType" s x else x
-- ----------------------------------------------------------------------------
-- Type definitions
-- | Vectorise a type environment.
-- The type environment contains all the type things defined in a module.
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)])
vectTypeEnv
:: TypeEnv
-> VM ( TypeEnv -- Vectorised type environment.
, [FamInst] -- New type family instances.
, [(Var, CoreExpr)]) -- New top level bindings.
vectTypeEnv env
= dtrace (ppr env)
$ do
......@@ -748,76 +749,3 @@ paMethods = [("dictPRepr", buildPRDict),
("fromArrPRepr", buildFromArrPRepr)]
-- ----------------------------------------------------------------------------
-- Conversions
-- | Build an expression that calls the vectorised version of some
-- function from a `Closure`.
--
-- For example
-- @
-- \(x :: Double) ->
-- \(y :: Double) ->
-- ($v_foo $: x) $: y
-- @
--
-- We use the type of the original binding to work out how many
-- outer lambdas to add.
--
fromVect
:: Type -- ^ The type of the original binding.
-> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@.
-> VM CoreExpr
-- Convert the type to the core view if it isn't already.
fromVect ty expr
| Just ty' <- coreView ty
= fromVect ty' expr
-- For each function constructor in the original type we add an outer
-- lambda to bind the parameter variable, and an inner application of it.
fromVect (FunTy arg_ty res_ty) expr
= do
arg <- newLocalVar (fsLit "x") arg_ty
varg <- toVect arg_ty (Var arg)
varg_ty <- vectType arg_ty
vres_ty <- vectType res_ty
apply <- builtin applyVar
body <- fromVect res_ty
$ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
return $ Lam arg body
-- If the type isn't a function then it's time to call on the closure.
fromVect ty expr
= identityConv ty >> return expr
-- TODO: What is this really doing?
toVect :: Type -> CoreExpr -> VM CoreExpr
toVect ty expr = identityConv ty >> return expr
-- | Check that we have the vectorised versions of all the
-- type constructors in this type.
identityConv :: Type -> VM ()
identityConv ty
| Just ty' <- coreView ty
= identityConv ty'
identityConv (TyConApp tycon tys)
= do mapM_ identityConv tys
identityConvTyCon tycon
identityConv _ = noV
-- | Check that we have the vectorised version of this type constructor.
identityConvTyCon :: TyCon -> VM ()
identityConvTyCon tc
| isBoxedTupleTyCon tc = return ()
| isUnLiftedTyCon tc = return ()
| otherwise
= do tc' <- maybeV (lookupTyCon tc)
if tc == tc' then return () else noV
module Vectorise.Convert
(fromVect)
where
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Type.Type
import CoreSyn
import TyCon
import Type
import TypeRep
import FastString
-- | Build an expression that calls the vectorised version of some
-- function from a `Closure`.
--
-- For example
-- @
-- \(x :: Double) ->
-- \(y :: Double) ->
-- ($v_foo $: x) $: y
-- @
--
-- We use the type of the original binding to work out how many
-- outer lambdas to add.
--
fromVect
:: Type -- ^ The type of the original binding.
-> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@.
-> VM CoreExpr
-- Convert the type to the core view if it isn't already.
fromVect ty expr
| Just ty' <- coreView ty
= fromVect ty' expr
-- For each function constructor in the original type we add an outer
-- lambda to bind the parameter variable, and an inner application of it.
fromVect (FunTy arg_ty res_ty) expr
= do
arg <- newLocalVar (fsLit "x") arg_ty
varg <- toVect arg_ty (Var arg)
varg_ty <- vectType arg_ty
vres_ty <- vectType res_ty
apply <- builtin applyVar
body <- fromVect res_ty
$ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
return $ Lam arg body
-- If the type isn't a function then it's time to call on the closure.
fromVect ty expr
= identityConv ty >> return expr
-- TODO: What is this really doing?
toVect :: Type -> CoreExpr -> VM CoreExpr
toVect ty expr = identityConv ty >> return expr
-- | Check that we have the vectorised versions of all the
-- type constructors in this type.
identityConv :: Type -> VM ()
identityConv ty
| Just ty' <- coreView ty
= identityConv ty'
identityConv (TyConApp tycon tys)
= do mapM_ identityConv tys
identityConvTyCon tycon
identityConv _ = noV
-- | Check that we have the vectorised version of this type constructor.
identityConvTyCon :: TyCon -> VM ()
identityConvTyCon tc
| isBoxedTupleTyCon tc = return ()
| isUnLiftedTyCon tc = return ()
| otherwise
= do tc' <- maybeV (lookupTyCon tc)
if tc == tc' then return () else noV
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