{-# 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

-- | Reshape the arguments to a function so that they fit the expected
-- shape declarations.  Not used to change rank of arguments.  Assumes
-- everything is otherwise type-correct.
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