{-# LANGUAGE FlexibleContexts #-}

module Futhark.Internalise.AccurateSizes
  ( argShapes,
    ensureResultShape,
    ensureResultExtShape,
    ensureExtShape,
    ensureShape,
    ensureArgShapes,
  )
where

import Control.Monad
import qualified Data.Map.Strict as M
import Data.Maybe
import Futhark.Construct
import Futhark.IR.SOACS
import Futhark.Internalise.Monad
import Futhark.Util (takeLast)

shapeMapping ::
  HasScope SOACS m =>
  [FParam] ->
  [Type] ->
  m (M.Map VName SubExp)
shapeMapping :: [FParam] -> [Type] -> m (Map VName SubExp)
shapeMapping [FParam]
all_params [Type]
value_arg_types =
  [Map VName SubExp] -> Map VName SubExp
forall a. Monoid a => [a] -> a
mconcat ([Map VName SubExp] -> Map VName SubExp)
-> m [Map VName SubExp] -> m (Map VName SubExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param (TypeBase Shape Uniqueness) -> Type -> m (Map VName SubExp))
-> [Param (TypeBase Shape Uniqueness)]
-> [Type]
-> m [Map VName SubExp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Param (TypeBase Shape Uniqueness) -> Type -> m (Map VName SubExp)
forall (f :: * -> *) u u.
Applicative f =>
Param (TypeBase Shape u)
-> TypeBase Shape u -> f (Map VName SubExp)
f [Param (TypeBase Shape Uniqueness)]
value_params [Type]
value_arg_types
  where
    value_params :: [Param (TypeBase Shape Uniqueness)]
value_params = Int
-> [Param (TypeBase Shape Uniqueness)]
-> [Param (TypeBase Shape Uniqueness)]
forall a. Int -> [a] -> [a]
takeLast ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
value_arg_types) [Param (TypeBase Shape Uniqueness)]
[FParam]
all_params

    f :: Param (TypeBase Shape u)
-> TypeBase Shape u -> f (Map VName SubExp)
f (Param VName
_ t1 :: TypeBase Shape u
t1@Array {}) t2 :: TypeBase Shape u
t2@Array {} =
      Map VName SubExp -> f (Map VName SubExp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map VName SubExp -> f (Map VName SubExp))
-> Map VName SubExp -> f (Map VName SubExp)
forall a b. (a -> b) -> a -> b
$ [(VName, SubExp)] -> Map VName SubExp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, SubExp)] -> Map VName SubExp)
-> [(VName, SubExp)] -> Map VName SubExp
forall a b. (a -> b) -> a -> b
$ ((SubExp, SubExp) -> Maybe (VName, SubExp))
-> [(SubExp, SubExp)] -> [(VName, SubExp)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SubExp, SubExp) -> Maybe (VName, SubExp)
forall b. (SubExp, b) -> Maybe (VName, b)
match ([(SubExp, SubExp)] -> [(VName, SubExp)])
-> [(SubExp, SubExp)] -> [(VName, SubExp)]
forall a b. (a -> b) -> a -> b
$ [SubExp] -> [SubExp] -> [(SubExp, SubExp)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TypeBase Shape u -> [SubExp]
forall u. TypeBase Shape u -> [SubExp]
arrayDims TypeBase Shape u
t1) (TypeBase Shape u -> [SubExp]
forall u. TypeBase Shape u -> [SubExp]
arrayDims TypeBase Shape u
t2)
    f Param (TypeBase Shape u)
_ TypeBase Shape u
_ =
      Map VName SubExp -> f (Map VName SubExp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map VName SubExp
forall a. Monoid a => a
mempty

    match :: (SubExp, b) -> Maybe (VName, b)
match (Var VName
v, b
se) = (VName, b) -> Maybe (VName, b)
forall a. a -> Maybe a
Just (VName
v, b
se)
    match (SubExp, b)
_ = Maybe (VName, b)
forall a. Maybe a
Nothing

argShapes ::
  (HasScope SOACS m, Monad m) =>
  [VName] ->
  [FParam] ->
  [Type] ->
  m [SubExp]
argShapes :: [VName] -> [FParam] -> [Type] -> m [SubExp]
argShapes [VName]
shapes [FParam]
all_params [Type]
valargts = do
  Map VName SubExp
mapping <- [FParam] -> [Type] -> m (Map VName SubExp)
forall (m :: * -> *).
HasScope SOACS m =>
[FParam] -> [Type] -> m (Map VName SubExp)
shapeMapping [FParam]
all_params [Type]
valargts
  let addShape :: VName -> SubExp
addShape VName
name =
        case VName -> Map VName SubExp -> Maybe SubExp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
name Map VName SubExp
mapping of
          Just SubExp
se -> SubExp
se
          Maybe SubExp
_ -> IntType -> Integer -> SubExp
intConst IntType
Int64 Integer
0 -- FIXME: we only need this because
          -- the defunctionaliser throws away
          -- sizes.
  [SubExp] -> m [SubExp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SubExp] -> m [SubExp]) -> [SubExp] -> m [SubExp]
forall a b. (a -> b) -> a -> b
$ (VName -> SubExp) -> [VName] -> [SubExp]
forall a b. (a -> b) -> [a] -> [b]
map VName -> SubExp
addShape [VName]
shapes

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
int64) SubExp
desired SubExp
has