diff --git a/docs/installation.rst b/docs/installation.rst
--- a/docs/installation.rst
+++ b/docs/installation.rst
@@ -6,8 +6,8 @@
There are two main ways to install the Futhark compiler: using a
precompiled tarball or compiling from source. Both methods are
discussed below. If you are using Linux, see
-:ref:`linux-installation`. If you are using Windows, make sure to
-read :ref:`windows-installation`. If you are using macOS, read
+:ref:`linux-installation`. If you are using Windows, see read
+:ref:`windows-installation`. If you are using macOS, see
:ref:`macos-installation`.
Futhark is also available via `Nix `_. If you
@@ -118,9 +118,6 @@
**Linux (x86_64)**
`futhark-nightly-linux-x86_64.tar.xz `_
-**Windows (x86_64)**
- `futhark-nightly-windows-x86_64.zip `_
-
You will still likely need to make a C compiler (such as GCC) available on your own.
.. _`Haskell tool stack`: http://docs.haskellstack.org/
@@ -207,165 +204,13 @@
Setting up Futhark on Windows
-----------------------------
-The Futhark compiler itself is easily installed on Windows via
-``stack`` (see above). If you are using the default Windows console,
-you may need to run ``chcp 65001`` to make Unicode characters show up
-correctly.
-
-It takes a little more work to make the OpenCL and PyOpenCL backends
-functional. This guide was last updated on the 5th of May 2016, and
-is for computers using 64-bit Windows along with `CUDA 7.5`_ and
-Python 2.7 (`Anaconda`_ preferred).
-
-Also `Git for Windows`_ is required for its Linux command line tools.
-If you have not marked the option to add them to path, there are
-instructions below how to do so. The GUI alternative to ``git``,
-`GitHub Desktop`_ is optional and does not come with the required
-tools.
-
-.. _`CUDA 7.5`: https://developer.nvidia.com/cuda-downloads
-.. _`Anaconda`: https://www.continuum.io/downloads#_windows
-.. _`Git for Windows`: https://git-scm.com/download/win
-.. _`GitHub Desktop`: https://desktop.github.com/
-
-Setting up Futhark and OpenCL
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-1) Clone the Futhark repository to your hard drive.
-
-2) Install `Stack`_ using the 64-bit installer. Compile the Futhark
- compiler as described in :ref:`installation`.
-
-3) For editing environment variables it is strongly recommended that
- you install the `Rapid Environment Editor`_
-
-4) For a Futhark compatible C/C++ compiler, that you will also need to
- install pyOpenCL later, install MingWpy. Do this using the ``pip
- install -i https://pypi.anaconda.org/carlkl/simple mingwpy``
- command.
-
-5) Assuming you have the latest Anaconda distribution as your primary
- one, it will get installed to a place such as
- ``C:\Users\UserName\Anaconda2\share\mingwpy``. The pip installation
- will not add its bin or include directories to path.
-
- To do so, open the Rapid Environment Editor and add
- ``C:\Users\UserName\Anaconda2\share\mingwpy\bin`` to the system-wide
- ``PATH`` variable.
-
- If you have other MingW or GCC distributions, make sure MingWpy takes
- priority by moving its entry above the other distributions. You can
- also change which Python distribution is the default one using the
- same trick should you need so.
-
- If have done so correctly, typing ``where gcc`` in the command prompt
- should list the aforementioned MingWpy installation at the top or show
- only it.
-
- To finish the installation, add the
- ``C:\Users\UserName\Anaconda2\share\mingwpy\include`` to the ``CPATH``
- environment variable (note: *not* ``PATH``). Create the variable if
- necessary.
-
-6) The header files and the .dll for OpenCL that comes with the CUDA
- 7.5 distribution also need to be installed into MingWpy. Go to
- ``C:\Program Files\NVIDIA GPU Computing Toolkit\CUDA\v7.5\include``
- and copy the ``CL`` directory into the MingWpy ``include`` directory.
-
- Next, go to ``C:\Program Files\NVIDIA Corporation\OpenCL`` and copy
- the ``OpenCL64.dll`` file into the MingWpy ``lib`` directory (it is
- next to ``include``).
-
- The CUDA distribution also comes with the static ``OpenCL.lib``, but
- trying to use that one instead of the ``OpenCL64.dll`` will cause
- programs compiled with ``futhark opencl`` to crash, so ignore it
- completely.
-
-Now you should be able to compile with ``futhark opencl`` and run
-Futhark programs on the GPU.
-
-Congratulations!
-
-.. _`Stack`: http://docs.haskellstack.org/en/stable/install_and_upgrade/#windows
-.. _`Rapid Environment Editor`: http://www.rapidee.com/en/about
-
-Setting up PyOpenCL
-~~~~~~~~~~~~~~~~~~~
-
-The following instructions are for how to setup the
-``futhark-pyopencl`` backend.
-
-First install Mako using ``pip install mako``.
-
-Also install PyPNG using ``pip install pypng`` (not stricly necessary,
-but some examples make use of it).
-
-7) Clone the `PyOpenCL repository`_ to your hard drive. Do
- this instead of downloading the zip, as the zip will not contain
- some of the other repositories it links to and you will end up with
- missing header files.
-
-8) If you have ignored the instructions and gotten Python 3.x instead
- 2.7, you will have to do some extra work.
-
- Edit ``.\pyopencl\compyte\ndarray\gen_elemwise.py`` and
- ``.\pyopencl\compyte\ndarray\test_gpu_ndarray.py`` and convert most
- Python 2.x style print statements to Python 3 syntax. Basically wrap
- print arguments in brackets "(..)" and ignore any lines containing
- StringIO ``>>`` operator.
-
- Otherwise just go to the next point.
-
-9) Go into the repo directory and from the command line execute
- ``python configure.py``.
-
- Edit ``siteconf.py`` to following::
-
- CL_TRACE = false
- CL_ENABLE_GL = false
- CL_INC_DIR = ['c:\\Program Files\\NVIDIA GPU Computing Toolkit\\CUDA\\v7.5\\include']
- CL_LIB_DIR = ['C:\\Program Files\\NVIDIA GPU Computing Toolkit\\CUDA\\v7.5\\lib\\x64']
- CL_LIBNAME = ['OpenCL']
- CXXFLAGS = ['-std=c++0x']
- LDFLAGS = []
-
- Run the following commands::
-
- > python setup.py build_ext --compiler=mingw32
- > python setup.py install
-
-If everything went in order, pyOpenCL should be installed on your machine now.
-
-10) Lastly, Pygame needs to be installed. Again, not stricly
- necessary, but some examples make use of it. To do so on Windows,
- download ``pygame-1.9.2a0-cp27-none-win_amd64.whl`` from `here
- `_. ``cp27``
- means Python 2.7 and ``win_amd64`` means 64-bit Windows.
-
- Go to the directory you have downloaded the file and execute ``pip
- install pygame-1.9.2a0-cp27-none-win_amd64.whl`` from the command
- line.
-
-Now you should be able to run the `Game of Life`_ example.
-
-11) To run the makefiles, first setup ``make`` by going to the ``bin``
- directory of MingWpy and making a copy of
- ``mingw32-make.exe``. Then simply rename ``mingw32-make –
- Copy.exe`` or similar to ``make.exe``. Now you will be able to run
- the makefiles.
-
- Also, if you have not selected to add the optional Linux command
- line tools to ``PATH`` during the ``Git for Windows``
- installation, add the ``C:\Program Files\Git\usr\bin`` directory
- to ``PATH`` manually now.
-
-12) This guide has been written off memory, so if you are having
- difficulties - ask on the `issues page`_. There might be errors in
- it.
+Due to limited maintenance and testing resources, Futhark is not
+directly supported on Windows. Install `WSL
+`_ and follow
+the Linux instructions above. The C code generated by the Futhark
+compiler should work on Windows.
-.. _`PyOpenCL repository`: https://github.com/pyopencl/pyopencl
-.. _`Game of Life`: https://github.com/diku-dk/futhark-benchmarks/tree/master/misc/life
-.. _`issues page`: https://github.com/diku-dk/futhark/issues
+In the future, we may support Windows directly again.
Futhark with Nix
----------------
diff --git a/docs/usage.rst b/docs/usage.rst
--- a/docs/usage.rst
+++ b/docs/usage.rst
@@ -227,8 +227,7 @@
On \*nix (including macOS), the `clinfo
`_ tool (available in many package
managers) can be used to determine which OpenCL platforms and devices
-are available on a given system. On Windows, `CPU-z
-`_ can be used.
+are available on a given system.
CUDA-specific Options
~~~~~~~~~~~~~~~~~~~~~
diff --git a/futhark.cabal b/futhark.cabal
--- a/futhark.cabal
+++ b/futhark.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.4
name: futhark
-version: 0.21.1
+version: 0.21.2
synopsis: An optimising compiler for a functional, array-oriented language.
description: Futhark is a small programming language designed to be compiled to
@@ -60,6 +60,7 @@
Futhark.Analysis.HORep.SOAC
Futhark.Analysis.Interference
Futhark.Analysis.LastUse
+ Futhark.Analysis.MemAlias
Futhark.Analysis.Metrics
Futhark.Analysis.Metrics.Type
Futhark.Analysis.PrimExp
@@ -102,7 +103,6 @@
Futhark.CodeGen.Backends.COpenCL.Boilerplate
Futhark.CodeGen.Backends.GenericC
Futhark.CodeGen.Backends.GenericC.CLI
- Futhark.CodeGen.Backends.GenericC.Manifest
Futhark.CodeGen.Backends.GenericC.Options
Futhark.CodeGen.Backends.GenericC.Server
Futhark.CodeGen.Backends.GenericPython
@@ -195,6 +195,7 @@
Futhark.IR.Syntax
Futhark.IR.Syntax.Core
Futhark.IR.Traversals
+ Futhark.IR.TypeCheck
Futhark.Internalise
Futhark.Internalise.AccurateSizes
Futhark.Internalise.Bindings
@@ -268,7 +269,6 @@
Futhark.Transform.FirstOrderTransform
Futhark.Transform.Rename
Futhark.Transform.Substitute
- Futhark.TypeCheck
Futhark.Util
Futhark.Util.Console
Futhark.Util.IntegralExp
@@ -333,6 +333,7 @@
, free >=4.12.4
, futhark-data >= 1.0.3.0
, futhark-server >= 1.1.2.0
+ , futhark-manifest >= 1.0.0.0
, githash >=0.1.6.1
, half >= 0.3
, haskeline
diff --git a/prelude/soacs.fut b/prelude/soacs.fut
--- a/prelude/soacs.fut
+++ b/prelude/soacs.fut
@@ -132,8 +132,16 @@
--
-- In practice, the *O(n)* behaviour only occurs if *m* is also very
-- large.
-def reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a =
- intrinsics.hist (1, dest, f, ne, is, as) :> *[m]a
+def reduce_by_index 'a [n] [m] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a =
+ intrinsics.hist_1d (1, dest, f, ne, is, as)
+
+-- | As `reduce_by_index`, but with two-dimensional indexes.
+def reduce_by_index_2d 'a [n] [m] [k] (dest : *[m][k]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64)) (as : [n]a) : *[m][k]a =
+ intrinsics.hist_2d (1, dest, f, ne, is, as)
+
+-- | As `reduce_by_index`, but with three-dimensional indexes.
+def reduce_by_index_3d 'a [n] [m] [k] [l] (dest : *[m][k][l]a) (f : a -> a -> a) (ne : a) (is : [n](i64,i64,i64)) (as : [n]a) : *[m][k][l]a =
+ intrinsics.hist_3d (1, dest, f, ne, is, as)
-- | Inclusive prefix scan. Has the same caveats with respect to
-- associativity and complexity as `reduce`.
diff --git a/rts/c/scheduler.h b/rts/c/scheduler.h
--- a/rts/c/scheduler.h
+++ b/rts/c/scheduler.h
@@ -1113,6 +1113,10 @@
}
static int scheduler_destroy(struct scheduler *scheduler) {
+ // We assume that this function is called by the thread controlling
+ // the first worker, which is why we treat scheduler->workers[0]
+ // specially here.
+
// First mark them all as dead.
for (int i = 1; i < scheduler->num_threads; i++) {
struct worker *cur_worker = &scheduler->workers[i];
@@ -1132,8 +1136,8 @@
CHECK_ERR(pthread_join(scheduler->workers[i].thread, NULL), "pthread_join");
}
- // And then destroy our local queue.
- subtask_queue_destroy(&worker_local->q);
+ // And then destroy our own queue.
+ subtask_queue_destroy(&scheduler->workers[0].q);
free(scheduler->workers);
diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs
--- a/src/Futhark/Actions.hs
+++ b/src/Futhark/Actions.hs
@@ -6,6 +6,9 @@
module Futhark.Actions
( printAction,
printAliasesAction,
+ printLastUseGPU,
+ printInterferenceGPU,
+ printMemAliasGPU,
callGraphAction,
impCodeGenAction,
kernelImpCodeGenAction,
@@ -30,6 +33,9 @@
import qualified Data.Text.IO as T
import Futhark.Analysis.Alias
import Futhark.Analysis.CallGraph (buildCallGraph)
+import qualified Futhark.Analysis.Interference as Interference
+import qualified Futhark.Analysis.LastUse as LastUse
+import qualified Futhark.Analysis.MemAlias as MemAlias
import Futhark.Analysis.Metrics
import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA
import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL
@@ -74,6 +80,33 @@
actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis
}
+-- | Print last use information to stdout.
+printLastUseGPU :: Action GPUMem
+printLastUseGPU =
+ Action
+ { actionName = "print last use gpu",
+ actionDescription = "Print last use information on gpu.",
+ actionProcedure = liftIO . putStrLn . pretty . LastUse.analyseGPUMem
+ }
+
+-- | Print interference information to stdout.
+printInterferenceGPU :: Action GPUMem
+printInterferenceGPU =
+ Action
+ { actionName = "print interference gpu",
+ actionDescription = "Print interference information on gpu.",
+ actionProcedure = liftIO . putStrLn . pretty . Interference.analyseProgGPU
+ }
+
+-- | Print memory alias information to stdout
+printMemAliasGPU :: Action GPUMem
+printMemAliasGPU =
+ Action
+ { actionName = "print mem alias gpu",
+ actionDescription = "Print memory alias information on gpu.",
+ actionProcedure = liftIO . putStrLn . pretty . MemAlias.analyzeGPUMem
+ }
+
-- | Print call graph to stdout.
callGraphAction :: Action SOACS
callGraphAction =
@@ -176,7 +209,7 @@
}
where
helper prog = do
- cprog <- handleWarnings fcfg $ SequentialC.compileProg prog
+ cprog <- handleWarnings fcfg $ SequentialC.compileProg (T.pack versionString) prog
let cpath = outpath `addExtension` "c"
hpath = outpath `addExtension` "h"
jsonpath = outpath `addExtension` "json"
@@ -204,7 +237,7 @@
}
where
helper prog = do
- cprog <- handleWarnings fcfg $ COpenCL.compileProg prog
+ cprog <- handleWarnings fcfg $ COpenCL.compileProg (T.pack versionString) prog
let cpath = outpath `addExtension` "c"
hpath = outpath `addExtension` "h"
jsonpath = outpath `addExtension` "json"
@@ -239,7 +272,7 @@
}
where
helper prog = do
- cprog <- handleWarnings fcfg $ CCUDA.compileProg prog
+ cprog <- handleWarnings fcfg $ CCUDA.compileProg (T.pack versionString) prog
let cpath = outpath `addExtension` "c"
hpath = outpath `addExtension` "h"
jsonpath = outpath `addExtension` "json"
@@ -271,7 +304,7 @@
}
where
helper prog = do
- cprog <- handleWarnings fcfg $ MulticoreC.compileProg prog
+ cprog <- handleWarnings fcfg $ MulticoreC.compileProg (T.pack versionString) prog
let cpath = outpath `addExtension` "c"
hpath = outpath `addExtension` "h"
jsonpath = outpath `addExtension` "json"
@@ -379,7 +412,9 @@
}
where
helper prog = do
- (cprog, jsprog, exps) <- handleWarnings fcfg $ SequentialWASM.compileProg prog
+ (cprog, jsprog, exps) <-
+ handleWarnings fcfg $
+ SequentialWASM.compileProg (T.pack versionString) prog
case mode of
ToLibrary -> do
writeLibs cprog jsprog
@@ -411,7 +446,9 @@
}
where
helper prog = do
- (cprog, jsprog, exps) <- handleWarnings fcfg $ MulticoreWASM.compileProg prog
+ (cprog, jsprog, exps) <-
+ handleWarnings fcfg $
+ MulticoreWASM.compileProg (T.pack versionString) prog
case mode of
ToLibrary -> do
diff --git a/src/Futhark/Analysis/HORep/SOAC.hs b/src/Futhark/Analysis/HORep/SOAC.hs
--- a/src/Futhark/Analysis/HORep/SOAC.hs
+++ b/src/Futhark/Analysis/HORep/SOAC.hs
@@ -459,7 +459,7 @@
scremaType w form
typeOf (Hist _ ops _ _) = do
op <- ops
- map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op)
+ map (`arrayOfShape` histShape op) (lambdaReturnType $ histOp op)
-- | The "width" of a SOAC is the expected outer size of its array
-- inputs _after_ input-transforms have been carried out.
diff --git a/src/Futhark/Analysis/Interference.hs b/src/Futhark/Analysis/Interference.hs
--- a/src/Futhark/Analysis/Interference.hs
+++ b/src/Futhark/Analysis/Interference.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE TypeFamilies #-}
-- | Interference analysis for Futhark programs.
-module Futhark.Analysis.Interference (Graph, analyseGPU) where
+module Futhark.Analysis.Interference (Graph, analyseProgGPU) where
import Control.Monad.Reader
import Data.Foldable (toList)
@@ -15,6 +15,8 @@
import Data.Set (Set)
import qualified Data.Set as S
import Futhark.Analysis.LastUse (LastUseMap)
+import qualified Futhark.Analysis.LastUse as LastUse
+import qualified Futhark.Analysis.MemAlias as MemAlias
import Futhark.IR.GPUMem
import Futhark.Util (invertMap)
@@ -41,8 +43,7 @@
-- combinator function.
cartesian :: (Monoid m, Foldable t) => (a -> a -> m) -> t a -> t a -> m
cartesian f xs ys =
- [(x, y) | x <- toList xs, y <- toList ys]
- & foldMap (uncurry f)
+ foldMap (uncurry f) [(x, y) | x <- toList xs, y <- toList ys]
analyseStm ::
LocalScope GPUMem m =>
@@ -215,6 +216,29 @@
m (InUse, LastUsed, Graph VName)
analyseLambda lumap inuse (Lambda _ body _) =
analyseBody lumap inuse body
+
+analyseProgGPU :: Prog GPUMem -> Graph VName
+analyseProgGPU prog =
+ let (lumap, _) = LastUse.analyseGPUMem prog
+ graph =
+ foldMap
+ ( \f ->
+ runReader (analyseGPU lumap $ bodyStms $ funDefBody f) $
+ scopeOf f
+ )
+ $ progFuns prog
+ graph' = applyAliases (MemAlias.analyzeGPUMem prog) graph
+ in graph'
+
+applyAliases :: MemAlias.MemAliases -> Graph VName -> Graph VName
+applyAliases aliases =
+ -- For each pair @(x, y)@ in graph, all memory aliases of x should interfere with all memory aliases of y
+ foldMap
+ ( \(x, y) ->
+ let xs = MemAlias.aliasesOf aliases x <> oneName x
+ ys = MemAlias.aliasesOf aliases y <> oneName y
+ in cartesian makeEdge (namesToList xs) (namesToList ys)
+ )
-- | Perform interference analysis on the given statements. The result is a
-- triple of the names currently in use, names that hit their last use somewhere
diff --git a/src/Futhark/Analysis/LastUse.hs b/src/Futhark/Analysis/LastUse.hs
--- a/src/Futhark/Analysis/LastUse.hs
+++ b/src/Futhark/Analysis/LastUse.hs
@@ -1,9 +1,13 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Provides last-use analysis for Futhark programs.
-module Futhark.Analysis.LastUse (LastUseMap, analyseProg) where
+module Futhark.Analysis.LastUse (LastUseMap, analyseGPUMem, analyseSeqMem) where
+import Control.Monad.Reader
import Data.Bifunctor (first)
import Data.Foldable
import Data.Function ((&))
@@ -13,6 +17,7 @@
import Futhark.Analysis.Alias (aliasAnalysis)
import Futhark.IR.Aliases
import Futhark.IR.GPUMem
+import Futhark.IR.SeqMem
-- | `LastUseMap` tells which names were last used in a given statement.
-- Statements are uniquely identified by the `VName` of the first value
@@ -27,31 +32,93 @@
-- or otherwise.
type Used = Names
+type LastUseOp rep =
+ VName -> (LastUse, Used) -> Op (Aliases rep) -> LastUseM rep
+
+newtype Env rep = Env {envLastUseOp :: LastUseOp rep}
+
+type LastUseM rep = Reader (Env rep) (LastUse, Used)
+
+analyseGPUMem :: Prog GPUMem -> (LastUseMap, Used)
+analyseGPUMem = analyseProg analyseGPUOp
+
+analyseSeqMem :: Prog SeqMem -> (LastUseMap, Used)
+analyseSeqMem = analyseProg analyseSeqOp
+
+analyseGPUOp :: LastUseOp GPUMem
+analyseGPUOp pat_name (lumap, used) (Alloc se sp) = do
+ let nms = (freeIn se <> freeIn sp) `namesSubtract` used
+ return (insertNames pat_name nms lumap, used <> nms)
+analyseGPUOp pat_name (lumap, used) (Inner (SizeOp sop)) = do
+ let nms = freeIn sop `namesSubtract` used
+ return (insertNames pat_name nms lumap, used <> nms)
+analyseGPUOp _ (lumap, used) (Inner (OtherOp ())) =
+ return (lumap, used)
+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegMap lvl _ tps body))) = do
+ (lumap', used') <- analyseKernelBody (lumap, used) body
+ let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'
+ return (insertNames pat_name nms lumap', used' <> nms)
+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegRed lvl _ binops tps body))) =
+ segOpHelper pat_name lumap used lvl binops tps body
+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegScan lvl _ binops tps body))) =
+ segOpHelper pat_name lumap used lvl binops tps body
+analyseGPUOp pat_name (lumap, used) (Inner (SegOp (SegHist lvl _ binops tps body))) = do
+ (lumap', used') <- foldM analyseHistOp (lumap, used) $ reverse binops
+ (lumap'', used'') <- analyseKernelBody (lumap', used') body
+ let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''
+ return (insertNames pat_name nms lumap'', used'' <> nms)
+
+segOpHelper ::
+ (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>
+ VName ->
+ LastUse ->
+ Used ->
+ SegLevel ->
+ [SegBinOp (Aliases rep)] ->
+ [Type] ->
+ KernelBody (Aliases rep) ->
+ LastUseM rep
+segOpHelper pat_name lumap used lvl binops tps body = do
+ (lumap', used') <- foldM analyseSegBinOp (lumap, used) $ reverse binops
+ (lumap'', used'') <- analyseKernelBody (lumap', used') body
+ let nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''
+ return (insertNames pat_name nms lumap'', used'' <> nms)
+
+analyseSeqOp :: LastUseOp SeqMem
+analyseSeqOp pat_name (lumap, used) (Alloc se sp) = do
+ let nms = (freeIn se <> freeIn sp) `namesSubtract` used
+ return (insertNames pat_name nms lumap, used <> nms)
+analyseSeqOp _ (lumap, used) (Inner ()) =
+ return (lumap, used)
+
-- | Analyses a program to return a last-use map, mapping each simple statement
-- in the program to the values that were last used within that statement, and
-- the set of all `VName` that were used inside.
-analyseProg :: Prog GPUMem -> (LastUseMap, Used)
-analyseProg prog =
- let consts =
- progConsts prog
- & concatMap (toList . fmap patElemName . patElems . stmPat)
- & namesFromList
- funs = progFuns $ aliasAnalysis prog
- (lus, used) = foldMap (analyseFun mempty consts) funs
- in (flipMap lus, used)
+analyseProg :: (CanBeAliased (Op rep), Mem rep inner) => LastUseOp rep -> Prog rep -> (LastUseMap, Used)
+analyseProg onOp prog =
+ runReader helper (Env onOp)
+ where
+ helper = do
+ let consts =
+ progConsts prog
+ & concatMap (toList . fmap patElemName . patElems . stmPat)
+ & namesFromList
+ funs = progFuns $ aliasAnalysis prog
+ (lus, used) <- mconcat <$> mapM (analyseFun mempty consts) funs
+ return (flipMap lus, used)
-analyseFun :: LastUse -> Used -> FunDef (Aliases GPUMem) -> (LastUse, Used)
-analyseFun lumap used fun =
- let (lumap', used') = analyseBody lumap used $ funDefBody fun
- in (lumap', used' <> freeIn (funDefParams fun))
+analyseFun :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> FunDef (Aliases rep) -> LastUseM rep
+analyseFun lumap used fun = do
+ (lumap', used') <- analyseBody lumap used $ funDefBody fun
+ return (lumap', used' <> freeIn (funDefParams fun))
-analyseStms :: LastUse -> Used -> Stms (Aliases GPUMem) -> (LastUse, Used)
-analyseStms lumap used stms = foldr analyseStm (lumap, used) $ stmsToList stms
+analyseStms :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Stms (Aliases rep) -> LastUseM rep
+analyseStms lumap used stms = foldM analyseStm (lumap, used) $ reverse $ stmsToList stms
-analyseStm :: Stm (Aliases GPUMem) -> (LastUse, Used) -> (LastUse, Used)
-analyseStm (Let pat _ e) (lumap0, used0) =
+analyseStm :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Stm (Aliases rep) -> LastUseM rep
+analyseStm (lumap0, used0) (Let pat _ e) = do
let (lumap', used') = patElems pat & foldl helper (lumap0, used0)
- in analyseExp (lumap', used') e
+ analyseExp (lumap', used') e
where
helper (lumap_acc, used_acc) (PatElem name (aliases, _)) =
-- Any aliases of `name` should have the same last-use as `name`
@@ -63,92 +130,72 @@
)
pat_name = patElemName $ head $ patElems pat
- analyseExp :: (LastUse, Used) -> Exp (Aliases GPUMem) -> (LastUse, Used)
- analyseExp (lumap, used) (BasicOp _) =
+
+ analyseExp (lumap, used) (BasicOp _) = do
let nms = freeIn e `namesSubtract` used
- in (insertNames pat_name nms lumap, used <> nms)
- analyseExp (lumap, used) (Apply _ args _ _) =
+ return (insertNames pat_name nms lumap, used <> nms)
+ analyseExp (lumap, used) (Apply _ args _ _) = do
let nms = freeIn $ map fst args
- in (insertNames pat_name nms lumap, used <> nms)
- analyseExp (lumap, used) (If cse then_body else_body dec) =
- let (lumap_then, used_then) = analyseBody lumap used then_body
- (lumap_else, used_else) = analyseBody lumap used else_body
- used' = used_then <> used_else
- nms = ((freeIn cse <> freeIn dec) `namesSubtract` used')
- in (insertNames pat_name nms (lumap_then <> lumap_else), used' <> nms)
- analyseExp (lumap, used) (DoLoop merge form body) =
- let (lumap', used') = analyseBody lumap used body
- nms = (freeIn merge <> freeIn form) `namesSubtract` used'
- in (insertNames pat_name nms lumap', used' <> nms)
- analyseExp (lumap, used) (Op (Alloc se sp)) =
- let nms = (freeIn se <> freeIn sp) `namesSubtract` used
- in (insertNames pat_name nms lumap, used <> nms)
- analyseExp (lumap, used) (Op (Inner (SizeOp sop))) =
- let nms = freeIn sop `namesSubtract` used
- in (insertNames pat_name nms lumap, used <> nms)
- analyseExp (lumap, used) (Op (Inner (OtherOp ()))) =
- (lumap, used)
- analyseExp (lumap, used) (Op (Inner (SegOp (SegMap lvl _ tps body)))) =
- let (lumap', used') = analyseKernelBody (lumap, used) body
- nms = (freeIn lvl <> freeIn tps) `namesSubtract` used'
- in (insertNames pat_name nms lumap', used' <> nms)
- analyseExp (lumap, used) (Op (Inner (SegOp (SegRed lvl _ binops tps body)))) =
- segOpHelper lumap used lvl binops tps body
- analyseExp (lumap, used) (Op (Inner (SegOp (SegScan lvl _ binops tps body)))) =
- segOpHelper lumap used lvl binops tps body
- analyseExp (lumap, used) (Op (Inner (SegOp (SegHist lvl _ binops tps body)))) =
- let (lumap', used') = foldr analyseHistOp (lumap, used) binops
- (lumap'', used'') = analyseKernelBody (lumap', used') body
- nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''
- in (insertNames pat_name nms lumap'', used'' <> nms)
+ return (insertNames pat_name nms lumap, used <> nms)
+ analyseExp (lumap, used) (If cse then_body else_body dec) = do
+ (lumap_then, used_then) <- analyseBody lumap used then_body
+ (lumap_else, used_else) <- analyseBody lumap used else_body
+ let used' = used_then <> used_else
+ nms = (freeIn cse <> freeIn dec) `namesSubtract` used'
+ return (insertNames pat_name nms (lumap_then <> lumap_else), used' <> nms)
+ analyseExp (lumap, used) (DoLoop merge form body) = do
+ (lumap', used') <- analyseBody lumap used body
+ let nms = (freeIn merge <> freeIn form) `namesSubtract` used'
+ return (insertNames pat_name nms lumap', used' <> nms)
+ analyseExp (lumap, used) (Op op) = do
+ onOp <- asks envLastUseOp
+ onOp pat_name (lumap, used) op
analyseExp (lumap, used) (WithAcc _ l) =
analyseLambda (lumap, used) l
- segOpHelper lumap used lvl binops tps body =
- let (lumap', used') = foldr analyseSegBinOp (lumap, used) binops
- (lumap'', used'') = analyseKernelBody (lumap', used') body
- nms = (freeIn lvl <> freeIn tps) `namesSubtract` used''
- in (insertNames pat_name nms lumap'', used'' <> nms)
-analyseBody :: LastUse -> Used -> Body (Aliases GPUMem) -> (LastUse, Used)
-analyseBody lumap used (Body _ stms result) =
+analyseBody :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => LastUse -> Used -> Body (Aliases rep) -> LastUseM rep
+analyseBody lumap used (Body _ stms result) = do
let used' = used <> freeIn result
- in analyseStms lumap used' stms
+ analyseStms lumap used' stms
analyseKernelBody ::
+ (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>
(LastUse, Used) ->
- KernelBody (Aliases GPUMem) ->
- (LastUse, Used)
+ KernelBody (Aliases rep) ->
+ LastUseM rep
analyseKernelBody (lumap, used) (KernelBody _ stms result) =
let used' = used <> freeIn result
in analyseStms lumap used' stms
analyseSegBinOp ::
- SegBinOp (Aliases GPUMem) ->
+ (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>
(LastUse, Used) ->
- (LastUse, Used)
-analyseSegBinOp (SegBinOp _ lambda neutral shp) (lumap, used) =
- let (lumap', used') = analyseLambda (lumap, used) lambda
- nms = (freeIn neutral <> freeIn shp) `namesSubtract` used'
- in (lumap', used' <> nms)
+ SegBinOp (Aliases rep) ->
+ LastUseM rep
+analyseSegBinOp (lumap, used) (SegBinOp _ lambda neutral shp) = do
+ (lumap', used') <- analyseLambda (lumap, used) lambda
+ let nms = (freeIn neutral <> freeIn shp) `namesSubtract` used'
+ return (lumap', used' <> nms)
analyseHistOp ::
- HistOp (Aliases GPUMem) ->
+ (FreeIn (OpWithAliases (Op rep)), ASTRep rep) =>
(LastUse, Used) ->
- (LastUse, Used)
-analyseHistOp (HistOp width race dest neutral shp lambda) (lumap, used) =
- let (lumap', used') = analyseLambda (lumap, used) lambda
- nms =
+ HistOp (Aliases rep) ->
+ LastUseM rep
+analyseHistOp (lumap, used) (HistOp width race dest neutral shp lambda) = do
+ (lumap', used') <- analyseLambda (lumap, used) lambda
+ let nms =
( freeIn width <> freeIn race <> freeIn dest <> freeIn neutral
<> freeIn shp
)
`namesSubtract` used'
- in (lumap', used' <> nms)
+ return (lumap', used' <> nms)
-analyseLambda :: (LastUse, Used) -> Lambda (Aliases GPUMem) -> (LastUse, Used)
-analyseLambda (lumap, used) (Lambda params body ret) =
- let (lumap', used') = analyseBody lumap used body
- used'' = used' <> freeIn params <> freeIn ret
- in (lumap', used'')
+analyseLambda :: (FreeIn (OpWithAliases (Op rep)), ASTRep rep) => (LastUse, Used) -> Lambda (Aliases rep) -> LastUseM rep
+analyseLambda (lumap, used) (Lambda params body ret) = do
+ (lumap', used') <- analyseBody lumap used body
+ let used'' = used' <> freeIn params <> freeIn ret
+ return (lumap', used'')
flipMap :: Map VName VName -> Map VName Names
flipMap m =
diff --git a/src/Futhark/Analysis/MemAlias.hs b/src/Futhark/Analysis/MemAlias.hs
new file mode 100644
--- /dev/null
+++ b/src/Futhark/Analysis/MemAlias.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Futhark.Analysis.MemAlias
+ ( analyzeSeqMem,
+ analyzeGPUMem,
+ canBeSameMemory,
+ aliasesOf,
+ MemAliases,
+ )
+where
+
+import Control.Monad.Reader
+import Data.Bifunctor
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe, mapMaybe)
+import qualified Data.Set as S
+import Futhark.IR.GPUMem
+import Futhark.IR.SeqMem
+import Futhark.Util
+import Futhark.Util.Pretty
+
+-- For our purposes, memory aliases are a bijective function: If @a@ aliases
+-- @b@, @b@ also aliases @a@. However, this relationship is not transitive. Consider for instance the following:
+--
+-- @
+-- let xs@mem_1 =
+-- if ... then
+-- replicate i 0 @ mem_2
+-- else
+-- replicate j 1 @ mem_3
+-- @
+--
+-- Here, @mem_1@ aliases both @mem_2@ and @mem_3@, each of which alias @mem_1@
+-- but not each other.
+newtype MemAliases = MemAliases (M.Map VName Names)
+ deriving (Show, Eq)
+
+instance Semigroup MemAliases where
+ (MemAliases m1) <> (MemAliases m2) = MemAliases $ M.unionWith (<>) m1 m2
+
+instance Monoid MemAliases where
+ mempty = MemAliases mempty
+
+instance Pretty MemAliases where
+ ppr (MemAliases m) = ppr m
+
+addAlias :: VName -> VName -> MemAliases -> MemAliases
+addAlias v1 v2 m =
+ m <> singleton v1 (oneName v2) <> singleton v2 mempty
+
+singleton :: VName -> Names -> MemAliases
+singleton v ns = MemAliases $ M.singleton v ns
+
+canBeSameMemory :: MemAliases -> VName -> VName -> Bool
+canBeSameMemory (MemAliases m) v1 v2 =
+ case fmap (v2 `nameIn`) (M.lookup v1 m) of
+ Just True -> True
+ Just False -> case fmap (v1 `nameIn`) (M.lookup v2 m) of
+ Just b -> b
+ Nothing -> error $ "VName not found in MemAliases: " <> pretty v2
+ Nothing -> error $ "VName not found in MemAliases: " <> pretty v1
+
+aliasesOf :: MemAliases -> VName -> Names
+aliasesOf (MemAliases m) v = fromMaybe mempty $ M.lookup v m
+
+isIn :: VName -> MemAliases -> Bool
+isIn v (MemAliases m) = v `S.member` M.keysSet m
+
+newtype Env inner = Env {onInner :: MemAliases -> inner -> MemAliasesM inner MemAliases}
+
+type MemAliasesM inner a = Reader (Env inner) a
+
+analyzeHostOp :: MemAliases -> HostOp GPUMem () -> MemAliasesM (HostOp GPUMem ()) MemAliases
+analyzeHostOp m (SegOp (SegMap _ _ _ kbody)) =
+ analyzeStms (kernelBodyStms kbody) m
+analyzeHostOp m (SegOp (SegRed _ _ _ _ kbody)) =
+ analyzeStms (kernelBodyStms kbody) m
+analyzeHostOp m (SegOp (SegScan _ _ _ _ kbody)) =
+ analyzeStms (kernelBodyStms kbody) m
+analyzeHostOp m (SegOp (SegHist _ _ _ _ kbody)) =
+ analyzeStms (kernelBodyStms kbody) m
+analyzeHostOp _ _ = return mempty
+
+analyzeStm :: (Mem rep inner, LetDec rep ~ LetDecMem) => MemAliases -> Stm rep -> MemAliasesM inner MemAliases
+analyzeStm m (Let (Pat [PatElem vname _]) _ (Op (Alloc _ _))) =
+ return $ m <> singleton vname mempty
+analyzeStm m (Let _ _ (Op (Inner inner))) = do
+ on_inner <- asks onInner
+ on_inner m inner
+analyzeStm m (Let pat _ (If _ then_body else_body _)) = do
+ m' <-
+ analyzeStms (bodyStms then_body) m
+ >>= analyzeStms (bodyStms else_body)
+ zip (patNames pat) (map resSubExp $ bodyResult then_body)
+ <> zip (patNames pat) (map resSubExp $ bodyResult else_body)
+ & mapMaybe (filterFun m')
+ & foldr (uncurry addAlias) m'
+ & return
+analyzeStm m (Let pat _ (DoLoop params _ body)) = do
+ let m_init =
+ map snd params
+ & zip (patNames pat)
+ & mapMaybe (filterFun m)
+ & foldr (uncurry addAlias) m
+ m_params =
+ mapMaybe (filterFun m_init . first paramName) params
+ & foldr (uncurry addAlias) m_init
+ m_body <- analyzeStms (bodyStms body) m_params
+ zip (patNames pat) (map resSubExp $ bodyResult body)
+ & mapMaybe (filterFun m_body)
+ & foldr (uncurry addAlias) m_body
+ & return
+analyzeStm m _ = return m
+
+filterFun :: MemAliases -> (VName, SubExp) -> Maybe (VName, VName)
+filterFun m' (v, Var v') | v' `isIn` m' = Just (v, v')
+filterFun _ _ = Nothing
+
+analyzeStms :: (Mem rep inner, LetDec rep ~ LetDecMem) => Stms rep -> MemAliases -> MemAliasesM inner MemAliases
+analyzeStms =
+ flip $ foldM analyzeStm
+
+analyzeFun :: (Mem rep inner, LetDec rep ~ LetDecMem) => FunDef rep -> MemAliasesM inner MemAliases
+analyzeFun f =
+ funDefParams f
+ & mapMaybe justMem
+ & mconcat
+ & analyzeStms (bodyStms $ funDefBody f)
+ where
+ justMem (Param _ v (MemMem _)) = Just $ singleton v mempty
+ justMem _ = Nothing
+
+transitiveClosure :: MemAliases -> MemAliases
+transitiveClosure ma@(MemAliases m) =
+ M.foldMapWithKey
+ ( \k ns ->
+ namesToList ns
+ & foldMap (aliasesOf ma)
+ & singleton k
+ )
+ m
+ <> ma
+
+analyzeSeqMem :: Prog SeqMem -> MemAliases
+analyzeSeqMem prog = completeBijection $ runReader (analyze prog) $ Env $ \x _ -> return x
+
+analyzeGPUMem :: Prog GPUMem -> MemAliases
+analyzeGPUMem prog = completeBijection $ runReader (analyze prog) $ Env analyzeHostOp
+
+analyze :: (Mem rep inner, LetDec rep ~ LetDecMem) => Prog rep -> MemAliasesM inner MemAliases
+analyze prog =
+ progFuns prog
+ & foldM (\m f -> (<>) m <$> analyzeFun f) (MemAliases mempty)
+ <&> fixPoint transitiveClosure
+
+completeBijection :: MemAliases -> MemAliases
+completeBijection ma@(MemAliases m) =
+ M.foldMapWithKey (\k ns -> foldMap (`singleton` oneName k) (namesToList ns)) m <> ma
diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs
--- a/src/Futhark/CLI/Dev.hs
+++ b/src/Futhark/CLI/Dev.hs
@@ -25,6 +25,7 @@
import qualified Futhark.IR.SOACS as SOACS
import qualified Futhark.IR.Seq as Seq
import qualified Futhark.IR.SeqMem as SeqMem
+import Futhark.IR.TypeCheck (Checkable, checkProg)
import Futhark.Internalise.Defunctionalise as Defunctionalise
import Futhark.Internalise.Defunctorise as Defunctorise
import Futhark.Internalise.LiftLambdas as LiftLambdas
@@ -48,7 +49,6 @@
import Futhark.Pass.KernelBabysitting
import Futhark.Pass.Simplify
import Futhark.Passes
-import Futhark.TypeCheck (Checkable, checkProg)
import Futhark.Util.Log
import Futhark.Util.Options
import qualified Futhark.Util.Pretty as PP
@@ -121,7 +121,7 @@
representation (Seq _) = "Seq"
representation (GPUMem _) = "GPUMem"
representation (MCMem _) = "MCMem"
- representation (SeqMem _) = "SeqMEm"
+ representation (SeqMem _) = "SeqMem"
instance PP.Pretty UntypedPassState where
ppr (SOACS prog) = PP.ppr prog
@@ -454,6 +454,30 @@
"Print the resulting IR with aliases.",
Option
[]
+ ["print-last-use-gpu"]
+ ( NoArg $
+ Right $ \opts ->
+ opts {futharkAction = GPUMemAction $ \_ _ _ -> printLastUseGPU}
+ )
+ "Print last use information.",
+ Option
+ []
+ ["print-interference-gpu"]
+ ( NoArg $
+ Right $ \opts ->
+ opts {futharkAction = GPUMemAction $ \_ _ _ -> printInterferenceGPU}
+ )
+ "Print interference information.",
+ Option
+ []
+ ["print-mem-alias-gpu"]
+ ( NoArg $
+ Right $ \opts ->
+ opts {futharkAction = GPUMemAction $ \_ _ _ -> printMemAliasGPU}
+ )
+ "Print memory alias information.",
+ Option
+ []
["call-graph"]
(NoArg $ Right $ \opts -> opts {futharkAction = SOACSAction callGraphAction})
"Print the resulting call graph.",
@@ -561,9 +585,17 @@
["gpu-mem"],
pipelineOption
getSOACSProg
+ "Seq"
+ Seq
+ "Run the sequential CPU compilation pipeline"
+ sequentialPipeline
+ []
+ ["seq"],
+ pipelineOption
+ getSOACSProg
"SeqMem"
SeqMem
- "Run the sequential CPU compilation pipeline"
+ "Run the sequential CPU+memory compilation pipeline"
sequentialCpuPipeline
[]
["seq-mem"],
diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs
--- a/src/Futhark/CodeGen/Backends/CCUDA.hs
+++ b/src/Futhark/CodeGen/Backends/CCUDA.hs
@@ -14,6 +14,7 @@
import Control.Monad
import Data.Maybe (catMaybes)
+import qualified Data.Text as T
import Futhark.CodeGen.Backends.CCUDA.Boilerplate
import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions, sizeLoggingCode)
import qualified Futhark.CodeGen.Backends.GenericC as GC
@@ -31,8 +32,8 @@
import NeatInterpolation (untrimming)
-- | Compile the program to C with calls to CUDA.
-compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)
-compileProg prog = do
+compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)
+compileProg version prog = do
(ws, Program cuda_code cuda_prelude kernels _ sizes failures prog') <-
ImpGen.compileProg prog
let cost_centres =
@@ -53,6 +54,7 @@
(ws,)
<$> GC.compileProg
"cuda"
+ version
operations
extra
cuda_includes
diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs
--- a/src/Futhark/CodeGen/Backends/COpenCL.hs
+++ b/src/Futhark/CodeGen/Backends/COpenCL.hs
@@ -15,6 +15,7 @@
import Control.Monad hiding (mapM)
import Data.List (intercalate)
+import qualified Data.Text as T
import Futhark.CodeGen.Backends.COpenCL.Boilerplate
import qualified Futhark.CodeGen.Backends.GenericC as GC
import Futhark.CodeGen.Backends.GenericC.Options
@@ -32,8 +33,8 @@
import NeatInterpolation (untrimming)
-- | Compile the program to C with calls to OpenCL.
-compileProg :: MonadFreshNames m => Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)
-compileProg prog = do
+compileProg :: MonadFreshNames m => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)
+compileProg version prog = do
( ws,
Program
opencl_code
@@ -55,6 +56,7 @@
(ws,)
<$> GC.compileProg
"opencl"
+ version
operations
( generateBoilerplate
opencl_code
diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs
--- a/src/Futhark/CodeGen/Backends/GenericC.hs
+++ b/src/Futhark/CodeGen/Backends/GenericC.hs
@@ -92,13 +92,13 @@
import Data.Maybe
import qualified Data.Text as T
import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs)
-import qualified Futhark.CodeGen.Backends.GenericC.Manifest as Manifest
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.GenericC.Server (serverDefs)
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode
import Futhark.CodeGen.RTS.C (halfH, lockH, timingH, utilH)
import Futhark.IR.Prop (isBuiltInFunction)
+import qualified Futhark.Manifest as Manifest
import Futhark.MonadFreshNames
import Futhark.Util.Pretty (prettyText)
import qualified Language.C.Quote.OpenCL as C
@@ -1497,6 +1497,7 @@
compileProg ::
MonadFreshNames m =>
T.Text ->
+ T.Text ->
Operations op () ->
CompilerM op () () ->
T.Text ->
@@ -1504,7 +1505,7 @@
[Option] ->
Definitions op ->
m CParts
-compileProg backend ops extra header_extra spaces options prog = do
+compileProg backend version ops extra header_extra spaces options prog = do
src <- getNameSource
let ((prototypes, definitions, entry_point_decls, manifest), endstate) =
runCompilerM ops src () compileProg'
@@ -1636,7 +1637,7 @@
( T.unlines $ map prettyText prototypes,
T.unlines $ map (prettyText . funcToDef) functions,
T.unlines $ map prettyText entry_points,
- Manifest.Manifest (M.fromList entry_points_manifest) types backend
+ Manifest.Manifest (M.fromList entry_points_manifest) types backend version
)
funcToDef func = C.FuncDef func loc
diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs
--- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs
+++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs
@@ -15,7 +15,6 @@
import Data.List (unzip5)
import qualified Data.Map as M
import qualified Data.Text as T
-import Futhark.CodeGen.Backends.GenericC.Manifest
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.SimpleRep
( cproduct,
@@ -24,6 +23,7 @@
scalarToPrim,
)
import Futhark.CodeGen.RTS.C (tuningH, valuesH)
+import Futhark.Manifest
import Futhark.Util.Pretty (pretty, prettyText)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
diff --git a/src/Futhark/CodeGen/Backends/GenericC/Manifest.hs b/src/Futhark/CodeGen/Backends/GenericC/Manifest.hs
deleted file mode 100644
--- a/src/Futhark/CodeGen/Backends/GenericC/Manifest.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | C manifest data structure and serialisation to JSON.
---
--- A manifest contains machine-readable information about the API of
--- the compiled Futhark program. Specifically which entry points are
--- available, which types are exposed, and what their C names are.
-module Futhark.CodeGen.Backends.GenericC.Manifest
- ( Manifest (..),
- Input (..),
- Output (..),
- EntryPoint (..),
- Type (..),
- ArrayOps (..),
- OpaqueOps (..),
- manifestToJSON,
- )
-where
-
-import Data.Aeson (ToJSON (..), object)
-import qualified Data.Aeson as JSON
-import qualified Data.Aeson.Key as JSON
-import Data.Aeson.Text (encodeToLazyText)
-import Data.Bifunctor (bimap)
-import qualified Data.Map as M
-import qualified Data.Text as T
-import Data.Text.Lazy (toStrict)
-
--- | Manifest info for an entry point parameter.
-data Input = Input
- { inputName :: T.Text,
- inputType :: T.Text,
- inputUnique :: Bool
- }
- deriving (Eq, Ord, Show)
-
--- | Manifest info for an entry point return value.
-data Output = Output
- { outputType :: T.Text,
- outputUnique :: Bool
- }
- deriving (Eq, Ord, Show)
-
--- | Manifest info for an entry point.
-data EntryPoint = EntryPoint
- { entryPointCFun :: T.Text,
- entryPointOutputs :: [Output],
- entryPointInputs :: [Input]
- }
- deriving (Eq, Ord, Show)
-
--- | The names of the C functions implementing the operations on some
--- array type.
-data ArrayOps = ArrayOps
- { arrayFree :: T.Text,
- arrayShape :: T.Text,
- arrayValues :: T.Text,
- arrayNew :: T.Text
- }
- deriving (Eq, Ord, Show)
-
--- | The names of the C functions implementing the operations on some
--- opaque type.
-data OpaqueOps = OpaqueOps
- { opaqueFree :: T.Text,
- opaqueStore :: T.Text,
- opaqueRestore :: T.Text
- }
- deriving (Eq, Ord, Show)
-
--- | Manifest info for a non-scalar type. Scalar types are not part
--- of the manifest for a program.
-data Type
- = -- | ctype, Futhark elemtype, rank.
- TypeArray T.Text T.Text Int ArrayOps
- | TypeOpaque T.Text OpaqueOps
- deriving (Eq, Ord, Show)
-
--- | A manifest for a compiled program.
-data Manifest = Manifest
- { -- | A mapping from Futhark entry points to how they are
- -- represented in C.
- manifestEntryPoints :: M.Map T.Text EntryPoint,
- -- | A mapping from Futhark type name to how they are represented
- -- at the C level. Should not contain any of the primitive scalar
- -- types. For array types, these have empty dimensions,
- -- e.g. @[]i32@.
- manifestTypes :: M.Map T.Text Type,
- -- | The compiler backend used to
- -- compile the program, e.g. @c@.
- manifestBackend :: T.Text
- }
- deriving (Eq, Ord, Show)
-
-instance JSON.ToJSON ArrayOps where
- toJSON (ArrayOps free shape values new) =
- object
- [ ("free", toJSON free),
- ("shape", toJSON shape),
- ("values", toJSON values),
- ("new", toJSON new)
- ]
-
-instance JSON.ToJSON OpaqueOps where
- toJSON (OpaqueOps free store restore) =
- object
- [ ("free", toJSON free),
- ("store", toJSON store),
- ("restore", toJSON restore)
- ]
-
-instance JSON.ToJSON Manifest where
- toJSON (Manifest entry_points types backend) =
- object
- [ ("backend", toJSON backend),
- ( "entry_points",
- object $ map (bimap JSON.fromText onEntryPoint) $ M.toList entry_points
- ),
- ( "types",
- object $ map (bimap JSON.fromText onType) $ M.toList types
- )
- ]
- where
- onEntryPoint (EntryPoint cfun outputs inputs) =
- object
- [ ("cfun", toJSON cfun),
- ("outputs", toJSON $ map onOutput outputs),
- ("inputs", toJSON $ map onInput inputs)
- ]
-
- onOutput (Output t u) =
- object
- [ ("type", toJSON t),
- ("unique", toJSON u)
- ]
-
- onInput (Input p t u) =
- object
- [ ("name", toJSON p),
- ("type", toJSON t),
- ("unique", toJSON u)
- ]
-
- onType (TypeArray t et rank ops) =
- object
- [ ("kind", "array"),
- ("ctype", toJSON t),
- ("rank", toJSON rank),
- ("elemtype", toJSON et),
- ("ops", toJSON ops)
- ]
- onType (TypeOpaque t ops) =
- object
- [ ("kind", "opaque"),
- ("ctype", toJSON t),
- ("ops", toJSON ops)
- ]
-
--- | Serialise a manifest in JSON format, so it can be read from other
--- tools. The schema supposed to be at
--- https://futhark-lang.org/manifest.schema.json.
-manifestToJSON :: Manifest -> T.Text
-manifestToJSON = toStrict . encodeToLazyText
diff --git a/src/Futhark/CodeGen/Backends/GenericC/Server.hs b/src/Futhark/CodeGen/Backends/GenericC/Server.hs
--- a/src/Futhark/CodeGen/Backends/GenericC/Server.hs
+++ b/src/Futhark/CodeGen/Backends/GenericC/Server.hs
@@ -15,10 +15,10 @@
import Data.Bifunctor (first, second)
import qualified Data.Map as M
import qualified Data.Text as T
-import Futhark.CodeGen.Backends.GenericC.Manifest
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH)
+import Futhark.Manifest
import Futhark.Util (zEncodeString)
import Futhark.Util.Pretty (prettyText)
import qualified Language.C.Quote.OpenCL as C
diff --git a/src/Futhark/CodeGen/Backends/MulticoreC.hs b/src/Futhark/CodeGen/Backends/MulticoreC.hs
--- a/src/Futhark/CodeGen/Backends/MulticoreC.hs
+++ b/src/Futhark/CodeGen/Backends/MulticoreC.hs
@@ -33,13 +33,12 @@
-- | Compile the program to ImpCode with multicore operations.
compileProg ::
- MonadFreshNames m =>
- Prog MCMem ->
- m (ImpGen.Warnings, GC.CParts)
-compileProg =
+ MonadFreshNames m => T.Text -> Prog MCMem -> m (ImpGen.Warnings, GC.CParts)
+compileProg version =
traverse
( GC.compileProg
"multicore"
+ version
operations
generateContext
""
diff --git a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs
--- a/src/Futhark/CodeGen/Backends/MulticoreWASM.hs
+++ b/src/Futhark/CodeGen/Backends/MulticoreWASM.hs
@@ -25,13 +25,18 @@
import Futhark.IR.MCMem
import Futhark.MonadFreshNames
-compileProg :: MonadFreshNames m => Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))
-compileProg prog = do
+compileProg ::
+ MonadFreshNames m =>
+ T.Text ->
+ Prog MCMem ->
+ m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))
+compileProg version prog = do
(ws, prog') <- ImpGen.compileProg prog
prog'' <-
GC.compileProg
"wasm_multicore"
+ version
MC.operations
MC.generateContext
""
diff --git a/src/Futhark/CodeGen/Backends/SequentialC.hs b/src/Futhark/CodeGen/Backends/SequentialC.hs
--- a/src/Futhark/CodeGen/Backends/SequentialC.hs
+++ b/src/Futhark/CodeGen/Backends/SequentialC.hs
@@ -13,6 +13,7 @@
where
import Control.Monad
+import qualified Data.Text as T
import qualified Futhark.CodeGen.Backends.GenericC as GC
import Futhark.CodeGen.Backends.SequentialC.Boilerplate
import qualified Futhark.CodeGen.ImpCode.Sequential as Imp
@@ -21,10 +22,10 @@
import Futhark.MonadFreshNames
-- | Compile the program to sequential C.
-compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, GC.CParts)
-compileProg =
+compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, GC.CParts)
+compileProg version =
traverse
- (GC.compileProg "c" operations generateBoilerplate mempty [DefaultSpace] [])
+ (GC.compileProg "c" version operations generateBoilerplate mempty [DefaultSpace] [])
<=< ImpGen.compileProg
where
operations :: GC.Operations Imp.Sequential ()
diff --git a/src/Futhark/CodeGen/Backends/SequentialWASM.hs b/src/Futhark/CodeGen/Backends/SequentialWASM.hs
--- a/src/Futhark/CodeGen/Backends/SequentialWASM.hs
+++ b/src/Futhark/CodeGen/Backends/SequentialWASM.hs
@@ -26,13 +26,14 @@
import Futhark.MonadFreshNames
-- | Compile the program to sequential C with a JavaScript wrapper.
-compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))
-compileProg prog = do
+compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String]))
+compileProg version prog = do
(ws, prog') <- ImpGen.compileProg prog
prog'' <-
GC.compileProg
"wasm"
+ version
operations
generateBoilerplate
""
diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs
--- a/src/Futhark/CodeGen/ImpGen.hs
+++ b/src/Futhark/CodeGen/ImpGen.hs
@@ -1621,7 +1621,9 @@
pretty name,
"and array-typed source",
pretty src,
- "with slice",
+ "of shape",
+ pretty (entryArrayShape arr),
+ "sliced with",
pretty src_slice
]
(ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do
@@ -1629,7 +1631,8 @@
bt = entryArrayElemType src_arr
emit =<< copyArrayDWIM bt dest_loc dest_slice src_loc src_slice
(ArrayDestination (Just dest_loc), ScalarVar _ (ScalarEntry bt))
- | Just dest_is <- mapM dimFix dest_slice -> do
+ | Just dest_is <- mapM dimFix dest_slice,
+ length dest_is == length (memLocShape dest_loc) -> do
(dest_mem, dest_space, dest_i) <- fullyIndexArray' dest_loc dest_is
vol <- asks envVolatility
emit $ Imp.Write dest_mem dest_i bt dest_space vol (Imp.var src bt)
diff --git a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs
--- a/src/Futhark/CodeGen/ImpGen/GPU/Base.hs
+++ b/src/Futhark/CodeGen/ImpGen/GPU/Base.hs
@@ -345,7 +345,7 @@
locks <- newVName "locks"
let num_locks = toInt64Exp $ unCount group_size
- dims = map toInt64Exp $ shapeDims (histShape op) ++ [histWidth op]
+ dims = map toInt64Exp $ shapeDims (histOpShape op <> histShape op)
l' = Locking locks 0 1 0 (pure . (`rem` num_locks) . flattenIndex dims)
locks_t = Array int32 (Shape [unCount group_size]) NoUniqueness
@@ -545,10 +545,10 @@
let vs_per_op = chunks (map (length . histDest) ops) red_vs
forM_ (zip4 red_is vs_per_op ops' ops) $
- \(bin, op_vs, do_op, HistOp dest_w _ _ _ shape lam) -> do
+ \(bin, op_vs, do_op, HistOp dest_shape _ _ _ shape lam) -> do
let bin' = toInt64Exp bin
- dest_w' = toInt64Exp dest_w
- bin_in_bounds = 0 .<=. bin' .&&. bin' .<. dest_w'
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ bin_in_bounds = inBounds (Slice (map DimFix [bin'])) dest_shape'
bin_is = map Imp.le64 (init ltids) ++ [bin']
vs_params = takeLast (length op_vs) $ lambdaParams lam
diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs
--- a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs
+++ b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs
@@ -40,7 +40,7 @@
module Futhark.CodeGen.ImpGen.GPU.SegHist (compileSegHist) where
import Control.Monad.Except
-import Data.List (foldl', genericLength, zip4, zip6)
+import Data.List (foldl', genericLength, zip5)
import Data.Maybe
import qualified Futhark.CodeGen.ImpCode.GPU as Imp
import Futhark.CodeGen.ImpGen
@@ -67,20 +67,21 @@
slugAtomicUpdate :: AtomicUpdate GPUMem KernelEnv
}
-histoSpaceUsage ::
+histSpaceUsage ::
HistOp GPUMem ->
Imp.Count Imp.Bytes (Imp.TExp Int64)
-histoSpaceUsage op =
- sum $
- map
- ( typeSize
- . (`arrayOfRow` histWidth op)
- . (`arrayOfShape` histShape op)
- )
- $ lambdaReturnType $ histOp op
+histSpaceUsage op =
+ sum . map (typeSize . (`arrayOfShape` (histShape op <> histOpShape op))) $
+ lambdaReturnType $ histOp op
+histSize :: HistOp GPUMem -> Imp.TExp Int64
+histSize = product . map toInt64Exp . shapeDims . histShape
+
+histRank :: HistOp GPUMem -> Int
+histRank = shapeRank . histShape
+
-- | Figure out how much memory is needed per histogram, both
--- segmented and unsegmented,, and compute some other auxiliary
+-- segmented and unsegmented, and compute some other auxiliary
-- information.
computeHistoUsage ::
SegSpace ->
@@ -115,7 +116,7 @@
subhistos_mem
$ IxFun.iota $ map pe64 $ shapeDims subhistos_shape
- return $
+ pure $
SubhistosInfo subhistos $ do
let unitHistoCase =
emit $
@@ -142,7 +143,7 @@
sIf (tvExp num_subhistos .==. 1) unitHistoCase multiHistoCase
- let h = histoSpaceUsage op
+ let h = histSpaceUsage op
segmented_h = h * product (map (Imp.bytes . toInt64Exp) $ init $ segSpaceDims space)
atomics <- hostAtomics <$> askEnv
@@ -180,10 +181,10 @@
let num_locks = 100151
dims =
map toInt64Exp $
- shapeDims (histShape (slugOp slug))
- ++ [ tvSize (slugNumSubhistos slug),
- histWidth (slugOp slug)
- ]
+ shapeDims (histOpShape (slugOp slug))
+ ++ [tvSize (slugNumSubhistos slug)]
+ ++ shapeDims (histShape (slugOp slug))
+
locks <-
sStaticArray "hist_locks" (Space "device") int32 $
Imp.ArrayZeros num_locks
@@ -219,7 +220,7 @@
-- paper.
-- The sum of all Hs.
- hist_H <- dPrimVE "hist_H" $ sum $ map (toInt64Exp . histWidth . slugOp) slugs
+ hist_H <- dPrimVE "hist_H" $ sum $ map (histSize . slugOp) slugs
hist_RF <-
dPrimVE "hist_RF" $
@@ -305,18 +306,18 @@
sExt32 $
unCount $
sum $
- map (typeSize . (`arrayOfShape` histShape op)) $
+ map (typeSize . (`arrayOfShape` histOpShape op)) $
Prim int32 : lambdaReturnType (histOp op)
_ ->
sExt32 $
unCount $
sum $
- map (typeSize . (`arrayOfShape` histShape op)) $
+ map (typeSize . (`arrayOfShape` histOpShape op)) $
lambdaReturnType (histOp op)
onOp hist_L2 hist_M_min hist_S hist_RACE_exp l slug = do
let SegHistSlug op num_subhistos subhisto_info do_op = slug
- hist_H = toInt64Exp $ histWidth op
+ hist_H = histSize op
hist_H_chk <- dPrimVE "hist_H_chk" $ hist_H `divUp` sExt64 hist_S
@@ -395,8 +396,8 @@
space_sizes_64 = map (sExt64 . toInt64Exp) space_sizes
total_w_64 = product space_sizes_64
- hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w ->
- dPrimVE "hist_H_chk" $ toInt64Exp w `divUp` sExt64 hist_S
+ hist_H_chks <- forM (map (histSize . slugOp) slugs) $ \w ->
+ dPrimVE "hist_H_chk" $ w `divUp` sExt64 hist_S
sKernelThread "seghist_global" num_groups group_size (segFlat space) $ do
constants <- kernelConstants <$> askEnv
@@ -437,35 +438,37 @@
(kernelResultSubExp res)
[]
- let (buckets, vs) = splitAt (length slugs) red_res
- perOp = chunks $ map (length . histDest . slugOp) slugs
+ let red_res_split =
+ splitHistResults (map slugOp slugs) $
+ map kernelResultSubExp red_res
sComment "perform atomic updates" $
- forM_ (zip6 (map slugOp slugs) histograms buckets (perOp vs) subhisto_inds hist_H_chks) $
- \( HistOp dest_w _ _ _ shape lam,
+ forM_ (zip5 (map slugOp slugs) histograms red_res_split subhisto_inds hist_H_chks) $
+ \( HistOp dest_shape _ _ _ shape lam,
do_op,
- bucket,
- vs',
+ (bucket, vs'),
subhisto_ind,
hist_H_chk
) -> do
let chk_beg = sExt64 chk_i * hist_H_chk
- bucket' = toInt64Exp $ kernelResultSubExp bucket
- dest_w' = toInt64Exp dest_w
+ bucket' = map toInt64Exp bucket
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ flat_bucket = flattenIndex dest_shape' bucket'
bucket_in_bounds =
- chk_beg .<=. bucket'
- .&&. bucket' .<. (chk_beg + hist_H_chk)
- .&&. bucket' .<. dest_w'
+ chk_beg .<=. flat_bucket
+ .&&. flat_bucket .<. (chk_beg + hist_H_chk)
+ .&&. inBounds (Slice (map DimFix bucket')) dest_shape'
vs_params = takeLast (length vs') $ lambdaParams lam
sWhen bucket_in_bounds $ do
let bucket_is =
map Imp.le64 (init space_is)
- ++ [sExt64 subhisto_ind, bucket']
+ ++ [sExt64 subhisto_ind]
+ ++ unflattenIndex dest_shape' (flat_bucket - chk_beg)
dLParams $ lambdaParams lam
sLoopNest shape $ \is -> do
forM_ (zip vs_params vs') $ \(p, res) ->
- copyDWIMFix (paramName p) [] (kernelResultSubExp res) is
+ copyDWIMFix (paramName p) [] res is
do_op (bucket_is ++ is)
histKernelGlobal ::
@@ -540,7 +543,7 @@
let lock_shape =
Shape $
tvSize num_subhistos_per_group :
- shapeDims (histShape op)
+ shapeDims (histOpShape op)
++ [hist_H_chk]
let dims = map toInt64Exp $ shapeDims lock_shape
@@ -560,7 +563,7 @@
forM (histType op) $ \t -> do
let sub_local_shape =
Shape [tvSize num_subhistos_per_group]
- <> (arrayShape t `setOuterDim` hist_H_chk)
+ <> setOuterDims (arrayShape t) (histRank op) (Shape [hist_H_chk])
sAllocArray
"subhistogram_local"
(elemType t)
@@ -614,13 +617,13 @@
dPrimVE "num_segments" $
product $ map toInt64Exp segment_dims
- hist_H_chks <- forM (map (histWidth . slugOp) slugs) $ \w ->
- dPrimV "hist_H_chk" $ toInt64Exp w `divUp` sExt64 hist_S
+ hist_H_chks <- forM (map slugOp slugs) $ \op ->
+ dPrimV "hist_H_chk" $ histSize op `divUp` sExt64 hist_S
histo_sizes <- forM (zip slugs hist_H_chks) $ \(slug, hist_H_chk) -> do
let histo_dims =
tvExp hist_H_chk :
- map toInt64Exp (shapeDims (histShape (slugOp slug)))
+ map toInt64Exp (shapeDims (histOpShape (slugOp slug)))
histo_size <-
dPrimVE "histo_size" $ product histo_dims
let group_hists_size =
@@ -683,9 +686,14 @@
local_subhisto_i <- dPrimVE "local_subhisto_i" $ j `quot` sExt32 histo_size
let local_bucket_is = unflattenIndex histo_dims $ sExt64 $ j `rem` sExt32 histo_size
+ nested_hist_size =
+ map toInt64Exp $ shapeDims $ histShape $ slugOp slug
+
global_bucket_is =
- head local_bucket_is + sExt64 chk_i * hist_H_chk :
- tail local_bucket_is
+ unflattenIndex
+ nested_hist_size
+ (head local_bucket_is + sExt64 chk_i * hist_H_chk)
+ ++ tail local_bucket_is
global_subhisto_i <- dPrimVE "global_subhisto_i" $ j_offset `quot` sExt32 histo_size
sWhen (j .<. group_hists_size) $
@@ -707,7 +715,7 @@
sIf
(global_subhisto_i .==. 0)
(copyDWIMFix dest_local local_is (Var dest_global) global_is)
- ( sLoopNest (histShape op) $ \is ->
+ ( sLoopNest (histOpShape op) $ \is ->
copyDWIMFix dest_local (local_is ++ is) ne []
)
@@ -724,8 +732,6 @@
let (red_res, map_res) =
splitFromEnd (length map_pes) $
map kernelResultSubExp $ kernelBodyResult kbody
- (buckets, vs) = splitAt (length slugs) red_res
- perOp = chunks $ map (length . histDest . slugOp) slugs
sWhen (chk_i .==. 0) $
sComment "save map-out results" $
@@ -736,20 +742,22 @@
se
[]
- forM_ (zip4 (map slugOp slugs) histograms buckets (perOp vs)) $
- \( HistOp dest_w _ _ _ shape lam,
+ let red_res_split = splitHistResults (map slugOp slugs) red_res
+ forM_ (zip3 (map slugOp slugs) histograms red_res_split) $
+ \( HistOp dest_shape _ _ _ shape lam,
(_, hist_H_chk, do_op),
- bucket,
- vs'
+ (bucket, vs')
) -> do
let chk_beg = sExt64 chk_i * tvExp hist_H_chk
- bucket' = toInt64Exp bucket
- dest_w' = toInt64Exp dest_w
+ bucket' = map toInt64Exp bucket
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ flat_bucket = flattenIndex dest_shape' bucket'
bucket_in_bounds =
- bucket' .<. dest_w'
- .&&. chk_beg .<=. bucket'
- .&&. bucket' .<. (chk_beg + tvExp hist_H_chk)
- bucket_is = [sExt64 thread_local_subhisto_i, bucket' - chk_beg]
+ inBounds (Slice (map DimFix bucket')) dest_shape'
+ .&&. chk_beg .<=. flat_bucket
+ .&&. flat_bucket .<. (chk_beg + tvExp hist_H_chk)
+ bucket_is =
+ [sExt64 thread_local_subhisto_i, flat_bucket - chk_beg]
vs_params = takeLast (length vs') $ lambdaParams lam
sComment "perform atomic updates" $
@@ -765,13 +773,11 @@
sComment "Compact the multiple local memory subhistograms to result in global memory" $
onSlugs $ \slug dests hist_H_chk histo_dims _histo_size bins_per_thread -> do
trunc_H <-
- dPrimV "trunc_H" $
- sMin64 hist_H_chk $
- toInt64Exp (histWidth (slugOp slug))
- - sExt64 chk_i * head histo_dims
+ dPrimV "trunc_H" . sMin64 hist_H_chk $
+ histSize (slugOp slug) - sExt64 chk_i * head histo_dims
let trunc_histo_dims =
tvExp trunc_H :
- map toInt64Exp (shapeDims (histShape (slugOp slug)))
+ map toInt64Exp (shapeDims (histOpShape (slugOp slug)))
trunc_histo_size <- dPrimVE "histo_size" $ sExt32 $ product trunc_histo_dims
sFor "local_i" bins_per_thread $ \i -> do
@@ -783,9 +789,13 @@
-- We are responsible for compacting the flat bin 'j', which
-- we immediately unflatten.
let local_bucket_is = unflattenIndex histo_dims $ sExt64 j
+ nested_hist_size =
+ map toInt64Exp $ shapeDims $ histShape $ slugOp slug
global_bucket_is =
- head local_bucket_is + sExt64 chk_i * hist_H_chk :
- tail local_bucket_is
+ unflattenIndex
+ nested_hist_size
+ (head local_bucket_is + sExt64 chk_i * hist_H_chk)
+ ++ tail local_bucket_is
dLParams $ lambdaParams $ histOp $ slugOp slug
let (global_dests, local_dests) = unzip dests
(xparams, yparams) =
@@ -1050,7 +1060,7 @@
let hist_B = unCount group_size'
-- Size of a histogram.
- hist_H <- dPrimVE "hist_H" $ sum $ map (toInt64Exp . histWidth) ops
+ hist_H <- dPrimVE "hist_H" $ sum $ map histSize ops
-- Size of a single histogram element. Actually the weighted
-- average of histogram elements in cases where we have more than
@@ -1116,13 +1126,11 @@
-- unchanged. To this, we add two dimensions: one over the number
-- of buckets, and one over the number of subhistograms. This
-- inner dimension is the one that is collapsed in the reduction.
- let num_buckets = histWidth op
-
- bucket_id <- newVName "bucket_id"
+ bucket_ids <-
+ replicateM (shapeRank (histShape op)) (newVName "bucket_id")
subhistogram_id <- newVName "subhistogram_id"
vector_ids <-
- mapM (const $ newVName "vector_id") $
- shapeDims $ histShape op
+ replicateM (shapeRank (histOpShape op)) (newVName "vector_id")
flat_gtid <- newVName "flat_gtid"
@@ -1130,18 +1138,20 @@
segred_space =
SegSpace flat_gtid $
segment_dims
- ++ [(bucket_id, num_buckets)]
- ++ zip vector_ids (shapeDims $ histShape op)
+ ++ zip bucket_ids (shapeDims (histShape op))
+ ++ zip vector_ids (shapeDims $ histOpShape op)
++ [(subhistogram_id, Var $ tvVar num_histos)]
let segred_op = SegBinOp Commutative (histOp op) (histNeutral op) mempty
compileSegRed' (Pat red_pes) lvl segred_space [segred_op] $ \red_cont ->
- red_cont $
- flip map subhistos $ \subhisto ->
- ( Var subhisto,
- map Imp.le64 $
- map fst segment_dims ++ [subhistogram_id, bucket_id] ++ vector_ids
- )
+ red_cont . flip map subhistos $ \subhisto ->
+ ( Var subhisto,
+ map Imp.le64 $
+ map fst segment_dims
+ ++ [subhistogram_id]
+ ++ bucket_ids
+ ++ vector_ids
+ )
emit $ Imp.DebugPrint "" Nothing
where
diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs
--- a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs
+++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs
@@ -4,7 +4,7 @@
where
import Control.Monad
-import Data.List (zip4, zip5)
+import Data.List (zip4)
import qualified Futhark.CodeGen.ImpCode.Multicore as Imp
import Futhark.CodeGen.ImpGen
import Futhark.CodeGen.ImpGen.Multicore.Base
@@ -33,6 +33,9 @@
segHistOpChunks :: [HistOp rep] -> [a] -> [[a]]
segHistOpChunks = chunks . map (length . histNeutral)
+histSize :: HistOp MCMem -> Imp.TExp Int64
+histSize = product . map toInt64Exp . shapeDims . histShape
+
nonsegmentedHist ::
Pat MCMem ->
SegSpace ->
@@ -44,7 +47,7 @@
let ns = map snd $ unSegSpace space
ns_64 = map toInt64Exp ns
num_histos' = tvExp num_histos
- hist_width = toInt64Exp $ histWidth $ head histops
+ hist_width = histSize $ head histops
use_subhistogram = sExt64 num_histos' * hist_width .<=. product ns_64
histops' <- renameHistOpLambda histops
@@ -81,9 +84,7 @@
-- Allocate a static array of locks
-- as in the GPU backend
let num_locks = 100151 -- This number is taken from the GPU backend
- dims =
- map toInt64Exp $
- shapeDims (histShape op) ++ [histWidth op]
+ dims = map toInt64Exp $ shapeDims (histOpShape op <> histShape op)
locks <-
sStaticArray "hist_locks" DefaultSpace int32 $
Imp.ArrayZeros num_locks
@@ -108,17 +109,17 @@
body <- collect $ do
zipWithM_ dPrimV_ is $ unflattenIndex ns_64 $ tvExp flat_idx
compileStms mempty (kernelBodyStms kbody) $ do
- let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody
- perOp = chunks $ map (length . histDest) histops
- (buckets, vs) = splitAt (length histops) red_res
+ let (red_res, map_res) =
+ splitFromEnd (length map_pes) $ kernelBodyResult kbody
+ red_res_split = splitHistResults histops $ map kernelResultSubExp red_res
let pes_per_op = chunks (map (length . histDest) histops) all_red_pes
- forM_ (zip5 histops (perOp vs) buckets atomicOps pes_per_op) $
- \(HistOp dest_w _ _ _ shape lam, vs', bucket, do_op, dest_res) -> do
+ forM_ (zip4 histops red_res_split atomicOps pes_per_op) $
+ \(HistOp dest_shape _ _ _ shape lam, (bucket, vs'), do_op, dest_res) -> do
let (_is_params, vs_params) = splitAt (length vs') $ lambdaParams lam
- dest_w' = toInt64Exp dest_w
- bucket' = toInt64Exp $ kernelResultSubExp bucket
- bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ bucket' = map toInt64Exp bucket
+ bucket_in_bounds = inBounds (Slice (map DimFix bucket')) dest_shape'
sComment "save map-out results" $
forM_ (zip map_pes map_res) $ \(pe, res) ->
@@ -126,11 +127,11 @@
sComment "perform updates" $
sWhen bucket_in_bounds $ do
- let bucket_is = map Imp.le64 (init is) ++ [bucket']
+ let bucket_is = map Imp.le64 (init is) ++ bucket'
dLParams $ lambdaParams lam
sLoopNest shape $ \is' -> do
forM_ (zip vs_params vs') $ \(p, res) ->
- copyDWIMFix (paramName p) [] (kernelResultSubExp res) is'
+ copyDWIMFix (paramName p) [] res is'
do_op (map patElemName dest_res) (bucket_is ++ is')
free_params <- freeParams body (segFlat space : [tvVar flat_idx])
@@ -202,9 +203,9 @@
sIf
(tid' .==. 0)
(copyDWIMFix hist [] (Var $ patElemName pe) [])
- ( sFor "i" (toInt64Exp $ histWidth histop) $ \i ->
- sLoopNest (histShape histop) $ \vec_is ->
- copyDWIMFix hist (i : vec_is) ne []
+ ( sLoopNest (histShape histop) $ \shape_is ->
+ sLoopNest (histOpShape histop) $ \vec_is ->
+ copyDWIMFix hist (shape_is <> vec_is) ne []
)
return op_local_subhistograms
@@ -213,37 +214,32 @@
body <- collect $ do
zipWithM_ dPrimV_ is $ unflattenIndex ns_64 $ sExt64 flat_idx'
compileStms mempty (kernelBodyStms kbody) $ do
- let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody
- (buckets, vs) = splitAt (length histops) red_res
- perOp = chunks $ map (length . histDest) histops
+ let (red_res, map_res) =
+ splitFromEnd (length map_pes) $
+ map kernelResultSubExp $ kernelBodyResult kbody
sComment "save map-out results" $
forM_ (zip map_pes map_res) $ \(pe, res) ->
- copyDWIMFix
- (patElemName pe)
- (map Imp.le64 is)
- (kernelResultSubExp res)
- []
+ copyDWIMFix (patElemName pe) (map Imp.le64 is) res []
- forM_ (zip4 histops local_subhistograms buckets (perOp vs)) $
- \( histop@(HistOp dest_w _ _ _ shape lam),
+ forM_ (zip3 histops local_subhistograms (splitHistResults histops red_res)) $
+ \( histop@(HistOp dest_shape _ _ _ shape lam),
histop_subhistograms,
- bucket,
- vs'
+ (bucket, vs')
) -> do
- let bucket' = toInt64Exp $ kernelResultSubExp bucket
- dest_w' = toInt64Exp dest_w
- bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'
+ let bucket' = map toInt64Exp bucket
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ bucket_in_bounds =
+ inBounds (Slice (map DimFix bucket')) dest_shape'
vs_params = takeLast (length vs') $ lambdaParams lam
- bucket_is = [bucket']
sComment "perform updates" $
sWhen bucket_in_bounds $ do
dLParams $ lambdaParams lam
sLoopNest shape $ \is' -> do
forM_ (zip vs_params vs') $ \(p, res) ->
- copyDWIMFix (paramName p) [] (kernelResultSubExp res) is'
- updateHisto histop histop_subhistograms (bucket_is ++ is')
+ copyDWIMFix (paramName p) [] res is'
+ updateHisto histop histop_subhistograms (bucket' ++ is')
-- Copy the task-local subhistograms to the global subhistograms,
-- where they will be combined.
@@ -257,17 +253,17 @@
-- Perform a segmented reduction over the subhistograms
forM_ (zip3 per_red_pes global_subhistograms histops) $ \(red_pes, hists, op) -> do
- bucket_id <- newVName "bucket_id"
+ bucket_ids <-
+ replicateM (shapeRank (histShape op)) (newVName "bucket_id")
subhistogram_id <- newVName "subhistogram_id"
- let num_buckets = histWidth op
- segred_space =
+ let segred_space =
SegSpace (segFlat space) $
segment_dims
- ++ [(bucket_id, num_buckets)]
+ ++ zip bucket_ids (shapeDims (histShape op))
++ [(subhistogram_id, tvSize num_histos)]
- segred_op = SegBinOp Noncommutative (histOp op) (histNeutral op) (histShape op)
+ segred_op = SegBinOp Noncommutative (histOp op) (histNeutral op) (histOpShape op)
nsubtasks_red <- dPrim "num_tasks" $ IntType Int32
red_code <- compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks_red $ \red_cont ->
@@ -275,7 +271,7 @@
flip map hists $ \subhisto ->
( Var subhisto,
map Imp.le64 $
- map fst segment_dims ++ [subhistogram_id, bucket_id]
+ map fst segment_dims ++ [subhistogram_id] ++ bucket_ids
)
let ns_red = map (toInt64Exp . snd) $ unSegSpace segred_space
@@ -331,15 +327,12 @@
let (red_res, map_res) =
splitFromEnd (length map_pes) $
map kernelResultSubExp $ kernelBodyResult kbody
- (buckets, vs) = splitAt (length histops) red_res
- perOp = chunks $ map (length . histDest) histops
-
- forM_ (zip4 per_red_pes histops (perOp vs) buckets) $
- \(red_pes, HistOp dest_w _ _ _ shape lam, vs', bucket) -> do
+ forM_ (zip3 per_red_pes histops (splitHistResults histops red_res)) $
+ \(red_pes, HistOp dest_shape _ _ _ shape lam, (bucket, vs')) -> do
let (is_params, vs_params) = splitAt (length vs') $ lambdaParams lam
- bucket' = toInt64Exp bucket
- dest_w' = toInt64Exp dest_w
- bucket_in_bounds = bucket' .<. dest_w' .&&. 0 .<=. bucket'
+ bucket' = map toInt64Exp bucket
+ dest_shape' = map toInt64Exp $ shapeDims dest_shape
+ bucket_in_bounds = inBounds (Slice (map DimFix bucket')) dest_shape'
sComment "save map-out results" $
forM_ (zip map_pes map_res) $ \(pe, res) ->
@@ -350,12 +343,20 @@
dLParams $ lambdaParams lam
sLoopNest shape $ \vec_is -> do
-- Index
- let buck = toInt64Exp bucket
forM_ (zip red_pes is_params) $ \(pe, p) ->
- copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ [buck] ++ vec_is)
+ copyDWIMFix
+ (paramName p)
+ []
+ (Var $ patElemName pe)
+ (map Imp.le64 (init is) ++ bucket' ++ vec_is)
-- Value at index
forM_ (zip vs_params vs') $ \(p, v) ->
copyDWIMFix (paramName p) [] v vec_is
compileStms mempty (bodyStms $ lambdaBody lam) $
forM_ (zip red_pes $ map resSubExp $ bodyResult $ lambdaBody lam) $
- \(pe, se) -> copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ [buck] ++ vec_is) se []
+ \(pe, se) ->
+ copyDWIMFix
+ (patElemName pe)
+ (map Imp.le64 (init is) ++ bucket' ++ vec_is)
+ se
+ []
diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs
--- a/src/Futhark/Compiler.hs
+++ b/src/Futhark/Compiler.hs
@@ -26,10 +26,10 @@
import Futhark.Compiler.Program
import Futhark.IR
import qualified Futhark.IR.SOACS as I
+import qualified Futhark.IR.TypeCheck as I
import Futhark.Internalise
import Futhark.MonadFreshNames
import Futhark.Pipeline
-import qualified Futhark.TypeCheck as I
import Futhark.Util.Log
import Futhark.Util.Pretty (ppr, prettyText)
import qualified Language.Futhark as E
diff --git a/src/Futhark/IR/GPU.hs b/src/Futhark/IR/GPU.hs
--- a/src/Futhark/IR/GPU.hs
+++ b/src/Futhark/IR/GPU.hs
@@ -25,7 +25,7 @@
import Futhark.IR.SOACS.SOAC hiding (HistOp (..))
import Futhark.IR.Syntax
import Futhark.IR.Traversals
-import qualified Futhark.TypeCheck as TypeCheck
+import qualified Futhark.IR.TypeCheck as TC
-- | The phantom data type for the kernels representation.
data GPU
@@ -36,13 +36,13 @@
instance ASTRep GPU where
expTypesFromPat = return . expExtTypesFromPat
-instance TypeCheck.CheckableOp GPU where
+instance TC.CheckableOp GPU where
checkOp = typeCheckGPUOp Nothing
where
typeCheckGPUOp lvl =
typeCheckHostOp (typeCheckGPUOp . Just) lvl typeCheckSOAC
-instance TypeCheck.Checkable GPU
+instance TC.Checkable GPU
instance Buildable GPU where
mkBody = Body ()
diff --git a/src/Futhark/IR/GPU/Op.hs b/src/Futhark/IR/GPU/Op.hs
--- a/src/Futhark/IR/GPU/Op.hs
+++ b/src/Futhark/IR/GPU/Op.hs
@@ -32,11 +32,11 @@
import Futhark.IR.GPU.Sizes
import Futhark.IR.Prop.Aliases
import Futhark.IR.SegOp
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rep
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
-import qualified Futhark.TypeCheck as TC
import Futhark.Util.Pretty
( commasep,
parens,
diff --git a/src/Futhark/IR/GPUMem.hs b/src/Futhark/IR/GPUMem.hs
--- a/src/Futhark/IR/GPUMem.hs
+++ b/src/Futhark/IR/GPUMem.hs
@@ -24,11 +24,11 @@
import Futhark.IR.GPU.Simplify (simplifyKernelOp)
import Futhark.IR.Mem
import Futhark.IR.Mem.Simplify
+import qualified Futhark.IR.TypeCheck as TC
import Futhark.MonadFreshNames
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Pass
import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')
-import qualified Futhark.TypeCheck as TC
data GPUMem
diff --git a/src/Futhark/IR/MC.hs b/src/Futhark/IR/MC.hs
--- a/src/Futhark/IR/MC.hs
+++ b/src/Futhark/IR/MC.hs
@@ -30,11 +30,11 @@
import Futhark.IR.SegOp
import Futhark.IR.Syntax
import Futhark.IR.Traversals
+import qualified Futhark.IR.TypeCheck as TypeCheck
import qualified Futhark.Optimise.Simplify as Simplify
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rules
import Futhark.Pass
-import qualified Futhark.TypeCheck as TypeCheck
data MC
diff --git a/src/Futhark/IR/MC/Op.hs b/src/Futhark/IR/MC/Op.hs
--- a/src/Futhark/IR/MC/Op.hs
+++ b/src/Futhark/IR/MC/Op.hs
@@ -23,12 +23,12 @@
import Futhark.IR.Aliases (Aliases)
import Futhark.IR.Prop.Aliases
import Futhark.IR.SegOp
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify as Simplify
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rep
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
-import qualified Futhark.TypeCheck as TC
import Futhark.Util.Pretty
( Pretty,
nestedBlock,
diff --git a/src/Futhark/IR/MCMem.hs b/src/Futhark/IR/MCMem.hs
--- a/src/Futhark/IR/MCMem.hs
+++ b/src/Futhark/IR/MCMem.hs
@@ -22,10 +22,10 @@
import Futhark.IR.Mem
import Futhark.IR.Mem.Simplify
import Futhark.IR.SegOp
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Pass
import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')
-import qualified Futhark.TypeCheck as TC
data MCMem
diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs
--- a/src/Futhark/IR/Mem.hs
+++ b/src/Futhark/IR/Mem.hs
@@ -128,11 +128,11 @@
import Futhark.IR.Prop.Aliases
import Futhark.IR.Syntax
import Futhark.IR.Traversals
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rep
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
-import qualified Futhark.TypeCheck as TC
import Futhark.Util
import Futhark.Util.Pretty (indent, ppr, text, (<+>), ())
import qualified Futhark.Util.Pretty as PP
diff --git a/src/Futhark/IR/Parse.hs b/src/Futhark/IR/Parse.hs
--- a/src/Futhark/IR/Parse.hs
+++ b/src/Futhark/IR/Parse.hs
@@ -623,7 +623,7 @@
where
pHistOp =
SOAC.HistOp
- <$> pSubExp <* pComma
+ <$> pShape <* pComma
<*> pSubExp <* pComma
<*> braces (pVName `sepBy` pComma) <* pComma
<*> braces (pSubExp `sepBy` pComma) <* pComma
@@ -804,7 +804,7 @@
pure $ SegOp.SegBinOp comm lam nes shape
pHistOp =
SegOp.HistOp
- <$> pSubExp <* pComma
+ <$> pShape <* pComma
<*> pSubExp <* pComma
<*> braces (pVName `sepBy` pComma) <* pComma
<*> braces (pSubExp `sepBy` pComma) <* pComma
diff --git a/src/Futhark/IR/Pretty.hs b/src/Futhark/IR/Pretty.hs
--- a/src/Futhark/IR/Pretty.hs
+++ b/src/Futhark/IR/Pretty.hs
@@ -308,7 +308,7 @@
ppr (Lambda [] (Body _ stms []) []) | stms == mempty = text "nilFn"
ppr (Lambda params body rettype) =
text "\\" <+> ppTuple' params
- <+/> colon <+> ppTupleLines' rettype <+> text "->"
+ indent 2 (colon <+> ppTupleLines' rettype <+> text "->")
indent 2 (ppr body)
instance Pretty EntryPointType where
diff --git a/src/Futhark/IR/Prop/Types.hs b/src/Futhark/IR/Prop/Types.hs
--- a/src/Futhark/IR/Prop/Types.hs
+++ b/src/Futhark/IR/Prop/Types.hs
@@ -19,6 +19,7 @@
setOuterSize,
setDimSize,
setOuterDim,
+ setOuterDims,
setDim,
setArrayDims,
peelArray,
@@ -220,6 +221,10 @@
setOuterDim :: ShapeBase d -> d -> ShapeBase d
setOuterDim = setDim 0
+-- | Replace some outermost dimensions of an array shape.
+setOuterDims :: ShapeBase d -> Int -> ShapeBase d -> ShapeBase d
+setOuterDims old k new = new <> stripDims k old
+
-- | Replace the specified dimension of an array shape.
setDim :: Int -> ShapeBase d -> d -> ShapeBase d
setDim i (Shape ds) e = Shape $ take i ds ++ e : drop (i + 1) ds
@@ -227,11 +232,7 @@
-- | @peelArray n t@ returns the type resulting from peeling the first
-- @n@ array dimensions from @t@. Returns @Nothing@ if @t@ has less
-- than @n@ dimensions.
-peelArray ::
- ArrayShape shape =>
- Int ->
- TypeBase shape u ->
- Maybe (TypeBase shape u)
+peelArray :: Int -> TypeBase Shape u -> Maybe (TypeBase Shape u)
peelArray 0 t = Just t
peelArray n (Array et shape u)
| shapeRank shape == n = Just $ Prim et
@@ -241,7 +242,7 @@
-- | @stripArray n t@ removes the @n@ outermost layers of the array.
-- Essentially, it is the type of indexing an array of type @t@ with
-- @n@ indexes.
-stripArray :: ArrayShape shape => Int -> TypeBase shape u -> TypeBase shape u
+stripArray :: Int -> TypeBase Shape u -> TypeBase Shape u
stripArray n (Array et shape u)
| n < shapeRank shape = Array et (stripDims n shape) u
| otherwise = Prim et
@@ -278,7 +279,7 @@
-- | Return the immediate row-type of an array. For @[[int]]@, this
-- would be @[int]@.
-rowType :: ArrayShape shape => TypeBase shape u -> TypeBase shape u
+rowType :: TypeBase Shape u -> TypeBase Shape u
rowType = stripArray 1
-- | A type is a primitive type if it is not an array or memory block.
diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs
--- a/src/Futhark/IR/SOACS.hs
+++ b/src/Futhark/IR/SOACS.hs
@@ -47,7 +47,7 @@
)
import qualified Futhark.IR.Syntax as AST
import Futhark.IR.Traversals
-import qualified Futhark.TypeCheck as TypeCheck
+import qualified Futhark.IR.TypeCheck as TC
-- This module could be written much nicer if Haskell had functors
-- like Standard ML. Instead, we have to abuse the namespace/module
@@ -80,10 +80,10 @@
type PatElem = AST.PatElem SOACS
-instance TypeCheck.CheckableOp SOACS where
+instance TC.CheckableOp SOACS where
checkOp = typeCheckSOAC
-instance TypeCheck.Checkable SOACS
+instance TC.Checkable SOACS
instance Buildable SOACS where
mkBody = AST.Body ()
diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs
--- a/src/Futhark/IR/SOACS/SOAC.hs
+++ b/src/Futhark/IR/SOACS/SOAC.hs
@@ -68,10 +68,10 @@
import Futhark.IR
import Futhark.IR.Aliases (Aliases, removeLambdaAliases)
import Futhark.IR.Prop.Aliases
+import qualified Futhark.IR.TypeCheck as TC
import Futhark.Optimise.Simplify.Rep
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
-import qualified Futhark.TypeCheck as TC
import Futhark.Util (chunks, maybeNth)
import Futhark.Util.Pretty (Doc, Pretty, comma, commasep, parens, ppr, text, (<+>), ())
import qualified Futhark.Util.Pretty as PP
@@ -131,7 +131,7 @@
-- | Information about computing a single histogram.
data HistOp rep = HistOp
- { histWidth :: SubExp,
+ { histShape :: Shape,
-- | Race factor @RF@ means that only @1/RF@
-- bins are used.
histRaceFactor :: SubExp,
@@ -430,8 +430,8 @@
<$> mapOnSOACSubExp tv w
<*> mapM (mapOnSOACVName tv) arrs
<*> mapM
- ( \(HistOp e rf op_arrs nes op) ->
- HistOp <$> mapOnSOACSubExp tv e
+ ( \(HistOp shape rf op_arrs nes op) ->
+ HistOp <$> mapM (mapOnSOACSubExp tv) shape
<*> mapOnSOACSubExp tv rf
<*> mapM (mapOnSOACVName tv) op_arrs
<*> mapM (mapOnSOACSubExp tv) nes
@@ -507,7 +507,7 @@
(ws, ns, _) = unzip3 dests
soacType (Hist _ _ ops _bucket_fun) = do
op <- ops
- map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op)
+ map (`arrayOfShape` histShape op) (lambdaReturnType $ histOp op)
soacType (Screma w _arrs form) =
scremaType w form
@@ -739,9 +739,9 @@
TC.require [Prim int64] w
-- Check the operators.
- forM_ ops $ \(HistOp dest_w rf dests nes op) -> do
+ forM_ ops $ \(HistOp dest_shape rf dests nes op) -> do
nes' <- mapM TC.checkArg nes
- TC.require [Prim int64] dest_w
+ mapM_ (TC.require [Prim int64]) dest_shape
TC.require [Prim int64] rf
-- Operator type must match the type of neutral elements.
@@ -757,7 +757,7 @@
-- Arrays must have proper type.
forM_ (zip nes_t dests) $ \(t, dest) -> do
- TC.requireI [t `arrayOfRow` dest_w] dest
+ TC.requireI [t `arrayOfShape` dest_shape] dest
TC.consume =<< TC.lookupAliases dest
-- Types of input arrays must equal parameter types for bucket function.
@@ -767,7 +767,9 @@
-- Return type of bucket function must be an index for each
-- operation followed by the values to write.
nes_ts <- concat <$> mapM (mapM subExpType . histNeutral) ops
- let bucket_ret_t = replicate (length ops) (Prim int64) ++ nes_ts
+ let bucket_ret_t =
+ concatMap ((`replicate` Prim int64) . shapeRank . histShape) ops
+ ++ nes_ts
unless (bucket_ret_t == lambdaReturnType bucket_fun) $
TC.bad $
TC.TypeError $
diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs
--- a/src/Futhark/IR/SegOp.hs
+++ b/src/Futhark/IR/SegOp.hs
@@ -24,6 +24,7 @@
-- * Details
HistOp (..),
histType,
+ splitHistResults,
SegBinOp (..),
segBinOpResults,
segBinOpChunks,
@@ -82,13 +83,13 @@
)
import Futhark.IR.Mem
import Futhark.IR.Prop.Aliases
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rep
import Futhark.Optimise.Simplify.Rule
import Futhark.Tools
import Futhark.Transform.Rename
import Futhark.Transform.Substitute
-import qualified Futhark.TypeCheck as TC
import Futhark.Util (chunks, maybeNth)
import Futhark.Util.Pretty
( Pretty,
@@ -126,7 +127,7 @@
-- | An operator for 'SegHist'.
data HistOp rep = HistOp
- { histWidth :: SubExp,
+ { histShape :: Shape,
histRaceFactor :: SubExp,
histDest :: [VName],
histNeutral :: [SubExp],
@@ -135,7 +136,7 @@
-- SOACS representation), these are the logical
-- "dimensions". This is used to generate more efficient
-- code.
- histShape :: Shape,
+ histOpShape :: Shape,
histOp :: Lambda rep
}
deriving (Eq, Ord, Show)
@@ -145,12 +146,20 @@
-- dealing with a segmented histogram.
histType :: HistOp rep -> [Type]
histType op =
- map
- ( (`arrayOfRow` histWidth op)
- . (`arrayOfShape` histShape op)
- )
- $ lambdaReturnType $ histOp op
+ map (`arrayOfShape` (histShape op <> histOpShape op)) $
+ lambdaReturnType $ histOp op
+-- | Split reduction results returned by a 'KernelBody' into those
+-- that correspond to indexes for the 'HistOps', and those that
+-- correspond to value.
+splitHistResults :: [HistOp rep] -> [SubExp] -> [([SubExp], [SubExp])]
+splitHistResults ops res =
+ let ranks = map (shapeRank . histShape) ops
+ (idxs, vals) = splitAt (sum ranks) res
+ in zip
+ (chunks ranks idxs)
+ (chunks (map (length . histDest) ops) vals)
+
-- | An operator for 'SegScan' and 'SegRed'.
data SegBinOp rep = SegBinOp
{ segBinOpComm :: Commutativity,
@@ -610,7 +619,7 @@
map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op)
segOpType (SegHist _ space ops _ _) = do
op <- ops
- let shape = Shape (segment_dims <> [histWidth op]) <> histShape op
+ let shape = Shape segment_dims <> histShape op <> histOpShape op
map (`arrayOfShape` shape) (lambdaReturnType $ histOp op)
where
dims = segSpaceDims space
@@ -667,8 +676,8 @@
mapM_ TC.checkType ts
TC.binding (scopeOfSegSpace space) $ do
- nes_ts <- forM ops $ \(HistOp dest_w rf dests nes shape op) -> do
- TC.require [Prim int64] dest_w
+ nes_ts <- forM ops $ \(HistOp dest_shape rf dests nes shape op) -> do
+ mapM_ (TC.require [Prim int64]) dest_shape
TC.require [Prim int64] rf
nes' <- mapM TC.checkArg nes
mapM_ (TC.require [Prim int64]) $ shapeDims shape
@@ -686,9 +695,9 @@
++ prettyTuple nes_t
-- Arrays must have proper type.
- let dest_shape = Shape (segment_dims <> [dest_w]) <> shape
+ let dest_shape' = Shape segment_dims <> dest_shape <> shape
forM_ (zip nes_t dests) $ \(t, dest) -> do
- TC.requireI [t `arrayOfShape` dest_shape] dest
+ TC.requireI [t `arrayOfShape` dest_shape'] dest
TC.consume =<< TC.lookupAliases dest
return $ map (`arrayOfShape` shape) nes_t
@@ -697,7 +706,9 @@
-- Return type of bucket function must be an index for each
-- operation followed by the values to write.
- let bucket_ret_t = replicate (length ops) (Prim int64) ++ concat nes_ts
+ let bucket_ret_t =
+ concatMap ((`replicate` Prim int64) . shapeRank . histShape) ops
+ ++ concat nes_ts
unless (bucket_ret_t == ts) $
TC.bad $
TC.TypeError $
@@ -819,7 +830,7 @@
<*> mapOnSegOpBody tv body
where
onHistOp (HistOp w rf arrs nes shape op) =
- HistOp <$> mapOnSegOpSubExp tv w
+ HistOp <$> mapM (mapOnSegOpSubExp tv) w
<*> mapOnSegOpSubExp tv rf
<*> mapM (mapOnSegOpVName tv) arrs
<*> mapM (mapOnSegOpSubExp tv) nes
diff --git a/src/Futhark/IR/Seq.hs b/src/Futhark/IR/Seq.hs
--- a/src/Futhark/IR/Seq.hs
+++ b/src/Futhark/IR/Seq.hs
@@ -22,11 +22,11 @@
import Futhark.IR.Prop
import Futhark.IR.Syntax
import Futhark.IR.Traversals
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify as Simplify
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Optimise.Simplify.Rules
import Futhark.Pass
-import qualified Futhark.TypeCheck as TypeCheck
-- | The phantom type for the Seq representation.
data Seq
@@ -37,10 +37,10 @@
instance ASTRep Seq where
expTypesFromPat = return . expExtTypesFromPat
-instance TypeCheck.CheckableOp Seq where
+instance TC.CheckableOp Seq where
checkOp = pure
-instance TypeCheck.Checkable Seq
+instance TC.Checkable Seq
instance Buildable Seq where
mkBody = Body ()
diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs
--- a/src/Futhark/IR/SeqMem.hs
+++ b/src/Futhark/IR/SeqMem.hs
@@ -19,10 +19,10 @@
import Futhark.Analysis.PrimExp.Convert
import Futhark.IR.Mem
import Futhark.IR.Mem.Simplify
+import qualified Futhark.IR.TypeCheck as TC
import qualified Futhark.Optimise.Simplify.Engine as Engine
import Futhark.Pass
import Futhark.Pass.ExplicitAllocations (BuilderOps (..), mkLetNamesB', mkLetNamesB'')
-import qualified Futhark.TypeCheck as TC
data SeqMem
diff --git a/src/Futhark/IR/Syntax/Core.hs b/src/Futhark/IR/Syntax/Core.hs
--- a/src/Futhark/IR/Syntax/Core.hs
+++ b/src/Futhark/IR/Syntax/Core.hs
@@ -19,6 +19,7 @@
NoUniqueness (..),
ShapeBase (..),
Shape,
+ stripDims,
Ext (..),
ExtSize,
ExtShape,
@@ -116,6 +117,11 @@
instance Monoid (ShapeBase d) where
mempty = Shape mempty
+-- | @stripDims n shape@ strips the outer @n@ dimensions from
+-- @shape@.
+stripDims :: Int -> ShapeBase d -> ShapeBase d
+stripDims n (Shape dims) = Shape $ drop n dims
+
-- | The size of an array as a list of subexpressions. If a variable,
-- that variable must be in scope where this array is used.
type Shape = ShapeBase SubExp
@@ -153,21 +159,15 @@
-- | Return the rank of an array with the given size.
shapeRank :: a -> Int
- -- | @stripDims n shape@ strips the outer @n@ dimensions from
- -- @shape@.
- stripDims :: Int -> a -> a
-
-- | Check whether one shape if a subset of another shape.
subShapeOf :: a -> a -> Bool
instance ArrayShape (ShapeBase SubExp) where
shapeRank (Shape l) = length l
- stripDims n (Shape dims) = Shape $ drop n dims
subShapeOf = (==)
instance ArrayShape (ShapeBase ExtSize) where
shapeRank (Shape l) = length l
- stripDims n (Shape dims) = Shape $ drop n dims
subShapeOf (Shape ds1) (Shape ds2) =
-- Must agree on Free dimensions, and ds1 may not be existential
-- where ds2 is Free. Existentials must also be congruent.
@@ -195,7 +195,6 @@
instance ArrayShape Rank where
shapeRank (Rank x) = x
- stripDims n (Rank x) = Rank $ x - n
subShapeOf = (==)
-- | The memory space of a block. If 'DefaultSpace', this is the "default"
diff --git a/src/Futhark/IR/TypeCheck.hs b/src/Futhark/IR/TypeCheck.hs
new file mode 100644
--- /dev/null
+++ b/src/Futhark/IR/TypeCheck.hs
@@ -0,0 +1,1534 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Strict #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | The type checker checks whether the program is type-consistent.
+module Futhark.IR.TypeCheck
+ ( -- * Interface
+ checkProg,
+ TypeError (..),
+ ErrorCase (..),
+
+ -- * Extensionality
+ TypeM,
+ bad,
+ context,
+ message,
+ Checkable (..),
+ CheckableOp (..),
+ lookupVar,
+ lookupAliases,
+ checkOpWith,
+
+ -- * Checkers
+ require,
+ requireI,
+ requirePrimExp,
+ checkSubExp,
+ checkCerts,
+ checkExp,
+ checkStms,
+ checkStm,
+ checkType,
+ checkExtType,
+ matchExtPat,
+ matchExtBranchType,
+ argType,
+ argAliases,
+ noArgAliases,
+ checkArg,
+ checkSOACArrayArgs,
+ checkLambda,
+ checkBody,
+ consume,
+ consumeOnlyParams,
+ binding,
+ alternative,
+ )
+where
+
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Control.Parallel.Strategies
+import Data.Bifunctor (second)
+import Data.List (find, intercalate, isPrefixOf, sort)
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import qualified Data.Set as S
+import Futhark.Analysis.PrimExp
+import Futhark.Construct (instantiateShapes)
+import Futhark.IR.Aliases hiding (lookupAliases)
+import Futhark.Util
+import Futhark.Util.Pretty (Pretty, align, indent, ppr, prettyDoc, text, (<+>), ())
+
+-- | Information about an error during type checking. The 'Show'
+-- instance for this type produces a human-readable description.
+data ErrorCase rep
+ = TypeError String
+ | UnexpectedType (Exp rep) Type [Type]
+ | ReturnTypeError Name [ExtType] [ExtType]
+ | DupDefinitionError Name
+ | DupParamError Name VName
+ | DupPatError VName
+ | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String)
+ | UnknownVariableError VName
+ | UnknownFunctionError Name
+ | ParameterMismatch (Maybe Name) [Type] [Type]
+ | SlicingError Int Int
+ | BadAnnotation String Type Type
+ | ReturnAliased Name VName
+ | UniqueReturnAliased Name
+ | NotAnArray VName Type
+ | PermutationError [Int] Int (Maybe VName)
+
+instance Checkable rep => Show (ErrorCase rep) where
+ show (TypeError msg) =
+ "Type error:\n" ++ msg
+ show (UnexpectedType e _ []) =
+ "Type of expression\n"
+ ++ prettyDoc 160 (indent 2 $ ppr e)
+ ++ "\ncannot have any type - possibly a bug in the type checker."
+ show (UnexpectedType e t ts) =
+ "Type of expression\n"
+ ++ prettyDoc 160 (indent 2 $ ppr e)
+ ++ "\nmust be one of "
+ ++ intercalate ", " (map pretty ts)
+ ++ ", but is "
+ ++ pretty t
+ ++ "."
+ show (ReturnTypeError fname rettype bodytype) =
+ "Declaration of function " ++ nameToString fname
+ ++ " declares return type\n "
+ ++ prettyTuple rettype
+ ++ "\nBut body has type\n "
+ ++ prettyTuple bodytype
+ show (DupDefinitionError name) =
+ "Duplicate definition of function " ++ nameToString name ++ ""
+ show (DupParamError funname paramname) =
+ "Parameter " ++ pretty paramname
+ ++ " mentioned multiple times in argument list of function "
+ ++ nameToString funname
+ ++ "."
+ show (DupPatError name) =
+ "Variable " ++ pretty name ++ " bound twice in pattern."
+ show (InvalidPatError pat t desc) =
+ "Pat\n" ++ pretty pat
+ ++ "\ncannot match value of type\n"
+ ++ prettyTupleLines t
+ ++ end
+ where
+ end = case desc of
+ Nothing -> "."
+ Just desc' -> ":\n" ++ desc'
+ show (UnknownVariableError name) =
+ "Use of unknown variable " ++ pretty name ++ "."
+ show (UnknownFunctionError fname) =
+ "Call of unknown function " ++ nameToString fname ++ "."
+ show (ParameterMismatch fname expected got) =
+ "In call of " ++ fname' ++ ":\n"
+ ++ "expecting "
+ ++ show nexpected
+ ++ " arguments of type(s)\n"
+ ++ intercalate ", " (map pretty expected)
+ ++ "\nGot "
+ ++ show ngot
+ ++ " arguments of types\n"
+ ++ intercalate ", " (map pretty got)
+ where
+ nexpected = length expected
+ ngot = length got
+ fname' = maybe "anonymous function" (("function " ++) . nameToString) fname
+ show (SlicingError dims got) =
+ show got ++ " indices given, but type of indexee has " ++ show dims ++ " dimension(s)."
+ show (BadAnnotation desc expected got) =
+ "Annotation of \"" ++ desc ++ "\" type of expression is " ++ pretty expected
+ ++ ", but derived to be "
+ ++ pretty got
+ ++ "."
+ show (ReturnAliased fname name) =
+ "Unique return value of function " ++ nameToString fname
+ ++ " is aliased to "
+ ++ pretty name
+ ++ ", which is not consumed."
+ show (UniqueReturnAliased fname) =
+ "A unique tuple element of return value of function "
+ ++ nameToString fname
+ ++ " is aliased to some other tuple component."
+ show (NotAnArray e t) =
+ "The expression " ++ pretty e
+ ++ " is expected to be an array, but is "
+ ++ pretty t
+ ++ "."
+ show (PermutationError perm rank name) =
+ "The permutation (" ++ intercalate ", " (map show perm)
+ ++ ") is not valid for array "
+ ++ name'
+ ++ "of rank "
+ ++ show rank
+ ++ "."
+ where
+ name' = maybe "" ((++ " ") . pretty) name
+
+-- | A type error.
+data TypeError rep = Error [String] (ErrorCase rep)
+
+instance Checkable rep => Show (TypeError rep) where
+ show (Error [] err) =
+ show err
+ show (Error msgs err) =
+ intercalate "\n" msgs ++ "\n" ++ show err
+
+-- | A tuple of a return type and a list of parameters, possibly
+-- named.
+type FunBinding rep = ([RetType (Aliases rep)], [FParam (Aliases rep)])
+
+type VarBinding rep = NameInfo (Aliases rep)
+
+data Usage
+ = Consumed
+ | Observed
+ deriving (Eq, Ord, Show)
+
+data Occurence = Occurence
+ { observed :: Names,
+ consumed :: Names
+ }
+ deriving (Eq, Show)
+
+observation :: Names -> Occurence
+observation = flip Occurence mempty
+
+consumption :: Names -> Occurence
+consumption = Occurence mempty
+
+nullOccurence :: Occurence -> Bool
+nullOccurence occ = observed occ == mempty && consumed occ == mempty
+
+type Occurences = [Occurence]
+
+allConsumed :: Occurences -> Names
+allConsumed = mconcat . map consumed
+
+seqOccurences :: Occurences -> Occurences -> Occurences
+seqOccurences occurs1 occurs2 =
+ filter (not . nullOccurence) (map filt occurs1) ++ occurs2
+ where
+ filt occ =
+ occ {observed = observed occ `namesSubtract` postcons}
+ postcons = allConsumed occurs2
+
+altOccurences :: Occurences -> Occurences -> Occurences
+altOccurences occurs1 occurs2 =
+ filter (not . nullOccurence) (map filt occurs1) ++ occurs2
+ where
+ filt occ =
+ occ
+ { consumed = consumed occ `namesSubtract` postcons,
+ observed = observed occ `namesSubtract` postcons
+ }
+ postcons = allConsumed occurs2
+
+unOccur :: Names -> Occurences -> Occurences
+unOccur to_be_removed = filter (not . nullOccurence) . map unOccur'
+ where
+ unOccur' occ =
+ occ
+ { observed = observed occ `namesSubtract` to_be_removed,
+ consumed = consumed occ `namesSubtract` to_be_removed
+ }
+
+-- | The 'Consumption' data structure is used to keep track of which
+-- variables have been consumed, as well as whether a violation has been detected.
+data Consumption
+ = ConsumptionError String
+ | Consumption Occurences
+ deriving (Show)
+
+instance Semigroup Consumption where
+ ConsumptionError e <> _ = ConsumptionError e
+ _ <> ConsumptionError e = ConsumptionError e
+ Consumption o1 <> Consumption o2
+ | v : _ <- namesToList $ consumed_in_o1 `namesIntersection` used_in_o2 =
+ ConsumptionError $ "Variable " <> pretty v <> " referenced after being consumed."
+ | otherwise =
+ Consumption $ o1 `seqOccurences` o2
+ where
+ consumed_in_o1 = mconcat $ map consumed o1
+ used_in_o2 = mconcat $ map consumed o2 <> map observed o2
+
+instance Monoid Consumption where
+ mempty = Consumption mempty
+
+-- | The environment contains a variable table and a function table.
+-- Type checking happens with access to this environment. The
+-- function table is only initialised at the very beginning, but the
+-- variable table will be extended during type-checking when
+-- let-expressions are encountered.
+data Env rep = Env
+ { envVtable :: M.Map VName (VarBinding rep),
+ envFtable :: M.Map Name (FunBinding rep),
+ envCheckOp :: OpWithAliases (Op rep) -> TypeM rep (),
+ envContext :: [String]
+ }
+
+data TState = TState
+ { stateNames :: Names,
+ stateCons :: Consumption
+ }
+
+-- | The type checker runs in this monad.
+newtype TypeM rep a
+ = TypeM
+ ( ReaderT
+ (Env rep)
+ (StateT TState (Either (TypeError rep)))
+ a
+ )
+ deriving
+ ( Monad,
+ Functor,
+ Applicative,
+ MonadReader (Env rep),
+ MonadState TState
+ )
+
+instance
+ Checkable rep =>
+ HasScope (Aliases rep) (TypeM rep)
+ where
+ lookupType = fmap typeOf . lookupVar
+ askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable
+ where
+ varType (name, dec) = Just (name, dec)
+
+runTypeM ::
+ Env rep ->
+ TypeM rep a ->
+ Either (TypeError rep) (a, Consumption)
+runTypeM env (TypeM m) =
+ second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty)
+
+bad :: ErrorCase rep -> TypeM rep a
+bad e = do
+ messages <- asks envContext
+ TypeM $ lift $ lift $ Left $ Error (reverse messages) e
+
+tell :: Consumption -> TypeM rep ()
+tell cons = modify $ \s -> s {stateCons = stateCons s <> cons}
+
+-- | Add information about what is being type-checked to the current
+-- context. Liberal use of this combinator makes it easier to track
+-- type errors, as the strings are added to type errors signalled via
+-- 'bad'.
+context ::
+ String ->
+ TypeM rep a ->
+ TypeM rep a
+context s = local $ \env -> env {envContext = s : envContext env}
+
+message ::
+ Pretty a =>
+ String ->
+ a ->
+ String
+message s x =
+ prettyDoc 80 $
+ text s <+> align (ppr x)
+
+-- | Mark a name as bound. If the name has been bound previously in
+-- the program, report a type error.
+bound :: VName -> TypeM rep ()
+bound name = do
+ already_seen <- gets $ nameIn name . stateNames
+ when already_seen $
+ bad $ TypeError $ "Name " ++ pretty name ++ " bound twice"
+ modify $ \s -> s {stateNames = oneName name <> stateNames s}
+
+occur :: Occurences -> TypeM rep ()
+occur = tell . Consumption . filter (not . nullOccurence)
+
+-- | Proclaim that we have made read-only use of the given variable.
+-- No-op unless the variable is array-typed.
+observe ::
+ Checkable rep =>
+ VName ->
+ TypeM rep ()
+observe name = do
+ dec <- lookupVar name
+ unless (primType $ typeOf dec) $
+ occur [observation $ oneName name <> aliases dec]
+
+-- | Proclaim that we have written to the given variables.
+consume :: Checkable rep => Names -> TypeM rep ()
+consume als = do
+ scope <- askScope
+ let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope)
+ occur [consumption $ namesFromList $ filter isArray $ namesToList als]
+
+collectOccurences :: TypeM rep a -> TypeM rep (a, Occurences)
+collectOccurences m = do
+ old <- gets stateCons
+ modify $ \s -> s {stateCons = mempty}
+ x <- m
+ new <- gets stateCons
+ modify $ \s -> s {stateCons = old}
+ o <- checkConsumption new
+ pure (x, o)
+
+checkOpWith ::
+ (OpWithAliases (Op rep) -> TypeM rep ()) ->
+ TypeM rep a ->
+ TypeM rep a
+checkOpWith checker = local $ \env -> env {envCheckOp = checker}
+
+checkConsumption :: Consumption -> TypeM rep Occurences
+checkConsumption (ConsumptionError e) = bad $ TypeError e
+checkConsumption (Consumption os) = return os
+
+alternative :: TypeM rep a -> TypeM rep b -> TypeM rep (a, b)
+alternative m1 m2 = do
+ (x, os1) <- collectOccurences m1
+ (y, os2) <- collectOccurences m2
+ tell $ Consumption $ os1 `altOccurences` os2
+ pure (x, y)
+
+-- | Permit consumption of only the specified names. If one of these
+-- names is consumed, the consumption will be rewritten to be a
+-- consumption of the corresponding alias set. Consumption of
+-- anything else will result in a type error.
+consumeOnlyParams :: [(VName, Names)] -> TypeM rep a -> TypeM rep a
+consumeOnlyParams consumable m = do
+ (x, os) <- collectOccurences m
+ tell . Consumption =<< mapM inspect os
+ return x
+ where
+ inspect o = do
+ new_consumed <- mconcat <$> mapM wasConsumed (namesToList $ consumed o)
+ return o {consumed = new_consumed}
+ wasConsumed v
+ | Just als <- lookup v consumable = return als
+ | otherwise =
+ bad $
+ TypeError $
+ unlines
+ [ pretty v ++ " was invalidly consumed.",
+ what ++ " can be consumed here."
+ ]
+ what
+ | null consumable = "Nothing"
+ | otherwise = "Only " ++ intercalate ", " (map (pretty . fst) consumable)
+
+-- | Given the immediate aliases, compute the full transitive alias
+-- set (including the immediate aliases).
+expandAliases :: Names -> Env rep -> Names
+expandAliases names env = names <> aliasesOfAliases
+ where
+ aliasesOfAliases = mconcat . map look . namesToList $ names
+ look k = case M.lookup k $ envVtable env of
+ Just (LetName (als, _)) -> unAliases als
+ _ -> mempty
+
+binding ::
+ Checkable rep =>
+ Scope (Aliases rep) ->
+ TypeM rep a ->
+ TypeM rep a
+binding stms = check . local (`bindVars` stms)
+ where
+ bindVars = M.foldlWithKey' bindVar
+ boundnames = M.keys stms
+
+ bindVar env name (LetName (AliasDec als, dec)) =
+ let als'
+ | primType (typeOf dec) = mempty
+ | otherwise = expandAliases als env
+ in env
+ { envVtable =
+ M.insert name (LetName (AliasDec als', dec)) $ envVtable env
+ }
+ bindVar env name dec =
+ env {envVtable = M.insert name dec $ envVtable env}
+
+ -- Check whether the bound variables have been used correctly
+ -- within their scope.
+ check m = do
+ mapM_ bound $ M.keys stms
+ (a, os) <- collectOccurences m
+ tell $ Consumption $ unOccur (namesFromList boundnames) os
+ return a
+
+lookupVar :: VName -> TypeM rep (NameInfo (Aliases rep))
+lookupVar name = do
+ stm <- asks $ M.lookup name . envVtable
+ case stm of
+ Nothing -> bad $ UnknownVariableError name
+ Just dec -> return dec
+
+lookupAliases :: Checkable rep => VName -> TypeM rep Names
+lookupAliases name = do
+ info <- lookupVar name
+ return $
+ if primType $ typeOf info
+ then mempty
+ else oneName name <> aliases info
+
+aliases :: NameInfo (Aliases rep) -> Names
+aliases (LetName (als, _)) = unAliases als
+aliases _ = mempty
+
+subExpAliasesM :: Checkable rep => SubExp -> TypeM rep Names
+subExpAliasesM Constant {} = return mempty
+subExpAliasesM (Var v) = lookupAliases v
+
+lookupFun ::
+ Checkable rep =>
+ Name ->
+ [SubExp] ->
+ TypeM rep ([RetType rep], [DeclType])
+lookupFun fname args = do
+ stm <- asks $ M.lookup fname . envFtable
+ case stm of
+ Nothing -> bad $ UnknownFunctionError fname
+ Just (ftype, params) -> do
+ argts <- mapM subExpType args
+ case applyRetType ftype params $ zip args argts of
+ Nothing ->
+ bad $ ParameterMismatch (Just fname) (map paramType params) argts
+ Just rt ->
+ return (rt, map paramDeclType params)
+
+-- | @checkAnnotation loc s t1 t2@ checks if @t2@ is equal to
+-- @t1@. If not, a 'BadAnnotation' is raised.
+checkAnnotation ::
+ String ->
+ Type ->
+ Type ->
+ TypeM rep ()
+checkAnnotation desc t1 t2
+ | t2 == t1 = return ()
+ | otherwise = bad $ BadAnnotation desc t1 t2
+
+-- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is
+-- not a subtype of one of the types in @ts@.
+require :: Checkable rep => [Type] -> SubExp -> TypeM rep ()
+require ts se = do
+ t <- checkSubExp se
+ unless (t `elem` ts) $
+ bad $ UnexpectedType (BasicOp $ SubExp se) t ts
+
+-- | Variant of 'require' working on variable names.
+requireI :: Checkable rep => [Type] -> VName -> TypeM rep ()
+requireI ts ident = require ts $ Var ident
+
+checkArrIdent ::
+ Checkable rep =>
+ VName ->
+ TypeM rep Type
+checkArrIdent v = do
+ t <- lookupType v
+ case t of
+ Array {} -> return t
+ _ -> bad $ NotAnArray v t
+
+checkAccIdent ::
+ Checkable rep =>
+ VName ->
+ TypeM rep (Shape, [Type])
+checkAccIdent v = do
+ t <- lookupType v
+ case t of
+ Acc _ ispace ts _ ->
+ pure (ispace, ts)
+ _ ->
+ bad . TypeError $
+ pretty v
+ ++ " should be an accumulator but is of type "
+ ++ pretty t
+
+-- | Type check a program containing arbitrary type information,
+-- yielding either a type error or a program with complete type
+-- information.
+checkProg ::
+ Checkable rep =>
+ Prog (Aliases rep) ->
+ Either (TypeError rep) ()
+checkProg (Prog consts funs) = do
+ let typeenv =
+ Env
+ { envVtable = M.empty,
+ envFtable = mempty,
+ envContext = [],
+ envCheckOp = checkOp
+ }
+ let onFunction ftable vtable fun =
+ fmap fst $
+ runTypeM typeenv $
+ local (\env -> env {envFtable = ftable, envVtable = vtable}) $
+ checkFun fun
+ (ftable, _) <- runTypeM typeenv buildFtable
+ (vtable, _) <-
+ runTypeM typeenv {envFtable = ftable} $
+ checkStms consts $ asks envVtable
+ sequence_ $ parMap rpar (onFunction ftable vtable) funs
+ where
+ buildFtable = do
+ table <- initialFtable
+ foldM expand table funs
+ expand ftable (FunDef _ _ name ret params _)
+ | M.member name ftable =
+ bad $ DupDefinitionError name
+ | otherwise =
+ return $ M.insert name (ret, params) ftable
+
+initialFtable ::
+ Checkable rep =>
+ TypeM rep (M.Map Name (FunBinding rep))
+initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions
+ where
+ addBuiltin (fname, (t, ts)) = do
+ ps <- mapM (primFParam name) ts
+ return (fname, ([primRetType t], ps))
+ name = VName (nameFromString "x") 0
+
+checkFun ::
+ Checkable rep =>
+ FunDef (Aliases rep) ->
+ TypeM rep ()
+checkFun (FunDef _ _ fname rettype params body) =
+ context ("In function " ++ nameToString fname) $
+ checkFun'
+ ( fname,
+ map declExtTypeOf rettype,
+ funParamsToNameInfos params
+ )
+ (Just consumable)
+ $ do
+ checkFunParams params
+ checkRetType rettype
+ context "When checking function body" $ checkFunBody rettype body
+ where
+ consumable =
+ [ (paramName param, mempty)
+ | param <- params,
+ unique $ paramDeclType param
+ ]
+
+funParamsToNameInfos ::
+ [FParam rep] ->
+ [(VName, NameInfo (Aliases rep))]
+funParamsToNameInfos = map nameTypeAndDec
+ where
+ nameTypeAndDec fparam =
+ ( paramName fparam,
+ FParamName $ paramDec fparam
+ )
+
+checkFunParams ::
+ Checkable rep =>
+ [FParam rep] ->
+ TypeM rep ()
+checkFunParams = mapM_ $ \param ->
+ context ("In function parameter " ++ pretty param) $
+ checkFParamDec (paramName param) (paramDec param)
+
+checkLambdaParams ::
+ Checkable rep =>
+ [LParam rep] ->
+ TypeM rep ()
+checkLambdaParams = mapM_ $ \param ->
+ context ("In lambda parameter " ++ pretty param) $
+ checkLParamDec (paramName param) (paramDec param)
+
+checkFun' ::
+ Checkable rep =>
+ ( Name,
+ [DeclExtType],
+ [(VName, NameInfo (Aliases rep))]
+ ) ->
+ Maybe [(VName, Names)] ->
+ TypeM rep [Names] ->
+ TypeM rep ()
+checkFun' (fname, rettype, params) consumable check = do
+ checkNoDuplicateParams
+ binding (M.fromList params) $
+ maybe id consumeOnlyParams consumable $ do
+ body_aliases <- check
+ scope <- askScope
+ let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)
+ context
+ ( "When checking the body aliases: "
+ ++ pretty (map namesToList body_aliases)
+ )
+ $ checkReturnAlias $ map (namesFromList . filter isArray . namesToList) body_aliases
+ where
+ param_names = map fst params
+
+ checkNoDuplicateParams = foldM_ expand [] param_names
+
+ expand seen pname
+ | Just _ <- find (== pname) seen =
+ bad $ DupParamError fname pname
+ | otherwise =
+ return $ pname : seen
+ checkReturnAlias =
+ foldM_ checkReturnAlias' mempty . returnAliasing rettype
+
+ checkReturnAlias' seen (Unique, names)
+ | any (`S.member` S.map fst seen) $ namesToList names =
+ bad $ UniqueReturnAliased fname
+ | otherwise = do
+ consume names
+ return $ seen <> tag Unique names
+ checkReturnAlias' seen (Nonunique, names)
+ | any (`S.member` seen) $ tag Unique names =
+ bad $ UniqueReturnAliased fname
+ | otherwise = return $ seen <> tag Nonunique names
+
+ tag u = S.fromList . map (,u) . namesToList
+
+ returnAliasing expected got =
+ reverse $
+ zip (reverse (map uniqueness expected) ++ repeat Nonunique) $
+ reverse got
+
+checkSubExp :: Checkable rep => SubExp -> TypeM rep Type
+checkSubExp (Constant val) =
+ return $ Prim $ primValueType val
+checkSubExp (Var ident) = context ("In subexp " ++ pretty ident) $ do
+ observe ident
+ lookupType ident
+
+checkCerts :: Checkable rep => Certs -> TypeM rep ()
+checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs
+
+checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type
+checkSubExpRes (SubExpRes cs se) = do
+ checkCerts cs
+ checkSubExp se
+
+checkStms ::
+ Checkable rep =>
+ Stms (Aliases rep) ->
+ TypeM rep a ->
+ TypeM rep a
+checkStms origstms m = delve $ stmsToList origstms
+ where
+ delve (stm@(Let pat _ e) : stms) = do
+ context (pretty $ "In expression of statement" indent 2 (ppr pat)) $
+ checkExp e
+ checkStm stm $
+ delve stms
+ delve [] =
+ m
+
+checkResult ::
+ Checkable rep =>
+ Result ->
+ TypeM rep ()
+checkResult = mapM_ checkSubExpRes
+
+checkFunBody ::
+ Checkable rep =>
+ [RetType rep] ->
+ Body (Aliases rep) ->
+ TypeM rep [Names]
+checkFunBody rt (Body (_, rep) stms res) = do
+ checkBodyDec rep
+ checkStms stms $ do
+ context "When checking body result" $ checkResult res
+ context "When matching declared return type to result of body" $
+ matchReturnType rt res
+ map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
+ where
+ bound_here = namesFromList $ M.keys $ scopeOf stms
+
+checkLambdaBody ::
+ Checkable rep =>
+ [Type] ->
+ Body (Aliases rep) ->
+ TypeM rep [Names]
+checkLambdaBody ret (Body (_, rep) stms res) = do
+ checkBodyDec rep
+ checkStms stms $ do
+ checkLambdaResult ret res
+ map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
+ where
+ bound_here = namesFromList $ M.keys $ scopeOf stms
+
+checkLambdaResult ::
+ Checkable rep =>
+ [Type] ->
+ Result ->
+ TypeM rep ()
+checkLambdaResult ts es
+ | length ts /= length es =
+ bad $
+ TypeError $
+ "Lambda has return type " ++ prettyTuple ts
+ ++ " describing "
+ ++ show (length ts)
+ ++ " values, but body returns "
+ ++ show (length es)
+ ++ " values: "
+ ++ prettyTuple es
+ | otherwise = forM_ (zip ts es) $ \(t, e) -> do
+ et <- checkSubExpRes e
+ unless (et == t) $
+ bad $
+ TypeError $
+ "Subexpression " ++ pretty e ++ " has type " ++ pretty et
+ ++ " but expected "
+ ++ pretty t
+
+checkBody ::
+ Checkable rep =>
+ Body (Aliases rep) ->
+ TypeM rep [Names]
+checkBody (Body (_, rep) stms res) = do
+ checkBodyDec rep
+ checkStms stms $ do
+ checkResult res
+ map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
+ where
+ bound_here = namesFromList $ M.keys $ scopeOf stms
+
+checkBasicOp :: Checkable rep => BasicOp -> TypeM rep ()
+checkBasicOp (SubExp es) =
+ void $ checkSubExp es
+checkBasicOp (Opaque _ es) =
+ void $ checkSubExp es
+checkBasicOp (ArrayLit [] _) =
+ return ()
+checkBasicOp (ArrayLit (e : es') t) = do
+ let check elemt eleme = do
+ elemet <- checkSubExp eleme
+ unless (elemet == elemt) $
+ bad $
+ TypeError $
+ pretty elemet
+ ++ " is not of expected type "
+ ++ pretty elemt
+ ++ "."
+ et <- checkSubExp e
+
+ -- Compare that type with the one given for the array literal.
+ checkAnnotation "array-element" t et
+
+ mapM_ (check et) es'
+checkBasicOp (UnOp op e) = require [Prim $ unOpType op] e
+checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2
+checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2
+checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e
+checkBasicOp (Index ident (Slice idxes)) = do
+ vt <- lookupType ident
+ observe ident
+ when (arrayRank vt /= length idxes) $
+ bad $ SlicingError (arrayRank vt) (length idxes)
+ mapM_ checkDimIndex idxes
+checkBasicOp (Update _ src (Slice idxes) se) = do
+ src_t <- checkArrIdent src
+ when (arrayRank src_t /= length idxes) $
+ bad $ SlicingError (arrayRank src_t) (length idxes)
+
+ se_aliases <- subExpAliasesM se
+ when (src `nameIn` se_aliases) $
+ bad $ TypeError "The target of an Update must not alias the value to be written."
+
+ mapM_ checkDimIndex idxes
+ require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims (Slice idxes))) NoUniqueness] se
+ consume =<< lookupAliases src
+checkBasicOp (FlatIndex ident slice) = do
+ vt <- lookupType ident
+ observe ident
+ when (arrayRank vt /= 1) $
+ bad $ SlicingError (arrayRank vt) 1
+ checkFlatSlice slice
+checkBasicOp (FlatUpdate src slice v) = do
+ src_t <- checkArrIdent src
+ when (arrayRank src_t /= 1) $
+ bad $ SlicingError (arrayRank src_t) 1
+
+ v_aliases <- lookupAliases v
+ when (src `nameIn` v_aliases) $
+ bad $ TypeError "The target of an Update must not alias the value to be written."
+
+ checkFlatSlice slice
+ requireI [arrayOf (Prim (elemType src_t)) (Shape (flatSliceDims slice)) NoUniqueness] v
+ consume =<< lookupAliases src
+checkBasicOp (Iota e x s et) = do
+ require [Prim int64] e
+ require [Prim $ IntType et] x
+ require [Prim $ IntType et] s
+checkBasicOp (Replicate (Shape dims) valexp) = do
+ mapM_ (require [Prim int64]) dims
+ void $ checkSubExp valexp
+checkBasicOp (Scratch _ shape) =
+ mapM_ checkSubExp shape
+checkBasicOp (Reshape newshape arrexp) = do
+ rank <- arrayRank <$> checkArrIdent arrexp
+ mapM_ (require [Prim int64] . newDim) newshape
+ zipWithM_ (checkDimChange rank) newshape [0 ..]
+ where
+ checkDimChange _ (DimNew _) _ =
+ return ()
+ checkDimChange rank (DimCoercion se) i
+ | i >= rank =
+ bad $
+ TypeError $
+ "Asked to coerce dimension " ++ show i ++ " to " ++ pretty se
+ ++ ", but array "
+ ++ pretty arrexp
+ ++ " has only "
+ ++ pretty rank
+ ++ " dimensions"
+ | otherwise =
+ return ()
+checkBasicOp (Rearrange perm arr) = do
+ arrt <- lookupType arr
+ let rank = arrayRank arrt
+ when (length perm /= rank || sort perm /= [0 .. rank -1]) $
+ bad $ PermutationError perm rank $ Just arr
+checkBasicOp (Rotate rots arr) = do
+ arrt <- lookupType arr
+ let rank = arrayRank arrt
+ mapM_ (require [Prim int64]) rots
+ when (length rots /= rank) $
+ bad $
+ TypeError $
+ "Cannot rotate " ++ show (length rots)
+ ++ " dimensions of "
+ ++ show rank
+ ++ "-dimensional array."
+checkBasicOp (Concat i arr1exp arr2exps ressize) = do
+ arr1t <- checkArrIdent arr1exp
+ arr2ts <- mapM checkArrIdent arr2exps
+ let success =
+ all
+ ( (== dropAt i 1 (arrayDims arr1t))
+ . dropAt i 1
+ . arrayDims
+ )
+ arr2ts
+ unless success $
+ bad $
+ TypeError $
+ "Types of arguments to concat do not match. Got "
+ ++ pretty arr1t
+ ++ " and "
+ ++ intercalate ", " (map pretty arr2ts)
+ require [Prim int64] ressize
+checkBasicOp (Copy e) =
+ void $ checkArrIdent e
+checkBasicOp (Manifest perm arr) =
+ checkBasicOp $ Rearrange perm arr -- Basically same thing!
+checkBasicOp (Assert e (ErrorMsg parts) _) = do
+ require [Prim Bool] e
+ mapM_ checkPart parts
+ where
+ checkPart ErrorString {} = return ()
+ checkPart (ErrorVal t x) = require [Prim t] x
+checkBasicOp (UpdateAcc acc is ses) = do
+ (shape, ts) <- checkAccIdent acc
+
+ unless (length ses == length ts) $
+ bad $
+ TypeError $
+ "Accumulator requires "
+ ++ show (length ts)
+ ++ " values, but "
+ ++ show (length ses)
+ ++ " provided."
+
+ unless (length is == shapeRank shape) $
+ bad $
+ TypeError $
+ "Accumulator requires "
+ ++ show (shapeRank shape)
+ ++ " indices, but "
+ ++ show (length is)
+ ++ " provided."
+
+ zipWithM_ require (map pure ts) ses
+ consume =<< lookupAliases acc
+
+matchLoopResultExt ::
+ Checkable rep =>
+ [Param DeclType] ->
+ Result ->
+ TypeM rep ()
+matchLoopResultExt merge loopres = do
+ let rettype_ext =
+ existentialiseExtTypes (map paramName merge) $
+ staticShapes $ map typeOf merge
+
+ bodyt <- mapM subExpResType loopres
+
+ case instantiateShapes (fmap resSubExp . (`maybeNth` loopres)) rettype_ext of
+ Nothing ->
+ bad $
+ ReturnTypeError
+ (nameFromString "")
+ rettype_ext
+ (staticShapes bodyt)
+ Just rettype' ->
+ unless (bodyt `subtypesOf` rettype') $
+ bad $
+ ReturnTypeError
+ (nameFromString "")
+ (staticShapes rettype')
+ (staticShapes bodyt)
+
+checkExp ::
+ Checkable rep =>
+ Exp (Aliases rep) ->
+ TypeM rep ()
+checkExp (BasicOp op) = checkBasicOp op
+checkExp (If e1 e2 e3 info) = do
+ require [Prim Bool] e1
+ _ <-
+ context "in true branch" (checkBody e2)
+ `alternative` context "in false branch" (checkBody e3)
+ context "in true branch" $ matchBranchType (ifReturns info) e2
+ context "in false branch" $ matchBranchType (ifReturns info) e3
+checkExp (Apply fname args rettype_annot _) = do
+ (rettype_derived, paramtypes) <- lookupFun fname $ map fst args
+ argflows <- mapM (checkArg . fst) args
+ when (rettype_derived /= rettype_annot) $
+ bad . TypeError . pretty $
+ "Expected apply result type:"
+ indent 2 (ppr rettype_derived)
+ "But annotation is:"
+ indent 2 (ppr rettype_annot)
+ consumeArgs paramtypes argflows
+checkExp (DoLoop merge form loopbody) = do
+ let (mergepat, mergeexps) = unzip merge
+ mergeargs <- mapM checkArg mergeexps
+
+ checkLoopArgs
+
+ binding (scopeOf form) $ do
+ form_consumable <- checkForm mergeargs form
+
+ let rettype = map paramDeclType mergepat
+ consumable =
+ [ (paramName param, mempty)
+ | param <- mergepat,
+ unique $ paramDeclType param
+ ]
+ ++ form_consumable
+
+ context "Inside the loop body" $
+ checkFun'
+ ( nameFromString "",
+ staticShapes rettype,
+ funParamsToNameInfos mergepat
+ )
+ (Just consumable)
+ $ do
+ checkFunParams mergepat
+ checkBodyDec $ snd $ bodyDec loopbody
+
+ checkStms (bodyStms loopbody) $ do
+ context "In loop body result" $
+ checkResult $ bodyResult loopbody
+
+ context "When matching result of body with loop parameters" $
+ matchLoopResult (map fst merge) $ bodyResult loopbody
+
+ let bound_here =
+ namesFromList $ M.keys $ scopeOf $ bodyStms loopbody
+ map (`namesSubtract` bound_here)
+ <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody)
+ where
+ checkLoopVar (p, a) = do
+ a_t <- lookupType a
+ observe a
+ case peelArray 1 a_t of
+ Just a_t_r -> do
+ checkLParamDec (paramName p) $ paramDec p
+ unless (a_t_r `subtypeOf` typeOf (paramDec p)) $
+ bad $
+ TypeError $
+ "Loop parameter " ++ pretty p
+ ++ " not valid for element of "
+ ++ pretty a
+ ++ ", which has row type "
+ ++ pretty a_t_r
+ als <- lookupAliases a
+ pure (paramName p, als)
+ _ ->
+ bad $
+ TypeError $
+ "Cannot loop over " ++ pretty a
+ ++ " of type "
+ ++ pretty a_t
+ checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do
+ iparam <- primFParam loopvar $ IntType it
+ let mergepat = map fst merge
+ funparams = iparam : mergepat
+ paramts = map paramDeclType funparams
+
+ consumable <- mapM checkLoopVar loopvars
+ boundarg <- checkArg boundexp
+ checkFuncall Nothing paramts $ boundarg : mergeargs
+ pure consumable
+ checkForm mergeargs (WhileLoop cond) = do
+ case find ((== cond) . paramName . fst) merge of
+ Just (condparam, _) ->
+ unless (paramType condparam == Prim Bool) $
+ bad $
+ TypeError $
+ "Conditional '" ++ pretty cond ++ "' of while-loop is not boolean, but "
+ ++ pretty (paramType condparam)
+ ++ "."
+ Nothing ->
+ bad $
+ TypeError $
+ "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge variable."
+ let mergepat = map fst merge
+ funparams = mergepat
+ paramts = map paramDeclType funparams
+ checkFuncall Nothing paramts mergeargs
+ pure mempty
+
+ checkLoopArgs = do
+ let (params, args) = unzip merge
+
+ argtypes <- mapM subExpType args
+
+ let expected = expectedTypes (map paramName params) params args
+ unless (expected == argtypes) . bad . TypeError . pretty $
+ "Loop parameters"
+ indent 2 (ppTuple' params)
+ "cannot accept initial values"
+ indent 2 (ppTuple' args)
+ "of types"
+ indent 2 (ppTuple' argtypes)
+checkExp (WithAcc inputs lam) = do
+ unless (length (lambdaParams lam) == 2 * num_accs) $
+ bad . TypeError $
+ show (length (lambdaParams lam))
+ ++ " parameters, but "
+ ++ show num_accs
+ ++ " accumulators."
+
+ let cert_params = take num_accs $ lambdaParams lam
+ acc_args <- forM (zip inputs cert_params) $ \((shape, arrs, op), p) -> do
+ mapM_ (require [Prim int64]) (shapeDims shape)
+ elem_ts <- forM arrs $ \arr -> do
+ arr_t <- lookupType arr
+ unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $
+ bad . TypeError $ pretty arr <> " is not an array of outer shape " <> pretty shape
+ consume =<< lookupAliases arr
+ pure $ stripArray (shapeRank shape) arr_t
+
+ case op of
+ Just (op_lam, nes) -> do
+ let mkArrArg t = (t, mempty)
+ nes_ts <- mapM checkSubExp nes
+ unless (nes_ts == lambdaReturnType op_lam) $
+ bad $
+ TypeError $
+ unlines
+ [ "Accumulator operator return type: " ++ pretty (lambdaReturnType op_lam),
+ "Type of neutral elements: " ++ pretty nes_ts
+ ]
+ checkLambda op_lam $
+ replicate (shapeRank shape) (Prim int64, mempty)
+ ++ map mkArrArg (elem_ts ++ elem_ts)
+ Nothing ->
+ return ()
+
+ pure (Acc (paramName p) shape elem_ts NoUniqueness, mempty)
+
+ checkAnyLambda False lam $ replicate num_accs (Prim Unit, mempty) ++ acc_args
+ where
+ num_accs = length inputs
+checkExp (Op op) = do
+ checker <- asks envCheckOp
+ checker op
+
+checkSOACArrayArgs ::
+ Checkable rep =>
+ SubExp ->
+ [VName] ->
+ TypeM rep [Arg]
+checkSOACArrayArgs width = mapM checkSOACArrayArg
+ where
+ checkSOACArrayArg v = do
+ (t, als) <- checkArg $ Var v
+ case t of
+ Acc {} -> pure (t, als)
+ Array {} -> do
+ let argSize = arraySize 0 t
+ unless (argSize == width) $
+ bad . TypeError $
+ "SOAC argument " ++ pretty v ++ " has outer size "
+ ++ pretty argSize
+ ++ ", but width of SOAC is "
+ ++ pretty width
+ pure (rowType t, als)
+ _ ->
+ bad . TypeError $
+ "SOAC argument " ++ pretty v ++ " is not an array"
+
+checkType ::
+ Checkable rep =>
+ TypeBase Shape u ->
+ TypeM rep ()
+checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d
+checkType (Acc cert shape ts _) = do
+ requireI [Prim Unit] cert
+ mapM_ (require [Prim int64]) $ shapeDims shape
+ mapM_ checkType ts
+checkType t = mapM_ checkSubExp $ arrayDims t
+
+checkExtType ::
+ Checkable rep =>
+ TypeBase ExtShape u ->
+ TypeM rep ()
+checkExtType = mapM_ checkExtDim . shapeDims . arrayShape
+ where
+ checkExtDim (Free se) = void $ checkSubExp se
+ checkExtDim (Ext _) = return ()
+
+checkCmpOp ::
+ Checkable rep =>
+ CmpOp ->
+ SubExp ->
+ SubExp ->
+ TypeM rep ()
+checkCmpOp (CmpEq t) x y = do
+ require [Prim t] x
+ require [Prim t] y
+checkCmpOp (CmpUlt t) x y = checkBinOpArgs (IntType t) x y
+checkCmpOp (CmpUle t) x y = checkBinOpArgs (IntType t) x y
+checkCmpOp (CmpSlt t) x y = checkBinOpArgs (IntType t) x y
+checkCmpOp (CmpSle t) x y = checkBinOpArgs (IntType t) x y
+checkCmpOp (FCmpLt t) x y = checkBinOpArgs (FloatType t) x y
+checkCmpOp (FCmpLe t) x y = checkBinOpArgs (FloatType t) x y
+checkCmpOp CmpLlt x y = checkBinOpArgs Bool x y
+checkCmpOp CmpLle x y = checkBinOpArgs Bool x y
+
+checkBinOpArgs ::
+ Checkable rep =>
+ PrimType ->
+ SubExp ->
+ SubExp ->
+ TypeM rep ()
+checkBinOpArgs t e1 e2 = do
+ require [Prim t] e1
+ require [Prim t] e2
+
+checkPatElem ::
+ Checkable rep =>
+ PatElemT (LetDec rep) ->
+ TypeM rep ()
+checkPatElem (PatElem name dec) =
+ context ("When checking pattern element " ++ pretty name) $
+ checkLetBoundDec name dec
+
+checkFlatDimIndex ::
+ Checkable rep =>
+ FlatDimIndex SubExp ->
+ TypeM rep ()
+checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s]
+
+checkFlatSlice ::
+ Checkable rep =>
+ FlatSlice SubExp ->
+ TypeM rep ()
+checkFlatSlice (FlatSlice offset idxs) = do
+ require [Prim int64] offset
+ mapM_ checkFlatDimIndex idxs
+
+checkDimIndex ::
+ Checkable rep =>
+ DimIndex SubExp ->
+ TypeM rep ()
+checkDimIndex (DimFix i) = require [Prim int64] i
+checkDimIndex (DimSlice i n s) = mapM_ (require [Prim int64]) [i, n, s]
+
+checkStm ::
+ Checkable rep =>
+ Stm (Aliases rep) ->
+ TypeM rep a ->
+ TypeM rep a
+checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do
+ context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs
+ context "When checking expression annotation" $ checkExpDec dec
+ context ("When matching\n" ++ message " " pat ++ "\nwith\n" ++ message " " e) $
+ matchPat pat e
+ binding (maybeWithoutAliases $ scopeOf stm) $ do
+ mapM_ checkPatElem (patElems $ removePatAliases pat)
+ m
+ where
+ -- FIXME: this is wrong. However, the core language type system
+ -- is not strong enough to fully capture the aliases we want (see
+ -- issue #803). Since we eventually inline everything anyway, and
+ -- our intra-procedural alias analysis is much simpler and
+ -- correct, I could not justify spending time on improving the
+ -- inter-procedural alias analysis. If we ever stop inlining
+ -- everything, probably we need to go back and refine this.
+ maybeWithoutAliases =
+ case stmExp stm of
+ Apply {} -> M.map withoutAliases
+ _ -> id
+ withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec)
+ withoutAliases info = info
+
+matchExtPat ::
+ Checkable rep =>
+ Pat (Aliases rep) ->
+ [ExtType] ->
+ TypeM rep ()
+matchExtPat pat ts =
+ unless (expExtTypesFromPat pat == ts) $
+ bad $ InvalidPatError pat ts Nothing
+
+matchExtReturnType ::
+ Checkable rep =>
+ [ExtType] ->
+ Result ->
+ TypeM rep ()
+matchExtReturnType rettype res = do
+ ts <- mapM subExpResType res
+ matchExtReturns rettype res ts
+
+matchExtBranchType ::
+ Checkable rep =>
+ [ExtType] ->
+ Body (Aliases rep) ->
+ TypeM rep ()
+matchExtBranchType rettype (Body _ stms res) = do
+ ts <- extendedScope (traverse subExpResType res) stmscope
+ matchExtReturns rettype res ts
+ where
+ stmscope = scopeOf stms
+
+matchExtReturns :: [ExtType] -> Result -> [Type] -> TypeM rep ()
+matchExtReturns rettype res ts = do
+ let problem :: TypeM rep a
+ problem =
+ bad $
+ TypeError $
+ unlines
+ [ "Type annotation is",
+ " " ++ prettyTuple rettype,
+ "But result returns type",
+ " " ++ prettyTuple ts
+ ]
+
+ unless (length res == length rettype) problem
+
+ let ctx_vals = zip res ts
+ instantiateExt i = case maybeNth i ctx_vals of
+ Just (SubExpRes _ se, Prim (IntType Int64)) -> return se
+ _ -> problem
+
+ rettype' <- instantiateShapes instantiateExt rettype
+
+ unless (rettype' == ts) problem
+
+validApply ::
+ ArrayShape shape =>
+ [TypeBase shape Uniqueness] ->
+ [TypeBase shape NoUniqueness] ->
+ Bool
+validApply expected got =
+ length got == length expected
+ && and
+ ( zipWith
+ subtypeOf
+ (map rankShaped got)
+ (map (fromDecl . rankShaped) expected)
+ )
+
+type Arg = (Type, Names)
+
+argType :: Arg -> Type
+argType (t, _) = t
+
+-- | Remove all aliases from the 'Arg'.
+argAliases :: Arg -> Names
+argAliases (_, als) = als
+
+noArgAliases :: Arg -> Arg
+noArgAliases (t, _) = (t, mempty)
+
+checkArg ::
+ Checkable rep =>
+ SubExp ->
+ TypeM rep Arg
+checkArg arg = do
+ argt <- checkSubExp arg
+ als <- subExpAliasesM arg
+ return (argt, als)
+
+checkFuncall ::
+ Maybe Name ->
+ [DeclType] ->
+ [Arg] ->
+ TypeM rep ()
+checkFuncall fname paramts args = do
+ let argts = map argType args
+ unless (validApply paramts argts) $
+ bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args
+ consumeArgs paramts args
+
+consumeArgs ::
+ [DeclType] ->
+ [Arg] ->
+ TypeM rep ()
+consumeArgs paramts args =
+ forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->
+ occur [consumption (consumeArg als d)]
+ where
+ consumeArg als Consume = als
+ consumeArg _ _ = mempty
+
+-- The boolean indicates whether we only allow consumption of
+-- parameters.
+checkAnyLambda ::
+ Checkable rep => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep ()
+checkAnyLambda soac (Lambda params body rettype) args = do
+ let fname = nameFromString ""
+ if length params == length args
+ then do
+ -- Consumption for this is done explicitly elsewhere.
+ checkFuncall
+ Nothing
+ (map ((`toDecl` Nonunique) . paramType) params)
+ $ map noArgAliases args
+ let consumable =
+ if soac
+ then Just $ zip (map paramName params) (map argAliases args)
+ else Nothing
+ checkFun'
+ ( fname,
+ staticShapes $ map (`toDecl` Nonunique) rettype,
+ [ ( paramName param,
+ LParamName $ paramDec param
+ )
+ | param <- params
+ ]
+ )
+ consumable
+ $ do
+ checkLambdaParams params
+ mapM_ checkType rettype
+ checkLambdaBody rettype body
+ else
+ bad $
+ TypeError $
+ "Anonymous function defined with " ++ show (length params) ++ " parameters:\n"
+ ++ pretty params
+ ++ "\nbut expected to take "
+ ++ show (length args)
+ ++ " arguments."
+
+checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep ()
+checkLambda = checkAnyLambda True
+
+checkPrimExp :: Checkable rep => PrimExp VName -> TypeM rep ()
+checkPrimExp ValueExp {} = return ()
+checkPrimExp (LeafExp v pt) = requireI [Prim pt] v
+checkPrimExp (BinOpExp op x y) = do
+ requirePrimExp (binOpType op) x
+ requirePrimExp (binOpType op) y
+checkPrimExp (CmpOpExp op x y) = do
+ requirePrimExp (cmpOpType op) x
+ requirePrimExp (cmpOpType op) y
+checkPrimExp (UnOpExp op x) = requirePrimExp (unOpType op) x
+checkPrimExp (ConvOpExp op x) = requirePrimExp (fst $ convOpType op) x
+checkPrimExp (FunExp h args t) = do
+ (h_ts, h_ret, _) <-
+ maybe
+ (bad $ TypeError $ "Unknown function: " ++ h)
+ return
+ $ M.lookup h primFuns
+ when (length h_ts /= length args) $
+ bad $
+ TypeError $
+ "Function expects " ++ show (length h_ts)
+ ++ " parameters, but given "
+ ++ show (length args)
+ ++ " arguments."
+ when (h_ret /= t) $
+ bad $
+ TypeError $
+ "Function return annotation is " ++ pretty t
+ ++ ", but expected "
+ ++ pretty h_ret
+ zipWithM_ requirePrimExp h_ts args
+
+requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep ()
+requirePrimExp t e = context ("in PrimExp " ++ pretty e) $ do
+ checkPrimExp e
+ unless (primExpType e == t) $
+ bad $
+ TypeError $
+ pretty e ++ " must have type " ++ pretty t
+
+class ASTRep rep => CheckableOp rep where
+ checkOp :: OpWithAliases (Op rep) -> TypeM rep ()
+ -- ^ Used at top level; can be locally changed with 'checkOpWith'.
+
+-- | The class of representations that can be type-checked.
+class (ASTRep rep, CanBeAliased (Op rep), CheckableOp rep) => Checkable rep where
+ checkExpDec :: ExpDec rep -> TypeM rep ()
+ checkBodyDec :: BodyDec rep -> TypeM rep ()
+ checkFParamDec :: VName -> FParamInfo rep -> TypeM rep ()
+ checkLParamDec :: VName -> LParamInfo rep -> TypeM rep ()
+ checkLetBoundDec :: VName -> LetDec rep -> TypeM rep ()
+ checkRetType :: [RetType rep] -> TypeM rep ()
+ matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()
+ primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep))
+ matchReturnType :: [RetType rep] -> Result -> TypeM rep ()
+ matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()
+ matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep ()
+
+ default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep ()
+ checkExpDec = return
+
+ default checkBodyDec :: BodyDec rep ~ () => BodyDec rep -> TypeM rep ()
+ checkBodyDec = return
+
+ default checkFParamDec :: FParamInfo rep ~ DeclType => VName -> FParamInfo rep -> TypeM rep ()
+ checkFParamDec _ = checkType
+
+ default checkLParamDec :: LParamInfo rep ~ Type => VName -> LParamInfo rep -> TypeM rep ()
+ checkLParamDec _ = checkType
+
+ default checkLetBoundDec :: LetDec rep ~ Type => VName -> LetDec rep -> TypeM rep ()
+ checkLetBoundDec _ = checkType
+
+ default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep ()
+ checkRetType = mapM_ $ checkExtType . declExtTypeOf
+
+ default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()
+ matchPat pat = matchExtPat pat <=< expExtType
+
+ default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))
+ primFParam name t = return $ Param mempty name (Prim t)
+
+ default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep ()
+ matchReturnType = matchExtReturnType . map fromDecl
+
+ default matchBranchType :: BranchType rep ~ ExtType => [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()
+ matchBranchType = matchExtBranchType
+
+ default matchLoopResult ::
+ FParamInfo rep ~ DeclType =>
+ [FParam (Aliases rep)] ->
+ Result ->
+ TypeM rep ()
+ matchLoopResult = matchLoopResultExt
diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs
--- a/src/Futhark/Internalise/Exps.hs
+++ b/src/Futhark/Internalise/Exps.hs
@@ -1136,6 +1136,7 @@
letValExp' desc . I.Op =<< f w lam' nes' arrs
internaliseHist ::
+ Int ->
String ->
E.Exp ->
E.Exp ->
@@ -1145,13 +1146,11 @@
E.Exp ->
SrcLoc ->
InternaliseM [SubExp]
-internaliseHist desc rf hist op ne buckets img loc = do
+internaliseHist dim desc rf hist op ne buckets img loc = do
rf' <- internaliseExp1 "hist_rf" rf
ne' <- internaliseExp "hist_ne" ne
hist' <- internaliseExpToVars "hist_hist" hist
- buckets' <-
- letExp "hist_buckets" . BasicOp . SubExp
- =<< internaliseExp1 "hist_buckets" buckets
+ buckets' <- internaliseExpToVars "hist_buckets" buckets
img' <- internaliseExpToVars "hist_img" img
-- reshape neutral element to have same size as the destination array
@@ -1164,15 +1163,15 @@
"hist_ne_right_shape"
n
ne_ts <- mapM I.subExpType ne_shp
- his_ts <- mapM lookupType hist'
+ his_ts <- mapM (fmap (I.stripArray (dim -1)) . lookupType) hist'
op' <- internaliseFoldLambda internaliseLambda op ne_ts his_ts
-- reshape return type of bucket function to have same size as neutral element
-- (modulo the index)
- bucket_param <- newParam "bucket_p" $ I.Prim int64
+ bucket_params <- replicateM dim (newParam "bucket_p" $ I.Prim int64)
img_params <- mapM (newParam "img_p" . rowType) =<< mapM lookupType img'
- let params = bucket_param : img_params
- rettype = I.Prim int64 : ne_ts
+ let params = bucket_params ++ img_params
+ rettype = replicate dim (I.Prim int64) ++ ne_ts
body = mkBody mempty $ varsRes $ map paramName params
lam' <-
mkLambda params $
@@ -1183,26 +1182,11 @@
=<< bodyBind body
-- get sizes of histogram and image arrays
- w_hist <- arraysSize 0 <$> mapM lookupType hist'
- w_img <- arraysSize 0 <$> mapM lookupType img'
-
- -- Generate an assertion and reshapes to ensure that buckets' and
- -- img' are the same size.
- b_shape <- I.arrayShape <$> lookupType buckets'
- let b_w = shapeSize 0 b_shape
- cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int64) b_w w_img
- c <-
- assert
- "bucket_cert"
- cmp
- "length of index and value array does not match"
- loc
- buckets'' <-
- certifying c . letExp (baseString buckets') $
- I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets'
+ shape_hist <- Shape . take dim . I.arrayDims <$> lookupType (head hist')
+ w_img <- I.arraySize 0 <$> lookupType (head img')
letValExp' desc . I.Op $
- I.Hist w_img (buckets'' : img') [HistOp w_hist rf' hist' ne_shp op'] lam'
+ I.Hist w_img (buckets' ++ img') [HistOp shape_hist rf' hist' ne_shp op'] lam'
internaliseStreamMap ::
String ->
@@ -1723,8 +1707,12 @@
internaliseStreamMap desc InOrder f arr
handleSOACs [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->
internaliseStreamMap desc Disorder f arr
- handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->
- internaliseHist desc rf dest op ne buckets img loc
+ handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_1d" = Just $ \desc ->
+ internaliseHist 1 desc rf dest op ne buckets img loc
+ handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_2d" = Just $ \desc ->
+ internaliseHist 2 desc rf dest op ne buckets img loc
+ handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist_3d" = Just $ \desc ->
+ internaliseHist 3 desc rf dest op ne buckets img loc
handleSOACs _ _ = Nothing
handleAccs [TupLit [dest, f, bs] _] "scatter_stream" = Just $ \desc ->
diff --git a/src/Futhark/Optimise/DoubleBuffer.hs b/src/Futhark/Optimise/DoubleBuffer.hs
--- a/src/Futhark/Optimise/DoubleBuffer.hs
+++ b/src/Futhark/Optimise/DoubleBuffer.hs
@@ -277,6 +277,7 @@
-- memory block?
[arr_param] <- filter (isArrayIn (paramName param)) $ map fst merge,
MemArray pt _ _ (ArrayIn _ ixfun) <- paramDec arr_param,
+ not $ merge_bound `namesIntersect` freeIn (IxFun.base ixfun),
Var res_v <- resSubExp res,
Just (res_v_alloc, body_stms'') <- extractAllocOf merge_bound res_v body_stms' = do
num_bytes <-
diff --git a/src/Futhark/Optimise/MemoryBlockMerging.hs b/src/Futhark/Optimise/MemoryBlockMerging.hs
--- a/src/Futhark/Optimise/MemoryBlockMerging.hs
+++ b/src/Futhark/Optimise/MemoryBlockMerging.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module implements an optimization that tries to statically reuse
@@ -9,7 +8,6 @@
module Futhark.Optimise.MemoryBlockMerging (optimise) where
import Control.Exception
-import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Function ((&))
import Data.Map (Map, (!))
@@ -17,7 +15,6 @@
import Data.Set (Set)
import qualified Data.Set as S
import qualified Futhark.Analysis.Interference as Interference
-import qualified Futhark.Analysis.LastUse as LastUse
import Futhark.Builder.Class
import Futhark.Construct
import Futhark.IR.GPUMem
@@ -100,34 +97,8 @@
return s
helper [] = error "impossible"
-definedInExp :: Exp GPUMem -> Set VName
-definedInExp (Op (Inner (SegOp segop))) =
- definedInSegOp segop
-definedInExp (If _ then_body else_body _) =
- foldMap definedInStm (bodyStms then_body)
- <> foldMap definedInStm (bodyStms else_body)
-definedInExp (DoLoop _ _ body) =
- foldMap definedInStm $ bodyStms body
-definedInExp _ = mempty
-
-definedInStm :: Stm GPUMem -> Set VName
-definedInStm Let {stmPat = Pat merge, stmExp} =
- let definedInside = merge & fmap patElemName & S.fromList
- in definedInExp stmExp <> definedInside
-
-definedInSegOp :: SegOp lvl GPUMem -> Set VName
-definedInSegOp (SegMap _ _ _ body) =
- foldMap definedInStm $ kernelBodyStms body
-definedInSegOp (SegRed _ _ _ _ body) =
- foldMap definedInStm $ kernelBodyStms body
-definedInSegOp (SegScan _ _ _ _ body) =
- foldMap definedInStm $ kernelBodyStms body
-definedInSegOp (SegHist _ _ _ _ body) =
- foldMap definedInStm $ kernelBodyStms body
-
-isKernelInvariant :: SegOp lvl GPUMem -> (SubExp, space) -> Bool
-isKernelInvariant segop (Var vname, _) =
- not $ vname `S.member` definedInSegOp segop
+isKernelInvariant :: Scope GPUMem -> (SubExp, space) -> Bool
+isKernelInvariant scope (Var vname, _) = vname `M.member` scope
isKernelInvariant _ _ = True
onKernelBodyStms ::
@@ -158,7 +129,8 @@
m (SegOp lvl GPUMem)
optimiseKernel graph segop0 = do
segop <- onKernelBodyStms segop0 $ onKernels $ optimiseKernel graph
- let allocs = M.filter (isKernelInvariant segop) $ getAllocsSegOp segop
+ scope_here <- askScope
+ let allocs = M.filter (isKernelInvariant scope_here) $ getAllocsSegOp segop
(colorspaces, coloring) =
GreedyColoring.colorGraph
(fmap snd allocs)
@@ -194,48 +166,33 @@
(SegOp SegLevel GPUMem -> m (SegOp SegLevel GPUMem)) ->
Stms GPUMem ->
m (Stms GPUMem)
-onKernels f =
- mapM helper
+onKernels f stms = inScopeOf stms $ mapM helper stms
where
- helper stm@Let {stmExp = Op (Inner (SegOp segop))} =
- inScopeOf stm $ do
- exp' <- f segop
- return $ stm {stmExp = Op $ Inner $ SegOp exp'}
- helper stm@Let {stmExp = If c then_body else_body dec} =
- inScopeOf stm $ do
- then_body_stms <- f `onKernels` bodyStms then_body
- else_body_stms <- f `onKernels` bodyStms else_body
- return $
- stm
- { stmExp =
- If
- c
- (then_body {bodyStms = then_body_stms})
- (else_body {bodyStms = else_body_stms})
- dec
- }
- helper stm@Let {stmExp = DoLoop merge form body} =
- inScopeOf stm $ do
- stms <- f `onKernels` bodyStms body
- return $ stm {stmExp = DoLoop merge form (body {bodyStms = stms})}
- helper stm =
- inScopeOf stm $ return stm
+ helper stm@Let {stmExp = Op (Inner (SegOp segop))} = do
+ exp' <- f segop
+ return $ stm {stmExp = Op $ Inner $ SegOp exp'}
+ helper stm@Let {stmExp = If c then_body else_body dec} = do
+ then_body_stms <- f `onKernels` bodyStms then_body
+ else_body_stms <- f `onKernels` bodyStms else_body
+ return $
+ stm
+ { stmExp =
+ If
+ c
+ (then_body {bodyStms = then_body_stms})
+ (else_body {bodyStms = else_body_stms})
+ dec
+ }
+ helper stm@Let {stmExp = DoLoop merge form body} = do
+ body_stms <- f `onKernels` bodyStms body
+ return $ stm {stmExp = DoLoop merge form (body {bodyStms = body_stms})}
+ helper stm = return stm
-- | Perform the reuse-allocations optimization.
optimise :: Pass GPUMem GPUMem
optimise =
Pass "reuse allocations" "reuse allocations" $ \prog ->
- let (lumap, _) = LastUse.analyseProg prog
- graph =
- foldMap
- ( \f ->
- runReader
- ( Interference.analyseGPU lumap $
- bodyStms $ funDefBody f
- )
- $ scopeOf f
- )
- $ progFuns prog
+ let graph = Interference.analyseProgGPU prog
in Pass.intraproceduralTransformation (onStms graph) prog
where
onStms ::
diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs
--- a/src/Futhark/Pass/ExplicitAllocations.hs
+++ b/src/Futhark/Pass/ExplicitAllocations.hs
@@ -45,7 +45,7 @@
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
-import Data.List (foldl', partition, zip4)
+import Data.List (foldl', partition, zip5)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
@@ -902,14 +902,6 @@
subExpIxFun Constant {} = return Nothing
subExpIxFun (Var v) = lookupIxFun v
-shiftShapeExts :: Int -> MemInfo ExtSize u r -> MemInfo ExtSize u r
-shiftShapeExts k (MemArray pt shape u returns) =
- MemArray pt (fmap shift shape) u returns
- where
- shift (Ext i) = Ext (i + k)
- shift (Free x) = Free x
-shiftShapeExts _ ret = ret
-
addResCtxInIfBody ::
(Allocable fromrep torep inner) =>
[ExtType] ->
@@ -919,69 +911,72 @@
AllocM fromrep torep (Body torep, [BodyReturns])
addResCtxInIfBody ifrets (Body _ stms res) spaces substs = buildBody $ do
mapM_ addStm stms
- (ctx, ctx_rets, res', res_rets, total_existentials) <-
- foldM helper ([], [], [], [], 0) (zip4 ifrets res substs spaces)
- pure
- ( ctx <> res',
- -- We need to adjust the existentials in shapes corresponding
- -- to the previous type, because we added more existentials in
- -- front.
- ctx_rets ++ map (shiftShapeExts total_existentials) res_rets
- )
+ let offsets = scanl (+) 0 $ zipWith numCtxNeeded ifrets substs
+ num_new_ctx = last offsets
+ (ctx, ctx_rets, res', res_rets) <-
+ foldM (helper num_new_ctx) ([], [], [], []) $
+ zip5 ifrets res substs spaces offsets
+ pure (ctx <> res', ctx_rets ++ res_rets)
where
- helper (ctx_acc, ctx_rets_acc, res_acc, res_rets_acc, k) (ifr, r, mbixfsub, sp) =
- case mbixfsub of
- Nothing -> do
- -- does NOT generalize/antiunify; ensure direct
- r' <- ensureDirect sp r
- (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r'
- let body_ret = inspect k ifr sp
- pure
- ( ctx_acc ++ mem_ctx_ses,
- ctx_rets_acc ++ mem_ctx_rets,
- res_acc ++ [r'],
- res_rets_acc ++ [body_ret],
- k + length mem_ctx_ses
- )
- Just (ixfn, m) -> do
- -- generalizes
- let i = length m
- ext_ses <- mapM (toSubExp "ixfn_exist") m
- (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r
- let sp' = fromMaybe DefaultSpace sp
- ixfn' = fmap (adjustExtPE k) ixfn
- exttp = case ifr of
- Array pt shp' u ->
- MemArray pt shp' u $ ReturnsNewBlock sp' (k + i) ixfn'
- _ -> error "Impossible case reached in addResCtxInIfBody"
- pure
- ( ctx_acc ++ subExpsRes ext_ses ++ mem_ctx_ses,
- ctx_rets_acc ++ map (const (MemPrim int64)) ext_ses ++ mem_ctx_rets,
- res_acc ++ [r],
- res_rets_acc ++ [exttp],
- k + i + 1
- )
+ numCtxNeeded Array {} Nothing = 1
+ numCtxNeeded Array {} (Just (_, m)) = length m + 1
+ numCtxNeeded _ _ = 0
- inspect k (Array pt shape u) space =
+ helper
+ num_new_ctx
+ (ctx_acc, ctx_rets_acc, res_acc, res_rets_acc)
+ (ifr, r, mbixfsub, sp, ctx_offset) =
+ case mbixfsub of
+ Nothing -> do
+ -- does NOT generalize/antiunify; ensure direct
+ r' <- ensureDirect sp r
+ (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r'
+ let body_ret = inspect num_new_ctx ctx_offset ifr sp
+ pure
+ ( ctx_acc ++ mem_ctx_ses,
+ ctx_rets_acc ++ mem_ctx_rets,
+ res_acc ++ [r'],
+ res_rets_acc ++ [body_ret]
+ )
+ Just (ixfn, m) -> do
+ -- generalizes
+ let i = length m
+ ext_ses <- mapM (toSubExp "ixfn_exist") m
+ (mem_ctx_ses, mem_ctx_rets) <- unzip <$> bodyReturnMemCtx r
+ let sp' = fromMaybe DefaultSpace sp
+ ixfn' = fmap (adjustExtPE ctx_offset) ixfn
+ exttp = case ifr of
+ Array pt shape u ->
+ MemArray pt (fmap (adjustExt num_new_ctx) shape) u $
+ ReturnsNewBlock sp' (ctx_offset + i) ixfn'
+ _ -> error "Impossible case reached in addResCtxInIfBody"
+ pure
+ ( ctx_acc ++ subExpsRes ext_ses ++ mem_ctx_ses,
+ ctx_rets_acc ++ map (const (MemPrim int64)) ext_ses ++ mem_ctx_rets,
+ res_acc ++ [r],
+ res_rets_acc ++ [exttp]
+ )
+
+ inspect num_new_ctx k (Array pt shape u) space =
let space' = fromMaybe DefaultSpace space
+ shape' = fmap (adjustExt num_new_ctx) shape
bodyret =
- MemArray pt shape u $
- ReturnsNewBlock space' k $
- IxFun.iota $ map convert $ shapeDims shape
+ MemArray pt shape' u . ReturnsNewBlock space' k $
+ IxFun.iota $ map convert $ shapeDims shape'
in bodyret
- inspect _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u
- inspect _ (Prim pt) _ = MemPrim pt
- inspect _ (Mem space) _ = MemMem space
+ inspect _ _ (Acc acc ispace ts u) _ = MemAcc acc ispace ts u
+ inspect _ _ (Prim pt) _ = MemPrim pt
+ inspect _ _ (Mem space) _ = MemMem space
convert (Ext i) = le64 (Ext i)
convert (Free v) = Free <$> pe64 v
- adjustExtV :: Int -> Ext VName -> Ext VName
- adjustExtV _ (Free v) = Free v
- adjustExtV k (Ext i) = Ext (k + i)
+ adjustExt :: Int -> Ext a -> Ext a
+ adjustExt _ (Free v) = Free v
+ adjustExt k (Ext i) = Ext (k + i)
adjustExtPE :: Int -> TPrimExp t (Ext VName) -> TPrimExp t (Ext VName)
- adjustExtPE k = fmap (adjustExtV k)
+ adjustExtPE k = fmap (adjustExt k)
mkSpaceOks ::
(Mem torep inner, LocalScope torep m) =>
diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs
--- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs
+++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs
@@ -974,10 +974,10 @@
[VName] ->
m (Stms (Rep m))
histKernel onLambda lvl orig_pat ispace inputs cs hist_w ops lam arrs = runBuilderT'_ $ do
- ops' <- forM ops $ \(SOACS.HistOp num_bins rf dests nes op) -> do
+ ops' <- forM ops $ \(SOACS.HistOp dest_shape rf dests nes op) -> do
(op', nes', shape) <- determineReduceOp op nes
op'' <- lift $ onLambda op'
- return $ HistOp num_bins rf dests nes' shape op''
+ return $ HistOp dest_shape rf dests nes' shape op''
let isDest = flip elem $ concatMap histDest ops'
inputs' = filter (not . isDest . kernelInputArray) inputs
diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs
--- a/src/Futhark/Passes.hs
+++ b/src/Futhark/Passes.hs
@@ -90,7 +90,6 @@
>>> onePass Seq.explicitAllocations
>>> passes
[ performCSE False,
- simplifySeqMem,
simplifySeqMem
]
diff --git a/src/Futhark/Pipeline.hs b/src/Futhark/Pipeline.hs
--- a/src/Futhark/Pipeline.hs
+++ b/src/Futhark/Pipeline.hs
@@ -38,9 +38,9 @@
import qualified Futhark.Analysis.Alias as Alias
import Futhark.Error
import Futhark.IR (PrettyRep, Prog)
+import Futhark.IR.TypeCheck
import Futhark.MonadFreshNames
import Futhark.Pass
-import Futhark.TypeCheck
import Futhark.Util.Log
import Futhark.Util.Pretty (prettyText)
import System.IO
diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs
--- a/src/Futhark/Transform/FirstOrderTransform.hs
+++ b/src/Futhark/Transform/FirstOrderTransform.hs
@@ -317,36 +317,35 @@
imgs'' <- map resSubExp <$> bindLambda bucket_fun (map (BasicOp . SubExp) imgs')
-- Split out values from bucket function.
- let lens = length ops
- inds = take lens imgs''
+ let lens = sum $ map (shapeRank . histShape) ops
+ ops_inds = chunks (map (shapeRank . histShape) ops) (take lens imgs'')
vals = chunks (map (length . lambdaReturnType . histOp) ops) $ drop lens imgs''
hists_out' =
chunks (map (length . lambdaReturnType . histOp) ops) $
map identName hists_out
- hists_out'' <- forM (zip4 hists_out' ops inds vals) $ \(hist, op, idx, val) -> do
+ hists_out'' <- forM (zip4 hists_out' ops ops_inds vals) $ \(hist, op, idxs, val) -> do
-- Check whether the indexes are in-bound. If they are not, we
-- return the histograms unchanged.
let outside_bounds_branch = buildBody_ $ pure $ varsRes hist
oob = case hist of
[] -> eSubExp $ constant True
- arr : _ -> eOutOfBounds arr [eSubExp idx]
+ arr : _ -> eOutOfBounds arr $ map eSubExp idxs
letTupExp "new_histo" <=< eIf oob outside_bounds_branch $
buildBody_ $ do
-- Read values from histogram.
h_val <- forM hist $ \arr -> do
arr_t <- lookupType arr
- letSubExp "read_hist" $ BasicOp $ Index arr $ fullSlice arr_t [DimFix idx]
+ letSubExp "read_hist" $ BasicOp $ Index arr $ fullSlice arr_t $ map DimFix idxs
-- Apply operator.
- h_val' <-
- bindLambda (histOp op) $ map (BasicOp . SubExp) $ h_val ++ val
+ h_val' <- bindLambda (histOp op) $ map (BasicOp . SubExp) $ h_val ++ val
-- Write values back to histograms.
hist' <- forM (zip hist h_val') $ \(arr, SubExpRes cs v) -> do
arr_t <- lookupType arr
- certifying cs . letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $
+ certifying cs . letInPlace "hist_out" arr (fullSlice arr_t $ map DimFix idxs) $
BasicOp $ SubExp v
pure $ varsRes hist'
diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs
deleted file mode 100644
--- a/src/Futhark/TypeCheck.hs
+++ /dev/null
@@ -1,1534 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Strict #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- | The type checker checks whether the program is type-consistent.
-module Futhark.TypeCheck
- ( -- * Interface
- checkProg,
- TypeError (..),
- ErrorCase (..),
-
- -- * Extensionality
- TypeM,
- bad,
- context,
- message,
- Checkable (..),
- CheckableOp (..),
- lookupVar,
- lookupAliases,
- checkOpWith,
-
- -- * Checkers
- require,
- requireI,
- requirePrimExp,
- checkSubExp,
- checkCerts,
- checkExp,
- checkStms,
- checkStm,
- checkType,
- checkExtType,
- matchExtPat,
- matchExtBranchType,
- argType,
- argAliases,
- noArgAliases,
- checkArg,
- checkSOACArrayArgs,
- checkLambda,
- checkBody,
- consume,
- consumeOnlyParams,
- binding,
- alternative,
- )
-where
-
-import Control.Monad.Reader
-import Control.Monad.State.Strict
-import Control.Parallel.Strategies
-import Data.Bifunctor (second)
-import Data.List (find, intercalate, isPrefixOf, sort)
-import qualified Data.Map.Strict as M
-import Data.Maybe
-import qualified Data.Set as S
-import Futhark.Analysis.PrimExp
-import Futhark.Construct (instantiateShapes)
-import Futhark.IR.Aliases hiding (lookupAliases)
-import Futhark.Util
-import Futhark.Util.Pretty (Pretty, align, indent, ppr, prettyDoc, text, (<+>), ())
-
--- | Information about an error during type checking. The 'Show'
--- instance for this type produces a human-readable description.
-data ErrorCase rep
- = TypeError String
- | UnexpectedType (Exp rep) Type [Type]
- | ReturnTypeError Name [ExtType] [ExtType]
- | DupDefinitionError Name
- | DupParamError Name VName
- | DupPatError VName
- | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String)
- | UnknownVariableError VName
- | UnknownFunctionError Name
- | ParameterMismatch (Maybe Name) [Type] [Type]
- | SlicingError Int Int
- | BadAnnotation String Type Type
- | ReturnAliased Name VName
- | UniqueReturnAliased Name
- | NotAnArray VName Type
- | PermutationError [Int] Int (Maybe VName)
-
-instance Checkable rep => Show (ErrorCase rep) where
- show (TypeError msg) =
- "Type error:\n" ++ msg
- show (UnexpectedType e _ []) =
- "Type of expression\n"
- ++ prettyDoc 160 (indent 2 $ ppr e)
- ++ "\ncannot have any type - possibly a bug in the type checker."
- show (UnexpectedType e t ts) =
- "Type of expression\n"
- ++ prettyDoc 160 (indent 2 $ ppr e)
- ++ "\nmust be one of "
- ++ intercalate ", " (map pretty ts)
- ++ ", but is "
- ++ pretty t
- ++ "."
- show (ReturnTypeError fname rettype bodytype) =
- "Declaration of function " ++ nameToString fname
- ++ " declares return type\n "
- ++ prettyTuple rettype
- ++ "\nBut body has type\n "
- ++ prettyTuple bodytype
- show (DupDefinitionError name) =
- "Duplicate definition of function " ++ nameToString name ++ ""
- show (DupParamError funname paramname) =
- "Parameter " ++ pretty paramname
- ++ " mentioned multiple times in argument list of function "
- ++ nameToString funname
- ++ "."
- show (DupPatError name) =
- "Variable " ++ pretty name ++ " bound twice in pattern."
- show (InvalidPatError pat t desc) =
- "Pat\n" ++ pretty pat
- ++ "\ncannot match value of type\n"
- ++ prettyTupleLines t
- ++ end
- where
- end = case desc of
- Nothing -> "."
- Just desc' -> ":\n" ++ desc'
- show (UnknownVariableError name) =
- "Use of unknown variable " ++ pretty name ++ "."
- show (UnknownFunctionError fname) =
- "Call of unknown function " ++ nameToString fname ++ "."
- show (ParameterMismatch fname expected got) =
- "In call of " ++ fname' ++ ":\n"
- ++ "expecting "
- ++ show nexpected
- ++ " arguments of type(s)\n"
- ++ intercalate ", " (map pretty expected)
- ++ "\nGot "
- ++ show ngot
- ++ " arguments of types\n"
- ++ intercalate ", " (map pretty got)
- where
- nexpected = length expected
- ngot = length got
- fname' = maybe "anonymous function" (("function " ++) . nameToString) fname
- show (SlicingError dims got) =
- show got ++ " indices given, but type of indexee has " ++ show dims ++ " dimension(s)."
- show (BadAnnotation desc expected got) =
- "Annotation of \"" ++ desc ++ "\" type of expression is " ++ pretty expected
- ++ ", but derived to be "
- ++ pretty got
- ++ "."
- show (ReturnAliased fname name) =
- "Unique return value of function " ++ nameToString fname
- ++ " is aliased to "
- ++ pretty name
- ++ ", which is not consumed."
- show (UniqueReturnAliased fname) =
- "A unique tuple element of return value of function "
- ++ nameToString fname
- ++ " is aliased to some other tuple component."
- show (NotAnArray e t) =
- "The expression " ++ pretty e
- ++ " is expected to be an array, but is "
- ++ pretty t
- ++ "."
- show (PermutationError perm rank name) =
- "The permutation (" ++ intercalate ", " (map show perm)
- ++ ") is not valid for array "
- ++ name'
- ++ "of rank "
- ++ show rank
- ++ "."
- where
- name' = maybe "" ((++ " ") . pretty) name
-
--- | A type error.
-data TypeError rep = Error [String] (ErrorCase rep)
-
-instance Checkable rep => Show (TypeError rep) where
- show (Error [] err) =
- show err
- show (Error msgs err) =
- intercalate "\n" msgs ++ "\n" ++ show err
-
--- | A tuple of a return type and a list of parameters, possibly
--- named.
-type FunBinding rep = ([RetType (Aliases rep)], [FParam (Aliases rep)])
-
-type VarBinding rep = NameInfo (Aliases rep)
-
-data Usage
- = Consumed
- | Observed
- deriving (Eq, Ord, Show)
-
-data Occurence = Occurence
- { observed :: Names,
- consumed :: Names
- }
- deriving (Eq, Show)
-
-observation :: Names -> Occurence
-observation = flip Occurence mempty
-
-consumption :: Names -> Occurence
-consumption = Occurence mempty
-
-nullOccurence :: Occurence -> Bool
-nullOccurence occ = observed occ == mempty && consumed occ == mempty
-
-type Occurences = [Occurence]
-
-allConsumed :: Occurences -> Names
-allConsumed = mconcat . map consumed
-
-seqOccurences :: Occurences -> Occurences -> Occurences
-seqOccurences occurs1 occurs2 =
- filter (not . nullOccurence) (map filt occurs1) ++ occurs2
- where
- filt occ =
- occ {observed = observed occ `namesSubtract` postcons}
- postcons = allConsumed occurs2
-
-altOccurences :: Occurences -> Occurences -> Occurences
-altOccurences occurs1 occurs2 =
- filter (not . nullOccurence) (map filt occurs1) ++ occurs2
- where
- filt occ =
- occ
- { consumed = consumed occ `namesSubtract` postcons,
- observed = observed occ `namesSubtract` postcons
- }
- postcons = allConsumed occurs2
-
-unOccur :: Names -> Occurences -> Occurences
-unOccur to_be_removed = filter (not . nullOccurence) . map unOccur'
- where
- unOccur' occ =
- occ
- { observed = observed occ `namesSubtract` to_be_removed,
- consumed = consumed occ `namesSubtract` to_be_removed
- }
-
--- | The 'Consumption' data structure is used to keep track of which
--- variables have been consumed, as well as whether a violation has been detected.
-data Consumption
- = ConsumptionError String
- | Consumption Occurences
- deriving (Show)
-
-instance Semigroup Consumption where
- ConsumptionError e <> _ = ConsumptionError e
- _ <> ConsumptionError e = ConsumptionError e
- Consumption o1 <> Consumption o2
- | v : _ <- namesToList $ consumed_in_o1 `namesIntersection` used_in_o2 =
- ConsumptionError $ "Variable " <> pretty v <> " referenced after being consumed."
- | otherwise =
- Consumption $ o1 `seqOccurences` o2
- where
- consumed_in_o1 = mconcat $ map consumed o1
- used_in_o2 = mconcat $ map consumed o2 <> map observed o2
-
-instance Monoid Consumption where
- mempty = Consumption mempty
-
--- | The environment contains a variable table and a function table.
--- Type checking happens with access to this environment. The
--- function table is only initialised at the very beginning, but the
--- variable table will be extended during type-checking when
--- let-expressions are encountered.
-data Env rep = Env
- { envVtable :: M.Map VName (VarBinding rep),
- envFtable :: M.Map Name (FunBinding rep),
- envCheckOp :: OpWithAliases (Op rep) -> TypeM rep (),
- envContext :: [String]
- }
-
-data TState = TState
- { stateNames :: Names,
- stateCons :: Consumption
- }
-
--- | The type checker runs in this monad.
-newtype TypeM rep a
- = TypeM
- ( ReaderT
- (Env rep)
- (StateT TState (Either (TypeError rep)))
- a
- )
- deriving
- ( Monad,
- Functor,
- Applicative,
- MonadReader (Env rep),
- MonadState TState
- )
-
-instance
- Checkable rep =>
- HasScope (Aliases rep) (TypeM rep)
- where
- lookupType = fmap typeOf . lookupVar
- askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable
- where
- varType (name, dec) = Just (name, dec)
-
-runTypeM ::
- Env rep ->
- TypeM rep a ->
- Either (TypeError rep) (a, Consumption)
-runTypeM env (TypeM m) =
- second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty)
-
-bad :: ErrorCase rep -> TypeM rep a
-bad e = do
- messages <- asks envContext
- TypeM $ lift $ lift $ Left $ Error (reverse messages) e
-
-tell :: Consumption -> TypeM rep ()
-tell cons = modify $ \s -> s {stateCons = stateCons s <> cons}
-
--- | Add information about what is being type-checked to the current
--- context. Liberal use of this combinator makes it easier to track
--- type errors, as the strings are added to type errors signalled via
--- 'bad'.
-context ::
- String ->
- TypeM rep a ->
- TypeM rep a
-context s = local $ \env -> env {envContext = s : envContext env}
-
-message ::
- Pretty a =>
- String ->
- a ->
- String
-message s x =
- prettyDoc 80 $
- text s <+> align (ppr x)
-
--- | Mark a name as bound. If the name has been bound previously in
--- the program, report a type error.
-bound :: VName -> TypeM rep ()
-bound name = do
- already_seen <- gets $ nameIn name . stateNames
- when already_seen $
- bad $ TypeError $ "Name " ++ pretty name ++ " bound twice"
- modify $ \s -> s {stateNames = oneName name <> stateNames s}
-
-occur :: Occurences -> TypeM rep ()
-occur = tell . Consumption . filter (not . nullOccurence)
-
--- | Proclaim that we have made read-only use of the given variable.
--- No-op unless the variable is array-typed.
-observe ::
- Checkable rep =>
- VName ->
- TypeM rep ()
-observe name = do
- dec <- lookupVar name
- unless (primType $ typeOf dec) $
- occur [observation $ oneName name <> aliases dec]
-
--- | Proclaim that we have written to the given variables.
-consume :: Checkable rep => Names -> TypeM rep ()
-consume als = do
- scope <- askScope
- let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope)
- occur [consumption $ namesFromList $ filter isArray $ namesToList als]
-
-collectOccurences :: TypeM rep a -> TypeM rep (a, Occurences)
-collectOccurences m = do
- old <- gets stateCons
- modify $ \s -> s {stateCons = mempty}
- x <- m
- new <- gets stateCons
- modify $ \s -> s {stateCons = old}
- o <- checkConsumption new
- pure (x, o)
-
-checkOpWith ::
- (OpWithAliases (Op rep) -> TypeM rep ()) ->
- TypeM rep a ->
- TypeM rep a
-checkOpWith checker = local $ \env -> env {envCheckOp = checker}
-
-checkConsumption :: Consumption -> TypeM rep Occurences
-checkConsumption (ConsumptionError e) = bad $ TypeError e
-checkConsumption (Consumption os) = return os
-
-alternative :: TypeM rep a -> TypeM rep b -> TypeM rep (a, b)
-alternative m1 m2 = do
- (x, os1) <- collectOccurences m1
- (y, os2) <- collectOccurences m2
- tell $ Consumption $ os1 `altOccurences` os2
- pure (x, y)
-
--- | Permit consumption of only the specified names. If one of these
--- names is consumed, the consumption will be rewritten to be a
--- consumption of the corresponding alias set. Consumption of
--- anything else will result in a type error.
-consumeOnlyParams :: [(VName, Names)] -> TypeM rep a -> TypeM rep a
-consumeOnlyParams consumable m = do
- (x, os) <- collectOccurences m
- tell . Consumption =<< mapM inspect os
- return x
- where
- inspect o = do
- new_consumed <- mconcat <$> mapM wasConsumed (namesToList $ consumed o)
- return o {consumed = new_consumed}
- wasConsumed v
- | Just als <- lookup v consumable = return als
- | otherwise =
- bad $
- TypeError $
- unlines
- [ pretty v ++ " was invalidly consumed.",
- what ++ " can be consumed here."
- ]
- what
- | null consumable = "Nothing"
- | otherwise = "Only " ++ intercalate ", " (map (pretty . fst) consumable)
-
--- | Given the immediate aliases, compute the full transitive alias
--- set (including the immediate aliases).
-expandAliases :: Names -> Env rep -> Names
-expandAliases names env = names <> aliasesOfAliases
- where
- aliasesOfAliases = mconcat . map look . namesToList $ names
- look k = case M.lookup k $ envVtable env of
- Just (LetName (als, _)) -> unAliases als
- _ -> mempty
-
-binding ::
- Checkable rep =>
- Scope (Aliases rep) ->
- TypeM rep a ->
- TypeM rep a
-binding stms = check . local (`bindVars` stms)
- where
- bindVars = M.foldlWithKey' bindVar
- boundnames = M.keys stms
-
- bindVar env name (LetName (AliasDec als, dec)) =
- let als'
- | primType (typeOf dec) = mempty
- | otherwise = expandAliases als env
- in env
- { envVtable =
- M.insert name (LetName (AliasDec als', dec)) $ envVtable env
- }
- bindVar env name dec =
- env {envVtable = M.insert name dec $ envVtable env}
-
- -- Check whether the bound variables have been used correctly
- -- within their scope.
- check m = do
- mapM_ bound $ M.keys stms
- (a, os) <- collectOccurences m
- tell $ Consumption $ unOccur (namesFromList boundnames) os
- return a
-
-lookupVar :: VName -> TypeM rep (NameInfo (Aliases rep))
-lookupVar name = do
- stm <- asks $ M.lookup name . envVtable
- case stm of
- Nothing -> bad $ UnknownVariableError name
- Just dec -> return dec
-
-lookupAliases :: Checkable rep => VName -> TypeM rep Names
-lookupAliases name = do
- info <- lookupVar name
- return $
- if primType $ typeOf info
- then mempty
- else oneName name <> aliases info
-
-aliases :: NameInfo (Aliases rep) -> Names
-aliases (LetName (als, _)) = unAliases als
-aliases _ = mempty
-
-subExpAliasesM :: Checkable rep => SubExp -> TypeM rep Names
-subExpAliasesM Constant {} = return mempty
-subExpAliasesM (Var v) = lookupAliases v
-
-lookupFun ::
- Checkable rep =>
- Name ->
- [SubExp] ->
- TypeM rep ([RetType rep], [DeclType])
-lookupFun fname args = do
- stm <- asks $ M.lookup fname . envFtable
- case stm of
- Nothing -> bad $ UnknownFunctionError fname
- Just (ftype, params) -> do
- argts <- mapM subExpType args
- case applyRetType ftype params $ zip args argts of
- Nothing ->
- bad $ ParameterMismatch (Just fname) (map paramType params) argts
- Just rt ->
- return (rt, map paramDeclType params)
-
--- | @checkAnnotation loc s t1 t2@ checks if @t2@ is equal to
--- @t1@. If not, a 'BadAnnotation' is raised.
-checkAnnotation ::
- String ->
- Type ->
- Type ->
- TypeM rep ()
-checkAnnotation desc t1 t2
- | t2 == t1 = return ()
- | otherwise = bad $ BadAnnotation desc t1 t2
-
--- | @require ts se@ causes a '(TypeError vn)' if the type of @se@ is
--- not a subtype of one of the types in @ts@.
-require :: Checkable rep => [Type] -> SubExp -> TypeM rep ()
-require ts se = do
- t <- checkSubExp se
- unless (t `elem` ts) $
- bad $ UnexpectedType (BasicOp $ SubExp se) t ts
-
--- | Variant of 'require' working on variable names.
-requireI :: Checkable rep => [Type] -> VName -> TypeM rep ()
-requireI ts ident = require ts $ Var ident
-
-checkArrIdent ::
- Checkable rep =>
- VName ->
- TypeM rep Type
-checkArrIdent v = do
- t <- lookupType v
- case t of
- Array {} -> return t
- _ -> bad $ NotAnArray v t
-
-checkAccIdent ::
- Checkable rep =>
- VName ->
- TypeM rep (Shape, [Type])
-checkAccIdent v = do
- t <- lookupType v
- case t of
- Acc _ ispace ts _ ->
- pure (ispace, ts)
- _ ->
- bad . TypeError $
- pretty v
- ++ " should be an accumulator but is of type "
- ++ pretty t
-
--- | Type check a program containing arbitrary type information,
--- yielding either a type error or a program with complete type
--- information.
-checkProg ::
- Checkable rep =>
- Prog (Aliases rep) ->
- Either (TypeError rep) ()
-checkProg (Prog consts funs) = do
- let typeenv =
- Env
- { envVtable = M.empty,
- envFtable = mempty,
- envContext = [],
- envCheckOp = checkOp
- }
- let onFunction ftable vtable fun =
- fmap fst $
- runTypeM typeenv $
- local (\env -> env {envFtable = ftable, envVtable = vtable}) $
- checkFun fun
- (ftable, _) <- runTypeM typeenv buildFtable
- (vtable, _) <-
- runTypeM typeenv {envFtable = ftable} $
- checkStms consts $ asks envVtable
- sequence_ $ parMap rpar (onFunction ftable vtable) funs
- where
- buildFtable = do
- table <- initialFtable
- foldM expand table funs
- expand ftable (FunDef _ _ name ret params _)
- | M.member name ftable =
- bad $ DupDefinitionError name
- | otherwise =
- return $ M.insert name (ret, params) ftable
-
-initialFtable ::
- Checkable rep =>
- TypeM rep (M.Map Name (FunBinding rep))
-initialFtable = fmap M.fromList $ mapM addBuiltin $ M.toList builtInFunctions
- where
- addBuiltin (fname, (t, ts)) = do
- ps <- mapM (primFParam name) ts
- return (fname, ([primRetType t], ps))
- name = VName (nameFromString "x") 0
-
-checkFun ::
- Checkable rep =>
- FunDef (Aliases rep) ->
- TypeM rep ()
-checkFun (FunDef _ _ fname rettype params body) =
- context ("In function " ++ nameToString fname) $
- checkFun'
- ( fname,
- map declExtTypeOf rettype,
- funParamsToNameInfos params
- )
- (Just consumable)
- $ do
- checkFunParams params
- checkRetType rettype
- context "When checking function body" $ checkFunBody rettype body
- where
- consumable =
- [ (paramName param, mempty)
- | param <- params,
- unique $ paramDeclType param
- ]
-
-funParamsToNameInfos ::
- [FParam rep] ->
- [(VName, NameInfo (Aliases rep))]
-funParamsToNameInfos = map nameTypeAndDec
- where
- nameTypeAndDec fparam =
- ( paramName fparam,
- FParamName $ paramDec fparam
- )
-
-checkFunParams ::
- Checkable rep =>
- [FParam rep] ->
- TypeM rep ()
-checkFunParams = mapM_ $ \param ->
- context ("In function parameter " ++ pretty param) $
- checkFParamDec (paramName param) (paramDec param)
-
-checkLambdaParams ::
- Checkable rep =>
- [LParam rep] ->
- TypeM rep ()
-checkLambdaParams = mapM_ $ \param ->
- context ("In lambda parameter " ++ pretty param) $
- checkLParamDec (paramName param) (paramDec param)
-
-checkFun' ::
- Checkable rep =>
- ( Name,
- [DeclExtType],
- [(VName, NameInfo (Aliases rep))]
- ) ->
- Maybe [(VName, Names)] ->
- TypeM rep [Names] ->
- TypeM rep ()
-checkFun' (fname, rettype, params) consumable check = do
- checkNoDuplicateParams
- binding (M.fromList params) $
- maybe id consumeOnlyParams consumable $ do
- body_aliases <- check
- scope <- askScope
- let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)
- context
- ( "When checking the body aliases: "
- ++ pretty (map namesToList body_aliases)
- )
- $ checkReturnAlias $ map (namesFromList . filter isArray . namesToList) body_aliases
- where
- param_names = map fst params
-
- checkNoDuplicateParams = foldM_ expand [] param_names
-
- expand seen pname
- | Just _ <- find (== pname) seen =
- bad $ DupParamError fname pname
- | otherwise =
- return $ pname : seen
- checkReturnAlias =
- foldM_ checkReturnAlias' mempty . returnAliasing rettype
-
- checkReturnAlias' seen (Unique, names)
- | any (`S.member` S.map fst seen) $ namesToList names =
- bad $ UniqueReturnAliased fname
- | otherwise = do
- consume names
- return $ seen <> tag Unique names
- checkReturnAlias' seen (Nonunique, names)
- | any (`S.member` seen) $ tag Unique names =
- bad $ UniqueReturnAliased fname
- | otherwise = return $ seen <> tag Nonunique names
-
- tag u = S.fromList . map (,u) . namesToList
-
- returnAliasing expected got =
- reverse $
- zip (reverse (map uniqueness expected) ++ repeat Nonunique) $
- reverse got
-
-checkSubExp :: Checkable rep => SubExp -> TypeM rep Type
-checkSubExp (Constant val) =
- return $ Prim $ primValueType val
-checkSubExp (Var ident) = context ("In subexp " ++ pretty ident) $ do
- observe ident
- lookupType ident
-
-checkCerts :: Checkable rep => Certs -> TypeM rep ()
-checkCerts (Certs cs) = mapM_ (requireI [Prim Unit]) cs
-
-checkSubExpRes :: Checkable rep => SubExpRes -> TypeM rep Type
-checkSubExpRes (SubExpRes cs se) = do
- checkCerts cs
- checkSubExp se
-
-checkStms ::
- Checkable rep =>
- Stms (Aliases rep) ->
- TypeM rep a ->
- TypeM rep a
-checkStms origstms m = delve $ stmsToList origstms
- where
- delve (stm@(Let pat _ e) : stms) = do
- context (pretty $ "In expression of statement" indent 2 (ppr pat)) $
- checkExp e
- checkStm stm $
- delve stms
- delve [] =
- m
-
-checkResult ::
- Checkable rep =>
- Result ->
- TypeM rep ()
-checkResult = mapM_ checkSubExpRes
-
-checkFunBody ::
- Checkable rep =>
- [RetType rep] ->
- Body (Aliases rep) ->
- TypeM rep [Names]
-checkFunBody rt (Body (_, rep) stms res) = do
- checkBodyDec rep
- checkStms stms $ do
- context "When checking body result" $ checkResult res
- context "When matching declared return type to result of body" $
- matchReturnType rt res
- map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
- where
- bound_here = namesFromList $ M.keys $ scopeOf stms
-
-checkLambdaBody ::
- Checkable rep =>
- [Type] ->
- Body (Aliases rep) ->
- TypeM rep [Names]
-checkLambdaBody ret (Body (_, rep) stms res) = do
- checkBodyDec rep
- checkStms stms $ do
- checkLambdaResult ret res
- map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
- where
- bound_here = namesFromList $ M.keys $ scopeOf stms
-
-checkLambdaResult ::
- Checkable rep =>
- [Type] ->
- Result ->
- TypeM rep ()
-checkLambdaResult ts es
- | length ts /= length es =
- bad $
- TypeError $
- "Lambda has return type " ++ prettyTuple ts
- ++ " describing "
- ++ show (length ts)
- ++ " values, but body returns "
- ++ show (length es)
- ++ " values: "
- ++ prettyTuple es
- | otherwise = forM_ (zip ts es) $ \(t, e) -> do
- et <- checkSubExpRes e
- unless (et == t) $
- bad $
- TypeError $
- "Subexpression " ++ pretty e ++ " has type " ++ pretty et
- ++ " but expected "
- ++ pretty t
-
-checkBody ::
- Checkable rep =>
- Body (Aliases rep) ->
- TypeM rep [Names]
-checkBody (Body (_, rep) stms res) = do
- checkBodyDec rep
- checkStms stms $ do
- checkResult res
- map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res
- where
- bound_here = namesFromList $ M.keys $ scopeOf stms
-
-checkBasicOp :: Checkable rep => BasicOp -> TypeM rep ()
-checkBasicOp (SubExp es) =
- void $ checkSubExp es
-checkBasicOp (Opaque _ es) =
- void $ checkSubExp es
-checkBasicOp (ArrayLit [] _) =
- return ()
-checkBasicOp (ArrayLit (e : es') t) = do
- let check elemt eleme = do
- elemet <- checkSubExp eleme
- unless (elemet == elemt) $
- bad $
- TypeError $
- pretty elemet
- ++ " is not of expected type "
- ++ pretty elemt
- ++ "."
- et <- checkSubExp e
-
- -- Compare that type with the one given for the array literal.
- checkAnnotation "array-element" t et
-
- mapM_ (check et) es'
-checkBasicOp (UnOp op e) = require [Prim $ unOpType op] e
-checkBasicOp (BinOp op e1 e2) = checkBinOpArgs (binOpType op) e1 e2
-checkBasicOp (CmpOp op e1 e2) = checkCmpOp op e1 e2
-checkBasicOp (ConvOp op e) = require [Prim $ fst $ convOpType op] e
-checkBasicOp (Index ident (Slice idxes)) = do
- vt <- lookupType ident
- observe ident
- when (arrayRank vt /= length idxes) $
- bad $ SlicingError (arrayRank vt) (length idxes)
- mapM_ checkDimIndex idxes
-checkBasicOp (Update _ src (Slice idxes) se) = do
- src_t <- checkArrIdent src
- when (arrayRank src_t /= length idxes) $
- bad $ SlicingError (arrayRank src_t) (length idxes)
-
- se_aliases <- subExpAliasesM se
- when (src `nameIn` se_aliases) $
- bad $ TypeError "The target of an Update must not alias the value to be written."
-
- mapM_ checkDimIndex idxes
- require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims (Slice idxes))) NoUniqueness] se
- consume =<< lookupAliases src
-checkBasicOp (FlatIndex ident slice) = do
- vt <- lookupType ident
- observe ident
- when (arrayRank vt /= 1) $
- bad $ SlicingError (arrayRank vt) 1
- checkFlatSlice slice
-checkBasicOp (FlatUpdate src slice v) = do
- src_t <- checkArrIdent src
- when (arrayRank src_t /= 1) $
- bad $ SlicingError (arrayRank src_t) 1
-
- v_aliases <- lookupAliases v
- when (src `nameIn` v_aliases) $
- bad $ TypeError "The target of an Update must not alias the value to be written."
-
- checkFlatSlice slice
- requireI [arrayOf (Prim (elemType src_t)) (Shape (flatSliceDims slice)) NoUniqueness] v
- consume =<< lookupAliases src
-checkBasicOp (Iota e x s et) = do
- require [Prim int64] e
- require [Prim $ IntType et] x
- require [Prim $ IntType et] s
-checkBasicOp (Replicate (Shape dims) valexp) = do
- mapM_ (require [Prim int64]) dims
- void $ checkSubExp valexp
-checkBasicOp (Scratch _ shape) =
- mapM_ checkSubExp shape
-checkBasicOp (Reshape newshape arrexp) = do
- rank <- arrayRank <$> checkArrIdent arrexp
- mapM_ (require [Prim int64] . newDim) newshape
- zipWithM_ (checkDimChange rank) newshape [0 ..]
- where
- checkDimChange _ (DimNew _) _ =
- return ()
- checkDimChange rank (DimCoercion se) i
- | i >= rank =
- bad $
- TypeError $
- "Asked to coerce dimension " ++ show i ++ " to " ++ pretty se
- ++ ", but array "
- ++ pretty arrexp
- ++ " has only "
- ++ pretty rank
- ++ " dimensions"
- | otherwise =
- return ()
-checkBasicOp (Rearrange perm arr) = do
- arrt <- lookupType arr
- let rank = arrayRank arrt
- when (length perm /= rank || sort perm /= [0 .. rank -1]) $
- bad $ PermutationError perm rank $ Just arr
-checkBasicOp (Rotate rots arr) = do
- arrt <- lookupType arr
- let rank = arrayRank arrt
- mapM_ (require [Prim int64]) rots
- when (length rots /= rank) $
- bad $
- TypeError $
- "Cannot rotate " ++ show (length rots)
- ++ " dimensions of "
- ++ show rank
- ++ "-dimensional array."
-checkBasicOp (Concat i arr1exp arr2exps ressize) = do
- arr1t <- checkArrIdent arr1exp
- arr2ts <- mapM checkArrIdent arr2exps
- let success =
- all
- ( (== dropAt i 1 (arrayDims arr1t))
- . dropAt i 1
- . arrayDims
- )
- arr2ts
- unless success $
- bad $
- TypeError $
- "Types of arguments to concat do not match. Got "
- ++ pretty arr1t
- ++ " and "
- ++ intercalate ", " (map pretty arr2ts)
- require [Prim int64] ressize
-checkBasicOp (Copy e) =
- void $ checkArrIdent e
-checkBasicOp (Manifest perm arr) =
- checkBasicOp $ Rearrange perm arr -- Basically same thing!
-checkBasicOp (Assert e (ErrorMsg parts) _) = do
- require [Prim Bool] e
- mapM_ checkPart parts
- where
- checkPart ErrorString {} = return ()
- checkPart (ErrorVal t x) = require [Prim t] x
-checkBasicOp (UpdateAcc acc is ses) = do
- (shape, ts) <- checkAccIdent acc
-
- unless (length ses == length ts) $
- bad $
- TypeError $
- "Accumulator requires "
- ++ show (length ts)
- ++ " values, but "
- ++ show (length ses)
- ++ " provided."
-
- unless (length is == shapeRank shape) $
- bad $
- TypeError $
- "Accumulator requires "
- ++ show (shapeRank shape)
- ++ " indices, but "
- ++ show (length is)
- ++ " provided."
-
- zipWithM_ require (map pure ts) ses
- consume =<< lookupAliases acc
-
-matchLoopResultExt ::
- Checkable rep =>
- [Param DeclType] ->
- Result ->
- TypeM rep ()
-matchLoopResultExt merge loopres = do
- let rettype_ext =
- existentialiseExtTypes (map paramName merge) $
- staticShapes $ map typeOf merge
-
- bodyt <- mapM subExpResType loopres
-
- case instantiateShapes (fmap resSubExp . (`maybeNth` loopres)) rettype_ext of
- Nothing ->
- bad $
- ReturnTypeError
- (nameFromString "")
- rettype_ext
- (staticShapes bodyt)
- Just rettype' ->
- unless (bodyt `subtypesOf` rettype') $
- bad $
- ReturnTypeError
- (nameFromString "")
- (staticShapes rettype')
- (staticShapes bodyt)
-
-checkExp ::
- Checkable rep =>
- Exp (Aliases rep) ->
- TypeM rep ()
-checkExp (BasicOp op) = checkBasicOp op
-checkExp (If e1 e2 e3 info) = do
- require [Prim Bool] e1
- _ <-
- context "in true branch" (checkBody e2)
- `alternative` context "in false branch" (checkBody e3)
- context "in true branch" $ matchBranchType (ifReturns info) e2
- context "in false branch" $ matchBranchType (ifReturns info) e3
-checkExp (Apply fname args rettype_annot _) = do
- (rettype_derived, paramtypes) <- lookupFun fname $ map fst args
- argflows <- mapM (checkArg . fst) args
- when (rettype_derived /= rettype_annot) $
- bad . TypeError . pretty $
- "Expected apply result type:"
- indent 2 (ppr rettype_derived)
- "But annotation is:"
- indent 2 (ppr rettype_annot)
- consumeArgs paramtypes argflows
-checkExp (DoLoop merge form loopbody) = do
- let (mergepat, mergeexps) = unzip merge
- mergeargs <- mapM checkArg mergeexps
-
- checkLoopArgs
-
- binding (scopeOf form) $ do
- form_consumable <- checkForm mergeargs form
-
- let rettype = map paramDeclType mergepat
- consumable =
- [ (paramName param, mempty)
- | param <- mergepat,
- unique $ paramDeclType param
- ]
- ++ form_consumable
-
- context "Inside the loop body" $
- checkFun'
- ( nameFromString "",
- staticShapes rettype,
- funParamsToNameInfos mergepat
- )
- (Just consumable)
- $ do
- checkFunParams mergepat
- checkBodyDec $ snd $ bodyDec loopbody
-
- checkStms (bodyStms loopbody) $ do
- context "In loop body result" $
- checkResult $ bodyResult loopbody
-
- context "When matching result of body with loop parameters" $
- matchLoopResult (map fst merge) $ bodyResult loopbody
-
- let bound_here =
- namesFromList $ M.keys $ scopeOf $ bodyStms loopbody
- map (`namesSubtract` bound_here)
- <$> mapM (subExpAliasesM . resSubExp) (bodyResult loopbody)
- where
- checkLoopVar (p, a) = do
- a_t <- lookupType a
- observe a
- case peelArray 1 a_t of
- Just a_t_r -> do
- checkLParamDec (paramName p) $ paramDec p
- unless (a_t_r `subtypeOf` typeOf (paramDec p)) $
- bad $
- TypeError $
- "Loop parameter " ++ pretty p
- ++ " not valid for element of "
- ++ pretty a
- ++ ", which has row type "
- ++ pretty a_t_r
- als <- lookupAliases a
- pure (paramName p, als)
- _ ->
- bad $
- TypeError $
- "Cannot loop over " ++ pretty a
- ++ " of type "
- ++ pretty a_t
- checkForm mergeargs (ForLoop loopvar it boundexp loopvars) = do
- iparam <- primFParam loopvar $ IntType it
- let mergepat = map fst merge
- funparams = iparam : mergepat
- paramts = map paramDeclType funparams
-
- consumable <- mapM checkLoopVar loopvars
- boundarg <- checkArg boundexp
- checkFuncall Nothing paramts $ boundarg : mergeargs
- pure consumable
- checkForm mergeargs (WhileLoop cond) = do
- case find ((== cond) . paramName . fst) merge of
- Just (condparam, _) ->
- unless (paramType condparam == Prim Bool) $
- bad $
- TypeError $
- "Conditional '" ++ pretty cond ++ "' of while-loop is not boolean, but "
- ++ pretty (paramType condparam)
- ++ "."
- Nothing ->
- bad $
- TypeError $
- "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge variable."
- let mergepat = map fst merge
- funparams = mergepat
- paramts = map paramDeclType funparams
- checkFuncall Nothing paramts mergeargs
- pure mempty
-
- checkLoopArgs = do
- let (params, args) = unzip merge
-
- argtypes <- mapM subExpType args
-
- let expected = expectedTypes (map paramName params) params args
- unless (expected == argtypes) . bad . TypeError . pretty $
- "Loop parameters"
- indent 2 (ppTuple' params)
- "cannot accept initial values"
- indent 2 (ppTuple' args)
- "of types"
- indent 2 (ppTuple' argtypes)
-checkExp (WithAcc inputs lam) = do
- unless (length (lambdaParams lam) == 2 * num_accs) $
- bad . TypeError $
- show (length (lambdaParams lam))
- ++ " parameters, but "
- ++ show num_accs
- ++ " accumulators."
-
- let cert_params = take num_accs $ lambdaParams lam
- acc_args <- forM (zip inputs cert_params) $ \((shape, arrs, op), p) -> do
- mapM_ (require [Prim int64]) (shapeDims shape)
- elem_ts <- forM arrs $ \arr -> do
- arr_t <- lookupType arr
- unless (shapeDims shape `isPrefixOf` arrayDims arr_t) $
- bad . TypeError $ pretty arr <> " is not an array of outer shape " <> pretty shape
- consume =<< lookupAliases arr
- pure $ stripArray (shapeRank shape) arr_t
-
- case op of
- Just (op_lam, nes) -> do
- let mkArrArg t = (t, mempty)
- nes_ts <- mapM checkSubExp nes
- unless (nes_ts == lambdaReturnType op_lam) $
- bad $
- TypeError $
- unlines
- [ "Accumulator operator return type: " ++ pretty (lambdaReturnType op_lam),
- "Type of neutral elements: " ++ pretty nes_ts
- ]
- checkLambda op_lam $
- replicate (shapeRank shape) (Prim int64, mempty)
- ++ map mkArrArg (elem_ts ++ elem_ts)
- Nothing ->
- return ()
-
- pure (Acc (paramName p) shape elem_ts NoUniqueness, mempty)
-
- checkAnyLambda False lam $ replicate num_accs (Prim Unit, mempty) ++ acc_args
- where
- num_accs = length inputs
-checkExp (Op op) = do
- checker <- asks envCheckOp
- checker op
-
-checkSOACArrayArgs ::
- Checkable rep =>
- SubExp ->
- [VName] ->
- TypeM rep [Arg]
-checkSOACArrayArgs width = mapM checkSOACArrayArg
- where
- checkSOACArrayArg v = do
- (t, als) <- checkArg $ Var v
- case t of
- Acc {} -> pure (t, als)
- Array {} -> do
- let argSize = arraySize 0 t
- unless (argSize == width) $
- bad . TypeError $
- "SOAC argument " ++ pretty v ++ " has outer size "
- ++ pretty argSize
- ++ ", but width of SOAC is "
- ++ pretty width
- pure (rowType t, als)
- _ ->
- bad . TypeError $
- "SOAC argument " ++ pretty v ++ " is not an array"
-
-checkType ::
- Checkable rep =>
- TypeBase Shape u ->
- TypeM rep ()
-checkType (Mem (ScalarSpace d _)) = mapM_ (require [Prim int64]) d
-checkType (Acc cert shape ts _) = do
- requireI [Prim Unit] cert
- mapM_ (require [Prim int64]) $ shapeDims shape
- mapM_ checkType ts
-checkType t = mapM_ checkSubExp $ arrayDims t
-
-checkExtType ::
- Checkable rep =>
- TypeBase ExtShape u ->
- TypeM rep ()
-checkExtType = mapM_ checkExtDim . shapeDims . arrayShape
- where
- checkExtDim (Free se) = void $ checkSubExp se
- checkExtDim (Ext _) = return ()
-
-checkCmpOp ::
- Checkable rep =>
- CmpOp ->
- SubExp ->
- SubExp ->
- TypeM rep ()
-checkCmpOp (CmpEq t) x y = do
- require [Prim t] x
- require [Prim t] y
-checkCmpOp (CmpUlt t) x y = checkBinOpArgs (IntType t) x y
-checkCmpOp (CmpUle t) x y = checkBinOpArgs (IntType t) x y
-checkCmpOp (CmpSlt t) x y = checkBinOpArgs (IntType t) x y
-checkCmpOp (CmpSle t) x y = checkBinOpArgs (IntType t) x y
-checkCmpOp (FCmpLt t) x y = checkBinOpArgs (FloatType t) x y
-checkCmpOp (FCmpLe t) x y = checkBinOpArgs (FloatType t) x y
-checkCmpOp CmpLlt x y = checkBinOpArgs Bool x y
-checkCmpOp CmpLle x y = checkBinOpArgs Bool x y
-
-checkBinOpArgs ::
- Checkable rep =>
- PrimType ->
- SubExp ->
- SubExp ->
- TypeM rep ()
-checkBinOpArgs t e1 e2 = do
- require [Prim t] e1
- require [Prim t] e2
-
-checkPatElem ::
- Checkable rep =>
- PatElemT (LetDec rep) ->
- TypeM rep ()
-checkPatElem (PatElem name dec) =
- context ("When checking pattern element " ++ pretty name) $
- checkLetBoundDec name dec
-
-checkFlatDimIndex ::
- Checkable rep =>
- FlatDimIndex SubExp ->
- TypeM rep ()
-checkFlatDimIndex (FlatDimIndex n s) = mapM_ (require [Prim int64]) [n, s]
-
-checkFlatSlice ::
- Checkable rep =>
- FlatSlice SubExp ->
- TypeM rep ()
-checkFlatSlice (FlatSlice offset idxs) = do
- require [Prim int64] offset
- mapM_ checkFlatDimIndex idxs
-
-checkDimIndex ::
- Checkable rep =>
- DimIndex SubExp ->
- TypeM rep ()
-checkDimIndex (DimFix i) = require [Prim int64] i
-checkDimIndex (DimSlice i n s) = mapM_ (require [Prim int64]) [i, n, s]
-
-checkStm ::
- Checkable rep =>
- Stm (Aliases rep) ->
- TypeM rep a ->
- TypeM rep a
-checkStm stm@(Let pat (StmAux (Certs cs) _ (_, dec)) e) m = do
- context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs
- context "When checking expression annotation" $ checkExpDec dec
- context ("When matching\n" ++ message " " pat ++ "\nwith\n" ++ message " " e) $
- matchPat pat e
- binding (maybeWithoutAliases $ scopeOf stm) $ do
- mapM_ checkPatElem (patElems $ removePatAliases pat)
- m
- where
- -- FIXME: this is wrong. However, the core language type system
- -- is not strong enough to fully capture the aliases we want (see
- -- issue #803). Since we eventually inline everything anyway, and
- -- our intra-procedural alias analysis is much simpler and
- -- correct, I could not justify spending time on improving the
- -- inter-procedural alias analysis. If we ever stop inlining
- -- everything, probably we need to go back and refine this.
- maybeWithoutAliases =
- case stmExp stm of
- Apply {} -> M.map withoutAliases
- _ -> id
- withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec)
- withoutAliases info = info
-
-matchExtPat ::
- Checkable rep =>
- Pat (Aliases rep) ->
- [ExtType] ->
- TypeM rep ()
-matchExtPat pat ts =
- unless (expExtTypesFromPat pat == ts) $
- bad $ InvalidPatError pat ts Nothing
-
-matchExtReturnType ::
- Checkable rep =>
- [ExtType] ->
- Result ->
- TypeM rep ()
-matchExtReturnType rettype res = do
- ts <- mapM subExpResType res
- matchExtReturns rettype res ts
-
-matchExtBranchType ::
- Checkable rep =>
- [ExtType] ->
- Body (Aliases rep) ->
- TypeM rep ()
-matchExtBranchType rettype (Body _ stms res) = do
- ts <- extendedScope (traverse subExpResType res) stmscope
- matchExtReturns rettype res ts
- where
- stmscope = scopeOf stms
-
-matchExtReturns :: [ExtType] -> Result -> [Type] -> TypeM rep ()
-matchExtReturns rettype res ts = do
- let problem :: TypeM rep a
- problem =
- bad $
- TypeError $
- unlines
- [ "Type annotation is",
- " " ++ prettyTuple rettype,
- "But result returns type",
- " " ++ prettyTuple ts
- ]
-
- unless (length res == length rettype) problem
-
- let ctx_vals = zip res ts
- instantiateExt i = case maybeNth i ctx_vals of
- Just (SubExpRes _ se, Prim (IntType Int64)) -> return se
- _ -> problem
-
- rettype' <- instantiateShapes instantiateExt rettype
-
- unless (rettype' == ts) problem
-
-validApply ::
- ArrayShape shape =>
- [TypeBase shape Uniqueness] ->
- [TypeBase shape NoUniqueness] ->
- Bool
-validApply expected got =
- length got == length expected
- && and
- ( zipWith
- subtypeOf
- (map rankShaped got)
- (map (fromDecl . rankShaped) expected)
- )
-
-type Arg = (Type, Names)
-
-argType :: Arg -> Type
-argType (t, _) = t
-
--- | Remove all aliases from the 'Arg'.
-argAliases :: Arg -> Names
-argAliases (_, als) = als
-
-noArgAliases :: Arg -> Arg
-noArgAliases (t, _) = (t, mempty)
-
-checkArg ::
- Checkable rep =>
- SubExp ->
- TypeM rep Arg
-checkArg arg = do
- argt <- checkSubExp arg
- als <- subExpAliasesM arg
- return (argt, als)
-
-checkFuncall ::
- Maybe Name ->
- [DeclType] ->
- [Arg] ->
- TypeM rep ()
-checkFuncall fname paramts args = do
- let argts = map argType args
- unless (validApply paramts argts) $
- bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args
- consumeArgs paramts args
-
-consumeArgs ::
- [DeclType] ->
- [Arg] ->
- TypeM rep ()
-consumeArgs paramts args =
- forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->
- occur [consumption (consumeArg als d)]
- where
- consumeArg als Consume = als
- consumeArg _ _ = mempty
-
--- The boolean indicates whether we only allow consumption of
--- parameters.
-checkAnyLambda ::
- Checkable rep => Bool -> Lambda (Aliases rep) -> [Arg] -> TypeM rep ()
-checkAnyLambda soac (Lambda params body rettype) args = do
- let fname = nameFromString ""
- if length params == length args
- then do
- -- Consumption for this is done explicitly elsewhere.
- checkFuncall
- Nothing
- (map ((`toDecl` Nonunique) . paramType) params)
- $ map noArgAliases args
- let consumable =
- if soac
- then Just $ zip (map paramName params) (map argAliases args)
- else Nothing
- checkFun'
- ( fname,
- staticShapes $ map (`toDecl` Nonunique) rettype,
- [ ( paramName param,
- LParamName $ paramDec param
- )
- | param <- params
- ]
- )
- consumable
- $ do
- checkLambdaParams params
- mapM_ checkType rettype
- checkLambdaBody rettype body
- else
- bad $
- TypeError $
- "Anonymous function defined with " ++ show (length params) ++ " parameters:\n"
- ++ pretty params
- ++ "\nbut expected to take "
- ++ show (length args)
- ++ " arguments."
-
-checkLambda :: Checkable rep => Lambda (Aliases rep) -> [Arg] -> TypeM rep ()
-checkLambda = checkAnyLambda True
-
-checkPrimExp :: Checkable rep => PrimExp VName -> TypeM rep ()
-checkPrimExp ValueExp {} = return ()
-checkPrimExp (LeafExp v pt) = requireI [Prim pt] v
-checkPrimExp (BinOpExp op x y) = do
- requirePrimExp (binOpType op) x
- requirePrimExp (binOpType op) y
-checkPrimExp (CmpOpExp op x y) = do
- requirePrimExp (cmpOpType op) x
- requirePrimExp (cmpOpType op) y
-checkPrimExp (UnOpExp op x) = requirePrimExp (unOpType op) x
-checkPrimExp (ConvOpExp op x) = requirePrimExp (fst $ convOpType op) x
-checkPrimExp (FunExp h args t) = do
- (h_ts, h_ret, _) <-
- maybe
- (bad $ TypeError $ "Unknown function: " ++ h)
- return
- $ M.lookup h primFuns
- when (length h_ts /= length args) $
- bad $
- TypeError $
- "Function expects " ++ show (length h_ts)
- ++ " parameters, but given "
- ++ show (length args)
- ++ " arguments."
- when (h_ret /= t) $
- bad $
- TypeError $
- "Function return annotation is " ++ pretty t
- ++ ", but expected "
- ++ pretty h_ret
- zipWithM_ requirePrimExp h_ts args
-
-requirePrimExp :: Checkable rep => PrimType -> PrimExp VName -> TypeM rep ()
-requirePrimExp t e = context ("in PrimExp " ++ pretty e) $ do
- checkPrimExp e
- unless (primExpType e == t) $
- bad $
- TypeError $
- pretty e ++ " must have type " ++ pretty t
-
-class ASTRep rep => CheckableOp rep where
- checkOp :: OpWithAliases (Op rep) -> TypeM rep ()
- -- ^ Used at top level; can be locally changed with 'checkOpWith'.
-
--- | The class of representations that can be type-checked.
-class (ASTRep rep, CanBeAliased (Op rep), CheckableOp rep) => Checkable rep where
- checkExpDec :: ExpDec rep -> TypeM rep ()
- checkBodyDec :: BodyDec rep -> TypeM rep ()
- checkFParamDec :: VName -> FParamInfo rep -> TypeM rep ()
- checkLParamDec :: VName -> LParamInfo rep -> TypeM rep ()
- checkLetBoundDec :: VName -> LetDec rep -> TypeM rep ()
- checkRetType :: [RetType rep] -> TypeM rep ()
- matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()
- primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep))
- matchReturnType :: [RetType rep] -> Result -> TypeM rep ()
- matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()
- matchLoopResult :: [FParam (Aliases rep)] -> Result -> TypeM rep ()
-
- default checkExpDec :: ExpDec rep ~ () => ExpDec rep -> TypeM rep ()
- checkExpDec = return
-
- default checkBodyDec :: BodyDec rep ~ () => BodyDec rep -> TypeM rep ()
- checkBodyDec = return
-
- default checkFParamDec :: FParamInfo rep ~ DeclType => VName -> FParamInfo rep -> TypeM rep ()
- checkFParamDec _ = checkType
-
- default checkLParamDec :: LParamInfo rep ~ Type => VName -> LParamInfo rep -> TypeM rep ()
- checkLParamDec _ = checkType
-
- default checkLetBoundDec :: LetDec rep ~ Type => VName -> LetDec rep -> TypeM rep ()
- checkLetBoundDec _ = checkType
-
- default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep ()
- checkRetType = mapM_ $ checkExtType . declExtTypeOf
-
- default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()
- matchPat pat = matchExtPat pat <=< expExtType
-
- default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))
- primFParam name t = return $ Param mempty name (Prim t)
-
- default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep ()
- matchReturnType = matchExtReturnType . map fromDecl
-
- default matchBranchType :: BranchType rep ~ ExtType => [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()
- matchBranchType = matchExtBranchType
-
- default matchLoopResult ::
- FParamInfo rep ~ DeclType =>
- [FParam (Aliases rep)] ->
- Result ->
- TypeM rep ()
- matchLoopResult = matchLoopResultExt
diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs
--- a/src/Futhark/Util.hs
+++ b/src/Futhark/Util.hs
@@ -53,6 +53,7 @@
zEncodeString,
atMostChars,
invertMap,
+ fixPoint,
)
where
@@ -462,3 +463,8 @@
M.toList m
& fmap (swap . first S.singleton)
& foldr (uncurry $ M.insertWith (<>)) mempty
+
+fixPoint :: Eq a => (a -> a) -> a -> a
+fixPoint f x =
+ let x' = f x
+ in if x' == x then x else fixPoint f x'
diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs
--- a/src/Language/Futhark/Interpreter.hs
+++ b/src/Language/Futhark/Interpreter.hs
@@ -26,6 +26,7 @@
import Control.Monad.Except
import Control.Monad.Free.Church
+import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
@@ -620,25 +621,41 @@
toArray' (indexShape is rowshape) <$> mapM (indexArray is . (arr !)) js
indexArray _ v = Just v
-updateArray :: [Indexing] -> Value -> Value -> Maybe Value
-updateArray (IndexingFix i : is) (ValueArray shape arr) v
+writeArray :: [Indexing] -> Value -> Value -> Maybe Value
+writeArray slice x y = runIdentity $ updateArray (\_ y' -> pure y') slice x y
+
+updateArray ::
+ Monad m =>
+ (Value -> Value -> m Value) ->
+ [Indexing] ->
+ Value ->
+ Value ->
+ m (Maybe Value)
+updateArray f (IndexingFix i : is) (ValueArray shape arr) v
| i >= 0,
i < n = do
- v' <- updateArray is (arr ! i') v
- Just $ ValueArray shape $ arr // [(i', v')]
+ v' <- updateArray f is (arr ! i') v
+ pure $ do
+ v'' <- v'
+ Just $ ValueArray shape $ arr // [(i', v'')]
| otherwise =
- Nothing
+ pure Nothing
where
n = arrayLength arr
i' = fromIntegral i
-updateArray (IndexingSlice start end stride : is) (ValueArray shape arr) (ValueArray _ v) = do
- arr_is <- indexesFor start end stride $ arrayLength arr
- guard $ length arr_is == arrayLength v
- let update arr' (i, v') = do
- x <- updateArray is (arr ! i) v'
- return $ arr' // [(i, x)]
- fmap (ValueArray shape) $ foldM update arr $ zip arr_is $ elems v
-updateArray _ _ v = Just v
+updateArray f (IndexingSlice start end stride : is) (ValueArray shape arr) (ValueArray _ v)
+ | Just arr_is <- indexesFor start end stride $ arrayLength arr,
+ length arr_is == arrayLength v = do
+ let update (Just arr') (i, v') = do
+ x <- updateArray f is (arr ! i) v'
+ pure $ do
+ x' <- x
+ Just $ arr' // [(i, x')]
+ update Nothing _ = pure Nothing
+ fmap (fmap (ValueArray shape)) $ foldM update (Just arr) $ zip arr_is $ elems v
+ | otherwise =
+ pure Nothing
+updateArray f _ x y = Just <$> f x y
evalDimIndex :: Env -> DimIndex -> EvalM Indexing
evalDimIndex env (DimFix x) =
@@ -903,7 +920,7 @@
let Ident src_vn (Info src_t) _ = src
dest' <-
maybe oob return
- =<< updateArray <$> mapM (evalDimIndex env) is
+ =<< writeArray <$> mapM (evalDimIndex env) is
<*> evalTermVar env (qualName src_vn) (toStruct src_t)
<*> eval env v
let t = T.BoundV [] $ toStruct $ unInfo $ identType dest
@@ -1044,7 +1061,7 @@
_ -> error $ "Cannot logically negate " ++ pretty ev
eval env (Update src is v loc) =
maybe oob return
- =<< updateArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v
+ =<< writeArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v
where
oob = bad loc env "Bad update"
eval env (RecordUpdate src all_fs v _ _) =
@@ -1611,7 +1628,7 @@
where
update :: Value -> (Maybe [Value], Value) -> Value
update arr (Just idxs@[_, _], v) =
- fromMaybe arr $ updateArray (map (IndexingFix . asInt64) idxs) arr v
+ fromMaybe arr $ writeArray (map (IndexingFix . asInt64) idxs) arr v
update _ _ =
error "scatter_2d expects 2-dimensional indices"
def "scatter_3d" = Just $
@@ -1626,27 +1643,42 @@
where
update :: Value -> (Maybe [Value], Value) -> Value
update arr (Just idxs@[_, _, _], v) =
- fromMaybe arr $ updateArray (map (IndexingFix . asInt64) idxs) arr v
+ fromMaybe arr $ writeArray (map (IndexingFix . asInt64) idxs) arr v
update _ _ =
error "scatter_3d expects 3-dimensional indices"
- def "hist" = Just $
- fun6t $ \_ arr fun _ is vs ->
- case arr of
- ValueArray shape arr' ->
- ValueArray shape
- <$> foldM
- (update fun)
- arr'
- (zip (map asInt $ snd $ fromArray is) (snd $ fromArray vs))
- _ ->
- error $ "hist expects array, but got: " ++ pretty arr
+ def "hist_1d" = Just . fun6t $ \_ arr fun _ is vs ->
+ foldM
+ (update fun)
+ arr
+ (zip (map asInt64 $ snd $ fromArray is) (snd $ fromArray vs))
where
- update fun arr' (i, v) =
- if i >= 0 && i < arrayLength arr'
- then do
- v' <- apply2 noLoc mempty fun (arr' ! i) v
- return $ arr' // [(i, v')]
- else return arr'
+ op = apply2 mempty mempty
+ update fun arr (i, v) =
+ fromMaybe arr <$> updateArray (op fun) [IndexingFix i] arr v
+ def "hist_2d" = Just . fun6t $ \_ arr fun _ is vs ->
+ foldM
+ (update fun)
+ arr
+ (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))
+ where
+ op = apply2 mempty mempty
+ update fun arr (Just idxs@[_, _], v) =
+ fromMaybe arr
+ <$> updateArray (op fun) (map (IndexingFix . asInt64) idxs) arr v
+ update _ _ _ =
+ error "hist_2d: bad index value"
+ def "hist_3d" = Just . fun6t $ \_ arr fun _ is vs ->
+ foldM
+ (update fun)
+ arr
+ (zip (map fromTuple $ snd $ fromArray is) (snd $ fromArray vs))
+ where
+ op = apply2 mempty mempty
+ update fun arr (Just idxs@[_, _, _], v) =
+ fromMaybe arr
+ <$> updateArray (op fun) (map (IndexingFix . asInt64) idxs) arr v
+ update _ _ _ =
+ error "hist_2d: bad index value"
def "partition" = Just $
fun3t $ \k f xs -> do
let (ShapeDim _ rowshape, xs') = fromArray xs
@@ -1739,7 +1771,7 @@
ShapeDim n1 (ShapeDim n2 _) -> do
let iota x = [0 .. x -1]
f arr' (i, j) =
- updateArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'
+ writeArray [IndexingFix $ offset' + i * s1' + j * s2'] arr'
=<< indexArray [IndexingFix i, IndexingFix j] v
case foldM f arr [(i, j) | i <- iota n1, j <- iota n2] of
Just arr' -> pure arr'
@@ -1779,7 +1811,7 @@
ShapeDim n1 (ShapeDim n2 (ShapeDim n3 _)) -> do
let iota x = [0 .. x -1]
f arr' (i, j, l) =
- updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'
+ writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3'] arr'
=<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l] v
case foldM f arr [(i, j, l) | i <- iota n1, j <- iota n2, l <- iota n3] of
Just arr' -> pure arr'
@@ -1823,7 +1855,7 @@
ShapeDim n1 (ShapeDim n2 (ShapeDim n3 (ShapeDim n4 _))) -> do
let iota x = [0 .. x -1]
f arr' (i, j, l, m) =
- updateArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'
+ writeArray [IndexingFix $ offset' + i * s1' + j * s2' + l * s3' + m * s4'] arr'
=<< indexArray [IndexingFix i, IndexingFix j, IndexingFix l, IndexingFix m] v
case foldM f arr [(i, j, l, m) | i <- iota n1, j <- iota n2, l <- iota n3, m <- iota n4] of
Just arr' -> pure arr'
diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs
--- a/src/Language/Futhark/Prop.hs
+++ b/src/Language/Futhark/Prop.hs
@@ -909,18 +909,42 @@
$ RetType [] . Scalar . Record . M.fromList $
zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]]
),
- ( "hist",
+ ( "hist_1d",
IntrinsicPolyFun
[tp_a, sp_n, sp_m]
[ Scalar $ Prim $ Signed Int64,
- uarr_a $ shape [n],
+ uarr_a $ shape [m],
Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
Scalar t_a,
- Array () Nonunique (Prim $ Signed Int64) (shape [m]),
- arr_a (shape [m])
+ Array () Nonunique (tupInt64 1) (shape [n]),
+ arr_a (shape [n])
]
- $ RetType [] $ uarr_a $ shape [n]
+ $ RetType [] $ uarr_a $ shape [m]
),
+ ( "hist_2d",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m, sp_k]
+ [ Scalar $ Prim $ Signed Int64,
+ uarr_a $ shape [m, k],
+ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ Array () Nonunique (tupInt64 2) (shape [n]),
+ arr_a (shape [n])
+ ]
+ $ RetType [] $ uarr_a $ shape [m, k]
+ ),
+ ( "hist_3d",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m, sp_k, sp_l]
+ [ Scalar $ Prim $ Signed Int64,
+ uarr_a $ shape [m, k, l],
+ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ Array () Nonunique (tupInt64 3) (shape [n]),
+ arr_a (shape [n])
+ ]
+ $ RetType [] $ uarr_a $ shape [m, k, l]
+ ),
( "map",
IntrinsicPolyFun
[tp_a, tp_b, sp_n]
@@ -1226,9 +1250,10 @@
intrinsicBinOp Geq = ordering
intrinsicBinOp _ = Nothing
+ tupInt64 1 =
+ Prim $ Signed Int64
tupInt64 x =
- Record . M.fromList . zip tupleFieldNames $
- replicate x $ Scalar $ Prim $ Signed Int64
+ tupleRecord $ replicate x $ Scalar $ Prim $ Signed Int64
-- | The largest tag used by an intrinsic - this can be used to
-- determine whether a 'VName' refers to an intrinsic or a user-defined name.
diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs
--- a/src/Language/Futhark/TypeChecker/Terms.hs
+++ b/src/Language/Futhark/TypeChecker/Terms.hs
@@ -1303,10 +1303,12 @@
typeError usage mempty . withIndexLink "ambiguous-type" $
"Type is ambiguous (could be one of" <+> commasep (map ppr ots) <> ")."
"Add a type annotation to disambiguate the type."
- fixOverloaded (_, NoConstraint _ usage) =
- typeError usage mempty . withIndexLink "ambiguous-type" $
- "Type of expression is ambiguous."
- "Add a type annotation to disambiguate the type."
+ fixOverloaded (v, NoConstraint _ usage) = do
+ -- See #1552.
+ unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $
+ Scalar $ tupleRecord []
+ when (v `S.member` tyvars_at_toplevel) $
+ warn usage "Defaulting ambiguous type to ()."
fixOverloaded (_, Equality usage) =
typeError usage mempty . withIndexLink "ambiguous-type" $
"Type is ambiguous (must be equality type)."