{-# LANGUAGE FlexibleContexts #-}
module Futhark.Internalise.AccurateSizes
( argShapes
, ensureResultShape
, ensureResultExtShape
, ensureExtShape
, ensureShape
, ensureArgShapes
)
where
import Control.Monad
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Futhark.Construct
import Futhark.Internalise.Monad
import Futhark.IR.SOACS
argShapes :: [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> [SubExp]
argShapes :: [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> [SubExp]
argShapes [VName]
shapes [TypeBase Shape u0]
valts [TypeBase Shape u1]
valargts =
(VName -> SubExp) -> [VName] -> [SubExp]
forall a b. (a -> b) -> [a] -> [b]
map VName -> SubExp
addShape [VName]
shapes
where mapping :: Map VName (Set SubExp)
mapping = [TypeBase Shape u0]
-> [TypeBase Shape u1] -> Map VName (Set SubExp)
forall u0 u1.
[TypeBase Shape u0]
-> [TypeBase Shape u1] -> Map VName (Set SubExp)
shapeMapping [TypeBase Shape u0]
valts [TypeBase Shape u1]
valargts
addShape :: VName -> SubExp
addShape VName
name =
case VName -> Map VName (Set SubExp) -> Maybe (Set SubExp)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name Map VName (Set SubExp)
mapping of
Just Set SubExp
s | SubExp
se:[SubExp]
_ <- Set SubExp -> [SubExp]
forall a. Set a -> [a]
S.toList Set SubExp
s -> SubExp
se
Maybe (Set SubExp)
_ -> IntType -> Integer -> SubExp
intConst IntType
Int32 Integer
0
ensureResultShape :: ErrorMsg SubExp -> SrcLoc -> [Type] -> Body
-> InternaliseM Body
ensureResultShape :: ErrorMsg SubExp -> SrcLoc -> [Type] -> Body -> InternaliseM Body
ensureResultShape ErrorMsg SubExp
msg SrcLoc
loc =
ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body -> InternaliseM Body
ensureResultExtShape ErrorMsg SubExp
msg SrcLoc
loc ([ExtType] -> Body -> InternaliseM Body)
-> ([Type] -> [ExtType]) -> [Type] -> Body -> InternaliseM Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [ExtType]
forall u. [TypeBase Shape u] -> [TypeBase ExtShape u]
staticShapes
ensureResultExtShape :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body
-> InternaliseM Body
ensureResultExtShape :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body -> InternaliseM Body
ensureResultExtShape ErrorMsg SubExp
msg SrcLoc
loc [ExtType]
rettype Body
body =
InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM))
forall (m :: * -> *).
MonadBinder m =>
m (Body (Lore m)) -> m (Body (Lore m))
insertStmsM (InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM)))
-> InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM))
forall a b. (a -> b) -> a -> b
$ do
[SubExp]
reses <- Body -> InternaliseM [SubExp]
forall (m :: * -> *). MonadBinder m => Body (Lore m) -> m [SubExp]
bodyBind (Body -> InternaliseM [SubExp])
-> InternaliseM Body -> InternaliseM [SubExp]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body -> InternaliseM Body
ensureResultExtShapeNoCtx ErrorMsg SubExp
msg SrcLoc
loc [ExtType]
rettype Body
body
[Type]
ts <- (SubExp -> InternaliseM Type) -> [SubExp] -> InternaliseM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SubExp -> InternaliseM Type
forall t (m :: * -> *). HasScope t m => SubExp -> m Type
subExpType [SubExp]
reses
let ctx :: [SubExp]
ctx = [ExtType] -> [[SubExp]] -> [SubExp]
forall u a. [TypeBase ExtShape u] -> [[a]] -> [a]
extractShapeContext [ExtType]
rettype ([[SubExp]] -> [SubExp]) -> [[SubExp]] -> [SubExp]
forall a b. (a -> b) -> a -> b
$ (Type -> [SubExp]) -> [Type] -> [[SubExp]]
forall a b. (a -> b) -> [a] -> [b]
map Type -> [SubExp]
forall u. TypeBase Shape u -> [SubExp]
arrayDims [Type]
ts
Stms (Lore InternaliseM)
-> [SubExp] -> InternaliseM (Body (Lore InternaliseM))
forall (m :: * -> *).
MonadBinder m =>
Stms (Lore m) -> [SubExp] -> m (Body (Lore m))
mkBodyM Stms (Lore InternaliseM)
forall a. Monoid a => a
mempty ([SubExp] -> InternaliseM (Body (Lore InternaliseM)))
-> [SubExp] -> InternaliseM (Body (Lore InternaliseM))
forall a b. (a -> b) -> a -> b
$ [SubExp]
ctx [SubExp] -> [SubExp] -> [SubExp]
forall a. [a] -> [a] -> [a]
++ [SubExp]
reses
ensureResultExtShapeNoCtx :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body
-> InternaliseM Body
ensureResultExtShapeNoCtx :: ErrorMsg SubExp -> SrcLoc -> [ExtType] -> Body -> InternaliseM Body
ensureResultExtShapeNoCtx ErrorMsg SubExp
msg SrcLoc
loc [ExtType]
rettype Body
body =
InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM))
forall (m :: * -> *).
MonadBinder m =>
m (Body (Lore m)) -> m (Body (Lore m))
insertStmsM (InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM)))
-> InternaliseM (Body (Lore InternaliseM))
-> InternaliseM (Body (Lore InternaliseM))
forall a b. (a -> b) -> a -> b
$ do
[SubExp]
es <- Body (Lore InternaliseM) -> InternaliseM [SubExp]
forall (m :: * -> *). MonadBinder m => Body (Lore m) -> m [SubExp]
bodyBind Body (Lore InternaliseM)
Body
body
[Type]
es_ts <- (SubExp -> InternaliseM Type) -> [SubExp] -> InternaliseM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SubExp -> InternaliseM Type
forall t (m :: * -> *). HasScope t m => SubExp -> m Type
subExpType [SubExp]
es
let ext_mapping :: Map Int SubExp
ext_mapping = [ExtType] -> [Type] -> Map Int SubExp
forall u u1.
[TypeBase ExtShape u] -> [TypeBase Shape u1] -> Map Int SubExp
shapeExtMapping [ExtType]
rettype [Type]
es_ts
rettype' :: [ExtType]
rettype' = ((Int, SubExp) -> [ExtType] -> [ExtType])
-> [ExtType] -> [(Int, SubExp)] -> [ExtType]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Int -> SubExp -> [ExtType] -> [ExtType])
-> (Int, SubExp) -> [ExtType] -> [ExtType]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> SubExp -> [ExtType] -> [ExtType]
forall t. FixExt t => Int -> SubExp -> t -> t
fixExt) [ExtType]
rettype ([(Int, SubExp)] -> [ExtType]) -> [(Int, SubExp)] -> [ExtType]
forall a b. (a -> b) -> a -> b
$ Map Int SubExp -> [(Int, SubExp)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int SubExp
ext_mapping
assertProperShape :: ExtType -> SubExp -> InternaliseM SubExp
assertProperShape ExtType
t SubExp
se =
let name :: [Char]
name = [Char]
"result_proper_shape"
in ErrorMsg SubExp
-> SrcLoc -> ExtType -> [Char] -> SubExp -> InternaliseM SubExp
ensureExtShape ErrorMsg SubExp
msg SrcLoc
loc ExtType
t [Char]
name SubExp
se
[SubExp] -> InternaliseM Body
forall (m :: * -> *).
MonadBinder m =>
[SubExp] -> m (Body (Lore m))
resultBodyM ([SubExp] -> InternaliseM Body)
-> InternaliseM [SubExp] -> InternaliseM Body
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ExtType -> SubExp -> InternaliseM SubExp)
-> [ExtType] -> [SubExp] -> InternaliseM [SubExp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ExtType -> SubExp -> InternaliseM SubExp
assertProperShape [ExtType]
rettype' [SubExp]
es
ensureExtShape :: ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> SubExp
-> InternaliseM SubExp
ensureExtShape :: ErrorMsg SubExp
-> SrcLoc -> ExtType -> [Char] -> SubExp -> InternaliseM SubExp
ensureExtShape ErrorMsg SubExp
msg SrcLoc
loc ExtType
t [Char]
name SubExp
orig
| Array{} <- ExtType
t, Var VName
v <- SubExp
orig =
VName -> SubExp
Var (VName -> SubExp) -> InternaliseM VName -> InternaliseM SubExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorMsg SubExp
-> SrcLoc -> ExtType -> [Char] -> VName -> InternaliseM VName
ensureShapeVar ErrorMsg SubExp
msg SrcLoc
loc ExtType
t [Char]
name VName
v
| Bool
otherwise = SubExp -> InternaliseM SubExp
forall (m :: * -> *) a. Monad m => a -> m a
return SubExp
orig
ensureShape :: ErrorMsg SubExp -> SrcLoc -> Type -> String -> SubExp
-> InternaliseM SubExp
ensureShape :: ErrorMsg SubExp
-> SrcLoc -> Type -> [Char] -> SubExp -> InternaliseM SubExp
ensureShape ErrorMsg SubExp
msg SrcLoc
loc = ErrorMsg SubExp
-> SrcLoc -> ExtType -> [Char] -> SubExp -> InternaliseM SubExp
ensureExtShape ErrorMsg SubExp
msg SrcLoc
loc (ExtType -> [Char] -> SubExp -> InternaliseM SubExp)
-> (Type -> ExtType)
-> Type
-> [Char]
-> SubExp
-> InternaliseM SubExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ExtType
forall u. TypeBase Shape u -> TypeBase ExtShape u
staticShapes1
ensureArgShapes :: (Typed (TypeBase Shape u)) =>
ErrorMsg SubExp -> SrcLoc -> [VName] -> [TypeBase Shape u] -> [SubExp]
-> InternaliseM [SubExp]
ensureArgShapes :: ErrorMsg SubExp
-> SrcLoc
-> [VName]
-> [TypeBase Shape u]
-> [SubExp]
-> InternaliseM [SubExp]
ensureArgShapes ErrorMsg SubExp
msg SrcLoc
loc [VName]
shapes [TypeBase Shape u]
paramts [SubExp]
args =
(Type -> SubExp -> InternaliseM SubExp)
-> [Type] -> [SubExp] -> InternaliseM [SubExp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> SubExp -> InternaliseM SubExp
ensureArgShape ([VName] -> [TypeBase Shape u] -> [SubExp] -> [Type]
forall t. Typed t => [VName] -> [t] -> [SubExp] -> [Type]
expectedTypes [VName]
shapes [TypeBase Shape u]
paramts [SubExp]
args) [SubExp]
args
where ensureArgShape :: Type -> SubExp -> InternaliseM SubExp
ensureArgShape Type
_ (Constant PrimValue
v) = SubExp -> InternaliseM SubExp
forall (m :: * -> *) a. Monad m => a -> m a
return (SubExp -> InternaliseM SubExp) -> SubExp -> InternaliseM SubExp
forall a b. (a -> b) -> a -> b
$ PrimValue -> SubExp
Constant PrimValue
v
ensureArgShape Type
t (Var VName
v)
| Type -> Int
forall shape u. ArrayShape shape => TypeBase shape u -> Int
arrayRank Type
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = SubExp -> InternaliseM SubExp
forall (m :: * -> *) a. Monad m => a -> m a
return (SubExp -> InternaliseM SubExp) -> SubExp -> InternaliseM SubExp
forall a b. (a -> b) -> a -> b
$ VName -> SubExp
Var VName
v
| Bool
otherwise =
ErrorMsg SubExp
-> SrcLoc -> Type -> [Char] -> SubExp -> InternaliseM SubExp
ensureShape ErrorMsg SubExp
msg SrcLoc
loc Type
t (VName -> [Char]
baseString VName
v) (SubExp -> InternaliseM SubExp) -> SubExp -> InternaliseM SubExp
forall a b. (a -> b) -> a -> b
$ VName -> SubExp
Var VName
v
ensureShapeVar :: ErrorMsg SubExp -> SrcLoc -> ExtType -> String -> VName
-> InternaliseM VName
ensureShapeVar :: ErrorMsg SubExp
-> SrcLoc -> ExtType -> [Char] -> VName -> InternaliseM VName
ensureShapeVar ErrorMsg SubExp
msg SrcLoc
loc ExtType
t [Char]
name VName
v
| Array{} <- ExtType
t = do
[SubExp]
newdims <- Type -> [SubExp]
forall u. TypeBase Shape u -> [SubExp]
arrayDims (Type -> [SubExp]) -> (Type -> Type) -> Type -> [SubExp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> Type -> Type
removeExistentials ExtType
t (Type -> [SubExp]) -> InternaliseM Type -> InternaliseM [SubExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> InternaliseM Type
forall lore (m :: * -> *). HasScope lore m => VName -> m Type
lookupType VName
v
[SubExp]
olddims <- Type -> [SubExp]
forall u. TypeBase Shape u -> [SubExp]
arrayDims (Type -> [SubExp]) -> InternaliseM Type -> InternaliseM [SubExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> InternaliseM Type
forall lore (m :: * -> *). HasScope lore m => VName -> m Type
lookupType VName
v
if [SubExp]
newdims [SubExp] -> [SubExp] -> Bool
forall a. Eq a => a -> a -> Bool
== [SubExp]
olddims
then VName -> InternaliseM VName
forall (m :: * -> *) a. Monad m => a -> m a
return VName
v
else do
[SubExp]
matches <- (SubExp -> SubExp -> InternaliseM SubExp)
-> [SubExp] -> [SubExp] -> InternaliseM [SubExp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM SubExp -> SubExp -> InternaliseM SubExp
forall (m :: * -> *). MonadBinder m => SubExp -> SubExp -> m SubExp
checkDim [SubExp]
newdims [SubExp]
olddims
SubExp
all_match <- [Char] -> Exp (Lore InternaliseM) -> InternaliseM SubExp
forall (m :: * -> *).
MonadBinder m =>
[Char] -> Exp (Lore m) -> m SubExp
letSubExp [Char]
"match" (ExpT SOACS -> InternaliseM SubExp)
-> InternaliseM (ExpT SOACS) -> InternaliseM SubExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [SubExp] -> InternaliseM (Exp (Lore InternaliseM))
forall (m :: * -> *). MonadBinder m => [SubExp] -> m (Exp (Lore m))
eAll [SubExp]
matches
Certificates
cs <- [Char]
-> SubExp -> ErrorMsg SubExp -> SrcLoc -> InternaliseM Certificates
assert [Char]
"empty_or_match_cert" SubExp
all_match ErrorMsg SubExp
msg SrcLoc
loc
Certificates -> InternaliseM VName -> InternaliseM VName
forall (m :: * -> *) a. MonadBinder m => Certificates -> m a -> m a
certifying Certificates
cs (InternaliseM VName -> InternaliseM VName)
-> InternaliseM VName -> InternaliseM VName
forall a b. (a -> b) -> a -> b
$ [Char] -> Exp (Lore InternaliseM) -> InternaliseM VName
forall (m :: * -> *).
MonadBinder m =>
[Char] -> Exp (Lore m) -> m VName
letExp [Char]
name (Exp (Lore InternaliseM) -> InternaliseM VName)
-> Exp (Lore InternaliseM) -> InternaliseM VName
forall a b. (a -> b) -> a -> b
$ [SubExp] -> VName -> ExpT SOACS
forall lore. [SubExp] -> VName -> Exp lore
shapeCoerce [SubExp]
newdims VName
v
| Bool
otherwise = VName -> InternaliseM VName
forall (m :: * -> *) a. Monad m => a -> m a
return VName
v
where checkDim :: SubExp -> SubExp -> m SubExp
checkDim SubExp
desired SubExp
has =
[Char] -> Exp (Lore m) -> m SubExp
forall (m :: * -> *).
MonadBinder m =>
[Char] -> Exp (Lore m) -> m SubExp
letSubExp [Char]
"dim_match" (Exp (Lore m) -> m SubExp) -> Exp (Lore m) -> m SubExp
forall a b. (a -> b) -> a -> b
$ BasicOp -> Exp (Lore m)
forall lore. BasicOp -> ExpT lore
BasicOp (BasicOp -> Exp (Lore m)) -> BasicOp -> Exp (Lore m)
forall a b. (a -> b) -> a -> b
$ CmpOp -> SubExp -> SubExp -> BasicOp
CmpOp (PrimType -> CmpOp
CmpEq PrimType
int32) SubExp
desired SubExp
has