-- | Check that a value definition does not violate any consumption
-- constraints.
module Language.Futhark.TypeChecker.Consumption
  ( checkValDef,
  )
where

import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifoldable
import Data.Bifunctor
import Data.DList qualified as DL
import Data.Foldable
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Set qualified as S
import Futhark.Util.Pretty hiding (space)
import Language.Futhark
import Language.Futhark.Traversals
import Language.Futhark.TypeChecker.Monad (Notes, TypeError (..), withIndexLink)
import Prelude hiding (mod)

type Names = S.Set VName

-- | A variable that is aliased.  Can be still in-scope, or have gone
-- out of scope and be free.  In the latter case, it behaves more like
-- an equivalence class.  See uniqueness-error18.fut for an example of
-- why this is necessary.
data Alias
  = AliasBound {Alias -> VName
aliasVar :: VName}
  | AliasFree {aliasVar :: VName}
  deriving (Alias -> Alias -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alias -> Alias -> Bool
$c/= :: Alias -> Alias -> Bool
== :: Alias -> Alias -> Bool
$c== :: Alias -> Alias -> Bool
Eq, Eq Alias
Alias -> Alias -> Bool
Alias -> Alias -> Ordering
Alias -> Alias -> Alias
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Alias -> Alias -> Alias
$cmin :: Alias -> Alias -> Alias
max :: Alias -> Alias -> Alias
$cmax :: Alias -> Alias -> Alias
>= :: Alias -> Alias -> Bool
$c>= :: Alias -> Alias -> Bool
> :: Alias -> Alias -> Bool
$c> :: Alias -> Alias -> Bool
<= :: Alias -> Alias -> Bool
$c<= :: Alias -> Alias -> Bool
< :: Alias -> Alias -> Bool
$c< :: Alias -> Alias -> Bool
compare :: Alias -> Alias -> Ordering
$ccompare :: Alias -> Alias -> Ordering
Ord, Int -> Alias -> ShowS
[Alias] -> ShowS
Alias -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alias] -> ShowS
$cshowList :: [Alias] -> ShowS
show :: Alias -> String
$cshow :: Alias -> String
showsPrec :: Int -> Alias -> ShowS
$cshowsPrec :: Int -> Alias -> ShowS
Show)

instance Pretty Alias where
  pretty :: forall ann. Alias -> Doc ann
pretty (AliasBound VName
v) = forall v a. IsName v => v -> Doc a
prettyName VName
v
  pretty (AliasFree VName
v) = Doc ann
"~" forall a. Semigroup a => a -> a -> a
<> forall v a. IsName v => v -> Doc a
prettyName VName
v

instance Pretty (S.Set Alias) where
  pretty :: forall ann. Set Alias -> Doc ann
pretty = forall ann. Doc ann -> Doc ann
braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
commasep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList

-- | The set of in-scope variables that are being aliased.
boundAliases :: Aliases -> S.Set VName
boundAliases :: Set Alias -> Names
boundAliases = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> VName
aliasVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Set a -> Set a
S.filter Alias -> Bool
bound
  where
    bound :: Alias -> Bool
bound AliasBound {} = Bool
True
    bound AliasFree {} = Bool
False

-- | Aliases for a type, which is a set of the variables that are
-- aliased.
type Aliases = S.Set Alias

type TypeAliases = TypeBase Size Aliases

-- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for
-- any already present aliases.
setAliases :: TypeBase dim asf -> ast -> TypeBase dim ast
setAliases :: forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
setAliases TypeBase dim asf
t = forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
addAliases TypeBase dim asf
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | @t \`addAliases\` f@ returns @t@, but with any already present
-- aliases replaced by @f@ applied to that aliases.
addAliases ::
  TypeBase dim asf ->
  (asf -> ast) ->
  TypeBase dim ast
addAliases :: forall dim asf ast.
TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast
addAliases = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second

aliases :: TypeAliases -> Aliases
aliases :: TypeAliases -> Set Alias
aliases = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a. a -> a
id

setFieldAliases :: TypeAliases -> [Name] -> TypeAliases -> TypeAliases
setFieldAliases :: TypeAliases -> [Name] -> TypeAliases -> TypeAliases
setFieldAliases TypeAliases
ve_als (Name
x : [Name]
xs) (Scalar (Record Map Name TypeAliases
fs)) =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (TypeAliases -> [Name] -> TypeAliases -> TypeAliases
setFieldAliases TypeAliases
ve_als [Name]
xs) Name
x Map Name TypeAliases
fs
setFieldAliases TypeAliases
ve_als [Name]
_ TypeAliases
_ = TypeAliases
ve_als

data Entry a
  = Consumable {forall a. Entry a -> a
entryAliases :: a}
  | Nonconsumable {entryAliases :: a}
  deriving (Entry a -> Entry a -> Bool
forall a. Eq a => Entry a -> Entry a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entry a -> Entry a -> Bool
$c/= :: forall a. Eq a => Entry a -> Entry a -> Bool
== :: Entry a -> Entry a -> Bool
$c== :: forall a. Eq a => Entry a -> Entry a -> Bool
Eq, Entry a -> Entry a -> Bool
Entry a -> Entry a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Entry a)
forall a. Ord a => Entry a -> Entry a -> Bool
forall a. Ord a => Entry a -> Entry a -> Ordering
forall a. Ord a => Entry a -> Entry a -> Entry a
min :: Entry a -> Entry a -> Entry a
$cmin :: forall a. Ord a => Entry a -> Entry a -> Entry a
max :: Entry a -> Entry a -> Entry a
$cmax :: forall a. Ord a => Entry a -> Entry a -> Entry a
>= :: Entry a -> Entry a -> Bool
$c>= :: forall a. Ord a => Entry a -> Entry a -> Bool
> :: Entry a -> Entry a -> Bool
$c> :: forall a. Ord a => Entry a -> Entry a -> Bool
<= :: Entry a -> Entry a -> Bool
$c<= :: forall a. Ord a => Entry a -> Entry a -> Bool
< :: Entry a -> Entry a -> Bool
$c< :: forall a. Ord a => Entry a -> Entry a -> Bool
compare :: Entry a -> Entry a -> Ordering
$ccompare :: forall a. Ord a => Entry a -> Entry a -> Ordering
Ord, Int -> Entry a -> ShowS
forall a. Show a => Int -> Entry a -> ShowS
forall a. Show a => [Entry a] -> ShowS
forall a. Show a => Entry a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entry a] -> ShowS
$cshowList :: forall a. Show a => [Entry a] -> ShowS
show :: Entry a -> String
$cshow :: forall a. Show a => Entry a -> String
showsPrec :: Int -> Entry a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Entry a -> ShowS
Show)

instance Functor Entry where
  fmap :: forall a b. (a -> b) -> Entry a -> Entry b
fmap a -> b
f (Consumable a
als) = forall a. a -> Entry a
Consumable forall a b. (a -> b) -> a -> b
$ a -> b
f a
als
  fmap a -> b
f (Nonconsumable a
als) = forall a. a -> Entry a
Nonconsumable forall a b. (a -> b) -> a -> b
$ a -> b
f a
als

data CheckEnv = CheckEnv
  { CheckEnv -> Map VName (Entry TypeAliases)
envVtable :: M.Map VName (Entry TypeAliases),
    -- | Location of the definition we are checking.
    CheckEnv -> Loc
envLoc :: Loc
  }

-- | A description of where an artificial compiler-generated
-- intermediate name came from.
data NameReason
  = -- | Name is the result of a function application.
    NameAppRes (Maybe (QualName VName)) SrcLoc
  | NameLoopRes SrcLoc

nameReason :: SrcLoc -> NameReason -> Doc a
nameReason :: forall a. SrcLoc -> NameReason -> Doc a
nameReason SrcLoc
loc (NameAppRes Maybe (QualName VName)
Nothing SrcLoc
apploc) =
  Doc a
"result of application at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (Located a, Located b) => a -> b -> String
locStrRel SrcLoc
loc SrcLoc
apploc)
nameReason SrcLoc
loc (NameAppRes Maybe (QualName VName)
fname SrcLoc
apploc) =
  Doc a
"result of applying"
    forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Maybe (QualName VName)
fname)
    forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
parens (Doc a
"at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (Located a, Located b) => a -> b -> String
locStrRel SrcLoc
loc SrcLoc
apploc))
nameReason SrcLoc
loc (NameLoopRes SrcLoc
apploc) =
  Doc a
"result of loop at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (Located a, Located b) => a -> b -> String
locStrRel SrcLoc
loc SrcLoc
apploc)

type Consumed = M.Map VName Loc

data CheckState = CheckState
  { CheckState -> Consumed
stateConsumed :: Consumed,
    CheckState -> DList TypeError
stateErrors :: DL.DList TypeError,
    CheckState -> Map VName NameReason
stateNames :: M.Map VName NameReason,
    CheckState -> Int
stateCounter :: Int
  }

newtype CheckM a = CheckM (ReaderT CheckEnv (State CheckState) a)
  deriving
    ( forall a b. a -> CheckM b -> CheckM a
forall a b. (a -> b) -> CheckM a -> CheckM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CheckM b -> CheckM a
$c<$ :: forall a b. a -> CheckM b -> CheckM a
fmap :: forall a b. (a -> b) -> CheckM a -> CheckM b
$cfmap :: forall a b. (a -> b) -> CheckM a -> CheckM b
Functor,
      Functor CheckM
forall a. a -> CheckM a
forall a b. CheckM a -> CheckM b -> CheckM a
forall a b. CheckM a -> CheckM b -> CheckM b
forall a b. CheckM (a -> b) -> CheckM a -> CheckM b
forall a b c. (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. CheckM a -> CheckM b -> CheckM a
$c<* :: forall a b. CheckM a -> CheckM b -> CheckM a
*> :: forall a b. CheckM a -> CheckM b -> CheckM b
$c*> :: forall a b. CheckM a -> CheckM b -> CheckM b
liftA2 :: forall a b c. (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
$cliftA2 :: forall a b c. (a -> b -> c) -> CheckM a -> CheckM b -> CheckM c
<*> :: forall a b. CheckM (a -> b) -> CheckM a -> CheckM b
$c<*> :: forall a b. CheckM (a -> b) -> CheckM a -> CheckM b
pure :: forall a. a -> CheckM a
$cpure :: forall a. a -> CheckM a
Applicative,
      Applicative CheckM
forall a. a -> CheckM a
forall a b. CheckM a -> CheckM b -> CheckM b
forall a b. CheckM a -> (a -> CheckM b) -> CheckM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CheckM a
$creturn :: forall a. a -> CheckM a
>> :: forall a b. CheckM a -> CheckM b -> CheckM b
$c>> :: forall a b. CheckM a -> CheckM b -> CheckM b
>>= :: forall a b. CheckM a -> (a -> CheckM b) -> CheckM b
$c>>= :: forall a b. CheckM a -> (a -> CheckM b) -> CheckM b
Monad,
      MonadReader CheckEnv,
      MonadState CheckState
    )

runCheckM :: Loc -> CheckM a -> (a, [TypeError])
runCheckM :: forall a. Loc -> CheckM a -> (a, [TypeError])
runCheckM Loc
loc (CheckM ReaderT CheckEnv (State CheckState) a
m) =
  let (a
a, CheckState
s) = forall s a. State s a -> s -> (a, s)
runState (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT CheckEnv (State CheckState) a
m CheckEnv
env) CheckState
initial_state
   in (a
a, forall a. DList a -> [a]
DL.toList (CheckState -> DList TypeError
stateErrors CheckState
s))
  where
    env :: CheckEnv
env =
      CheckEnv
        { envVtable :: Map VName (Entry TypeAliases)
envVtable = forall a. Monoid a => a
mempty,
          envLoc :: Loc
envLoc = Loc
loc
        }
    initial_state :: CheckState
initial_state =
      CheckState
        { stateConsumed :: Consumed
stateConsumed = forall a. Monoid a => a
mempty,
          stateErrors :: DList TypeError
stateErrors = forall a. Monoid a => a
mempty,
          stateNames :: Map VName NameReason
stateNames = forall a. Monoid a => a
mempty,
          stateCounter :: Int
stateCounter = Int
0
        }

describeVar :: VName -> CheckM (Doc a)
describeVar :: forall a. VName -> CheckM (Doc a)
describeVar VName
v = do
  Loc
loc <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CheckEnv -> Loc
envLoc
  forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc a
"variable" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName VName
v)) (forall a. SrcLoc -> NameReason -> Doc a
nameReason (forall a. Located a => a -> SrcLoc
srclocOf Loc
loc))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Map VName NameReason
stateNames

noConsumable :: CheckM a -> CheckM a
noConsumable :: forall a. CheckM a -> CheckM a
noConsumable = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \CheckEnv
env -> CheckEnv
env {envVtable :: Map VName (Entry TypeAliases)
envVtable = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall {b}. Entry b -> Entry b
f forall a b. (a -> b) -> a -> b
$ CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env}
  where
    f :: Entry b -> Entry b
f = forall a. a -> Entry a
Nonconsumable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Entry a -> a
entryAliases

addError :: Located loc => loc -> Notes -> Doc () -> CheckM ()
addError :: forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError loc
loc Notes
notes Doc ()
e = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
s ->
  CheckState
s {stateErrors :: DList TypeError
stateErrors = forall a. DList a -> a -> DList a
DL.snoc (CheckState -> DList TypeError
stateErrors CheckState
s) (Loc -> Notes -> Doc () -> TypeError
TypeError (forall a. Located a => a -> Loc
locOf loc
loc) Notes
notes Doc ()
e)}

incCounter :: CheckM Int
incCounter :: CheckM Int
incCounter =
  forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \CheckState
s -> (CheckState -> Int
stateCounter CheckState
s, CheckState
s {stateCounter :: Int
stateCounter = CheckState -> Int
stateCounter CheckState
s forall a. Num a => a -> a -> a
+ Int
1})

returnAliased :: Name -> SrcLoc -> CheckM ()
returnAliased :: Name -> SrcLoc -> CheckM ()
returnAliased Name
name SrcLoc
loc =
  forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError SrcLoc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"return-aliased" forall a b. (a -> b) -> a -> b
$
    Doc ()
"Unique-typed return value is aliased to"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName Name
name) forall a. Semigroup a => a -> a -> a
<> Doc ()
", which is not consumable."

uniqueReturnAliased :: SrcLoc -> CheckM ()
uniqueReturnAliased :: SrcLoc -> CheckM ()
uniqueReturnAliased SrcLoc
loc =
  forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError SrcLoc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"unique-return-aliased" forall a b. (a -> b) -> a -> b
$
    Doc ()
"A unique-typed component of the return value is aliased to some other component."

checkReturnAlias :: SrcLoc -> [Pat ParamType] -> ResType -> TypeAliases -> CheckM ()
checkReturnAlias :: SrcLoc
-> [Pat (TypeBase Size Diet)]
-> ResType
-> TypeAliases
-> CheckM ()
checkReturnAlias SrcLoc
loc [Pat (TypeBase Size Diet)]
params ResType
rettp =
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (forall {t :: * -> *} {dim}.
Foldable t =>
t (Pat (TypeBase dim Diet))
-> Set (Uniqueness, VName)
-> (Uniqueness, Names)
-> CheckM (Set (Uniqueness, VName))
checkReturnAlias' [Pat (TypeBase Size Diet)]
params) forall a. Set a
S.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {shape}.
TypeBase shape Uniqueness -> TypeAliases -> [(Uniqueness, Names)]
returnAliases ResType
rettp
  where
    checkReturnAlias' :: t (Pat (TypeBase dim Diet))
-> Set (Uniqueness, VName)
-> (Uniqueness, Names)
-> CheckM (Set (Uniqueness, VName))
checkReturnAlias' t (Pat (TypeBase dim Diet))
params' Set (Uniqueness, VName)
seen (Uniqueness
Unique, Names
names) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`S.member` forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall a b. (a, b) -> b
snd Set (Uniqueness, VName)
seen) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Names
names) forall a b. (a -> b) -> a -> b
$
        SrcLoc -> CheckM ()
uniqueReturnAliased SrcLoc
loc
      forall {t :: * -> *} {dim}.
Foldable t =>
t (Pat (TypeBase dim Diet)) -> Names -> CheckM ()
notAliasesParam t (Pat (TypeBase dim Diet))
params' Names
names
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set (Uniqueness, VName)
seen forall a. Ord a => Set a -> Set a -> Set a
`S.union` forall {t} {a}. (Ord t, Ord a) => t -> Set a -> Set (t, a)
tag Uniqueness
Unique Names
names
    checkReturnAlias' t (Pat (TypeBase dim Diet))
_ Set (Uniqueness, VName)
seen (Uniqueness
Nonunique, Names
names) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Uniqueness, VName)
seen) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall {t} {a}. (Ord t, Ord a) => t -> Set a -> Set (t, a)
tag Uniqueness
Unique Names
names) forall a b. (a -> b) -> a -> b
$
        SrcLoc -> CheckM ()
uniqueReturnAliased SrcLoc
loc
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set (Uniqueness, VName)
seen forall a. Ord a => Set a -> Set a -> Set a
`S.union` forall {t} {a}. (Ord t, Ord a) => t -> Set a -> Set (t, a)
tag Uniqueness
Nonunique Names
names

    notAliasesParam :: t (Pat (TypeBase dim Diet)) -> Names -> CheckM ()
notAliasesParam t (Pat (TypeBase dim Diet))
params' Names
names =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (Pat (TypeBase dim Diet))
params' forall a b. (a -> b) -> a -> b
$ \Pat (TypeBase dim Diet)
p ->
        let consumedNonunique :: (VName, TypeBase dim Diet) -> Bool
consumedNonunique (VName
v, TypeBase dim Diet
t) =
              Bool -> Bool
not (forall {dim}. TypeBase dim Diet -> Bool
consumableParamType TypeBase dim Diet
t) Bool -> Bool -> Bool
&& (VName
v forall a. Ord a => a -> Set a -> Bool
`S.member` Names
names)
         in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {dim}. (VName, TypeBase dim Diet) -> Bool
consumedNonunique forall a b. (a -> b) -> a -> b
$ forall t. Pat t -> [(VName, t)]
patternMap Pat (TypeBase dim Diet)
p of
              Just (VName
v, TypeBase dim Diet
_) ->
                Name -> SrcLoc -> CheckM ()
returnAliased (VName -> Name
baseName VName
v) SrcLoc
loc
              Maybe (VName, TypeBase dim Diet)
Nothing ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    tag :: t -> Set a -> Set (t, a)
tag t
u = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (t
u,)

    returnAliases :: TypeBase shape Uniqueness -> TypeAliases -> [(Uniqueness, Names)]
returnAliases (Scalar (Record Map Name (TypeBase shape Uniqueness)
ets1)) (Scalar (Record Map Name TypeAliases
ets2)) =
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase shape Uniqueness -> TypeAliases -> [(Uniqueness, Names)]
returnAliases Map Name (TypeBase shape Uniqueness)
ets1 Map Name TypeAliases
ets2
    returnAliases TypeBase shape Uniqueness
expected TypeAliases
got =
      [(forall shape. TypeBase shape Uniqueness -> Uniqueness
uniqueness TypeBase shape Uniqueness
expected, forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> VName
aliasVar forall a b. (a -> b) -> a -> b
$ TypeAliases -> Set Alias
aliases TypeAliases
got)]

    consumableParamType :: TypeBase dim Diet -> Bool
consumableParamType (Array Diet
u Shape dim
_ ScalarTypeBase dim NoUniqueness
_) = Diet
u forall a. Eq a => a -> a -> Bool
== Diet
Consume
    consumableParamType (Scalar Prim {}) = Bool
True
    consumableParamType (Scalar (TypeVar Diet
u QualName VName
_ [TypeArg dim]
_)) = Diet
u forall a. Eq a => a -> a -> Bool
== Diet
Consume
    consumableParamType (Scalar (Record Map Name (TypeBase dim Diet)
fs)) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TypeBase dim Diet -> Bool
consumableParamType Map Name (TypeBase dim Diet)
fs
    consumableParamType (Scalar (Sum Map Name [TypeBase dim Diet]
fs)) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TypeBase dim Diet -> Bool
consumableParamType) Map Name [TypeBase dim Diet]
fs
    consumableParamType (Scalar Arrow {}) = Bool
False

unscope :: [VName] -> Aliases -> Aliases
unscope :: [VName] -> Set Alias -> Set Alias
unscope [VName]
bound = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> Alias
f
  where
    f :: Alias -> Alias
f (AliasFree VName
v) = VName -> Alias
AliasFree VName
v
    f (AliasBound VName
v) = if VName
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
bound then VName -> Alias
AliasFree VName
v else VName -> Alias
AliasBound VName
v

-- | Figure out the aliases of each bound name in a pattern.
matchPat :: Pat t -> TypeAliases -> DL.DList (VName, (t, TypeAliases))
matchPat :: forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat (PatParens PatBase Info VName t
p SrcLoc
_) TypeAliases
t = forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat PatBase Info VName t
p TypeAliases
t
matchPat (TuplePat [PatBase Info VName t]
ps SrcLoc
_) TypeAliases
t
  | Just [TypeAliases]
ts <- forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
isTupleRecord TypeAliases
t = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat [PatBase Info VName t]
ps [TypeAliases]
ts
matchPat (RecordPat [(Name, PatBase Info VName t)]
fs1 SrcLoc
_) (Scalar (Record Map Name TypeAliases
fs2)) =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
      forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat
      (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall a. Map Name a -> [(Name, a)]
sortFields (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, PatBase Info VName t)]
fs1)))
      (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall a. Map Name a -> [(Name, a)]
sortFields Map Name TypeAliases
fs2))
matchPat (Id VName
v (Info t
t) SrcLoc
_) TypeAliases
als = forall a. a -> DList a
DL.singleton (VName
v, (t
t, TypeAliases
als))
matchPat (PatAscription PatBase Info VName t
p TypeExp Info VName
_ SrcLoc
_) TypeAliases
t = forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat PatBase Info VName t
p TypeAliases
t
matchPat (PatConstr Name
v Info t
_ [PatBase Info VName t]
ps SrcLoc
_) (Scalar (Sum Map Name [TypeAliases]
cs))
  | Just [TypeAliases]
ts <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
v Map Name [TypeAliases]
cs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat [PatBase Info VName t]
ps [TypeAliases]
ts
matchPat TuplePat {} TypeAliases
_ = forall a. Monoid a => a
mempty
matchPat RecordPat {} TypeAliases
_ = forall a. Monoid a => a
mempty
matchPat PatConstr {} TypeAliases
_ = forall a. Monoid a => a
mempty
matchPat Wildcard {} TypeAliases
_ = forall a. Monoid a => a
mempty
matchPat PatLit {} TypeAliases
_ = forall a. Monoid a => a
mempty
matchPat (PatAttr AttrInfo VName
_ PatBase Info VName t
p SrcLoc
_) TypeAliases
t = forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat PatBase Info VName t
p TypeAliases
t

bindingPat ::
  Pat StructType ->
  TypeAliases ->
  CheckM (a, TypeAliases) ->
  CheckM (a, TypeAliases)
bindingPat :: forall a.
Pat StructType
-> TypeAliases
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingPat Pat StructType
p TypeAliases
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([VName] -> Set Alias -> Set Alias
unscope (forall t. Pat t -> [VName]
patNames Pat StructType
p)))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CheckEnv -> CheckEnv
bind
  where
    bind :: CheckEnv -> CheckEnv
bind CheckEnv
env =
      CheckEnv
env
        { envVtable :: Map VName (Entry TypeAliases)
envVtable =
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {p :: * -> * -> *} {a} {a}.
Bifunctor p =>
(VName, (a, p a (Set Alias))) -> (VName, Entry (p a (Set Alias)))
f (forall t. Pat t -> TypeAliases -> DList (VName, (t, TypeAliases))
matchPat Pat StructType
p TypeAliases
t))
        }
      where
        f :: (VName, (a, p a (Set Alias))) -> (VName, Entry (p a (Set Alias)))
f (VName
v, (a
_, p a (Set Alias)
als)) = (VName
v, forall a. a -> Entry a
Consumable forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Ord a => a -> Set a -> Set a
S.insert (VName -> Alias
AliasBound VName
v)) p a (Set Alias)
als)

bindingParam :: Pat ParamType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParam :: forall a.
Pat (TypeBase Size Diet)
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParam Pat (TypeBase Size Diet)
p CheckM (a, TypeAliases)
m = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. CheckM a -> CheckM a
noConsumable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_ Size -> CheckM (Size, TypeAliases)
checkExp forall (f :: * -> *) a. Applicative f => a -> f a
pure) Pat (TypeBase Size Diet)
p
  forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([VName] -> Set Alias -> Set Alias
unscope (forall t. Pat t -> [VName]
patNames Pat (TypeBase Size Diet)
p))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CheckEnv -> CheckEnv
bind CheckM (a, TypeAliases)
m
  where
    bind :: CheckEnv -> CheckEnv
bind CheckEnv
env =
      CheckEnv
env
        { envVtable :: Map VName (Entry TypeAliases)
envVtable =
            forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {dim}.
(VName, TypeBase dim Diet)
-> (VName, Entry (TypeBase dim (Set Alias)))
f (forall t. Pat t -> [(VName, t)]
patternMap Pat (TypeBase Size Diet)
p))
        }
    f :: (VName, TypeBase dim Diet)
-> (VName, Entry (TypeBase dim (Set Alias)))
f (VName
v, TypeBase dim Diet
t)
      | forall shape. TypeBase shape Diet -> Diet
diet TypeBase dim Diet
t forall a. Eq a => a -> a -> Bool
== Diet
Consume = (VName
v, forall a. a -> Entry a
Consumable forall a b. (a -> b) -> a -> b
$ TypeBase dim Diet
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. a -> Set a
S.singleton (VName -> Alias
AliasBound VName
v))
      | Bool
otherwise = (VName
v, forall a. a -> Entry a
Nonconsumable forall a b. (a -> b) -> a -> b
$ TypeBase dim Diet
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. a -> Set a
S.singleton (VName -> Alias
AliasBound VName
v))

bindingIdent :: Diet -> Ident StructType -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingIdent :: forall a.
Diet
-> IdentBase Info VName StructType
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingIdent Diet
d (Ident VName
v (Info StructType
t) SrcLoc
_) =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([VName] -> Set Alias -> Set Alias
unscope [VName
v]))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CheckEnv -> CheckEnv
bind
  where
    bind :: CheckEnv -> CheckEnv
bind CheckEnv
env = CheckEnv
env {envVtable :: Map VName (Entry TypeAliases)
envVtable = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v Entry TypeAliases
t' (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env)}
    d' :: a -> Entry a
d' = case Diet
d of
      Diet
Consume -> forall a. a -> Entry a
Consumable
      Diet
Observe -> forall a. a -> Entry a
Nonconsumable
    t' :: Entry TypeAliases
t' = forall a. a -> Entry a
d' forall a b. (a -> b) -> a -> b
$ StructType
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. a -> Set a
S.singleton (VName -> Alias
AliasBound VName
v)

bindingParams :: [Pat ParamType] -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParams :: forall a.
[Pat (TypeBase Size Diet)]
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParams [Pat (TypeBase Size Diet)]
params CheckM (a, TypeAliases)
m =
  forall a. CheckM a -> CheckM a
noConsumable forall a b. (a -> b) -> a -> b
$
    forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([VName] -> Set Alias -> Set Alias
unscope (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall t. Pat t -> [VName]
patNames [Pat (TypeBase Size Diet)]
params)))
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a.
Pat (TypeBase Size Diet)
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParam CheckM (a, TypeAliases)
m [Pat (TypeBase Size Diet)]
params

bindingLoopForm :: LoopFormBase Info VName -> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingLoopForm :: forall a.
LoopFormBase Info VName
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingLoopForm (For IdentBase Info VName StructType
ident Size
_) CheckM (a, TypeAliases)
m = forall a.
Diet
-> IdentBase Info VName StructType
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingIdent Diet
Observe IdentBase Info VName StructType
ident CheckM (a, TypeAliases)
m
bindingLoopForm (ForIn Pat StructType
pat Size
_) CheckM (a, TypeAliases)
m = forall a.
Pat (TypeBase Size Diet)
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParam Pat (TypeBase Size Diet)
pat' CheckM (a, TypeAliases)
m
  where
    pat' :: Pat (TypeBase Size Diet)
pat' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const Diet
Observe)) Pat StructType
pat
bindingLoopForm While {} CheckM (a, TypeAliases)
m = CheckM (a, TypeAliases)
m

bindingFun :: VName -> TypeAliases -> CheckM a -> CheckM a
bindingFun :: forall a. VName -> TypeAliases -> CheckM a -> CheckM a
bindingFun VName
v TypeAliases
t = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \CheckEnv
env ->
  CheckEnv
env {envVtable :: Map VName (Entry TypeAliases)
envVtable = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v (forall a. a -> Entry a
Nonconsumable TypeAliases
t) (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env)}

checkIfConsumed :: Loc -> Aliases -> CheckM ()
checkIfConsumed :: Loc -> Set Alias -> CheckM ()
checkIfConsumed Loc
rloc Set Alias
als = do
  Consumed
cons <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CheckState -> Consumed
stateConsumed
  let bad :: VName -> Maybe (VName, Loc)
bad VName
v = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VName
v,) forall a b. (a -> b) -> a -> b
$ VName
v forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Consumed
cons
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (VName -> Maybe (VName, Loc)
bad forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Alias
als) forall a b. (a -> b) -> a -> b
$ \(VName
v, Loc
wloc) -> do
    Doc ()
v' <- forall a. VName -> CheckM (Doc a)
describeVar VName
v
    forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
rloc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"use-after-consume" forall a b. (a -> b) -> a -> b
$
      Doc ()
"Using"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
v' forall a. Semigroup a => a -> a -> a
<> Doc ()
", but this was consumed at"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. (Located a, Located b) => a -> b -> String
locStrRel Loc
rloc Loc
wloc) forall a. Semigroup a => a -> a -> a
<> Doc ()
".  (Possibly through aliases.)"

consumed :: Consumed -> CheckM ()
consumed :: Consumed -> CheckM ()
consumed Consumed
vs = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
s -> CheckState
s {stateConsumed :: Consumed
stateConsumed = CheckState -> Consumed
stateConsumed CheckState
s forall a. Semigroup a => a -> a -> a
<> Consumed
vs}

consumeAliases :: Loc -> Aliases -> CheckM ()
consumeAliases :: Loc -> Set Alias -> CheckM ()
consumeAliases Loc
loc Set Alias
als = do
  Map VName (Entry TypeAliases)
vtable <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CheckEnv -> Map VName (Entry TypeAliases)
envVtable
  let isBad :: VName -> Bool
isBad VName
v =
        case VName
v forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map VName (Entry TypeAliases)
vtable of
          Just (Nonconsumable {}) -> Bool
True
          Just Entry TypeAliases
_ -> Bool
False
          Maybe (Entry TypeAliases)
Nothing -> Bool
True
      checkIfConsumable :: Alias -> CheckM ()
checkIfConsumable (AliasBound VName
v)
        | VName -> Bool
isBad VName
v = do
            Doc ()
v' <- forall a. VName -> CheckM (Doc a)
describeVar VName
v
            forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"not-consumable" forall a b. (a -> b) -> a -> b
$
              Doc ()
"Consuming" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
v' forall a. Semigroup a => a -> a -> a
<> Doc ()
", which is not consumable."
      checkIfConsumable Alias
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alias -> CheckM ()
checkIfConsumable forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Alias
als
  Loc -> Set Alias -> CheckM ()
checkIfConsumed Loc
loc Set Alias
als
  Consumed -> CheckM ()
consumed Consumed
als'
  where
    als' :: Consumed
als' = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((,Loc
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Alias
als

consume :: Loc -> VName -> StructType -> CheckM ()
consume :: Loc -> VName -> StructType -> CheckM ()
consume Loc
loc VName
v StructType
t =
  Loc -> Set Alias -> CheckM ()
consumeAliases Loc
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeAliases -> Set Alias
aliases forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Loc -> VName -> StructType -> CheckM TypeAliases
observeVar Loc
loc VName
v StructType
t

-- | Observe the given name here and return its aliases.
observeVar :: Loc -> VName -> StructType -> CheckM TypeAliases
observeVar :: Loc -> VName -> StructType -> CheckM TypeAliases
observeVar Loc
loc VName
v StructType
t = do
  TypeAliases
als <-
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ \CheckEnv
env ->
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {a}. Map VName a -> TypeAliases
isGlobal (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env)) forall a. Entry a -> a
isLocal forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v (CheckEnv -> Map VName (Entry TypeAliases)
envVtable CheckEnv
env)
  Loc -> Set Alias -> CheckM ()
checkIfConsumed Loc
loc (TypeAliases -> Set Alias
aliases TypeAliases
als)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeAliases
als
  where
    isLocal :: Entry a -> a
isLocal = forall a. Entry a -> a
entryAliases

    -- Handling globals is tricky.  For arrays and such, we do want to
    -- track their aliases.  We do not want to track the aliases of
    -- functions.  However, array bindings that are *polymorphic*
    -- should be treated like functions.  However, we do not have
    -- access to the original binding information here.  To avoid
    -- having to plumb that all the way here, we infer that an array
    -- binding is a polymorphic instantiation if its size contains any
    -- locally bound names.
    isGlobal :: Map VName a -> TypeAliases
isGlobal Map VName a
vtable
      | forall {a} {u}. Map VName a -> TypeBase Size u -> Bool
isInstantiation Map VName a
vtable StructType
t = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) StructType
t
      | Bool
otherwise = forall {dim}. TypeBase dim (Set Alias) -> TypeBase dim (Set Alias)
selfAlias forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) StructType
t

    isInstantiation :: Map VName a -> TypeBase Size u -> Bool
isInstantiation Map VName a
vtable =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map VName a
vtable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FV -> Names
fvVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall u. TypeBase Size u -> FV
freeInType

    selfAlias :: TypeBase dim (Set Alias) -> TypeBase dim (Set Alias)
selfAlias (Array Set Alias
als Shape dim
shape ScalarTypeBase dim NoUniqueness
et) = forall dim u.
u -> Shape dim -> ScalarTypeBase dim NoUniqueness -> TypeBase dim u
Array (forall a. Ord a => a -> Set a -> Set a
S.insert (VName -> Alias
AliasBound VName
v) Set Alias
als) Shape dim
shape ScalarTypeBase dim NoUniqueness
et
    selfAlias (Scalar ScalarTypeBase dim (Set Alias)
st) = forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ ScalarTypeBase dim (Set Alias) -> ScalarTypeBase dim (Set Alias)
selfAlias' ScalarTypeBase dim (Set Alias)
st
    selfAlias' :: ScalarTypeBase dim (Set Alias) -> ScalarTypeBase dim (Set Alias)
selfAlias' (TypeVar Set Alias
als QualName VName
tn [TypeArg dim]
args) = forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar Set Alias
als QualName VName
tn [TypeArg dim]
args -- #1675 FIXME
    selfAlias' (Record Map Name (TypeBase dim (Set Alias))
fs) = forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeBase dim (Set Alias) -> TypeBase dim (Set Alias)
selfAlias Map Name (TypeBase dim (Set Alias))
fs
    selfAlias' (Sum Map Name [TypeBase dim (Set Alias)]
fs) = forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map TypeBase dim (Set Alias) -> TypeBase dim (Set Alias)
selfAlias) Map Name [TypeBase dim (Set Alias)]
fs
    selfAlias' et :: ScalarTypeBase dim (Set Alias)
et@Arrow {} = ScalarTypeBase dim (Set Alias)
et
    selfAlias' et :: ScalarTypeBase dim (Set Alias)
et@Prim {} = ScalarTypeBase dim (Set Alias)
et

-- Capture any newly consumed variables that occur during the provided action.
contain :: CheckM a -> CheckM (a, Consumed)
contain :: forall a. CheckM a -> CheckM (a, Consumed)
contain CheckM a
m = do
  Consumed
prev_cons <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CheckState -> Consumed
stateConsumed
  a
x <- CheckM a
m
  Consumed
new_cons <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ (forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Consumed
prev_cons) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Consumed
stateConsumed
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
s -> CheckState
s {stateConsumed :: Consumed
stateConsumed = Consumed
prev_cons}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, Consumed
new_cons)

-- | The two types are assumed to be approximately structurally equal,
-- but not necessarily regarding sizes.  Combines aliases and prefers
-- other information from first argument.
combineAliases :: TypeAliases -> TypeAliases -> TypeAliases
combineAliases :: TypeAliases -> TypeAliases -> TypeAliases
combineAliases (Array Set Alias
als1 Shape Size
et1 ScalarTypeBase Size NoUniqueness
shape1) TypeAliases
t2 =
  forall dim u.
u -> Shape dim -> ScalarTypeBase dim NoUniqueness -> TypeBase dim u
Array (Set Alias
als1 forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
t2) Shape Size
et1 ScalarTypeBase Size NoUniqueness
shape1
combineAliases (Scalar (TypeVar Set Alias
als1 QualName VName
tv1 [TypeArg Size]
targs1)) TypeAliases
t2 =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar (Set Alias
als1 forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
t2) QualName VName
tv1 [TypeArg Size]
targs1
combineAliases (Scalar (Record Map Name TypeAliases
ts1)) (Scalar (Record Map Name TypeAliases
ts2))
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length Map Name TypeAliases
ts1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length Map Name TypeAliases
ts2,
    forall a. Ord a => [a] -> [a]
L.sort (forall k a. Map k a -> [k]
M.keys Map Name TypeAliases
ts1) forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
L.sort (forall k a. Map k a -> [k]
M.keys Map Name TypeAliases
ts2) =
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeAliases -> TypeAliases -> TypeAliases
combineAliases Map Name TypeAliases
ts1 Map Name TypeAliases
ts2
combineAliases
  (Scalar (Arrow Set Alias
als1 PName
mn1 Diet
d1 StructType
pt1 (RetType [VName]
dims1 ResType
rt1)))
  (Scalar (Arrow Set Alias
als2 PName
_ Diet
_ StructType
_ (RetType [VName]
_ ResType
_))) =
    forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar (forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow (Set Alias
als1 forall a. Semigroup a => a -> a -> a
<> Set Alias
als2) PName
mn1 Diet
d1 StructType
pt1 (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims1 ResType
rt1))
combineAliases (Scalar (Sum Map Name [TypeAliases]
cs1)) (Scalar (Sum Map Name [TypeAliases]
cs2))
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length Map Name [TypeAliases]
cs1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length Map Name [TypeAliases]
cs2,
    forall a. Ord a => [a] -> [a]
L.sort (forall k a. Map k a -> [k]
M.keys Map Name [TypeAliases]
cs1) forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
L.sort (forall k a. Map k a -> [k]
M.keys Map Name [TypeAliases]
cs2) =
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeAliases -> TypeAliases -> TypeAliases
combineAliases) Map Name [TypeAliases]
cs1 Map Name [TypeAliases]
cs2
combineAliases (Scalar (Prim PrimType
t)) TypeAliases
_ = forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. PrimType -> ScalarTypeBase dim u
Prim PrimType
t
combineAliases TypeAliases
t1 TypeAliases
t2 =
  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"combineAliases invalid args: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (TypeAliases
t1, TypeAliases
t2)

-- An alias inhibits uniqueness if it is used in disjoint values.
aliasesMultipleTimes :: TypeAliases -> Names
aliasesMultipleTimes :: TypeAliases -> Names
aliasesMultipleTimes = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeAliases -> Map VName Int
delve
  where
    delve :: TypeAliases -> Map VName Int
delve (Scalar (Record Map Name TypeAliases
fs)) =
      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Num a => a -> a -> a
(+)) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TypeAliases -> Map VName Int
delve forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map Name TypeAliases
fs
    delve TypeAliases
t =
      forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map Alias -> VName
aliasVar forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList (TypeAliases -> Set Alias
aliases TypeAliases
t)) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat (Int
1 :: Int)

consumingParams :: [Pat ParamType] -> Names
consumingParams :: [Pat (TypeBase Size Diet)] -> Names
consumingParams =
  forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Diet
Consume) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall shape. TypeBase shape Diet -> Diet
diet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall t. Pat t -> [(VName, t)]
patternMap

arrayAliases :: TypeAliases -> Aliases
arrayAliases :: TypeAliases -> Set Alias
arrayAliases (Array Set Alias
als Shape Size
_ ScalarTypeBase Size NoUniqueness
_) = Set Alias
als
arrayAliases (Scalar Prim {}) = forall a. Monoid a => a
mempty
arrayAliases (Scalar (Record Map Name TypeAliases
fs)) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeAliases -> Set Alias
arrayAliases Map Name TypeAliases
fs
arrayAliases (Scalar (TypeVar Set Alias
als QualName VName
_ [TypeArg Size]
_)) = Set Alias
als
arrayAliases (Scalar Arrow {}) = forall a. Monoid a => a
mempty
arrayAliases (Scalar (Sum Map Name [TypeAliases]
fs)) =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map TypeAliases -> Set Alias
arrayAliases) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map Name [TypeAliases]
fs

overlapCheck :: (Pretty src, Pretty ve) => Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()
overlapCheck :: forall src ve.
(Pretty src, Pretty ve) =>
Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()
overlapCheck Loc
loc (src
src, TypeAliases
src_als) (ve
ve, TypeAliases
ve_als) =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`S.member` TypeAliases -> Set Alias
aliases TypeAliases
src_als) (TypeAliases -> Set Alias
aliases TypeAliases
ve_als)) forall a b. (a -> b) -> a -> b
$
    forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      Doc ()
"Source array for in-place update"
        forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty src
src)
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"might alias update value"
        forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty ve
ve)
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Hint: use"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes Doc ()
"copy"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"to remove aliases from the value."

inferReturnUniqueness :: [Pat ParamType] -> ResType -> TypeAliases -> ResType
inferReturnUniqueness :: [Pat (TypeBase Size Diet)] -> ResType -> TypeAliases -> ResType
inferReturnUniqueness [] ResType
ret TypeAliases
_ = ResType
ret forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Uniqueness
Nonunique
inferReturnUniqueness [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
ret_als = forall {dim} {u1}.
TypeBase dim u1 -> TypeAliases -> TypeBase dim Uniqueness
delve ResType
ret TypeAliases
ret_als
  where
    forbidden :: Names
forbidden = TypeAliases -> Names
aliasesMultipleTimes TypeAliases
ret_als
    consumings :: Names
consumings = [Pat (TypeBase Size Diet)] -> Names
consumingParams [Pat (TypeBase Size Diet)]
params
    delve :: TypeBase dim u1 -> TypeAliases -> TypeBase dim Uniqueness
delve (Scalar (Record Map Name (TypeBase dim u1)
fs1)) (Scalar (Record Map Name TypeAliases
fs2)) =
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase dim u1 -> TypeAliases -> TypeBase dim Uniqueness
delve Map Name (TypeBase dim u1)
fs1 Map Name TypeAliases
fs2
    delve (Scalar (Sum Map Name [TypeBase dim u1]
cs1)) (Scalar (Sum Map Name [TypeAliases]
cs2)) =
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeBase dim u1 -> TypeAliases -> TypeBase dim Uniqueness
delve) Map Name [TypeBase dim u1]
cs1 Map Name [TypeAliases]
cs2
    delve TypeBase dim u1
t TypeAliases
t_als
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> Set a -> Bool
`S.member` Names
consumings) forall a b. (a -> b) -> a -> b
$ Set Alias -> Names
boundAliases (TypeAliases -> Set Alias
arrayAliases TypeAliases
t_als),
        Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> Set a -> Bool
`S.member` Names
forbidden) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar) (TypeAliases -> Set Alias
aliases TypeAliases
t_als) =
          TypeBase dim u1
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Uniqueness
Unique
      | Bool
otherwise =
          TypeBase dim u1
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Uniqueness
Nonunique

checkSubExps :: ASTMappable e => e -> CheckM e
checkSubExps :: forall e. ASTMappable e => e -> CheckM e
checkSubExps = forall x (m :: * -> *).
(ASTMappable x, Monad m) =>
ASTMapper m -> x -> m x
astMap forall (m :: * -> *). Monad m => ASTMapper m
identityMapper {mapOnExp :: Size -> CheckM Size
mapOnExp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> CheckM (Size, TypeAliases)
checkExp}

noAliases :: Exp -> CheckM (Exp, TypeAliases)
noAliases :: Size -> CheckM (Size, TypeAliases)
noAliases Size
e = do
  Size
e' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
e', forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) (Size -> StructType
typeOf Size
e))

aliasParts :: TypeAliases -> [Aliases]
aliasParts :: TypeAliases -> [Set Alias]
aliasParts (Scalar (Record Map Name TypeAliases
ts)) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeAliases -> [Set Alias]
aliasParts forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map Name TypeAliases
ts
aliasParts TypeAliases
t = [TypeAliases -> Set Alias
aliases TypeAliases
t]

noSelfAliases :: Loc -> TypeAliases -> CheckM ()
noSelfAliases :: Loc -> TypeAliases -> CheckM ()
noSelfAliases Loc
loc = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ forall {a}. Ord a => Set a -> Set a -> CheckM (Set a)
check forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeAliases -> [Set Alias]
aliasParts
  where
    check :: Set a -> Set a -> CheckM (Set a)
check Set a
seen Set a
als = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen) Set a
als) forall a b. (a -> b) -> a -> b
$
        forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"self-aliases-arg" forall a b. (a -> b) -> a -> b
$
          Doc ()
"Argument passed for consuming parameter is self-aliased."
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set a
als forall a. Semigroup a => a -> a -> a
<> Set a
seen

consumeAsNeeded :: Loc -> ParamType -> TypeAliases -> CheckM ()
consumeAsNeeded :: Loc -> TypeBase Size Diet -> TypeAliases -> CheckM ()
consumeAsNeeded Loc
loc (Scalar (Record Map Name (TypeBase Size Diet)
fs1)) (Scalar (Record Map Name TypeAliases
fs2)) =
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (Loc -> TypeBase Size Diet -> TypeAliases -> CheckM ()
consumeAsNeeded Loc
loc) Map Name (TypeBase Size Diet)
fs1 Map Name TypeAliases
fs2
consumeAsNeeded Loc
loc TypeBase Size Diet
pt TypeAliases
t =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall shape. TypeBase shape Diet -> Diet
diet TypeBase Size Diet
pt forall a. Eq a => a -> a -> Bool
== Diet
Consume) forall a b. (a -> b) -> a -> b
$ Loc -> Set Alias -> CheckM ()
consumeAliases Loc
loc forall a b. (a -> b) -> a -> b
$ TypeAliases -> Set Alias
aliases TypeAliases
t

checkArg :: ParamType -> Exp -> CheckM (Exp, TypeAliases)
checkArg :: TypeBase Size Diet -> Size -> CheckM (Size, TypeAliases)
checkArg TypeBase Size Diet
p_t Size
e = do
  ((Size
e', TypeAliases
e_als), Consumed
e_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  Consumed -> CheckM ()
consumed Consumed
e_cons
  let e_t :: StructType
e_t = Size -> StructType
typeOf Size
e'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Consumed
e_cons forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Bool -> Bool
not (forall dim as. TypeBase dim as -> Bool
orderZero StructType
e_t)) forall a b. (a -> b) -> a -> b
$
    forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError (forall a. Located a => a -> Loc
locOf Size
e) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      Doc ()
"Argument of functional type"
        forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty StructType
e_t)
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"contains consumption, which is not allowed."
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall shape. TypeBase shape Diet -> Diet
diet TypeBase Size Diet
p_t forall a. Eq a => a -> a -> Bool
== Diet
Consume) forall a b. (a -> b) -> a -> b
$ do
    Loc -> TypeAliases -> CheckM ()
noSelfAliases (forall a. Located a => a -> Loc
locOf Size
e) TypeAliases
e_als
    Loc -> TypeBase Size Diet -> TypeAliases -> CheckM ()
consumeAsNeeded (forall a. Located a => a -> Loc
locOf Size
e) TypeBase Size Diet
p_t TypeAliases
e_als
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size
e', TypeAliases
e_als)

-- | @returnType appres ret_type arg_diet arg_type@ gives result of applying
-- an argument the given types to a function with the given return
-- type, consuming the argument with the given diet.
returnType :: Aliases -> ResType -> Diet -> TypeAliases -> TypeAliases
returnType :: Set Alias -> ResType -> Diet -> TypeAliases -> TypeAliases
returnType Set Alias
_ (Array Uniqueness
Unique Shape Size
et ScalarTypeBase Size NoUniqueness
shape) Diet
_ TypeAliases
_ =
  forall dim u.
u -> Shape dim -> ScalarTypeBase dim NoUniqueness -> TypeBase dim u
Array forall a. Monoid a => a
mempty Shape Size
et ScalarTypeBase Size NoUniqueness
shape
returnType Set Alias
appres (Array Uniqueness
Nonunique Shape Size
et ScalarTypeBase Size NoUniqueness
shape) Diet
Consume TypeAliases
_ =
  forall dim u.
u -> Shape dim -> ScalarTypeBase dim NoUniqueness -> TypeBase dim u
Array Set Alias
appres Shape Size
et ScalarTypeBase Size NoUniqueness
shape
returnType Set Alias
appres (Array Uniqueness
Nonunique Shape Size
et ScalarTypeBase Size NoUniqueness
shape) Diet
Observe TypeAliases
arg =
  forall dim u.
u -> Shape dim -> ScalarTypeBase dim NoUniqueness -> TypeBase dim u
Array (Set Alias
appres forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
arg) Shape Size
et ScalarTypeBase Size NoUniqueness
shape
returnType Set Alias
_ (Scalar (TypeVar Uniqueness
Unique QualName VName
t [TypeArg Size]
targs)) Diet
_ TypeAliases
_ =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar forall a. Monoid a => a
mempty QualName VName
t [TypeArg Size]
targs
returnType Set Alias
appres (Scalar (TypeVar Uniqueness
Nonunique QualName VName
t [TypeArg Size]
targs)) Diet
Consume TypeAliases
_ =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar Set Alias
appres QualName VName
t [TypeArg Size]
targs
returnType Set Alias
appres (Scalar (TypeVar Uniqueness
Nonunique QualName VName
t [TypeArg Size]
targs)) Diet
Observe TypeAliases
arg =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u -> QualName VName -> [TypeArg dim] -> ScalarTypeBase dim u
TypeVar (Set Alias
appres forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
arg) QualName VName
t [TypeArg Size]
targs
returnType Set Alias
appres (Scalar (Record Map Name ResType
fs)) Diet
d TypeAliases
arg =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ResType
et -> Set Alias -> ResType -> Diet -> TypeAliases -> TypeAliases
returnType Set Alias
appres ResType
et Diet
d TypeAliases
arg) Map Name ResType
fs
returnType Set Alias
_ (Scalar (Prim PrimType
t)) Diet
_ TypeAliases
_ =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. PrimType -> ScalarTypeBase dim u
Prim PrimType
t
returnType Set Alias
appres (Scalar (Arrow Uniqueness
_ PName
v Diet
pd StructType
t1 (RetType [VName]
dims ResType
t2))) Diet
Consume TypeAliases
_ =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow Set Alias
appres PName
v Diet
pd StructType
t1 forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims ResType
t2
returnType Set Alias
appres (Scalar (Arrow Uniqueness
_ PName
v Diet
pd StructType
t1 (RetType [VName]
dims ResType
t2))) Diet
Observe TypeAliases
arg =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow (Set Alias
appres forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
arg) PName
v Diet
pd StructType
t1 forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
dims ResType
t2
returnType Set Alias
appres (Scalar (Sum Map Name [ResType]
cs)) Diet
d TypeAliases
arg =
  forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\ResType
et -> Set Alias -> ResType -> Diet -> TypeAliases -> TypeAliases
returnType Set Alias
appres ResType
et Diet
d TypeAliases
arg) Map Name [ResType]
cs

applyArg :: TypeAliases -> TypeAliases -> TypeAliases
applyArg :: TypeAliases -> TypeAliases -> TypeAliases
applyArg (Scalar (Arrow Set Alias
closure_als PName
_ Diet
d StructType
_ (RetType [VName]
_ ResType
rettype))) TypeAliases
arg_als =
  Set Alias -> ResType -> Diet -> TypeAliases -> TypeAliases
returnType Set Alias
closure_als ResType
rettype Diet
d TypeAliases
arg_als
applyArg TypeAliases
t TypeAliases
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"applyArg: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TypeAliases
t

boundFreeInExp :: Exp -> CheckM (M.Map VName TypeAliases)
boundFreeInExp :: Size -> CheckM (Map VName TypeAliases)
boundFreeInExp Size
e = do
  Map VName (Entry TypeAliases)
vtable <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CheckEnv -> Map VName (Entry TypeAliases)
envVtable
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Entry a -> a
entryAliases) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map VName (Entry TypeAliases)
vtable) forall a b. (a -> b) -> a -> b
$
      FV -> Names
fvVars (Size -> FV
freeInExp Size
e)

-- Loops are tricky because we want to infer the uniqueness of their
-- parameters.  This is pretty unusual: we do not do this for ordinary
-- functions.
type Loop = (Pat ParamType, Exp, LoopFormBase Info VName, Exp)

-- | Mark bindings of consumed names as Consume.
updateParamDiet :: Names -> Pat ParamType -> Pat ParamType
updateParamDiet :: Names -> Pat (TypeBase Size Diet) -> Pat (TypeBase Size Diet)
updateParamDiet Names
cons = forall {dim}.
PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse
  where
    recurse :: PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse (Wildcard (Info TypeBase dim Diet
t) SrcLoc
wloc) =
      forall (f :: * -> *) vn t. f t -> SrcLoc -> PatBase f vn t
Wildcard (forall a. a -> Info a
Info forall a b. (a -> b) -> a -> b
$ TypeBase dim Diet
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Diet
Observe) SrcLoc
wloc
    recurse (PatParens PatBase Info VName (TypeBase dim Diet)
p SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
PatBase f vn t -> SrcLoc -> PatBase f vn t
PatParens (PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse PatBase Info VName (TypeBase dim Diet)
p) SrcLoc
ploc
    recurse (PatAttr AttrInfo VName
attr PatBase Info VName (TypeBase dim Diet)
p SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
AttrInfo vn -> PatBase f vn t -> SrcLoc -> PatBase f vn t
PatAttr AttrInfo VName
attr (PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse PatBase Info VName (TypeBase dim Diet)
p) SrcLoc
ploc
    recurse (Id VName
name (Info TypeBase dim Diet
t) SrcLoc
iloc)
      | VName
name forall a. Ord a => a -> Set a -> Bool
`S.member` Names
cons =
          let t' :: TypeBase dim Diet
t' = TypeBase dim Diet
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Diet
Consume
           in forall (f :: * -> *) vn t. vn -> f t -> SrcLoc -> PatBase f vn t
Id VName
name (forall a. a -> Info a
Info TypeBase dim Diet
t') SrcLoc
iloc
      | Bool
otherwise =
          let t' :: TypeBase dim Diet
t' = TypeBase dim Diet
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setUniqueness` Diet
Observe
           in forall (f :: * -> *) vn t. vn -> f t -> SrcLoc -> PatBase f vn t
Id VName
name (forall a. a -> Info a
Info TypeBase dim Diet
t') SrcLoc
iloc
    recurse (TuplePat [PatBase Info VName (TypeBase dim Diet)]
pats SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
[PatBase f vn t] -> SrcLoc -> PatBase f vn t
TuplePat (forall a b. (a -> b) -> [a] -> [b]
map PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse [PatBase Info VName (TypeBase dim Diet)]
pats) SrcLoc
ploc
    recurse (RecordPat [(Name, PatBase Info VName (TypeBase dim Diet))]
fs SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
[(Name, PatBase f vn t)] -> SrcLoc -> PatBase f vn t
RecordPat (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse) [(Name, PatBase Info VName (TypeBase dim Diet))]
fs) SrcLoc
ploc
    recurse (PatAscription PatBase Info VName (TypeBase dim Diet)
p TypeExp Info VName
t SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
PatBase f vn t -> TypeExp f vn -> SrcLoc -> PatBase f vn t
PatAscription PatBase Info VName (TypeBase dim Diet)
p TypeExp Info VName
t SrcLoc
ploc
    recurse p :: PatBase Info VName (TypeBase dim Diet)
p@PatLit {} = PatBase Info VName (TypeBase dim Diet)
p
    recurse (PatConstr Name
n Info (TypeBase dim Diet)
t [PatBase Info VName (TypeBase dim Diet)]
ps SrcLoc
ploc) =
      forall (f :: * -> *) vn t.
Name -> f t -> [PatBase f vn t] -> SrcLoc -> PatBase f vn t
PatConstr Name
n Info (TypeBase dim Diet)
t (forall a b. (a -> b) -> [a] -> [b]
map PatBase Info VName (TypeBase dim Diet)
-> PatBase Info VName (TypeBase dim Diet)
recurse [PatBase Info VName (TypeBase dim Diet)]
ps) SrcLoc
ploc

convergeLoopParam :: Loc -> Pat ParamType -> Names -> TypeAliases -> CheckM (Pat ParamType)
convergeLoopParam :: Loc
-> Pat (TypeBase Size Diet)
-> Names
-> TypeAliases
-> CheckM (Pat (TypeBase Size Diet))
convergeLoopParam Loc
loop_loc Pat (TypeBase Size Diet)
param Names
body_cons TypeAliases
body_als = do
  let -- Make the pattern Consume where needed.
      param' :: Pat (TypeBase Size Diet)
param' = Names -> Pat (TypeBase Size Diet) -> Pat (TypeBase Size Diet)
updateParamDiet (forall a. (a -> Bool) -> Set a -> Set a
S.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall t. Pat t -> [VName]
patNames Pat (TypeBase Size Diet)
param) Names
body_cons) Pat (TypeBase Size Diet)
param

  -- Check that the new values of consumed merge parameters do not
  -- alias something bound outside the loop, AND that anything
  -- returned for a unique merge parameter does not alias anything
  -- else returned.
  let checkMergeReturn :: PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn (Id vn
pat_v (Info TypeBase shape Diet
pat_v_t) SrcLoc
patloc) TypeAliases
t = do
        let free_als :: Names
free_als = forall a. (a -> Bool) -> Set a -> Set a
S.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall t. Pat t -> [VName]
patNames Pat (TypeBase Size Diet)
param) forall a b. (a -> b) -> a -> b
$ Set Alias -> Names
boundAliases (TypeAliases -> Set Alias
aliases TypeAliases
t)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall shape. TypeBase shape Diet -> Diet
diet TypeBase shape Diet
pat_v_t forall a. Eq a => a -> a -> Bool
== Diet
Consume) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Names
free_als forall a b. (a -> b) -> a -> b
$ \VName
v ->
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loop_loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
            Doc ()
"Return value for consuming loop parameter"
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName vn
pat_v)
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"aliases"
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName VName
v) forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
        (Set Alias
cons, Set Alias
obs) <- forall s (m :: * -> *). MonadState s m => m s
get
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
S.null forall a b. (a -> b) -> a -> b
$ TypeAliases -> Set Alias
aliases TypeAliases
t forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Alias
cons) forall a b. (a -> b) -> a -> b
$
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loop_loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
            Doc ()
"Return value for loop parameter"
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName vn
pat_v)
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"aliases other consumed loop parameter."
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
          ( forall shape. TypeBase shape Diet -> Diet
diet TypeBase shape Diet
pat_v_t forall a. Eq a => a -> a -> Bool
== Diet
Consume
              Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Set a -> Bool
S.null (TypeAliases -> Set Alias
aliases TypeAliases
t forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` (Set Alias
cons forall a. Semigroup a => a -> a -> a
<> Set Alias
obs)))
          )
          forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loop_loc forall a. Monoid a => a
mempty
          forall a b. (a -> b) -> a -> b
$ Doc ()
"Return value for consuming loop parameter"
            forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName vn
pat_v)
            forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"aliases previously returned value."
        if forall shape. TypeBase shape Diet -> Diet
diet TypeBase shape Diet
pat_v_t forall a. Eq a => a -> a -> Bool
== Diet
Consume
          then forall s (m :: * -> *). MonadState s m => s -> m ()
put (Set Alias
cons forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
t, Set Alias
obs)
          else forall s (m :: * -> *). MonadState s m => s -> m ()
put (Set Alias
cons, Set Alias
obs forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
t)

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn t. vn -> f t -> SrcLoc -> PatBase f vn t
Id vn
pat_v (forall a. a -> Info a
Info TypeBase shape Diet
pat_v_t) SrcLoc
patloc
      checkMergeReturn (Wildcard (Info TypeBase shape Diet
pat_v_t) SrcLoc
patloc) TypeAliases
_ =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn t. f t -> SrcLoc -> PatBase f vn t
Wildcard (forall a. a -> Info a
Info TypeBase shape Diet
pat_v_t) SrcLoc
patloc
      checkMergeReturn (PatParens PatBase Info vn (TypeBase shape Diet)
p SrcLoc
_) TypeAliases
t =
        PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn PatBase Info vn (TypeBase shape Diet)
p TypeAliases
t
      checkMergeReturn (PatAscription PatBase Info vn (TypeBase shape Diet)
p TypeExp Info vn
_ SrcLoc
_) TypeAliases
t =
        PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn PatBase Info vn (TypeBase shape Diet)
p TypeAliases
t
      checkMergeReturn (RecordPat [(Name, PatBase Info vn (TypeBase shape Diet))]
pfs SrcLoc
patloc) (Scalar (Record Map Name TypeAliases
tfs)) =
        forall (f :: * -> *) vn t.
[(Name, PatBase f vn t)] -> SrcLoc -> PatBase f vn t
RecordPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Map Name (t CheckM (PatBase Info vn (TypeBase shape Diet)))
pfs' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
patloc
        where
          pfs' :: Map Name (t CheckM (PatBase Info vn (TypeBase shape Diet)))
pfs' = forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, PatBase Info vn (TypeBase shape Diet))]
pfs) Map Name TypeAliases
tfs
      checkMergeReturn (TuplePat [PatBase Info vn (TypeBase shape Diet)]
pats SrcLoc
patloc) TypeAliases
t
        | Just [TypeAliases]
ts <- forall dim as. TypeBase dim as -> Maybe [TypeBase dim as]
isTupleRecord TypeAliases
t =
            forall (f :: * -> *) vn t.
[PatBase f vn t] -> SrcLoc -> PatBase f vn t
TuplePat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn [PatBase Info vn (TypeBase shape Diet)]
pats [TypeAliases]
ts forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
patloc
      checkMergeReturn PatBase Info vn (TypeBase shape Diet)
p TypeAliases
_ =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure PatBase Info vn (TypeBase shape Diet)
p

  (Pat (TypeBase Size Diet)
param'', (Set Alias
param_cons, Set Alias
_)) <-
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall {t :: (* -> *) -> * -> *} {vn} {shape}.
(MonadTrans t, IsName vn,
 MonadState (Set Alias, Set Alias) (t CheckM)) =>
PatBase Info vn (TypeBase shape Diet)
-> TypeAliases -> t CheckM (PatBase Info vn (TypeBase shape Diet))
checkMergeReturn Pat (TypeBase Size Diet)
param' TypeAliases
body_als) (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)

  let body_cons' :: Names
body_cons' = Names
body_cons forall a. Semigroup a => a -> a -> a
<> forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Alias -> VName
aliasVar Set Alias
param_cons
  if Names
body_cons' forall a. Eq a => a -> a -> Bool
== Names
body_cons Bool -> Bool -> Bool
&& forall d u. Pat (TypeBase d u) -> TypeBase d u
patternType Pat (TypeBase Size Diet)
param'' forall a. Eq a => a -> a -> Bool
== forall d u. Pat (TypeBase d u) -> TypeBase d u
patternType Pat (TypeBase Size Diet)
param
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat (TypeBase Size Diet)
param'
    else Loc
-> Pat (TypeBase Size Diet)
-> Names
-> TypeAliases
-> CheckM (Pat (TypeBase Size Diet))
convergeLoopParam Loc
loop_loc Pat (TypeBase Size Diet)
param'' Names
body_cons' TypeAliases
body_als

checkLoop :: Loc -> Loop -> CheckM (Loop, TypeAliases)
checkLoop :: Loc -> Loop -> CheckM (Loop, TypeAliases)
checkLoop Loc
loop_loc (Pat (TypeBase Size Diet)
param, Size
arg, LoopFormBase Info VName
form, Size
body) = do
  LoopFormBase Info VName
form' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps LoopFormBase Info VName
form
  -- We pretend that every part of the loop parameter has a consuming
  -- diet, as we need to allow consumption in the body, which we then
  -- use to infer the proper diet of the parameter.
  ((Size
body', Consumed
body_cons), TypeAliases
body_als) <-
    forall a. CheckM a -> CheckM a
noConsumable
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Pat (TypeBase Size Diet)
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParam (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const Diet
Consume)) Pat (TypeBase Size Diet)
param)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
LoopFormBase Info VName
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingLoopForm LoopFormBase Info VName
form'
      forall a b. (a -> b) -> a -> b
$ do
        ((Size
body', TypeAliases
body_als), Consumed
body_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
body
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Size
body', Consumed
body_cons), TypeAliases
body_als)
  Pat (TypeBase Size Diet)
param' <- Loc
-> Pat (TypeBase Size Diet)
-> Names
-> TypeAliases
-> CheckM (Pat (TypeBase Size Diet))
convergeLoopParam Loc
loop_loc Pat (TypeBase Size Diet)
param (forall k a. Map k a -> Set k
M.keysSet Consumed
body_cons) TypeAliases
body_als

  let param_t :: TypeBase Size Diet
param_t = forall d u. Pat (TypeBase d u) -> TypeBase d u
patternType Pat (TypeBase Size Diet)
param'
  ((Size
arg', TypeAliases
arg_als), Consumed
arg_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ TypeBase Size Diet -> Size -> CheckM (Size, TypeAliases)
checkArg TypeBase Size Diet
param_t Size
arg
  Consumed -> CheckM ()
consumed Consumed
arg_cons
  Map VName TypeAliases
free_bound <- Size -> CheckM (Map VName TypeAliases)
boundFreeInExp Size
body

  let bad :: (a, TypeAliases) -> Bool
bad = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Consumed
arg_cons) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Alias -> Names
boundAliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeAliases -> Set Alias
aliases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. (a, TypeAliases) -> Bool
bad forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map VName TypeAliases
free_bound) forall a b. (a -> b) -> a -> b
$ \(VName
v, TypeAliases
_) -> do
    Doc ()
v' <- forall a. VName -> CheckM (Doc a)
describeVar VName
v
    forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError Loc
loop_loc forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      Doc ()
"Loop body uses"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
v' forall a. Semigroup a => a -> a -> a
<> Doc ()
" (or an alias),"
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"but this is consumed by the initial loop argument."

  VName
v <- Name -> Int -> VName
VName Name
"internal_loop_result" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckM Int
incCounter
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
s -> CheckState
s {stateNames :: Map VName NameReason
stateNames = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v (SrcLoc -> NameReason
NameLoopRes (forall a. Located a => a -> SrcLoc
srclocOf Loc
loop_loc)) forall a b. (a -> b) -> a -> b
$ CheckState -> Map VName NameReason
stateNames CheckState
s}

  let loopt :: TypeAliases
loopt =
        [Pat (TypeBase Size Diet)]
-> RetTypeBase Size Uniqueness -> StructType
funType [Pat (TypeBase Size Diet)
param'] (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [] forall a b. (a -> b) -> a -> b
$ TypeBase Size Diet -> ResType
paramToRes TypeBase Size Diet
param_t)
          forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. a -> Set a
S.singleton (VName -> Alias
AliasFree VName
v)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( (Pat (TypeBase Size Diet)
param', Size
arg', LoopFormBase Info VName
form', Size
body'),
      TypeAliases -> TypeAliases -> TypeAliases
applyArg TypeAliases
loopt TypeAliases
arg_als TypeAliases -> TypeAliases -> TypeAliases
`combineAliases` TypeAliases
body_als
    )

checkFuncall ::
  Foldable f =>
  SrcLoc ->
  Maybe (QualName VName) ->
  TypeAliases ->
  f TypeAliases ->
  CheckM TypeAliases
checkFuncall :: forall (f :: * -> *).
Foldable f =>
SrcLoc
-> Maybe (QualName VName)
-> TypeAliases
-> f TypeAliases
-> CheckM TypeAliases
checkFuncall SrcLoc
loc Maybe (QualName VName)
fname TypeAliases
f_als f TypeAliases
args_als = do
  VName
v <- Name -> Int -> VName
VName Name
"internal_app_result" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckM Int
incCounter
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
s -> CheckState
s {stateNames :: Map VName NameReason
stateNames = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v (Maybe (QualName VName) -> SrcLoc -> NameReason
NameAppRes Maybe (QualName VName)
fname SrcLoc
loc) forall a b. (a -> b) -> a -> b
$ CheckState -> Map VName NameReason
stateNames CheckState
s}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeAliases -> TypeAliases -> TypeAliases
applyArg (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Ord a => a -> Set a -> Set a
S.insert (VName -> Alias
AliasFree VName
v)) TypeAliases
f_als) f TypeAliases
args_als

checkExp :: Exp -> CheckM (Exp, TypeAliases)
-- First we have the complicated cases.

--
checkExp :: Size -> CheckM (Size, TypeAliases)
checkExp (AppExp (Apply Size
f NonEmpty (Info (Diet, Maybe VName), Size)
args SrcLoc
loc) Info AppRes
appres) = do
  -- Note Futhark uses right-to-left evaluation of applications.
  (NonEmpty (Info (Diet, Maybe VName), Size)
args', NonEmpty TypeAliases
args_als) <- forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> NonEmpty a
NE.reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b}.
(Info (Diet, b), Size)
-> CheckM ((Info (Diet, b), Size), TypeAliases)
checkArg' (forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (Info (Diet, Maybe VName), Size)
args)
  (Size
f', TypeAliases
f_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
f
  TypeAliases
res_als <- forall (f :: * -> *).
Foldable f =>
SrcLoc
-> Maybe (QualName VName)
-> TypeAliases
-> f TypeAliases
-> CheckM TypeAliases
checkFuncall SrcLoc
loc (forall {f :: * -> *} {vn}. ExpBase f vn -> Maybe (QualName vn)
fname Size
f) TypeAliases
f_als NonEmpty TypeAliases
args_als
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn
-> NonEmpty (f (Diet, Maybe VName), ExpBase f vn)
-> SrcLoc
-> AppExpBase f vn
Apply Size
f' NonEmpty (Info (Diet, Maybe VName), Size)
args' SrcLoc
loc) Info AppRes
appres, TypeAliases
res_als)
  where
    fname :: ExpBase f vn -> Maybe (QualName vn)
fname (Var QualName vn
v f StructType
_ SrcLoc
_) = forall a. a -> Maybe a
Just QualName vn
v
    fname (AppExp (Apply ExpBase f vn
e NonEmpty (f (Diet, Maybe VName), ExpBase f vn)
_ SrcLoc
_) f AppRes
_) = ExpBase f vn -> Maybe (QualName vn)
fname ExpBase f vn
e
    fname ExpBase f vn
_ = forall a. Maybe a
Nothing
    checkArg' :: (Info (Diet, b), Size)
-> CheckM ((Info (Diet, b), Size), TypeAliases)
checkArg' (Info (Diet
d, b
p), Size
e) = do
      (Size
e', TypeAliases
e_als) <- TypeBase Size Diet -> Size -> CheckM (Size, TypeAliases)
checkArg (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const Diet
d) (Size -> StructType
typeOf Size
e)) Size
e
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. a -> Info a
Info (Diet
d, b
p), Size
e'), TypeAliases
e_als)

--
checkExp (AppExp (DoLoop [VName]
sparams Pat (TypeBase Size Diet)
pat Size
args LoopFormBase Info VName
form Size
body SrcLoc
loc) Info AppRes
appres) = do
  ((Pat (TypeBase Size Diet)
pat', Size
args', LoopFormBase Info VName
form', Size
body'), TypeAliases
als) <- Loc -> Loop -> CheckM (Loop, TypeAliases)
checkLoop (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (Pat (TypeBase Size Diet)
pat, Size
args, LoopFormBase Info VName
form, Size
body)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
[VName]
-> PatBase f vn (TypeBase Size Diet)
-> ExpBase f vn
-> LoopFormBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
DoLoop [VName]
sparams Pat (TypeBase Size Diet)
pat' Size
args' LoopFormBase Info VName
form' Size
body' SrcLoc
loc) Info AppRes
appres,
      TypeAliases
als
    )

--
checkExp (AppExp (LetPat [SizeBinder VName]
sizes Pat StructType
p Size
e Size
body SrcLoc
loc) Info AppRes
appres) = do
  ((Size
e', TypeAliases
e_als), Consumed
e_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  Consumed -> CheckM ()
consumed Consumed
e_cons
  let e_t :: StructType
e_t = Size -> StructType
typeOf Size
e'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Consumed
e_cons forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Bool -> Bool
not (forall dim as. TypeBase dim as -> Bool
orderZero StructType
e_t)) forall a b. (a -> b) -> a -> b
$
    forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError (forall a. Located a => a -> Loc
locOf Size
e) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      Doc ()
"Let-bound expression of higher-order type"
        forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty StructType
e_t)
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"contains consumption, which is not allowed."
  forall a.
Pat StructType
-> TypeAliases
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingPat Pat StructType
p TypeAliases
e_als forall a b. (a -> b) -> a -> b
$ do
    (Size
body', TypeAliases
body_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
body
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
[SizeBinder vn]
-> PatBase f vn StructType
-> ExpBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetPat [SizeBinder VName]
sizes Pat StructType
p Size
e' Size
body' SrcLoc
loc) Info AppRes
appres,
        TypeAliases
body_als
      )

--
checkExp (AppExp (If Size
cond Size
te Size
fe SrcLoc
loc) Info AppRes
appres) = do
  (Size
cond', TypeAliases
_) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
cond
  ((Size
te', TypeAliases
te_als), Consumed
te_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
te
  ((Size
fe', TypeAliases
fe_als), Consumed
fe_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
fe
  let all_cons :: Consumed
all_cons = Consumed
te_cons forall a. Semigroup a => a -> a -> a
<> Consumed
fe_cons
      notConsumed :: Alias -> Bool
notConsumed = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Consumed
all_cons) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar
      comb_als :: TypeAliases
comb_als = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> Set a -> Set a
S.filter Alias -> Bool
notConsumed) forall a b. (a -> b) -> a -> b
$ TypeAliases
te_als TypeAliases -> TypeAliases -> TypeAliases
`combineAliases` TypeAliases
fe_als
  Consumed -> CheckM ()
consumed Consumed
all_cons
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn
-> ExpBase f vn -> ExpBase f vn -> SrcLoc -> AppExpBase f vn
If Size
cond' Size
te' Size
fe' SrcLoc
loc) Info AppRes
appres,
      AppRes -> StructType
appResType (forall a. Info a -> a
unInfo Info AppRes
appres) forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. Monoid a => a
mempty TypeAliases -> TypeAliases -> TypeAliases
`combineAliases` TypeAliases
comb_als
    )

--
checkExp (AppExp (Match Size
cond NonEmpty (CaseBase Info VName)
cs SrcLoc
loc) Info AppRes
appres) = do
  (Size
cond', TypeAliases
cond_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
cond
  ((NonEmpty (CaseBase Info VName)
cs', NonEmpty TypeAliases
cs_als), NonEmpty Consumed
cs_cons) <-
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeAliases
-> CaseBase Info VName
-> CheckM ((CaseBase Info VName, TypeAliases), Consumed)
checkCase TypeAliases
cond_als) NonEmpty (CaseBase Info VName)
cs
  let all_cons :: Consumed
all_cons = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold NonEmpty Consumed
cs_cons
      notConsumed :: Alias -> Bool
notConsumed = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Consumed
all_cons) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alias -> VName
aliasVar
      comb_als :: TypeAliases
comb_als = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> Set a -> Set a
S.filter Alias -> Bool
notConsumed) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 TypeAliases -> TypeAliases -> TypeAliases
combineAliases NonEmpty TypeAliases
cs_als
  Consumed -> CheckM ()
consumed Consumed
all_cons
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn
-> NonEmpty (CaseBase f vn) -> SrcLoc -> AppExpBase f vn
Match Size
cond' NonEmpty (CaseBase Info VName)
cs' SrcLoc
loc) Info AppRes
appres,
      AppRes -> StructType
appResType (forall a. Info a -> a
unInfo Info AppRes
appres) forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. Monoid a => a
mempty TypeAliases -> TypeAliases -> TypeAliases
`combineAliases` TypeAliases
comb_als
    )
  where
    checkCase :: TypeAliases
-> CaseBase Info VName
-> CheckM ((CaseBase Info VName, TypeAliases), Consumed)
checkCase TypeAliases
cond_als (CasePat Pat StructType
p Size
body SrcLoc
caseloc) =
      forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ forall a.
Pat StructType
-> TypeAliases
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingPat Pat StructType
p TypeAliases
cond_als forall a b. (a -> b) -> a -> b
$ do
        (Size
body', TypeAliases
body_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
body
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
PatBase f vn StructType -> ExpBase f vn -> SrcLoc -> CaseBase f vn
CasePat Pat StructType
p Size
body' SrcLoc
caseloc, TypeAliases
body_als)

--
checkExp (AppExp (LetFun VName
fname ([TypeParamBase VName]
typarams, [Pat (TypeBase Size Diet)]
params, Maybe (TypeExp Info VName)
te, Info (RetType [VName]
ext ResType
ret), Size
funbody) Size
letbody SrcLoc
loc) Info AppRes
appres) = do
  ((ResType
ret', Size
funbody'), TypeAliases
ftype) <- forall a.
[Pat (TypeBase Size Diet)]
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParams [Pat (TypeBase Size Diet)]
params forall a b. (a -> b) -> a -> b
$ do
    -- Throw away the consumption - it can refer only to the parameters
    -- anyway.
    ((Size
funbody', TypeAliases
funbody_als), Consumed
_body_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
funbody
    SrcLoc
-> [Pat (TypeBase Size Diet)]
-> ResType
-> TypeAliases
-> CheckM ()
checkReturnAlias SrcLoc
loc [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
funbody_als
    SrcLoc -> [Pat (TypeBase Size Diet)] -> TypeAliases -> CheckM ()
checkGlobalAliases SrcLoc
loc [Pat (TypeBase Size Diet)]
params TypeAliases
funbody_als
    Map VName TypeAliases
free_bound <- Size -> CheckM (Map VName TypeAliases)
boundFreeInExp Size
funbody
    let ret' :: ResType
ret' = [Pat (TypeBase Size Diet)] -> ResType -> TypeAliases -> ResType
inferReturnUniqueness [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
funbody_als
        als :: Set Alias
als = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeAliases -> Set Alias
aliases (forall k a. Map k a -> [a]
M.elems Map VName TypeAliases
free_bound)
        ftype :: TypeAliases
ftype = [Pat (TypeBase Size Diet)]
-> RetTypeBase Size Uniqueness -> StructType
funType [Pat (TypeBase Size Diet)]
params (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext ResType
ret') forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Set Alias
als
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ResType
ret', Size
funbody'), TypeAliases
ftype)
  (Size
letbody', TypeAliases
letbody_als) <- forall a. VName -> TypeAliases -> CheckM a -> CheckM a
bindingFun VName
fname TypeAliases
ftype forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
letbody
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
vn
-> ([TypeParamBase vn], [PatBase f vn (TypeBase Size Diet)],
    Maybe (TypeExp f vn), f (RetTypeBase Size Uniqueness),
    ExpBase f vn)
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetFun VName
fname ([TypeParamBase VName]
typarams, [Pat (TypeBase Size Diet)]
params, Maybe (TypeExp Info VName)
te, forall a. a -> Info a
Info (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext ResType
ret'), Size
funbody') Size
letbody' SrcLoc
loc) Info AppRes
appres,
      TypeAliases
letbody_als
    )

--
checkExp (AppExp (BinOp (QualName VName
op, SrcLoc
oploc) Info StructType
opt (Size
x, Info (Maybe VName)
xp) (Size
y, Info (Maybe VName)
yp) SrcLoc
loc) Info AppRes
appres) = do
  TypeAliases
op_als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
oploc) (forall vn. QualName vn -> vn
qualLeaf QualName VName
op) (forall a. Info a -> a
unInfo Info StructType
opt)
  let TypeBase Size Diet
at1 : TypeBase Size Diet
at2 : [TypeBase Size Diet]
_ = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall dim as.
TypeBase dim as -> ([TypeBase dim Diet], TypeBase dim NoUniqueness)
unfoldFunType TypeAliases
op_als
  (Size
x', TypeAliases
x_als) <- TypeBase Size Diet -> Size -> CheckM (Size, TypeAliases)
checkArg TypeBase Size Diet
at1 Size
x
  (Size
y', TypeAliases
y_als) <- TypeBase Size Diet -> Size -> CheckM (Size, TypeAliases)
checkArg TypeBase Size Diet
at2 Size
y
  TypeAliases
res_als <- forall (f :: * -> *).
Foldable f =>
SrcLoc
-> Maybe (QualName VName)
-> TypeAliases
-> f TypeAliases
-> CheckM TypeAliases
checkFuncall SrcLoc
loc (forall a. a -> Maybe a
Just QualName VName
op) TypeAliases
op_als [TypeAliases
x_als, TypeAliases
y_als]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
(QualName vn, SrcLoc)
-> f StructType
-> (ExpBase f vn, f (Maybe VName))
-> (ExpBase f vn, f (Maybe VName))
-> SrcLoc
-> AppExpBase f vn
BinOp (QualName VName
op, SrcLoc
oploc) Info StructType
opt (Size
x', Info (Maybe VName)
xp) (Size
y', Info (Maybe VName)
yp) SrcLoc
loc) Info AppRes
appres,
      TypeAliases
res_als
    )

--
checkExp e :: Size
e@(Lambda [Pat (TypeBase Size Diet)]
params Size
body Maybe (TypeExp Info VName)
te (Info (RetType [VName]
ext ResType
ret)) SrcLoc
loc) =
  forall a.
[Pat (TypeBase Size Diet)]
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParams [Pat (TypeBase Size Diet)]
params forall a b. (a -> b) -> a -> b
$ do
    -- Throw away the consumption - it can refer only to the parameters
    -- anyway.
    ((Size
body', TypeAliases
body_als), Consumed
_body_cons) <- forall a. CheckM a -> CheckM (a, Consumed)
contain forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
body
    SrcLoc
-> [Pat (TypeBase Size Diet)]
-> ResType
-> TypeAliases
-> CheckM ()
checkReturnAlias SrcLoc
loc [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
body_als
    SrcLoc -> [Pat (TypeBase Size Diet)] -> TypeAliases -> CheckM ()
checkGlobalAliases SrcLoc
loc [Pat (TypeBase Size Diet)]
params TypeAliases
body_als
    Map VName TypeAliases
free_bound <- Size -> CheckM (Map VName TypeAliases)
boundFreeInExp Size
e
    let ret' :: ResType
ret' = [Pat (TypeBase Size Diet)] -> ResType -> TypeAliases -> ResType
inferReturnUniqueness [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
body_als
        als :: Set Alias
als = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TypeAliases -> Set Alias
aliases (forall k a. Map k a -> [a]
M.elems Map VName TypeAliases
free_bound)
        ftype :: TypeAliases
ftype = [Pat (TypeBase Size Diet)]
-> RetTypeBase Size Uniqueness -> StructType
funType [Pat (TypeBase Size Diet)]
params (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext ResType
ret') forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` Set Alias
als
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall (f :: * -> *) vn.
[PatBase f vn (TypeBase Size Diet)]
-> ExpBase f vn
-> Maybe (TypeExp f vn)
-> f (RetTypeBase Size Uniqueness)
-> SrcLoc
-> ExpBase f vn
Lambda [Pat (TypeBase Size Diet)]
params Size
body' Maybe (TypeExp Info VName)
te (forall a. a -> Info a
Info (forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext ResType
ret')) SrcLoc
loc,
        TypeAliases
ftype
      )

--
checkExp (AppExp (LetWith IdentBase Info VName StructType
dst IdentBase Info VName StructType
src SliceBase Info VName
slice Size
ve Size
body SrcLoc
loc) Info AppRes
appres) = do
  TypeAliases
src_als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf IdentBase Info VName StructType
dst) (forall {k} (f :: k -> *) vn (t :: k). IdentBase f vn t -> vn
identName IdentBase Info VName StructType
src) (forall a. Info a -> a
unInfo forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) vn (t :: k). IdentBase f vn t -> f t
identType IdentBase Info VName StructType
src)
  SliceBase Info VName
slice' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps SliceBase Info VName
slice
  (Size
ve', TypeAliases
ve_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
ve
  Loc -> VName -> StructType -> CheckM ()
consume (forall a. Located a => a -> Loc
locOf IdentBase Info VName StructType
src) (forall {k} (f :: k -> *) vn (t :: k). IdentBase f vn t -> vn
identName IdentBase Info VName StructType
src) (forall a. Info a -> a
unInfo (forall {k} (f :: k -> *) vn (t :: k). IdentBase f vn t -> f t
identType IdentBase Info VName StructType
src))
  forall src ve.
(Pretty src, Pretty ve) =>
Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()
overlapCheck (forall a. Located a => a -> Loc
locOf Size
ve) (IdentBase Info VName StructType
src, TypeAliases
src_als) (Size
ve', TypeAliases
ve_als)
  (Size
body', TypeAliases
body_als) <- forall a.
Diet
-> IdentBase Info VName StructType
-> CheckM (a, TypeAliases)
-> CheckM (a, TypeAliases)
bindingIdent Diet
Consume IdentBase Info VName StructType
dst forall a b. (a -> b) -> a -> b
$ Size -> CheckM (Size, TypeAliases)
checkExp Size
body
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
IdentBase f vn StructType
-> IdentBase f vn StructType
-> SliceBase f vn
-> ExpBase f vn
-> ExpBase f vn
-> SrcLoc
-> AppExpBase f vn
LetWith IdentBase Info VName StructType
dst IdentBase Info VName StructType
src SliceBase Info VName
slice' Size
ve' Size
body' SrcLoc
loc) Info AppRes
appres, TypeAliases
body_als)

--
checkExp (Update Size
src SliceBase Info VName
slice Size
ve SrcLoc
loc) = do
  SliceBase Info VName
slice' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps SliceBase Info VName
slice
  (Size
ve', TypeAliases
ve_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
ve
  (Size
src', TypeAliases
src_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
src
  forall src ve.
(Pretty src, Pretty ve) =>
Loc -> (src, TypeAliases) -> (ve, TypeAliases) -> CheckM ()
overlapCheck (forall a. Located a => a -> Loc
locOf Size
ve) (Size
src', TypeAliases
src_als) (Size
ve', TypeAliases
ve_als)
  Loc -> Set Alias -> CheckM ()
consumeAliases (forall a. Located a => a -> Loc
locOf SrcLoc
loc) forall a b. (a -> b) -> a -> b
$ TypeAliases -> Set Alias
aliases TypeAliases
src_als
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
ExpBase f vn
-> SliceBase f vn -> ExpBase f vn -> SrcLoc -> ExpBase f vn
Update Size
src' SliceBase Info VName
slice' Size
ve' SrcLoc
loc, forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) TypeAliases
src_als)

-- Cases that simply propagate aliases directly.
checkExp (Var QualName VName
v (Info StructType
t) SrcLoc
loc) = do
  TypeAliases
als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (forall vn. QualName vn -> vn
qualLeaf QualName VName
v) StructType
t
  Loc -> Set Alias -> CheckM ()
checkIfConsumed (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (TypeAliases -> Set Alias
aliases TypeAliases
als)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
QualName vn -> f StructType -> SrcLoc -> ExpBase f vn
Var QualName VName
v (forall a. a -> Info a
Info StructType
t) SrcLoc
loc, TypeAliases
als)
checkExp (OpSection QualName VName
v (Info StructType
t) SrcLoc
loc) = do
  TypeAliases
als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (forall vn. QualName vn -> vn
qualLeaf QualName VName
v) StructType
t
  Loc -> Set Alias -> CheckM ()
checkIfConsumed (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (TypeAliases -> Set Alias
aliases TypeAliases
als)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
QualName vn -> f StructType -> SrcLoc -> ExpBase f vn
OpSection QualName VName
v (forall a. a -> Info a
Info StructType
t) SrcLoc
loc, TypeAliases
als)
checkExp (OpSectionLeft QualName VName
op Info StructType
ftype Size
arg (Info (PName, TypeBase Size Diet, Maybe VName),
 Info (PName, TypeBase Size Diet))
arginfo (Info (RetTypeBase Size Uniqueness), Info [VName])
retinfo SrcLoc
loc) = do
  let (Info (PName, TypeBase Size Diet, Maybe VName)
_, Info (PName
pn, TypeBase Size Diet
pt2)) = (Info (PName, TypeBase Size Diet, Maybe VName),
 Info (PName, TypeBase Size Diet))
arginfo
      (Info RetTypeBase Size Uniqueness
ret, Info [VName]
_) = (Info (RetTypeBase Size Uniqueness), Info [VName])
retinfo
  TypeAliases
als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (forall vn. QualName vn -> vn
qualLeaf QualName VName
op) (forall a. Info a -> a
unInfo Info StructType
ftype)
  (Size
arg', TypeAliases
arg_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
arg
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
QualName vn
-> f StructType
-> ExpBase f vn
-> (f (PName, TypeBase Size Diet, Maybe VName),
    f (PName, TypeBase Size Diet))
-> (f (RetTypeBase Size Uniqueness), f [VName])
-> SrcLoc
-> ExpBase f vn
OpSectionLeft QualName VName
op Info StructType
ftype Size
arg' (Info (PName, TypeBase Size Diet, Maybe VName),
 Info (PName, TypeBase Size Diet))
arginfo (Info (RetTypeBase Size Uniqueness), Info [VName])
retinfo SrcLoc
loc,
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow (TypeAliases -> Set Alias
aliases TypeAliases
arg_als forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
als) PName
pn (forall shape. TypeBase shape Diet -> Diet
diet TypeBase Size Diet
pt2) (forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase Size Diet
pt2) RetTypeBase Size Uniqueness
ret
    )
checkExp (OpSectionRight QualName VName
op Info StructType
ftype Size
arg (Info (PName, TypeBase Size Diet),
 Info (PName, TypeBase Size Diet, Maybe VName))
arginfo Info (RetTypeBase Size Uniqueness)
retinfo SrcLoc
loc) = do
  let (Info (PName
pn, TypeBase Size Diet
pt2), Info (PName, TypeBase Size Diet, Maybe VName)
_) = (Info (PName, TypeBase Size Diet),
 Info (PName, TypeBase Size Diet, Maybe VName))
arginfo
      Info RetTypeBase Size Uniqueness
ret = Info (RetTypeBase Size Uniqueness)
retinfo
  TypeAliases
als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
loc) (forall vn. QualName vn -> vn
qualLeaf QualName VName
op) (forall a. Info a -> a
unInfo Info StructType
ftype)
  (Size
arg', TypeAliases
arg_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
arg
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
QualName vn
-> f StructType
-> ExpBase f vn
-> (f (PName, TypeBase Size Diet),
    f (PName, TypeBase Size Diet, Maybe VName))
-> f (RetTypeBase Size Uniqueness)
-> SrcLoc
-> ExpBase f vn
OpSectionRight QualName VName
op Info StructType
ftype Size
arg' (Info (PName, TypeBase Size Diet),
 Info (PName, TypeBase Size Diet, Maybe VName))
arginfo Info (RetTypeBase Size Uniqueness)
retinfo SrcLoc
loc,
      forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u.
u
-> PName
-> Diet
-> TypeBase dim NoUniqueness
-> RetTypeBase dim Uniqueness
-> ScalarTypeBase dim u
Arrow (TypeAliases -> Set Alias
aliases TypeAliases
arg_als forall a. Semigroup a => a -> a -> a
<> TypeAliases -> Set Alias
aliases TypeAliases
als) PName
pn (forall shape. TypeBase shape Diet -> Diet
diet TypeBase Size Diet
pt2) (forall dim u. TypeBase dim u -> TypeBase dim NoUniqueness
toStruct TypeBase Size Diet
pt2) RetTypeBase Size Uniqueness
ret
    )
checkExp (IndexSection SliceBase Info VName
slice Info StructType
t SrcLoc
loc) = do
  SliceBase Info VName
slice' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps SliceBase Info VName
slice
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
SliceBase f vn -> f StructType -> SrcLoc -> ExpBase f vn
IndexSection SliceBase Info VName
slice' Info StructType
t SrcLoc
loc, forall a. Info a -> a
unInfo Info StructType
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. Monoid a => a
mempty)
checkExp (ProjectSection [Name]
fs Info StructType
t SrcLoc
loc) = do
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
[Name] -> f StructType -> SrcLoc -> ExpBase f vn
ProjectSection [Name]
fs Info StructType
t SrcLoc
loc, forall a. Info a -> a
unInfo Info StructType
t forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. Monoid a => a
mempty)
checkExp (Coerce Size
e TypeExp Info VName
te Info StructType
t SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
ExpBase f vn
-> TypeExp f vn -> f StructType -> SrcLoc -> ExpBase f vn
Coerce Size
e' TypeExp Info VName
te Info StructType
t SrcLoc
loc, TypeAliases
e_als)
checkExp (Ascript Size
e TypeExp Info VName
te SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
ExpBase f vn -> TypeExp f vn -> SrcLoc -> ExpBase f vn
Ascript Size
e' TypeExp Info VName
te SrcLoc
loc, TypeAliases
e_als)
checkExp (AppExp (Index Size
v SliceBase Info VName
slice SrcLoc
loc) Info AppRes
appres) = do
  (Size
v', TypeAliases
v_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
v
  SliceBase Info VName
slice' <- forall e. ASTMappable e => e -> CheckM e
checkSubExps SliceBase Info VName
slice
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn -> SliceBase f vn -> SrcLoc -> AppExpBase f vn
Index Size
v' SliceBase Info VName
slice' SrcLoc
loc) Info AppRes
appres,
      AppRes -> StructType
appResType (forall a. Info a -> a
unInfo Info AppRes
appres) forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` TypeAliases -> Set Alias
aliases TypeAliases
v_als
    )
checkExp (Assert Size
e1 Size
e2 Info Text
t SrcLoc
loc) = do
  (Size
e1', TypeAliases
_) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e1
  (Size
e2', TypeAliases
e2_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
ExpBase f vn -> ExpBase f vn -> f Text -> SrcLoc -> ExpBase f vn
Assert Size
e1' Size
e2' Info Text
t SrcLoc
loc, TypeAliases
e2_als)
checkExp (Parens Size
e SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. ExpBase f vn -> SrcLoc -> ExpBase f vn
Parens Size
e' SrcLoc
loc, TypeAliases
e_als)
checkExp (QualParens (QualName VName, SrcLoc)
v Size
e SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
(QualName vn, SrcLoc) -> ExpBase f vn -> SrcLoc -> ExpBase f vn
QualParens (QualName VName, SrcLoc)
v Size
e' SrcLoc
loc, TypeAliases
e_als)
checkExp (Attr AttrInfo VName
attr Size
e SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
AttrInfo vn -> ExpBase f vn -> SrcLoc -> ExpBase f vn
Attr AttrInfo VName
attr Size
e' SrcLoc
loc, TypeAliases
e_als)
checkExp (Project Name
name Size
e Info StructType
t SrcLoc
loc) = do
  (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
Name -> ExpBase f vn -> f StructType -> SrcLoc -> ExpBase f vn
Project Name
name Size
e' Info StructType
t SrcLoc
loc,
      case TypeAliases
e_als of
        Scalar (Record Map Name TypeAliases
fs)
          | Just TypeAliases
name_als <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name Map Name TypeAliases
fs -> TypeAliases
name_als
        TypeAliases
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkExp Project: bad type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettyString TypeAliases
e_als
    )
checkExp (TupLit [Size]
es SrcLoc
loc) = do
  ([Size]
es', [TypeAliases]
es_als) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Size -> CheckM (Size, TypeAliases)
checkExp [Size]
es
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. [ExpBase f vn] -> SrcLoc -> ExpBase f vn
TupLit [Size]
es' SrcLoc
loc, forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim as. [TypeBase dim as] -> ScalarTypeBase dim as
tupleRecord [TypeAliases]
es_als)
checkExp (Constr Name
name [Size]
es Info StructType
t SrcLoc
loc) = do
  ([Size]
es', [TypeAliases]
es_als) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Size -> CheckM (Size, TypeAliases)
checkExp [Size]
es
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
Name -> [ExpBase f vn] -> f StructType -> SrcLoc -> ExpBase f vn
Constr Name
name [Size]
es' Info StructType
t SrcLoc
loc,
      case forall a. Info a -> a
unInfo Info StructType
t of
        Scalar (Sum Map Name [StructType]
cs) ->
          forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall dim u. Map Name [TypeBase dim u] -> ScalarTypeBase dim u
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [TypeAliases]
es_als forall a b. (a -> b) -> a -> b
$
            forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> b) -> [a] -> [b]
map (forall dim asf ast. TypeBase dim asf -> ast -> TypeBase dim ast
`setAliases` forall a. Monoid a => a
mempty)) Map Name [StructType]
cs
        StructType
t' -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkExp Constr: bad type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettyString StructType
t'
    )
checkExp (RecordUpdate Size
src [Name]
fields Size
ve Info StructType
t SrcLoc
loc) = do
  (Size
src', TypeAliases
src_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
src
  (Size
ve', TypeAliases
ve_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
ve
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall (f :: * -> *) vn.
ExpBase f vn
-> [Name] -> ExpBase f vn -> f StructType -> SrcLoc -> ExpBase f vn
RecordUpdate Size
src' [Name]
fields Size
ve' Info StructType
t SrcLoc
loc,
      TypeAliases -> [Name] -> TypeAliases -> TypeAliases
setFieldAliases TypeAliases
ve_als [Name]
fields TypeAliases
src_als
    )
checkExp (RecordLit [FieldBase Info VName]
fs SrcLoc
loc) = do
  ([FieldBase Info VName]
fs', [(Name, TypeAliases)]
fs_als) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM FieldBase Info VName
-> CheckM (FieldBase Info VName, (Name, TypeAliases))
checkField [FieldBase Info VName]
fs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn. [FieldBase f vn] -> SrcLoc -> ExpBase f vn
RecordLit [FieldBase Info VName]
fs' SrcLoc
loc, forall dim u. ScalarTypeBase dim u -> TypeBase dim u
Scalar forall a b. (a -> b) -> a -> b
$ forall dim u. Map Name (TypeBase dim u) -> ScalarTypeBase dim u
Record forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, TypeAliases)]
fs_als)
  where
    checkField :: FieldBase Info VName
-> CheckM (FieldBase Info VName, (Name, TypeAliases))
checkField (RecordFieldExplicit Name
name Size
e SrcLoc
floc) = do
      (Size
e', TypeAliases
e_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
e
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
Name -> ExpBase f vn -> SrcLoc -> FieldBase f vn
RecordFieldExplicit Name
name Size
e' SrcLoc
floc, (Name
name, TypeAliases
e_als))
    checkField (RecordFieldImplicit VName
name Info StructType
t SrcLoc
floc) = do
      TypeAliases
name_als <- Loc -> VName -> StructType -> CheckM TypeAliases
observeVar (forall a. Located a => a -> Loc
locOf SrcLoc
floc) VName
name forall a b. (a -> b) -> a -> b
$ forall a. Info a -> a
unInfo Info StructType
t
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) vn.
vn -> f StructType -> SrcLoc -> FieldBase f vn
RecordFieldImplicit VName
name Info StructType
t SrcLoc
floc, (VName -> Name
baseName VName
name, TypeAliases
name_als))

-- Cases that create alias-free values.
checkExp e :: Size
e@(AppExp Range {} Info AppRes
_) = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@IntLit {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@FloatLit {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@Literal {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@StringLit {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@ArrayLit {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@Negate {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@Not {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e
checkExp e :: Size
e@Hole {} = Size -> CheckM (Size, TypeAliases)
noAliases Size
e

checkGlobalAliases :: SrcLoc -> [Pat ParamType] -> TypeAliases -> CheckM ()
checkGlobalAliases :: SrcLoc -> [Pat (TypeBase Size Diet)] -> TypeAliases -> CheckM ()
checkGlobalAliases SrcLoc
loc [Pat (TypeBase Size Diet)]
params TypeAliases
body_t = do
  Map VName (Entry TypeAliases)
vtable <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CheckEnv -> Map VName (Entry TypeAliases)
envVtable
  let global :: VName -> Bool
global = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
M.notMember Map VName (Entry TypeAliases)
vtable
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pat (TypeBase Size Diet)]
params) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set Alias -> Names
boundAliases forall a b. (a -> b) -> a -> b
$ TypeAliases -> Set Alias
arrayAliases TypeAliases
body_t) forall a b. (a -> b) -> a -> b
$ \VName
v ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VName -> Bool
global VName
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError SrcLoc
loc forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann
withIndexLink Doc ()
"alias-free-variable" forall a b. (a -> b) -> a -> b
$
      Doc ()
"Function result aliases the free variable "
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
dquotes (forall v a. IsName v => v -> Doc a
prettyName VName
v)
        forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
        forall ann. Doc ann -> Doc ann -> Doc ann
</> Doc ()
"Use"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes Doc ()
"copy"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"to break the aliasing."

-- | Type-check a value definition.  This also infers a new return
-- type that may be more unique than previously.
checkValDef ::
  (VName, [Pat ParamType], Exp, ResRetType, Maybe (TypeExp Info VName), SrcLoc) ->
  ((Exp, ResRetType), [TypeError])
checkValDef :: (VName, [Pat (TypeBase Size Diet)], Size,
 RetTypeBase Size Uniqueness, Maybe (TypeExp Info VName), SrcLoc)
-> ((Size, RetTypeBase Size Uniqueness), [TypeError])
checkValDef (VName
_fname, [Pat (TypeBase Size Diet)]
params, Size
body, RetType [VName]
ext ResType
ret, Maybe (TypeExp Info VName)
retdecl, SrcLoc
loc) = forall a. Loc -> CheckM a -> (a, [TypeError])
runCheckM (forall a. Located a => a -> Loc
locOf SrcLoc
loc) forall a b. (a -> b) -> a -> b
$ do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
[Pat (TypeBase Size Diet)]
-> CheckM (a, TypeAliases) -> CheckM (a, TypeAliases)
bindingParams [Pat (TypeBase Size Diet)]
params forall a b. (a -> b) -> a -> b
$ do
    (Size
body', TypeAliases
body_als) <- Size -> CheckM (Size, TypeAliases)
checkExp Size
body
    SrcLoc
-> [Pat (TypeBase Size Diet)]
-> ResType
-> TypeAliases
-> CheckM ()
checkReturnAlias SrcLoc
loc [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
body_als
    SrcLoc -> [Pat (TypeBase Size Diet)] -> TypeAliases -> CheckM ()
checkGlobalAliases SrcLoc
loc [Pat (TypeBase Size Diet)]
params TypeAliases
body_als
    -- If the user did not provide an annotation (meaning the return
    -- type is fully inferred), we infer the uniqueness.  Otherwise,
    -- we go with whatever they wanted.  This lets the user define
    -- non-unique return types even if the body actually has no
    -- aliases.
    RetTypeBase Size Uniqueness
ret' <- case Maybe (TypeExp Info VName)
retdecl of
      Just TypeExp Info VName
retdecl' -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pat (TypeBase Size Diet)]
params Bool -> Bool -> Bool
&& forall shape. TypeBase shape Uniqueness -> Bool
unique ResType
ret) forall a b. (a -> b) -> a -> b
$
          forall loc. Located loc => loc -> Notes -> Doc () -> CheckM ()
addError TypeExp Info VName
retdecl' forall a. Monoid a => a
mempty Doc ()
"A top-level constant cannot have a unique type."
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext ResType
ret
      Maybe (TypeExp Info VName)
Nothing ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall dim as. [VName] -> TypeBase dim as -> RetTypeBase dim as
RetType [VName]
ext forall a b. (a -> b) -> a -> b
$ [Pat (TypeBase Size Diet)] -> ResType -> TypeAliases -> ResType
inferReturnUniqueness [Pat (TypeBase Size Diet)]
params ResType
ret TypeAliases
body_als
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( (Size
body', RetTypeBase Size Uniqueness
ret'),
        TypeAliases
body_als -- Don't matter.
      )
{-# NOINLINE checkValDef #-}