diff --git a/docs/c-api.rst b/docs/c-api.rst
--- a/docs/c-api.rst
+++ b/docs/c-api.rst
@@ -90,8 +90,10 @@
.. c:function:: void futhark_context_free(struct futhark_context *ctx)
- Free the context object. It must not be used again. The
- configuration must be freed separately with
+ Free the context object. It must not be used again. You must call
+ :c:func:`futhark_context_sync` before calling this function to
+ ensure there are no outstanding asynchronous operations still
+ running. The configuration must be freed separately with
:c:func:`futhark_context_config_free`.
.. c:function:: int futhark_context_sync(struct futhark_context *ctx)
@@ -132,7 +134,7 @@
contain interesting information if
:c:func:`futhark_context_config_set_debugging` or
:c:func:`futhark_context_config_set_profiling` has been called
- previously.
+ previously. Returns ``NULL`` on failure.
.. c:function:: int futhark_context_clear_caches(struct futhark_context *ctx)
@@ -171,7 +173,7 @@
dimensions express the number of elements. The data is copied into
the new value. It is the caller's responsibility to eventually
call :c:func:`futhark_free_i32_1d`. Multi-dimensional arrays are
- assumed to be in row-major form.
+ assumed to be in row-major form. Returns ``NULL`` on failure.
.. c:function:: struct futhark_i32_1d *futhark_new_raw_i32_1d(struct futhark_context *ctx, char *data, int offset, int64_t dim0)
@@ -180,6 +182,7 @@
``c`` backend, but when using e.g. the ``opencl`` backend, the
``data`` parameter will be a ``cl_mem``. It is the caller's
responsibility to eventually call :c:func:`futhark_free_i32_1d`.
+ Returns ``NULL`` on failure.
.. c:function:: int futhark_free_i32_1d(struct futhark_context *ctx, struct futhark_i32_1d *arr)
@@ -197,7 +200,8 @@
Return a pointer to the shape of the array, with one element per
dimension. The lifetime of the shape is the same as ``arr``, and
- should *not* be manually freed.
+ should *not* be manually freed. Assuming ``arr`` is a valid
+ object, this function cannot fail.
.. _opaques:
diff --git a/docs/installation.rst b/docs/installation.rst
--- a/docs/installation.rst
+++ b/docs/installation.rst
@@ -366,3 +366,30 @@
.. _`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
+
+Futhark with Nix
+----------------
+
+Futhark mostly works fine with Nix and `NixOS
+`_, but when using OpenCL you may need to make
+more packages available in your environment. This is regardless of
+whether you are using the ``futhark`` package from Nixpkgs or one you
+have installed otherwise.
+
+* On NixOS, for OpenCL, you should import ``opencl-headers`` and
+ ``opencl-icd``. You also need some form of OpenCL backend. If you
+ have an AMD GPU and use ROCm, you may also need
+ ``rocm-opencl-runtime``.
+
+* On NixOS, for CUDA (and probably also OpenCL on NVIDIA GPUs), you
+ need ``cudatoolkit``. However, ``cudatoolkit`` does not appear to
+ provide ``libcuda.so`` and similar libraries. These are instead
+ provided in an ``nvidia_x11`` package that is specific to some
+ kernel version, e.g. ``linuxPackages_5_4.nvidia_x11``. You will
+ need this as well.
+
+* On macOS, for OpenCL, you need ``darwin.apple_sdk.frameworks.OpenCL``.
+
+These can be easily made available with e.g::
+
+ nix-shell -p opencl-headers -p opencl-icd
diff --git a/docs/language-reference.rst b/docs/language-reference.rst
--- a/docs/language-reference.rst
+++ b/docs/language-reference.rst
@@ -107,8 +107,9 @@
Compound types can be constructed based on the primitive types. The
Futhark type system is entirely structural, and type abbreviations are
-merely shorthands. The only exception is abstract types whose
-definition has been hidden via the module system (see `Module
+merely shorthands (with one exception, see
+:ref:`sizes-in-abbreviations`). The only exception is abstract types
+whose definition has been hidden via the module system (see `Module
System`_).
.. productionlist::
@@ -435,7 +436,7 @@
: | `exp` [ ".." `exp` ] "..<" `exp`
: | `exp` [ ".." `exp` ] "..>" `exp`
: | "if" `exp` "then" `exp` "else" `exp`
- : | "let" `pat` "=" `exp` "in" `exp`
+ : | "let" `size`* `pat` "=" `exp` "in" `exp`
: | "let" `id` "[" `index` ("," `index`)* "]" "=" `exp` "in" `exp`
: | "let" `id` `type_param`* `pat`+ [":" `type`] "=" `exp` "in" `exp`
: | "(" "\" `pat`+ [":" `type`] "->" `exp` ")"
@@ -448,6 +449,7 @@
: | "match" `exp` ("case" `pat` "->" `exp`)+
field: `fieldid` "=" `exp`
: | `id`
+ size : "[" `id` "]"
pat: `id`
: | `literal`
: | "_"
@@ -863,8 +865,15 @@
(see :ref:`patterns`) while evaluating ``body``. The ``in`` keyword
is optional if ``body`` is a ``let`` expression.
+``let [n] pat = e in body``
+...........................
+
+As above, but bind sizes (here ``n``) used in the pattern (here to the
+size of the array being bound). All sizes must be used in the
+pattern. Roughly Equivalent to ``let f [n] pat = body in f e``.
+
``let a[i] = v in body``
-........................................
+........................
Write ``v`` to ``a[i]`` and evaluate ``body``. The given index need
not be complete and can also be a slice, but in these cases, the value
@@ -1282,6 +1291,30 @@
``k`` was generated inside its body. A function of this type cannot
be passed to ``map``, as explained before. The solution is to bind
``length`` to a name *before* the lambda.
+
+.. _sizes-in-abbreviations:
+
+Sizes in type abbreviations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When anonymous sizes are passed to type abbreviations, if that
+anonymous size is eventually instantiated with an existential size,
+the *same* existential size is going to be used for all instances of
+the corresponding parameter in the right-hand-side of the type
+abbreviation. Note that this breaks with the usual conception of type
+abbreviations as purely a shorthand, as this could not be expressed
+without the abbreviation. Example::
+
+ type square [n] = [n][n]i32
+
+The following function is be *known* to return a square array::
+
+ val f : () -> square []
+
+But this is not the case for the function that inlines the definition
+of ``square``::
+
+ val g : () -> [][]i32
.. _in-place-updates:
diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst
--- a/docs/man/futhark-literate.rst
+++ b/docs/man/futhark-literate.rst
@@ -20,7 +20,7 @@
programming techniques.
* Top-level comments that start with a line comment marker (``--``)
- and a space in the first column will be turned into ordinary text in
+ and a space in the next column will be turned into ordinary text in
the Markdown file.
* Ordinary top-level definitions will be enclosed in Markdown code
@@ -31,8 +31,8 @@
**Warning:** Do not run untrusted programs. See SAFETY below.
-Image directives and builtin functions Shells out to ``convert`` (from
-ImageMagick). Video generation uses ``fmpeg``.
+Image directives and builtin functions shell out to ``convert`` (from
+ImageMagick). Video generation uses ``ffmpeg``.
OPTIONS
=======
@@ -189,13 +189,19 @@
Only an extremely limited subset of Futhark is supported:
.. productionlist::
- scriptexp: `fun` `scriptexp`*
- : | "(" `scriptexp` ")"
- : | "(" `scriptexp` ( "," `scriptexp` )+ ")"
+ script_exp: `fun` `script_exp`*
+ : | "(" `script_exp` ")"
+ : | "(" `script_exp` ( "," `script_exp` )+ ")"
+ : | "[" `script_exp` ( "," `script_exp` )+ "]"
+ : | "empty" "(" ("[" `decimal` "]" )+ `script_type` ")"
: | "{" "}"
- : | "{" (`id` = `scriptexp`) ("," `id` = `scriptexp`)* "}"
+ : | "{" (`id` = `script_exp`) ("," `id` = `script_exp`)* "}"
: | `literal`
- fun: `id` | "$" `id`
+ script_fun: `id` | "$" `id`
+ script_type: `int_type` | `float_type` | "bool"
+
+Note that empty arrays must be written using the ``empty(t)``
+notation, e.g. ``empty([0]i32)``.
Function applications are either of Futhark funtions or *builtin
functions*. The latter are prefixed with ``$`` and are magical
diff --git a/docs/server-protocol.rst b/docs/server-protocol.rst
--- a/docs/server-protocol.rst
+++ b/docs/server-protocol.rst
@@ -52,8 +52,8 @@
produce outputs of defined types. The notion of transparent and
opaque types are the same as in the C API: primitives and array of
primitives are directly supported, and everything else is treated as
-opaque. When printed, types follow basic Futhark type syntax
-*without* sizes (e.g. ``[][]i32``).
+opaque. See also :ref:`valuemapping`. When printed, types
+follow basic Futhark type syntax *without* sizes (e.g. ``[][]i32``).
Commands
--------
diff --git a/docs/usage.rst b/docs/usage.rst
--- a/docs/usage.rst
+++ b/docs/usage.rst
@@ -298,21 +298,47 @@
Futhark entry points are mapped to some form of function or method in
the target language. Generally, an entry point taking *n* parameters
-will result in a function taking *n* parameters. Extra parameters may
-be added to pass in context data, or *out*-parameters for writing the
-result, for target languages that do not support multiple return
-values from functions.
+will result in a function taking *n* parameters. If the entry point
+returns an *m*-element tuple, then the function will return *m* values
+(although the tuple can be replaced with a single opaque value, see
+below). Extra parameters may be added to pass in context data, or
+*out*-parameters for writing the result, for target languages that do
+not support multiple return values from functions.
Not all Futhark types can be mapped cleanly to the target language.
-Arrays of tuples, for example, are a common issue. In such cases, *opaque
-types* are used in the generated code. Values of these types cannot
-be directly inspected, but can be passed back to Futhark entry points.
-In the general case, these types will be named with a random hash.
-However, if you insert an explicit type annotation (and the type
-name contains only characters valid for identifiers for the used
+Arrays of tuples, for example, are a common issue. In such cases,
+*opaque types* are used in the generated code. Values of these types
+cannot be directly inspected, but can be passed back to Futhark entry
+points. In the general case, these types will be named with a random
+hash. However, if you insert an explicit type annotation (and the
+type name contains only characters valid for identifiers for the used
backend), the indicated name will be used. Note that arrays contain
-brackets, which are usually not valid in identifiers. Defining a
-simple type alias is the best way around this.
+brackets, which are usually not valid in identifiers. Defining and
+using a type abbreviation is the best way around this.
+
+.. _valuemapping:
+
+Value Mapping
+~~~~~~~~~~~~~
+
+The rules for how Futhark values are mapped to target language values
+are as follows:
+
+* Primitive types or arrays of primitive types are mapped
+ transparently (although for the C backends, this still involves a
+ distinct type for arrays).
+
+* All other types are mapped to an opaque type. Use a type ascription
+ with a type abbreviation to give it a specific name, otherwise one
+ will be generated.
+
+Return types follow the rules, with one addition:
+
+* If the return type is an *m*-element tuple, then the the function
+ returns *m* values, mapped according to the rules above (but not
+ including this one - nested tuples are not mapped directly). This
+ rule does not apply when the entry point has been given a return
+ type ascription that is not syntactically a tuple type.
Generating C
^^^^^^^^^^^^
diff --git a/futhark.cabal b/futhark.cabal
--- a/futhark.cabal
+++ b/futhark.cabal
@@ -1,7 +1,7 @@
cabal-version: 2.4
-- Run 'cabal2nix . >futhark.nix' after adding deps.
name: futhark
-version: 0.19.4
+version: 0.19.5
synopsis: An optimising compiler for a functional, array-oriented language.
description: Futhark is a small programming language designed to be compiled to
@@ -337,7 +337,7 @@
, utf8-string >=1
, vector >=0.12
, vector-binary-instances >=0.2.2.0
- , versions >=4.0.1
+ , versions >=5.0.0
, zip-archive >=0.3.1.1
, zlib >=0.6.1.2
default-language: Haskell2010
diff --git a/prelude/math.fut b/prelude/math.fut
--- a/prelude/math.fut
+++ b/prelude/math.fut
@@ -152,6 +152,8 @@
val atan2: t -> t -> t
+ val hypot: t -> t -> t
+
val gamma: t -> t
val lgamma: t -> t
-- | Linear interpolation. The third argument must be in the range
@@ -210,6 +212,10 @@
val num_bits: i32
val get_bit: i32 -> t -> i32
val set_bit: i32 -> t -> i32 -> t
+
+ -- | The difference between 1.0 and the next larger representable
+ -- number.
+ val epsilon: t
}
-- | Boolean numbers. When converting from a number to `bool`, 0 is
@@ -894,6 +900,7 @@
let asinh (x: f64) = intrinsics.asinh64 x
let atanh (x: f64) = intrinsics.atanh64 x
let atan2 (x: f64) (y: f64) = intrinsics.atan2_64 (x, y)
+ let hypot (x: f64) (y: f64) = intrinsics.hypot64 (x, y)
let gamma = intrinsics.gamma64
let lgamma = intrinsics.lgamma64
@@ -922,6 +929,7 @@
let highest = inf
let lowest = -inf
+ let epsilon = 2.220446049250313e-16f64
let pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164062f64
let e = 2.718281828459045235360287471352662497757247093699959574966967627724076630353f64
@@ -1000,6 +1008,7 @@
let asinh (x: f32) = intrinsics.asinh32 x
let atanh (x: f32) = intrinsics.atanh32 x
let atan2 (x: f32) (y: f32) = intrinsics.atan2_32 (x, y)
+ let hypot (x: f32) (y: f32) = intrinsics.hypot32 (x, y)
let gamma = intrinsics.gamma32
let lgamma = intrinsics.lgamma32
@@ -1028,6 +1037,7 @@
let highest = inf
let lowest = -inf
+ let epsilon = 1.1920929e-7f32
let pi = f64 f64m.pi
let e = f64 f64m.e
diff --git a/rts/c/cuda.h b/rts/c/cuda.h
--- a/rts/c/cuda.h
+++ b/rts/c/cuda.h
@@ -245,7 +245,8 @@
{ 6, 2, "compute_62" },
{ 7, 0, "compute_70" },
{ 7, 2, "compute_72" },
- { 7, 5, "compute_75" }
+ { 7, 5, "compute_75" },
+ { 8, 0, "compute_80" }
};
int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR);
diff --git a/rts/python/scalar.py b/rts/python/scalar.py
--- a/rts/python/scalar.py
+++ b/rts/python/scalar.py
@@ -432,6 +432,9 @@
def futhark_atan2_64(x, y):
return np.arctan2(x, y)
+def futhark_hypot64(x, y):
+ return np.hypot(x, y)
+
def futhark_gamma64(x):
return np.float64(math.gamma(x))
@@ -514,6 +517,9 @@
def futhark_atan2_32(x, y):
return np.arctan2(x, y)
+
+def futhark_hypot32(x, y):
+ return np.hypot(x, y)
def futhark_gamma32(x):
return np.float32(math.gamma(x))
diff --git a/rts/python/values.py b/rts/python/values.py
--- a/rts/python/values.py
+++ b/rts/python/values.py
@@ -567,12 +567,11 @@
if m:
dims = int(len(m.group(1))/2)
basetype = m.group(2)
- assert basetype in FUTHARK_PRIMTYPES, "Unknown type: {}".format(type_desc)
- if dims > 0:
- return read_array(reader, basetype, dims)
- else:
- return read_scalar(reader, basetype)
- return (dims, basetype)
+ assert m and basetype in FUTHARK_PRIMTYPES, "Unknown type: {}".format(type_desc)
+ if dims > 0:
+ return read_array(reader, basetype, dims)
+ else:
+ return read_scalar(reader, basetype)
def end_of_input(entry, f=input_reader):
skip_spaces(f)
diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs
--- a/src/Futhark/Analysis/Metrics.hs
+++ b/src/Futhark/Analysis/Metrics.hs
@@ -111,6 +111,8 @@
inside "False" $ bodyMetrics fb
expMetrics Apply {} =
seen "Apply"
+expMetrics (WithAcc _ lam) =
+ inside "MkAcc" $ lambdaMetrics lam
expMetrics (Op op) =
opMetrics op
@@ -134,6 +136,7 @@
primOpMetrics Reshape {} = seen "Reshape"
primOpMetrics Rearrange {} = seen "Rearrange"
primOpMetrics Rotate {} = seen "Rotate"
+primOpMetrics UpdateAcc {} = seen "UpdateAcc"
-- | Compute metrics for this lambda.
lambdaMetrics :: OpMetrics (Op lore) => Lambda lore -> MetricsM ()
diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs
--- a/src/Futhark/Analysis/PrimExp/Convert.hs
+++ b/src/Futhark/Analysis/PrimExp/Convert.hs
@@ -9,6 +9,10 @@
le32,
pe64,
le64,
+ f32pe,
+ f32le,
+ f64pe,
+ f64le,
primExpFromSubExpM,
replaceInPrimExp,
replaceInPrimExpM,
@@ -101,6 +105,22 @@
-- | Shorthand for constructing a 'TPrimExp' of type 'Int64', from a leaf.
le64 :: a -> TPrimExp Int64 a
le64 = isInt64 . flip LeafExp int64
+
+-- | Shorthand for constructing a 'TPrimExp' of type 'Float32'.
+f32pe :: SubExp -> TPrimExp Float VName
+f32pe = isF32 . primExpFromSubExp float32
+
+-- | Shorthand for constructing a 'TPrimExp' of type 'Float32', from a leaf.
+f32le :: a -> TPrimExp Float a
+f32le = isF32 . flip LeafExp float32
+
+-- | Shorthand for constructing a 'TPrimExp' of type 'Float64'.
+f64pe :: SubExp -> TPrimExp Double VName
+f64pe = isF64 . primExpFromSubExp float64
+
+-- | Shorthand for constructing a 'TPrimExp' of type 'Float64', from a leaf.
+f64le :: a -> TPrimExp Double a
+f64le = isF64 . flip LeafExp float64
-- | Applying a monadic transformation to the leaves in a 'PrimExp'.
replaceInPrimExpM ::
diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs
--- a/src/Futhark/Analysis/SymbolTable.hs
+++ b/src/Futhark/Analysis/SymbolTable.hs
@@ -15,6 +15,7 @@
entryLetBoundDec,
entryIsSize,
entryStm,
+ entryFParam,
-- * Lookup
elem,
@@ -191,6 +192,11 @@
entryStm :: Entry lore -> Maybe (Stm lore)
entryStm = fmap letBoundStm . isLetBound
+
+entryFParam :: Entry lore -> Maybe (FParamInfo lore)
+entryFParam e = case entryType e of
+ FParam e' -> Just $ fparamDec e'
+ _ -> Nothing
entryLetBoundDec :: Entry lore -> Maybe (LetDec lore)
entryLetBoundDec = fmap letBoundDec . isLetBound
diff --git a/src/Futhark/Analysis/UsageTable.hs b/src/Futhark/Analysis/UsageTable.hs
--- a/src/Futhark/Analysis/UsageTable.hs
+++ b/src/Futhark/Analysis/UsageTable.hs
@@ -141,6 +141,9 @@
withoutU :: Usages -> Usages -> Usages
withoutU (Usages x) (Usages y) = Usages $ x .&. complement y
+usageInBody :: Aliased lore => Body lore -> UsageTable
+usageInBody = foldMap consumedUsage . namesToList . consumedInBody
+
-- | Produce a usage table reflecting the use of the free variables in
-- a single statement.
usageInStm :: (ASTLore lore, Aliased lore) => Stm lore -> UsageTable
@@ -170,20 +173,16 @@
| (arg, d) <- args,
d == Consume
]
-usageInExp (DoLoop _ merge _ _) =
- mconcat
- [ mconcat $
- map consumedUsage $
- namesToList $ subExpAliases se
- | (v, se) <- merge,
- unique $ paramDeclType v
- ]
+usageInExp e@DoLoop {} =
+ foldMap consumedUsage $ namesToList $ consumedInExp e
usageInExp (If _ tbranch fbranch _) =
- foldMap consumedUsage $
- namesToList $
- consumedInBody tbranch <> consumedInBody fbranch
+ usageInBody tbranch <> usageInBody fbranch
+usageInExp (WithAcc inputs lam) =
+ foldMap inputUsage inputs <> usageInBody (lambdaBody lam)
+ where
+ inputUsage (_, arrs, _) = foldMap consumedUsage arrs
usageInExp (BasicOp (Update src _ _)) =
consumedUsage src
usageInExp (Op op) =
mconcat $ map consumedUsage (namesToList $ consumedInOp op)
-usageInExp _ = mempty
+usageInExp (BasicOp _) = mempty
diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs
--- a/src/Futhark/CLI/Autotune.hs
+++ b/src/Futhark/CLI/Autotune.hs
@@ -231,17 +231,21 @@
(String, Path) ->
IO Path
tuneThreshold opts datasets already_tuned (v, _v_path) = do
- (_, threshold) <-
- foldM tuneDataset (thresholdMin, thresholdMax) datasets
- return $ (v, threshold) : already_tuned
+ tune_result <-
+ foldM tuneDataset Nothing datasets
+ case tune_result of
+ Nothing ->
+ return $ (v, thresholdMin) : already_tuned
+ Just (_, threshold) ->
+ return $ (v, threshold) : already_tuned
where
- tuneDataset :: (Int, Int) -> (DatasetName, RunDataset, T.Text) -> IO (Int, Int)
- tuneDataset (tMin, tMax) (dataset_name, run, entry_point) =
+ tuneDataset :: Maybe (Int, Int) -> (DatasetName, RunDataset, T.Text) -> IO (Maybe (Int, Int))
+ tuneDataset thresholds (dataset_name, run, entry_point) =
if not $ isPrefixOf (T.unpack entry_point ++ ".") v
then do
when (optVerbose opts > 0) $
putStrLn $ unwords [v, "is irrelevant for", T.unpack entry_point]
- return (tMin, tMax)
+ return thresholds
else do
putStrLn $
unwords
@@ -253,7 +257,10 @@
dataset_name
]
- sample_run <- run (optTimeout opts) ((v, tMax) : already_tuned)
+ sample_run <-
+ run
+ (optTimeout opts)
+ ((v, maybe thresholdMax snd thresholds) : already_tuned)
case sample_run of
Left err -> do
@@ -263,8 +270,9 @@
when (optVerbose opts > 0) $
putStrLn $
"Sampling run failed:\n" ++ err
- return (tMin, tMax)
+ return thresholds
Right (cmps, t) -> do
+ let (tMin, tMax) = fromMaybe (thresholdMin, thresholdMax) thresholds
let ePars =
S.toAscList $
S.map snd $
@@ -286,7 +294,7 @@
newMax <- binarySearch runner (t, tMax) ePars
let newMinIdx = pred <$> elemIndex newMax ePars
let newMin = maxinum $ catMaybes [Just tMin, newMinIdx]
- return (newMin, newMax)
+ return $ Just (newMin, newMax)
bestPair :: [(Int, Int)] -> (Int, Int)
bestPair = minimumBy (compare `on` fst)
diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs
--- a/src/Futhark/CLI/Bench.hs
+++ b/src/Futhark/CLI/Bench.hs
@@ -21,7 +21,7 @@
import Futhark.Bench
import Futhark.Server
import Futhark.Test
-import Futhark.Util (fancyTerminal, maxinum, maybeNth, pmapIO)
+import Futhark.Util (atMostChars, fancyTerminal, maxinum, maybeNth, pmapIO)
import Futhark.Util.Console
import Futhark.Util.Options
import System.Console.ANSI (clearLine)
@@ -92,15 +92,15 @@
futhark <- FutharkExe . compFuthark <$> compileOptions opts
- results <-
- concat
- <$> mapM
- (runBenchmark opts futhark)
- (sortBy (comparing fst) compiled_benchmarks)
+ maybe_results <-
+ mapM
+ (runBenchmark opts futhark)
+ (sortBy (comparing fst) compiled_benchmarks)
+ let results = concat $ catMaybes maybe_results
case optJSON opts of
Nothing -> return ()
Just file -> LBS.writeFile file $ encodeBenchResults results
- when (anyFailed results) exitFailure
+ when (any isNothing maybe_results || anyFailed results) exitFailure
where
ignored f = any (`match` f) $ optIgnoreFiles opts
@@ -165,7 +165,7 @@
where
hasRuns (InputOutputs _ runs) = not $ null runs
-withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO a) -> IO a
+withProgramServer :: FilePath -> FilePath -> [String] -> (Server -> IO a) -> IO (Maybe a)
withProgramServer program runner extra_options f = do
-- Explicitly prefixing the current directory is necessary for
-- readProcessWithExitCode to find the binary when binOutputf has
@@ -177,14 +177,15 @@
| null runner = (binpath, extra_options)
| otherwise = (runner, binpath : extra_options)
- liftIO $ withServer to_run to_run_args f `catch` onError
+ liftIO $ (Just <$> withServer to_run to_run_args f) `catch` onError
where
- onError :: SomeException -> IO a
+ onError :: SomeException -> IO (Maybe a)
onError e = do
- hPrint stderr e
- exitFailure
+ putStrLn $ inBold $ inRed $ "\nFailed to run " ++ program
+ putStrLn $ inRed $ show e
+ pure Nothing
-runBenchmark :: BenchOptions -> FutharkExe -> (FilePath, [InputOutputs]) -> IO [BenchResult]
+runBenchmark :: BenchOptions -> FutharkExe -> (FilePath, [InputOutputs]) -> IO (Maybe [BenchResult])
runBenchmark opts futhark (program, cases) = do
(tuning_opts, tuning_desc) <- determineTuning (optTuning opts) program
let runopts = "-L" : optExtraOptions opts ++ tuning_opts
@@ -203,7 +204,7 @@
relevant = maybe (const True) (==) (optEntryPoint opts) . T.unpack . iosEntryPoint
- pad_to = foldl max 0 $ concatMap (map (length . runDescription) . iosTestRuns) cases
+ pad_to = foldl max 0 $ concatMap (map (length . atMostChars 40 . runDescription) . iosTestRuns) cases
runOptions :: (Int -> IO ()) -> BenchOptions -> RunOptions
runOptions f opts =
@@ -250,7 +251,7 @@
i <- readIORef count
let i' = if isJust us then i + 1 else i
writeIORef count i'
- putStr $ descString dataset_desc pad_to ++ progressBar i' runs 10
+ putStr $ descString (atMostChars 40 dataset_desc) pad_to ++ progressBar i' runs 10
putStr " " -- Just to move the cursor away from the progress bar.
hFlush stdout
| otherwise = do
@@ -310,12 +311,12 @@
case res of
Left err -> do
when fancyTerminal $
- liftIO $ putStrLn $ descString dataset_desc pad_to
+ liftIO $ putStrLn $ descString (atMostChars 40 dataset_desc) pad_to
liftIO $ putStrLn $ inRed $ T.unpack err
return $ Just $ DataResult dataset_desc $ Left err
Right (runtimes, errout) -> do
when fancyTerminal $
- putStr $ descString dataset_desc pad_to
+ putStr $ descString (atMostChars 40 dataset_desc) pad_to
reportResult runtimes
Result runtimes (getMemoryUsage errout) errout
diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs
--- a/src/Futhark/CLI/Literate.hs
+++ b/src/Futhark/CLI/Literate.hs
@@ -220,6 +220,14 @@
s <- lexeme $ takeWhileP Nothing (not . isSpace)
pure params {videoFormat = Just s}
+atStartOfLine :: Parser ()
+atStartOfLine = do
+ col <- sourceColumn <$> getSourcePos
+ when (col /= pos1) empty
+
+afterExp :: Parser ()
+afterExp = choice [atStartOfLine, void eol]
+
parseBlock :: Parser Block
parseBlock =
choice
@@ -231,7 +239,7 @@
where
parseDirective =
choice
- [ DirectiveRes <$> parseExp postlexeme,
+ [ DirectiveRes <$> parseExp postlexeme <* afterExp,
directiveName "covert" $> DirectiveCovert
<*> parseDirective,
directiveName "brief" $> DirectiveBrief
diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs
--- a/src/Futhark/CLI/Test.hs
+++ b/src/Futhark/CLI/Test.hs
@@ -20,7 +20,7 @@
import Futhark.Analysis.Metrics.Type
import Futhark.Server
import Futhark.Test
-import Futhark.Util (fancyTerminal)
+import Futhark.Util (atMostChars, fancyTerminal)
import Futhark.Util.Console
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyText)
@@ -467,11 +467,6 @@
moveCursorToTableTop :: IO ()
moveCursorToTableTop = cursorUpLine tableLines
-
-atMostChars :: Int -> String -> String
-atMostChars n s
- | length s > n = take (n -3) s ++ "..."
- | otherwise = s
reportText :: TestStatus -> IO ()
reportText ts =
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
@@ -15,7 +15,7 @@
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Futhark.CodeGen.Backends.CCUDA.Boilerplate
-import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions)
+import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions, sizeLoggingCode)
import qualified Futhark.CodeGen.Backends.GenericC as GC
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.ImpCode.OpenCL
@@ -251,6 +251,7 @@
callKernel (CmpSizeLe v key x) = do
x' <- GC.compileExp x
GC.stm [C.cstm|$id:v = ctx->sizes.$id:key <= $exp:x';|]
+ sizeLoggingCode v key x'
callKernel (GetSizeMax v size_class) =
let field = "max_" ++ cudaSizeClass size_class
in GC.stm [C.cstm|$id:v = ctx->cuda.$id:field;|]
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
@@ -25,7 +25,6 @@
GetSizeMax,
)
import Futhark.MonadFreshNames
-import Futhark.Util.Pretty (prettyOneLine)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
@@ -318,10 +317,7 @@
callKernel (CmpSizeLe v key x) = do
x' <- GC.compileExp x
GC.stm [C.cstm|$id:v = ctx->sizes.$id:key <= $exp:x';|]
- GC.stm
- [C.cstm|if (ctx->logging) {
- fprintf(ctx->log, "Compared %s <= %ld: %s.\n", $string:(prettyOneLine key), (long)$exp:x', $id:v ? "true" : "false");
- }|]
+ sizeLoggingCode v key x'
callKernel (GetSizeMax v size_class) =
let field = "max_" ++ pretty size_class
in GC.stm [C.cstm|$id:v = ctx->opencl.$id:field;|]
diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs
--- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs
+++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs
@@ -16,6 +16,7 @@
costCentreReport,
kernelRuntime,
kernelRuns,
+ sizeLoggingCode,
)
where
@@ -28,6 +29,7 @@
import Futhark.CodeGen.ImpCode.OpenCL
import Futhark.CodeGen.OpenCL.Heuristics
import Futhark.Util (chunk, zEncodeString)
+import Futhark.Util.Pretty (prettyOneLine)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
@@ -666,6 +668,17 @@
Just _ -> return ()
return [C.cexp|$id:v|]
+
+-- Output size information if logging is enabled.
+--
+-- The autotuner depends on the format of this output, so use caution if
+-- changing it.
+sizeLoggingCode :: VName -> Name -> C.Exp -> GC.CompilerM op () ()
+sizeLoggingCode v key x' = do
+ GC.stm
+ [C.cstm|if (ctx->logging) {
+ fprintf(ctx->log, "Compared %s <= %ld: %s.\n", $string:(prettyOneLine key), (long)$exp:x', $id:v ? "true" : "false");
+ }|]
-- Options that are common to multiple GPU-like backends.
commonOptions :: [Option]
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
@@ -839,7 +839,7 @@
resetMem [C.cexp|arr->mem|] space
allocMem
[C.cexp|arr->mem|]
- [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|]
+ [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]
space
[C.cstm|return NULL;|]
forM_ [0 .. rank -1] $ \i ->
@@ -855,7 +855,7 @@
[C.cexp|data|]
[C.cexp|0|]
DefaultSpace
- [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|]
+ [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]
new_raw_body <- collect $ do
prepare_new
@@ -866,7 +866,7 @@
[C.cexp|data|]
[C.cexp|offset|]
space
- [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|]
+ [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]
free_body <- collect $ unRefMem [C.cexp|arr->mem|] space
@@ -879,7 +879,7 @@
[C.cexp|arr->mem.mem|]
[C.cexp|0|]
space
- [C.cexp|((size_t)$exp:arr_size_array) * sizeof($ty:pt')|]
+ [C.cexp|((size_t)$exp:arr_size_array) * $int:(primByteSize pt::Int)|]
ctx_ty <- contextType
ops <- asks envOperations
@@ -994,7 +994,7 @@
in ( storageSize pt rank shape',
storeValueHeader sign pt rank shape' [C.cexp|out|]
++ [C.cstms|ret |= $id:values_array(ctx, obj->$id:field, (void*)out);
- out += $exp:num_elems * sizeof($ty:(primTypeToCType pt));|]
+ out += $exp:num_elems * $int:(primByteSize pt::Int);|]
)
ctx_ty <- contextType
@@ -1031,7 +1031,7 @@
stms $ loadValueHeader sign pt rank [C.cexp|$id:shapearr|] [C.cexp|src|]
item [C.citem|const void* $id:dataptr = src;|]
stm [C.cstm|obj->$id:field = NULL;|]
- stm [C.cstm|src += $exp:num_elems * sizeof($ty:(primTypeToCType pt));|]
+ stm [C.cstm|src += $exp:num_elems * $int:(primByteSize pt::Int);|]
pure
[C.cstms|
obj->$id:field = $id:new_array(ctx, $id:dataptr, $args:dims);
@@ -1565,9 +1565,14 @@
}|]
)
+ sync <- publicName "context_sync"
publicDef_ "context_report" MiscDecl $ \s ->
( [C.cedecl|char* $id:s($ty:ctx *ctx);|],
[C.cedecl|char* $id:s($ty:ctx *ctx) {
+ if ($id:sync(ctx) != 0) {
+ return NULL;
+ }
+
struct str_builder builder;
str_builder_init(&builder);
if (ctx->detail_memory || ctx->profiling || ctx->logging) {
@@ -1786,7 +1791,7 @@
where
b' :: Int
b' = if b then 1 else 0
-compilePrimValue Checked =
+compilePrimValue UnitValue =
[C.cexp|0|]
derefPointer :: C.Exp -> C.Exp -> C.Type -> C.Exp
@@ -1844,10 +1849,6 @@
compileLeaf (Index src (Count iexp) _ ScalarSpace {} _) = do
iexp' <- compileExp $ untyped iexp
return [C.cexp|$id:src[$exp:iexp']|]
- compileLeaf (SizeOf t) =
- return [C.cexp|(typename int64_t)sizeof($ty:t')|]
- where
- t' = primTypeToCType t
-- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you.
compilePrimExp :: Monad m => (v -> m C.Exp) -> PrimExp v -> m C.Exp
@@ -2031,6 +2032,7 @@
<*> compileExp (untyped srcoffset)
<*> pure srcspace
<*> compileExp (untyped size)
+compileCode (Write _ _ Unit _ _ _) = pure ()
compileCode (Write dest (Count idx) elemtype DefaultSpace vol elemexp) = do
dest' <- rawMem dest
deref <-
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
@@ -171,7 +171,7 @@
primTypeInfo (FloatType Float32) _ = [C.cexp|f32_info|]
primTypeInfo (FloatType Float64) _ = [C.cexp|f64_info|]
primTypeInfo Bool _ = [C.cexp|bool_info|]
-primTypeInfo Cert _ = [C.cexp|bool_info|]
+primTypeInfo Unit _ = [C.cexp|bool_info|]
readPrimStm :: C.ToIdent a => a -> Int -> PrimType -> Signedness -> C.Stm
readPrimStm place i t ept =
diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs
--- a/src/Futhark/CodeGen/Backends/GenericPython.hs
+++ b/src/Futhark/CodeGen/Backends/GenericPython.hs
@@ -742,7 +742,7 @@
readTypeEnum (FloatType Float32) _ = "f32"
readTypeEnum (FloatType Float64) _ = "f64"
readTypeEnum Imp.Bool _ = "bool"
-readTypeEnum Cert _ = error "readTypeEnum: cert"
+readTypeEnum Unit _ = "bool"
readInput :: Imp.ExternalValue -> PyStmt
readInput (Imp.OpaqueValue desc _) =
@@ -1039,7 +1039,7 @@
FloatType Float32 -> "ct.c_float"
FloatType Float64 -> "ct.c_double"
Imp.Bool -> "ct.c_bool"
- Cert -> "ct.c_bool"
+ Unit -> "ct.c_bool"
-- | The ctypes type corresponding to a 'PrimType', taking sign into account.
compilePrimTypeExt :: PrimType -> Imp.Signedness -> String
@@ -1056,7 +1056,7 @@
(FloatType Float32, _) -> "ct.c_float"
(FloatType Float64, _) -> "ct.c_double"
(Imp.Bool, _) -> "ct.c_bool"
- (Cert, _) -> "ct.c_byte"
+ (Unit, _) -> "ct.c_byte"
-- | The Numpy type corresponding to a 'PrimType'.
compilePrimToNp :: Imp.PrimType -> String
@@ -1069,7 +1069,7 @@
FloatType Float32 -> "np.float32"
FloatType Float64 -> "np.float64"
Imp.Bool -> "np.byte"
- Cert -> "np.byte"
+ Unit -> "np.byte"
-- | The Numpy type corresponding to a 'PrimType', taking sign into account.
compilePrimToExtNp :: Imp.PrimType -> Imp.Signedness -> String
@@ -1086,7 +1086,7 @@
(FloatType Float32, _) -> "np.float32"
(FloatType Float64, _) -> "np.float64"
(Imp.Bool, _) -> "np.bool_"
- (Cert, _) -> "np.byte"
+ (Unit, _) -> "np.byte"
compilePrimValue :: Imp.PrimValue -> PyExp
compilePrimValue (IntValue (Int8Value v)) =
@@ -1110,7 +1110,7 @@
Var "np.nan"
| otherwise = simpleCall "np.float64" [Float $ fromRational $ toRational v]
compilePrimValue (BoolValue v) = Bool v
-compilePrimValue Checked = Var "True"
+compilePrimValue UnitValue = Var "None"
compileVar :: VName -> CompilerM op s PyExp
compileVar v =
@@ -1160,8 +1160,6 @@
where
compileLeaf (Imp.ScalarVar vname) =
compileVar vname
- compileLeaf (Imp.SizeOf t) =
- return $ simpleCall (compilePrimToNp $ IntType Int32) [Integer $ primByteSize t]
compileLeaf (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) =
join $
asks envReadScalar
@@ -1207,7 +1205,7 @@
compileCode (Imp.SetScalar name exp1) =
stm =<< Assign <$> compileVar name <*> compileExp exp1
compileCode Imp.DeclareMem {} = return ()
-compileCode (Imp.DeclareScalar v _ Cert) = do
+compileCode (Imp.DeclareScalar v _ Unit) = do
v' <- compileVar v
stm $ Assign v' $ Var "True"
compileCode Imp.DeclareScalar {} = return ()
@@ -1313,6 +1311,7 @@
<*> pure srcspace
<*> compileExp (Imp.untyped size)
<*> pure (IntType Int32) -- FIXME
+compileCode (Imp.Write _ _ Unit _ _ _) = pure ()
compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) =
join $
asks envWriteScalar
diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs
--- a/src/Futhark/CodeGen/Backends/SimpleRep.hs
+++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs
@@ -65,7 +65,7 @@
primTypeToCType (IntType t) = intTypeToCType t
primTypeToCType (FloatType t) = floatTypeToCType t
primTypeToCType Bool = [C.cty|typename bool|]
-primTypeToCType Cert = [C.cty|typename bool|]
+primTypeToCType Unit = [C.cty|typename bool|]
-- | The C type corresponding to a primitive type. Integers are
-- assumed to have the specified sign.
@@ -174,7 +174,7 @@
toExp (FloatValue v) = C.toExp v
toExp (BoolValue True) = C.toExp (1 :: Int8)
toExp (BoolValue False) = C.toExp (0 :: Int8)
- toExp Checked = C.toExp (1 :: Int8)
+ toExp UnitValue = C.toExp (1 :: Int8)
instance C.ToExp SubExp where
toExp (Var v) = C.toExp v
@@ -761,6 +761,10 @@
return atan2(x,y);
}
+ static inline float $id:(funName' "hypot32")(float x, float y) {
+ return hypot(x,y);
+ }
+
static inline float $id:(funName' "gamma32")(float x) {
return tgamma(x);
}
@@ -863,6 +867,10 @@
return atan2f(x,y);
}
+ static inline float $id:(funName' "hypot32")(float x, float y) {
+ return hypotf(x,y);
+ }
+
static inline float $id:(funName' "gamma32")(float x) {
return tgammaf(x);
}
@@ -991,6 +999,10 @@
return atan2(x,y);
}
+ static inline double $id:(funName' "hypot64")(double x, double y) {
+ return hypot(x,y);
+ }
+
static inline double $id:(funName' "gamma64")(double x) {
return tgamma(x);
}
@@ -1081,7 +1093,7 @@
typeStr sign pt =
case (sign, pt) of
(_, Bool) -> "bool"
- (_, Cert) -> "bool"
+ (_, Unit) -> "bool"
(_, FloatType Float32) -> " f32"
(_, FloatType Float64) -> " f64"
(TypeDirect, IntType Int8) -> " i8"
diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs
--- a/src/Futhark/CodeGen/ImpCode.hs
+++ b/src/Futhark/CodeGen/ImpCode.hs
@@ -328,8 +328,6 @@
= -- | A scalar variable. The type is stored in the
-- 'LeafExp' constructor itself.
ScalarVar VName
- | -- | The size of a primitive type.
- SizeOf PrimType
| -- | Reading a value from memory. The arguments have
-- the same meaning as with 'Write'.
Index VName (Count Elements (TExp Int64)) PrimType Space Volatility
@@ -365,8 +363,7 @@
-- | Convert a count of elements into a count of bytes, given the
-- per-element size.
withElemType :: Count Elements (TExp Int64) -> PrimType -> Count Bytes (TExp Int64)
-withElemType (Count e) t =
- bytes $ sExt64 e * isInt64 (LeafExp (SizeOf t) (IntType Int64))
+withElemType (Count e) t = bytes $ sExt64 e * primByteSize t
-- | Turn a 'VName' into a 'Imp.ScalarVar'.
var :: VName -> PrimType -> Exp
@@ -528,8 +525,6 @@
vol' = case vol of
Volatile -> text "volatile "
Nonvolatile -> mempty
- ppr (SizeOf t) =
- text "sizeof" <> parens (ppr t)
instance Functor Functions where
fmap = fmapDefault
@@ -673,7 +668,6 @@
instance FreeIn ExpLeaf where
freeIn' (Index v e _ _ _) = freeIn' v <> freeIn' e
freeIn' (ScalarVar v) = freeIn' v
- freeIn' (SizeOf _) = mempty
instance FreeIn Arg where
freeIn' (MemArg m) = freeIn' m
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
@@ -52,6 +52,7 @@
lookupVar,
lookupArray,
lookupMemory,
+ lookupAcc,
-- * Building Blocks
TV,
@@ -76,6 +77,7 @@
copyDWIMFix,
copyElementWise,
typeSize,
+ inBounds,
isMapTransposeCopy,
-- * Constructing code.
@@ -218,6 +220,7 @@
= ArrayVar (Maybe (Exp lore)) ArrayEntry
| ScalarVar (Maybe (Exp lore)) ScalarEntry
| MemVar (Maybe (Exp lore)) MemEntry
+ | AccVar (Maybe (Exp lore)) (VName, Shape, [Type])
deriving (Show)
-- | When compiling an expression, this is a description of where the
@@ -281,11 +284,18 @@
stateFunctions :: Imp.Functions op,
stateCode :: Imp.Code op,
stateWarnings :: Warnings,
+ -- | Maps the arrays backing each accumulator to their
+ -- update function and neutral elements. This works
+ -- because an array name can only become part of a single
+ -- accumulator throughout its lifetime. If the arrays
+ -- backing an accumulator is not in this mapping, the
+ -- accumulator is scatter-like.
+ stateAccs :: M.Map VName ([VName], Maybe (Lambda lore, [SubExp])),
stateNameSource :: VNameSource
}
newState :: VNameSource -> ImpState lore r op
-newState = ImpState mempty mempty mempty mempty
+newState = ImpState mempty mempty mempty mempty mempty
newtype ImpM lore r op a
= ImpM (ReaderT (Env lore r op) (State (ImpState lore r op)) a)
@@ -315,6 +325,8 @@
NoUniqueness
entryType (ScalarVar _ scalarEntry) =
Prim $ entryScalarType scalarEntry
+ entryType (AccVar _ (acc, ispace, ts)) =
+ Acc acc ispace ts NoUniqueness
runImpM ::
ImpM lore r op a ->
@@ -356,7 +368,8 @@
stateFunctions = mempty,
stateCode = mempty,
stateNameSource = stateNameSource s,
- stateWarnings = mempty
+ stateWarnings = mempty,
+ stateAccs = stateAccs s
}
(x, s'') = runState (runReaderT m env') s'
@@ -493,6 +506,8 @@
Right $
ArrayDecl name bt $
MemLocation mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun
+ MemAcc {} ->
+ error "Functions may not have accumulator parameters."
where
name = paramName fparam
@@ -587,6 +602,8 @@
mkParam MemMem {} _ =
error "Functions may not explicitly return memory blocks."
+ mkParam MemAcc {} _ =
+ error "Functions may not return accumulators."
mkParam (MemPrim t) ept = do
out <- imp $ newVName "scalar_out"
tell ([Imp.ScalarParam out t], mempty)
@@ -785,6 +802,18 @@
where
merge = ctx ++ val
mergepat = map fst merge
+defCompileExp pat (WithAcc inputs lam) = do
+ dLParams $ lambdaParams lam
+ forM_ (zip inputs $ lambdaParams lam) $ \((_, arrs, op), p) ->
+ modify $ \s ->
+ s {stateAccs = M.insert (paramName p) (arrs, op) $ stateAccs s}
+ compileStms mempty (bodyStms $ lambdaBody lam) $ do
+ let nonacc_res = drop num_accs (bodyResult (lambdaBody lam))
+ nonacc_pat_names = takeLast (length nonacc_res) (patternNames pat)
+ forM_ (zip nonacc_pat_names nonacc_res) $ \(v, se) ->
+ copyDWIM v [] se []
+ where
+ num_accs = length inputs
defCompileExp pat (Op op) = do
opc <- asks envOpCompiler
opc pat op
@@ -889,6 +918,39 @@
return ()
defCompileBasicOp _ Reshape {} =
return ()
+defCompileBasicOp _ (UpdateAcc acc is vs) = sComment "UpdateAcc" $ do
+ -- We are abusing the comment mechanism to wrap the operator in
+ -- braces when we end up generating code. This is necessary because
+ -- we might otherwise end up declaring lambda parameters (if any)
+ -- multiple times, as they are duplicated every time we do an
+ -- UpdateAcc for the same accumulator.
+ let is' = map toInt64Exp is
+
+ -- We need to figure out whether we are updating a scatter-like
+ -- accumulator or a generalised reduction. This also binds the
+ -- index parameters.
+ (_, _, arrs, dims, op) <- lookupAcc acc is'
+
+ sWhen (inBounds (map DimFix is') dims) $
+ case op of
+ Nothing ->
+ -- Scatter-like.
+ forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v []
+ Just lam -> do
+ -- Generalised reduction.
+ dLParams $ lambdaParams lam
+ let (x_params, y_params) =
+ splitAt (length vs) $ map paramName $ lambdaParams lam
+
+ forM_ (zip x_params arrs) $ \(xp, arr) ->
+ copyDWIMFix xp [] (Var arr) is'
+
+ forM_ (zip y_params vs) $ \(yp, v) ->
+ copyDWIM yp [] v []
+
+ compileStms mempty (bodyStms $ lambdaBody lam) $
+ forM_ (zip arrs (bodyResult (lambdaBody lam))) $ \(arr, se) ->
+ copyDWIMFix arr is' se []
defCompileBasicOp pat e =
error $
"ImpGen.defCompileBasicOp: Invalid pattern\n "
@@ -986,6 +1048,8 @@
ScalarVar e ScalarEntry {entryScalarType = bt}
memBoundToVarEntry e (MemMem space) =
MemVar e $ MemEntry space
+memBoundToVarEntry e (MemAcc acc ispace ts _) =
+ AccVar e (acc, ispace, ts)
memBoundToVarEntry e (MemArray bt shape _ (ArrayIn mem ixfun)) =
let location = MemLocation mem (shapeDims shape) $ fmap (fmap Imp.ScalarVar) ixfun
in ArrayVar
@@ -1019,6 +1083,8 @@
emit $ Imp.DeclareScalar name Imp.Nonvolatile $ entryScalarType entry'
ArrayVar _ _ ->
return ()
+ AccVar {} ->
+ return ()
addVar name entry
dScope ::
@@ -1189,6 +1255,43 @@
MemVar _ entry -> return entry
_ -> error $ "Unknown memory block: " ++ pretty name
+lookupArraySpace :: VName -> ImpM lore r op Space
+lookupArraySpace =
+ fmap entryMemSpace . lookupMemory
+ <=< fmap (memLocationName . entryArrayLocation) . lookupArray
+
+-- | In the case of a histogram-like accumulator, also sets the index
+-- parameters.
+lookupAcc ::
+ VName ->
+ [Imp.TExp Int64] ->
+ ImpM lore r op (VName, Space, [VName], [Imp.TExp Int64], Maybe (Lambda lore))
+lookupAcc name is = do
+ res <- lookupVar name
+ case res of
+ AccVar _ (acc, ispace, _) -> do
+ acc' <- gets $ M.lookup acc . stateAccs
+ case acc' of
+ Just ([], _) ->
+ error $ "Accumulator with no arrays: " ++ pretty name
+ Just (arrs@(arr : _), Just (op, _)) -> do
+ space <- lookupArraySpace arr
+ let (i_params, ps) = splitAt (length is) $ lambdaParams op
+ zipWithM_ dPrimV_ (map paramName i_params) is
+ return
+ ( acc,
+ space,
+ arrs,
+ map toInt64Exp (shapeDims ispace),
+ Just op {lambdaParams = ps}
+ )
+ Just (arrs@(arr : _), Nothing) -> do
+ space <- lookupArraySpace arr
+ return (acc, space, arrs, map toInt64Exp (shapeDims ispace), Nothing)
+ Nothing ->
+ error $ "ImpGen.lookupAcc: unlisted accumulator: " ++ pretty name
+ _ -> error $ "ImpGen.lookupAcc: not an accumulator: " ++ pretty name
+
destinationFromPattern :: Mem lore => Pattern lore -> ImpM lore r op Destination
destinationFromPattern pat =
fmap (Destination (baseTag <$> maybeHead (patternNames pat))) . mapM inspect $
@@ -1204,6 +1307,8 @@
return $ MemoryDestination name
ScalarVar {} ->
return $ ScalarDestination name
+ AccVar {} ->
+ return $ ArrayDestination Nothing
fullyIndexArray ::
VName ->
@@ -1515,6 +1620,8 @@
(ArrayDestination Nothing, _) ->
return () -- Nothing to do; something else set some memory
-- somewhere.
+ (_, AccVar {}) ->
+ return () -- Nothing to do; accumulators are phantoms.
-- | Copy from here to there; both destination and source be
-- indexeded. If so, they better be arrays of enough dimensions.
@@ -1536,6 +1643,9 @@
ArrayDestination $ Just $ MemLocation mem shape ixfun
MemVar _ _ ->
MemoryDestination dest
+ AccVar {} ->
+ -- Does not matter; accumulators are phantoms.
+ ArrayDestination Nothing
copyDWIMDest dest_target dest_slice src src_slice
-- | As 'copyDWIM', but implicitly 'DimFix'es the indexes.
@@ -1570,9 +1680,18 @@
-- straightforward contiguous format, as an t'Int64' expression.
typeSize :: Type -> Count Bytes (Imp.TExp Int64)
typeSize t =
- Imp.bytes $
- isInt64 (Imp.LeafExp (Imp.SizeOf $ elemType t) int64)
- * product (map toInt64Exp (arrayDims t))
+ Imp.bytes $ primByteSize (elemType t) * product (map toInt64Exp (arrayDims t))
+
+-- | Is this indexing in-bounds for an array of the given shape? This
+-- is useful for things like scatter, which ignores out-of-bounds
+-- writes.
+inBounds :: Slice (Imp.TExp Int64) -> [Imp.TExp Int64] -> Imp.TExp Bool
+inBounds slice dims =
+ let condInBounds (DimFix i) d =
+ 0 .<=. i .&&. i .<. d
+ condInBounds (DimSlice i n s) d =
+ 0 .<=. i .&&. i + n * s .<. d
+ in foldl1 (.&&.) $ zipWith condInBounds slice dims
--- Building blocks for constructing code.
diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs
--- a/src/Futhark/CodeGen/ImpGen/Kernels.hs
+++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs
@@ -91,8 +91,8 @@
compileProgOpenCL,
compileProgCUDA ::
MonadFreshNames m => Prog KernelsMem -> m (Warnings, Imp.Program)
-compileProgOpenCL = compileProg $ HostEnv openclAtomics OpenCL
-compileProgCUDA = compileProg $ HostEnv cudaAtomics CUDA
+compileProgOpenCL = compileProg $ HostEnv openclAtomics OpenCL mempty
+compileProgCUDA = compileProg $ HostEnv cudaAtomics CUDA mempty
opCompiler ::
Pattern KernelsMem ->
@@ -199,6 +199,31 @@
-- they fit.
alignedSize x = x + ((8 - (x `rem` 8)) `rem` 8)
+withAcc ::
+ Pattern KernelsMem ->
+ [(Shape, [VName], Maybe (Lambda KernelsMem, [SubExp]))] ->
+ Lambda KernelsMem ->
+ CallKernelGen ()
+withAcc pat inputs lam = do
+ atomics <- hostAtomics <$> askEnv
+ locksForInputs atomics $ zip accs inputs
+ where
+ accs = map paramName $ lambdaParams lam
+ locksForInputs _ [] =
+ defCompileExp pat $ WithAcc inputs lam
+ locksForInputs atomics ((c, (_, _, op)) : inputs')
+ | Just (op_lam, _) <- op,
+ AtomicLocking _ <- atomicUpdateLocking atomics op_lam = do
+ let num_locks = 100151
+ locks_arr <-
+ sStaticArray "withacc_locks" (Space "device") int32 $
+ Imp.ArrayZeros num_locks
+ let locks = Locks locks_arr num_locks
+ extend env = env {hostLocks = M.insert c locks $ hostLocks env}
+ localEnv extend $ locksForInputs atomics inputs'
+ | otherwise =
+ locksForInputs atomics inputs'
+
expCompiler :: ExpCompiler KernelsMem HostEnv Imp.HostOp
-- We generate a simple kernel for itoa and replicate.
expCompiler (Pattern _ [pe]) (BasicOp (Iota n x s et)) = do
@@ -211,6 +236,8 @@
-- Allocation in the "local" space is just a placeholder.
expCompiler _ (Op (Alloc _ (Space "local"))) =
return ()
+expCompiler pat (WithAcc inputs lam) =
+ withAcc pat inputs lam
-- This is a multi-versioning If created by incremental flattening.
-- We need to augment the conditional with a check that any local
-- memory requirements in tbranch are compatible with the hardware.
@@ -375,9 +402,7 @@
.&&. block_dim .<. Imp.vi32 x
copy_code =
- let num_bytes =
- sExt64 $
- Imp.vi32 x * Imp.vi32 y * isInt32 (Imp.LeafExp (Imp.SizeOf bt) (IntType Int32))
+ let num_bytes = sExt64 $ Imp.vi32 x * Imp.vi32 y * primByteSize bt
in Imp.Copy
destmem
(Imp.Count $ sExt64 $ Imp.vi32 destoffset)
diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs
--- a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs
+++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs
@@ -7,6 +7,7 @@
keyWithEntryPoint,
CallKernelGen,
InKernelGen,
+ Locks (..),
HostEnv (..),
Target (..),
KernelEnv (..),
@@ -56,14 +57,22 @@
-- targeting.
data Target = CUDA | OpenCL
+-- | Information about the locks available for accumulators.
+data Locks = Locks
+ { locksArray :: VName,
+ locksCount :: Int
+ }
+
data HostEnv = HostEnv
{ hostAtomics :: AtomicBinOp,
- hostTarget :: Target
+ hostTarget :: Target,
+ hostLocks :: M.Map VName Locks
}
data KernelEnv = KernelEnv
{ kernelAtomics :: AtomicBinOp,
- kernelConstants :: KernelConstants
+ kernelConstants :: KernelConstants,
+ kernelLocks :: M.Map VName Locks
}
type CallKernelGen = ImpM KernelsMem HostEnv Imp.HostOp
@@ -155,10 +164,41 @@
splitSpace pat _ _ _ _ =
error $ "Invalid target for splitSpace: " ++ pretty pat
+updateAcc :: VName -> [SubExp] -> [SubExp] -> InKernelGen ()
+updateAcc acc is vs = sComment "UpdateAcc" $ do
+ -- See the ImpGen implementation of UpdateAcc for general notes.
+ let is' = map toInt64Exp is
+ (c, space, arrs, dims, op) <- lookupAcc acc is'
+ sWhen (inBounds (map DimFix is') dims) $
+ case op of
+ Nothing ->
+ forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v []
+ Just lam -> do
+ dLParams $ lambdaParams lam
+ let (_x_params, y_params) =
+ splitAt (length vs) $ map paramName $ lambdaParams lam
+ forM_ (zip y_params vs) $ \(yp, v) -> copyDWIM yp [] v []
+ atomics <- kernelAtomics <$> askEnv
+ case atomicUpdateLocking atomics lam of
+ AtomicPrim f -> f space arrs is'
+ AtomicCAS f -> f space arrs is'
+ AtomicLocking f -> do
+ c_locks <- M.lookup c . kernelLocks <$> askEnv
+ case c_locks of
+ Just (Locks locks num_locks) -> do
+ let locking =
+ Locking locks 0 1 0 $
+ pure . (`rem` fromIntegral num_locks) . flattenIndex dims
+ f locking space arrs is'
+ Nothing ->
+ error $ "Missing locks for " ++ pretty acc
+
compileThreadExp :: ExpCompiler KernelsMem KernelEnv Imp.KernelOp
compileThreadExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =
forM_ (zip [0 ..] es) $ \(i, e) ->
copyDWIMFix (patElemName dest) [fromIntegral (i :: Int64)] e []
+compileThreadExp _ (BasicOp (UpdateAcc acc is vs)) =
+ updateAcc acc is vs
compileThreadExp dest e =
defCompileExp dest e
@@ -214,6 +254,8 @@
compileGroupExp (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =
forM_ (zip [0 ..] es) $ \(i, e) ->
copyDWIMFix (patElemName dest) [fromIntegral (i :: Int64)] e []
+compileGroupExp _ (BasicOp (UpdateAcc acc is vs)) =
+ updateAcc acc is vs
compileGroupExp (Pattern _ [dest]) (BasicOp (Replicate ds se)) = do
let ds' = map toInt64Exp $ shapeDims ds
groupCoverSpace ds' $ \is ->
@@ -769,14 +811,13 @@
vtable <- getVTable
case t of
Array {} -> return Nothing
+ Acc {} -> return Nothing
Mem (Space "local") -> return Nothing
Mem {} -> return $ Just $ Imp.MemoryUse var
Prim bt ->
isConstExp vtable (Imp.var var bt) >>= \case
Just ce -> return $ Just $ Imp.ConstUse var ce
- Nothing
- | bt == Cert -> return Nothing
- | otherwise -> return $ Just $ Imp.ScalarUse var bt
+ Nothing -> return $ Just $ Imp.ScalarUse var bt
isConstExp ::
VTable KernelsMem ->
@@ -785,7 +826,6 @@
isConstExp vtable size = do
fname <- askFunction
let onLeaf (Imp.ScalarVar name) _ = lookupConstExp name
- onLeaf (Imp.SizeOf pt) _ = Just $ ValueExp $ IntValue $ Int32Value $ primByteSize pt
onLeaf Imp.Index {} _ = Nothing
lookupConstExp name =
constExp =<< hasExp =<< M.lookup name vtable
@@ -795,6 +835,7 @@
return $ replaceInPrimExpM onLeaf size
where
hasExp (ArrayVar e _) = e
+ hasExp (AccVar e _) = e
hasExp (ScalarVar e _) = e
hasExp (MemVar e _) = e
@@ -1341,8 +1382,8 @@
InKernelGen () ->
CallKernelGen ()
sKernelFailureTolerant tol ops constants name m = do
- HostEnv atomics _ <- askEnv
- body <- makeAllMemoryGlobal $ subImpM_ (KernelEnv atomics constants) ops m
+ HostEnv atomics _ locks <- askEnv
+ body <- makeAllMemoryGlobal $ subImpM_ (KernelEnv atomics constants locks) ops m
uses <- computeKernelUses body mempty
emit $
Imp.Op $
diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs
--- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs
+++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs
@@ -372,6 +372,7 @@
let ctp = case bt of
-- OpenCL does not permit bool as a kernel parameter type.
Bool -> [C.cty|unsigned char|]
+ Unit -> [C.cty|unsigned char|]
_ -> GC.primTypeToCType bt
in Just [C.cparam|$ty:ctp $id:name|]
useAsParam (MemoryUse name) =
@@ -885,4 +886,3 @@
typesInExp (FunExp _ args t) = S.singleton t <> mconcat (map typesInExp args)
typesInExp (LeafExp (Index _ (Count (TPrimExp e)) t _ _) _) = S.singleton t <> typesInExp e
typesInExp (LeafExp ScalarVar {} _) = mempty
-typesInExp (LeafExp (SizeOf t) _) = S.singleton t
diff --git a/src/Futhark/CodeGen/ImpGen/Multicore.hs b/src/Futhark/CodeGen/ImpGen/Multicore.hs
--- a/src/Futhark/CodeGen/ImpGen/Multicore.hs
+++ b/src/Futhark/CodeGen/ImpGen/Multicore.hs
@@ -8,6 +8,8 @@
)
where
+import Control.Monad
+import qualified Data.Map as M
import qualified Futhark.CodeGen.ImpCode.Multicore as Imp
import Futhark.CodeGen.ImpGen
import Futhark.CodeGen.ImpGen.Multicore.Base
@@ -17,6 +19,7 @@
import Futhark.CodeGen.ImpGen.Multicore.SegScan
import Futhark.IR.MCMem
import Futhark.MonadFreshNames
+import Futhark.Util.IntegralExp (rem)
import Prelude hiding (quot, rem)
-- GCC supported primitve atomic Operations
@@ -41,11 +44,76 @@
MonadFreshNames m =>
Prog MCMem ->
m (Warnings, Imp.Definitions Imp.Multicore)
-compileProg = Futhark.CodeGen.ImpGen.compileProg (HostEnv gccAtomics) ops Imp.DefaultSpace
+compileProg = Futhark.CodeGen.ImpGen.compileProg (HostEnv gccAtomics mempty) ops Imp.DefaultSpace
where
- ops = defaultOperations opCompiler
+ ops =
+ (defaultOperations opCompiler)
+ { opsExpCompiler = compileMCExp
+ }
opCompiler dest (Alloc e space) = compileAlloc dest e space
opCompiler dest (Inner op) = compileMCOp dest op
+
+updateAcc :: VName -> [SubExp] -> [SubExp] -> MulticoreGen ()
+updateAcc acc is vs = sComment "UpdateAcc" $ do
+ -- See the ImpGen implementation of UpdateAcc for general notes.
+ let is' = map toInt64Exp is
+ (c, _space, arrs, dims, op) <- lookupAcc acc is'
+ sWhen (inBounds (map DimFix is') dims) $
+ case op of
+ Nothing ->
+ forM_ (zip arrs vs) $ \(arr, v) -> copyDWIMFix arr is' v []
+ Just lam -> do
+ dLParams $ lambdaParams lam
+ let (_x_params, y_params) =
+ splitAt (length vs) $ map paramName $ lambdaParams lam
+ forM_ (zip y_params vs) $ \(yp, v) -> copyDWIM yp [] v []
+ atomics <- hostAtomics <$> askEnv
+ case atomicUpdateLocking atomics lam of
+ AtomicPrim f -> f arrs is'
+ AtomicCAS f -> f arrs is'
+ AtomicLocking f -> do
+ c_locks <- M.lookup c . hostLocks <$> askEnv
+ case c_locks of
+ Just (Locks locks num_locks) -> do
+ let locking =
+ Locking locks 0 1 0 $
+ pure . (`rem` fromIntegral num_locks) . flattenIndex dims
+ f locking arrs is'
+ Nothing ->
+ error $ "Missing locks for " ++ pretty acc
+
+withAcc ::
+ Pattern MCMem ->
+ [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))] ->
+ Lambda MCMem ->
+ MulticoreGen ()
+withAcc pat inputs lam = do
+ atomics <- hostAtomics <$> askEnv
+ locksForInputs atomics $ zip accs inputs
+ where
+ accs = map paramName $ lambdaParams lam
+ locksForInputs _ [] =
+ defCompileExp pat $ WithAcc inputs lam
+ locksForInputs atomics ((c, (_, _, op)) : inputs')
+ | Just (op_lam, _) <- op,
+ AtomicLocking _ <- atomicUpdateLocking atomics op_lam = do
+ let num_locks = 100151
+ locks_arr <-
+ sStaticArray "withacc_locks" DefaultSpace int32 $
+ Imp.ArrayZeros num_locks
+ let locks = Locks locks_arr num_locks
+ extend env = env {hostLocks = M.insert c locks $ hostLocks env}
+ localEnv extend $ locksForInputs atomics inputs'
+ | otherwise =
+ locksForInputs atomics inputs'
+
+compileMCExp :: ExpCompiler MCMem HostEnv Imp.Multicore
+compileMCExp _ (BasicOp (UpdateAcc acc is vs)) =
+ updateAcc acc is vs
+compileMCExp pat (WithAcc inputs lam) =
+ withAcc pat inputs lam
+compileMCExp dest e =
+ defCompileExp dest e
compileMCOp ::
Pattern MCMem ->
diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs
--- a/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs
+++ b/src/Futhark/CodeGen/ImpGen/Multicore/Base.hs
@@ -1,6 +1,7 @@
module Futhark.CodeGen.ImpGen.Multicore.Base
( extractAllocations,
compileThreadResult,
+ Locks (..),
HostEnv (..),
AtomicBinOp,
MulticoreGen,
@@ -23,6 +24,7 @@
import Control.Monad
import Data.Bifunctor
import Data.List (elemIndex, find)
+import qualified Data.Map as M
import Data.Maybe
import qualified Futhark.CodeGen.ImpCode.Multicore as Imp
import Futhark.CodeGen.ImpGen
@@ -37,9 +39,17 @@
BinOp ->
Maybe (VName -> VName -> Imp.Count Imp.Elements (Imp.TExp Int32) -> Imp.Exp -> Imp.AtomicOp)
-newtype HostEnv = HostEnv
- {hostAtomics :: AtomicBinOp}
+-- | Information about the locks available for accumulators.
+data Locks = Locks
+ { locksArray :: VName,
+ locksCount :: Int
+ }
+data HostEnv = HostEnv
+ { hostAtomics :: AtomicBinOp,
+ hostLocks :: M.Map VName Locks
+ }
+
type MulticoreGen = ImpM MCMem HostEnv Imp.Multicore
segOpString :: SegOp () MCMem -> MulticoreGen String
@@ -48,16 +58,20 @@
segOpString SegScan {} = return "segscan"
segOpString SegHist {} = return "seghist"
-toParam :: VName -> TypeBase shape u -> MulticoreGen Imp.Param
-toParam name (Prim pt) = return $ Imp.ScalarParam name pt
-toParam name (Mem space) = return $ Imp.MemParam name space
-toParam name Array {} = do
- name_entry <- lookupVar name
+arrParam :: VName -> MulticoreGen Imp.Param
+arrParam arr = do
+ name_entry <- lookupVar arr
case name_entry of
ArrayVar _ (ArrayEntry (MemLocation mem _ _) _) ->
return $ Imp.MemParam mem DefaultSpace
- _ -> error $ "[toParam] Could not handle array for " ++ show name
+ _ -> error $ "arrParam: could not handle array " ++ show arr
+toParam :: VName -> TypeBase shape u -> MulticoreGen [Imp.Param]
+toParam name (Prim pt) = return [Imp.ScalarParam name pt]
+toParam name (Mem space) = return [Imp.MemParam name space]
+toParam name Array {} = pure <$> arrParam name
+toParam name Acc {} = error $ "toParam Acc: " ++ pretty name
+
getSpace :: SegOp () MCMem -> SegSpace
getSpace (SegHist _ space _ _ _) = space
getSpace (SegRed _ space _ _ _) = space
@@ -85,7 +99,7 @@
getReturnParams pat SegRed {} = do
let retvals = map patElemName $ patternElements pat
retvals_ts <- mapM lookupType retvals
- zipWithM toParam retvals retvals_ts
+ concat <$> zipWithM toParam retvals retvals_ts
getReturnParams _ _ = return mempty
renameSegBinOp :: [SegBinOp MCMem] -> MulticoreGen [SegBinOp MCMem]
@@ -119,7 +133,7 @@
freeParams code names = do
let freeVars = freeVariables code names
ts <- mapM lookupType freeVars
- zipWithM toParam freeVars ts
+ concat <$> zipWithM toParam freeVars ts
-- | Arrays for storing group results shared between threads
groupResultArrays ::
@@ -130,9 +144,8 @@
groupResultArrays s num_threads reds =
forM reds $ \(SegBinOp _ lam _ shape) ->
forM (lambdaReturnType lam) $ \t -> do
- let pt = elemType t
- full_shape = Shape [num_threads] <> shape <> arrayShape t
- sAllocArray s pt full_shape DefaultSpace
+ let full_shape = Shape [num_threads] <> shape <> arrayShape t
+ sAllocArray s (elemType t) full_shape DefaultSpace
isLoadBalanced :: Imp.Code -> Bool
isLoadBalanced (a Imp.:>>: b) = isLoadBalanced a && isLoadBalanced b
diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs
--- a/src/Futhark/Construct.hs
+++ b/src/Futhark/Construct.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-- | = Constructing Futhark ASTs
@@ -79,10 +80,13 @@
resultBody,
resultBodyM,
insertStmsM,
+ buildBody,
+ buildBody_,
mapResult,
foldBinOp,
binOpLambda,
cmpOpLambda,
+ mkLambda,
sliceDim,
fullSlice,
fullSliceNum,
@@ -280,10 +284,10 @@
(MonadBinder m) =>
[m (Exp (Lore m))] ->
m (Body (Lore m))
-eBody es = insertStmsM $ do
+eBody es = buildBody_ $ do
es' <- sequence es
xs <- mapM (letTupExp "x") es'
- mkBodyM mempty $ map Var $ concat xs
+ pure $ map Var $ concat xs
eLambda ::
MonadBinder m =>
@@ -362,16 +366,15 @@
outside_bounds <- letSubExp "outside_bounds" =<< eOutOfBounds arr is
- outside_bounds_branch <- insertStmsM $ resultBodyM [Var arr]
+ outside_bounds_branch <- buildBody_ $ pure [Var arr]
- in_bounds_branch <- insertStmsM $ do
- res <-
+ in_bounds_branch <-
+ buildBody_ . fmap (pure . Var) $
letInPlace
"write_out_inside_bounds"
arr
(fullSlice arr_t (map DimFix is'))
- $ BasicOp $ SubExp v'
- resultBodyM [Var res]
+ (BasicOp $ SubExp v')
return $
If outside_bounds outside_bounds_branch in_bounds_branch $
@@ -381,6 +384,7 @@
eBlank :: MonadBinder m => Type -> m (Exp (Lore m))
eBlank (Prim t) = return $ BasicOp $ SubExp $ Constant $ blankPrimValue t
eBlank (Array t shape _) = return $ BasicOp $ Scratch t $ shapeDims shape
+eBlank Acc {} = error "eBlank: cannot create blank accumulator"
eBlank Mem {} = error "eBlank: cannot create blank memory"
-- | Sign-extend to the given integer type.
@@ -453,9 +457,9 @@
binLambda bop arg_t ret_t = do
x <- newVName "x"
y <- newVName "y"
- body <- insertStmsM $ do
- res <- letSubExp "binlam_res" $ BasicOp $ bop (Var x) (Var y)
- return $ resultBody [res]
+ body <-
+ buildBody_ . fmap pure $
+ letSubExp "binlam_res" $ BasicOp $ bop (Var x) (Var y)
return
Lambda
{ lambdaParams =
@@ -466,6 +470,19 @@
lambdaBody = body
}
+-- | Easily construct a 'Lambda' within a 'MonadBinder'.
+mkLambda ::
+ MonadBinder m =>
+ [LParam (Lore m)] ->
+ m Result ->
+ m (Lambda (Lore m))
+mkLambda params m = do
+ (body, ret) <- buildBody . localScope (scopeOfLParams params) $ do
+ res <- m
+ ret <- mapM subExpType res
+ pure (res, ret)
+ pure $ Lambda params body ret
+
-- | Slice a full dimension of the given size.
sliceDim :: SubExp -> DimIndex SubExp
sliceDim d = DimSlice (constant (0 :: Int64)) d (constant (1 :: Int64))
@@ -524,6 +541,25 @@
insertStmsM m = do
(Body _ bnds res, otherbnds) <- collectStms m
mkBodyM (otherbnds <> bnds) res
+
+-- | Evaluate an action that produces a 'Result' and an auxiliary
+-- value, then return the body constructed from the 'Result' and any
+-- statements added during the action, along the auxiliary value.
+buildBody ::
+ MonadBinder m =>
+ m (Result, a) ->
+ m (Body (Lore m), a)
+buildBody m = do
+ ((res, v), stms) <- collectStms m
+ body <- mkBodyM stms res
+ pure (body, v)
+
+-- | As 'buildBody', but there is no auxiliary value.
+buildBody_ ::
+ MonadBinder m =>
+ m Result ->
+ m (Body (Lore m))
+buildBody_ m = fst <$> buildBody ((,()) <$> m)
-- | Change that result where evaluation of the body would stop. Also
-- change type annotations at branches.
diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs
--- a/src/Futhark/Doc/Generator.hs
+++ b/src/Futhark/Doc/Generator.hs
@@ -679,7 +679,7 @@
concat (replicate (length (splitPath src) - 1) "../") ++ dest
dimDeclHtml :: DimDecl VName -> DocM Html
-dimDeclHtml AnyDim = return mempty
+dimDeclHtml (AnyDim _) = return mempty
dimDeclHtml (NamedDim v) = qualNameHtml v
dimDeclHtml (ConstDim n) = return $ toHtml (show n)
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
@@ -256,6 +256,8 @@
-- byte offsets, multiply the offset with the size of the array
-- element type.
MemArray PrimType (ShapeBase d) u ret
+ | -- | An accumulator, which is not stored anywhere.
+ MemAcc VName Shape [Type] u
deriving (Eq, Show, Ord) --- XXX Ord?
type MemBound u = MemInfo SubExp u MemBind
@@ -264,17 +266,20 @@
declExtTypeOf (MemPrim pt) = Prim pt
declExtTypeOf (MemMem space) = Mem space
declExtTypeOf (MemArray pt shape u _) = Array pt shape u
+ declExtTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u
instance FixExt ret => ExtTyped (MemInfo ExtSize NoUniqueness ret) where
extTypeOf (MemPrim pt) = Prim pt
extTypeOf (MemMem space) = Mem space
extTypeOf (MemArray pt shape u _) = Array pt shape u
+ extTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u
instance FixExt ret => FixExt (MemInfo ExtSize u ret) where
fixExt _ _ (MemPrim pt) = MemPrim pt
fixExt _ _ (MemMem space) = MemMem space
fixExt i se (MemArray pt shape u ret) =
MemArray pt (fixExt i se shape) u (fixExt i se ret)
+ fixExt _ _ (MemAcc acc ispace ts u) = MemAcc acc ispace ts u
instance Typed (MemInfo SubExp Uniqueness ret) where
typeOf = fromDecl . declTypeOf
@@ -283,16 +288,19 @@
typeOf (MemPrim pt) = Prim pt
typeOf (MemMem space) = Mem space
typeOf (MemArray bt shape u _) = Array bt shape u
+ typeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u
instance DeclTyped (MemInfo SubExp Uniqueness ret) where
declTypeOf (MemPrim bt) = Prim bt
declTypeOf (MemMem space) = Mem space
declTypeOf (MemArray bt shape u _) = Array bt shape u
+ declTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u
instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d u ret) where
freeIn' (MemArray _ shape _ ret) = freeIn' shape <> freeIn' ret
freeIn' (MemMem s) = freeIn' s
freeIn' MemPrim {} = mempty
+ freeIn' (MemAcc acc ispace ts _) = freeIn' (acc, ispace, ts)
instance (Substitute d, Substitute ret) => Substitute (MemInfo d u ret) where
substituteNames subst (MemArray bt shape u ret) =
@@ -301,6 +309,12 @@
(substituteNames subst shape)
u
(substituteNames subst ret)
+ substituteNames substs (MemAcc acc ispace ts u) =
+ MemAcc
+ (substituteNames substs acc)
+ (substituteNames substs ispace)
+ (substituteNames substs ts)
+ u
substituteNames _ (MemMem space) =
MemMem space
substituteNames _ (MemPrim bt) =
@@ -337,9 +351,12 @@
pure $ MemMem space
simplify (MemArray bt shape u ret) =
MemArray bt <$> Engine.simplify shape <*> pure u <*> Engine.simplify ret
+ simplify (MemAcc acc ispace ts u) =
+ MemAcc <$> Engine.simplify acc <*> Engine.simplify ispace <*> Engine.simplify ts <*> pure u
instance
- ( PP.Pretty (TypeBase (ShapeBase d) u),
+ ( PP.Pretty (ShapeBase d),
+ PP.Pretty (TypeBase (ShapeBase d) u),
PP.Pretty d,
PP.Pretty u,
PP.Pretty ret
@@ -351,6 +368,8 @@
ppr (MemMem s) = PP.text "mem" <> PP.ppr s
ppr (MemArray bt shape u ret) =
PP.ppr (Array bt shape u) <+> PP.text "@" <+> PP.ppr ret
+ ppr (MemAcc acc ispace ts u) =
+ PP.ppr u <> PP.ppr (Acc acc ispace ts NoUniqueness :: Type)
-- | Memory information for an array bound somewhere in the program.
data MemBind
@@ -494,6 +513,8 @@
MemPrim bt
maybeReturns (MemMem space) =
MemMem space
+maybeReturns (MemAcc acc ispace ts u) =
+ MemAcc acc ispace ts u
noUniquenessReturns :: MemInfo d u r -> MemInfo d NoUniqueness r
noUniquenessReturns (MemArray bt shape _ r) =
@@ -502,6 +523,8 @@
MemPrim bt
noUniquenessReturns (MemMem space) =
MemMem space
+noUniquenessReturns (MemAcc acc ispace ts _) =
+ MemAcc acc ispace ts NoUniqueness
funReturnsToExpReturns :: FunReturns -> ExpReturns
funReturnsToExpReturns = noUniquenessReturns . maybeReturns
@@ -535,6 +558,7 @@
case dec of
MemPrim _ -> return ()
MemMem {} -> return ()
+ MemAcc {} -> return ()
MemArray _ _ _ (ArrayIn _ ixfun)
| IxFun.isLinear ixfun ->
return ()
@@ -570,6 +594,8 @@
MemPrim t
toRet (MemMem space) =
MemMem space
+ toRet (MemAcc acc ispace ts u) =
+ MemAcc acc ispace ts u
toRet (MemArray pt shape u (ArrayIn mem ixfun))
| Just i <- mem `elemIndex` ctx_names,
Param _ (MemMem space) : _ <- drop i ctx =
@@ -644,6 +670,9 @@
| x == y = return ()
checkReturn (MemMem x) (MemMem y)
| x == y = return ()
+ checkReturn (MemAcc xacc xispace xts _) (MemAcc yacc yispace yts _)
+ | (xacc, xispace, xts) == (yacc, yispace, yts) =
+ return ()
checkReturn
(MemArray x_pt x_shape _ x_ret)
(MemArray y_pt y_shape _ y_ret)
@@ -795,6 +824,8 @@
matches _ _ (MemPrim x) (MemPrim y) = x == y
matches _ _ (MemMem x_space) (MemMem y_space) =
x_space == y_space
+ matches _ _ (MemAcc x_accs x_ispace x_ts _) (MemAcc y_accs y_ispace y_ts _) =
+ (x_accs, x_ispace, x_ts) == (y_accs, y_ispace, y_ts)
matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) =
x_pt == y_pt && x_shape == y_shape
&& case (x_ret, y_ret) of
@@ -888,6 +919,8 @@
checkMemInfo _ (MemPrim _) = return ()
checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require [Prim int64]) d
checkMemInfo _ (MemMem _) = return ()
+checkMemInfo _ (MemAcc acc ispace ts u) =
+ TC.checkType $ Acc acc ispace ts u
checkMemInfo name (MemArray _ shape _ (ArrayIn v ixfun)) = do
t <- lookupType v
case t of
@@ -942,11 +975,12 @@
ReturnsNewBlock space i $
existentialiseIxFun (map patElemName ctx) ixfun
_ -> ReturnsInBlock mem $ existentialiseIxFun [] ixfun
+ MemAcc acc ispace ts u -> MemAcc acc ispace ts u
)
extReturns :: [ExtType] -> [ExpReturns]
-extReturns ts =
- evalState (mapM addDec ts) 0
+extReturns ets =
+ evalState (mapM addDec ets) 0
where
addDec (Prim bt) =
return $ MemPrim bt
@@ -962,6 +996,8 @@
IxFun.iota $ map convert $ shapeDims shape
| otherwise =
return $ MemArray bt shape u Nothing
+ addDec (Acc acc ispace ts u) =
+ return $ MemAcc acc ispace ts u
convert (Ext i) = le64 (Ext i)
convert (Free v) = Free <$> pe64 v
@@ -992,18 +1028,26 @@
Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun
MemMem space ->
return $ MemMem space
+ MemAcc acc ispace ts u ->
+ return $ MemAcc acc ispace ts u
+subExpReturns :: (HasScope lore m, Monad m, Mem lore) => SubExp -> m ExpReturns
+subExpReturns (Var v) =
+ varReturns v
+subExpReturns (Constant v) =
+ pure $ MemPrim $ primValueType v
+
-- | The return information of an expression. This can be seen as the
-- "return type with memory annotations" of the expression.
expReturns ::
( Monad m,
- HasScope lore m,
+ LocalScope lore m,
Mem lore
) =>
Exp lore ->
m [ExpReturns]
-expReturns (BasicOp (SubExp (Var v))) =
- pure <$> varReturns v
+expReturns (BasicOp (SubExp se)) =
+ pure <$> subExpReturns se
expReturns (BasicOp (Opaque (Var v))) =
pure <$> varReturns v
expReturns (BasicOp (Reshape newshape v)) = do
@@ -1040,6 +1084,7 @@
Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun
]
MemPrim pt -> return [MemPrim pt]
+ MemAcc acc ispace ts u -> return [MemAcc acc ispace ts u]
MemMem space -> return [MemMem space]
expReturns (BasicOp (Update v _ _)) =
pure <$> varReturns v
@@ -1051,23 +1096,25 @@
where
typeWithDec t p =
case (t, paramDec p) of
- ( Array bt shape u,
+ ( Array pt shape u,
MemArray _ _ _ (ArrayIn mem ixfun)
)
| Just (i, mem_p) <- isMergeVar mem,
Mem space <- paramType mem_p ->
- return $ MemArray bt shape u $ Just $ ReturnsNewBlock space i ixfun'
+ return $ MemArray pt shape u $ Just $ ReturnsNewBlock space i ixfun'
| otherwise ->
return
- ( MemArray bt shape u $
+ ( MemArray pt shape u $
Just $ ReturnsInBlock mem ixfun'
)
where
ixfun' = existentialiseIxFun (map paramName mergevars) ixfun
(Array {}, _) ->
error "expReturns: Array return type but not array merge variable."
- (Prim bt, _) ->
- return $ MemPrim bt
+ (Acc acc ispace ts u, _) ->
+ return $ MemAcc acc ispace ts u
+ (Prim pt, _) ->
+ return $ MemPrim pt
(Mem {}, _) ->
error "expReturns: loop returns memory block explicitly."
isMergeVar v = find ((== v) . paramName . snd) $ zip [0 ..] mergevars
@@ -1078,6 +1125,16 @@
return $ map bodyReturnsToExpReturns ret
expReturns (Op op) =
opReturns op
+expReturns (WithAcc inputs lam) =
+ (<>)
+ <$> (concat <$> mapM inputReturns inputs)
+ <*>
+ -- XXX: this is a bit dubious because it enforces extra copies. I
+ -- think WithAcc should perhaps have a return annotation like If.
+ pure (extReturns $ staticShapes $ drop num_accs $ lambdaReturnType lam)
+ where
+ inputReturns (_, arrs, _) = mapM varReturns arrs
+ num_accs = length inputs
sliceInfo ::
(Monad m, HasScope lore m, Mem lore) =>
@@ -1132,6 +1189,8 @@
correctDims (MemArray et shape u memsummary) =
MemArray et (correctShape shape) u $
correctSummary memsummary
+ correctDims (MemAcc acc ispace ts u) =
+ MemAcc acc ispace ts u
correctShape = Shape . map correctDim . shapeDims
correctDim (Ext i) = Ext i
diff --git a/src/Futhark/IR/Mem/IxFun.hs b/src/Futhark/IR/Mem/IxFun.hs
--- a/src/Futhark/IR/Mem/IxFun.hs
+++ b/src/Futhark/IR/Mem/IxFun.hs
@@ -156,7 +156,7 @@
semisep
[ "base: " <> brackets (commasep $ map ppr oshp),
"contiguous: " <> if cg then "true" else "false",
- "LMADs: " <> brackets (commasep $ NE.toList $ NE.map ppr lmads)
+ "LMADs: " <> brackets (commastack $ NE.toList $ NE.map ppr lmads)
]
instance Substitute num => Substitute (LMAD num) where
@@ -384,24 +384,15 @@
return $ IxFun (setLMADPermutation perm' lmad' :| lmads) oshp cg'
where
- updatePerm ps inds = foldl (\acc p -> acc ++ decrease p) [] ps
+ updatePerm ps inds = concatMap decrease ps
where
decrease p =
- let d =
- foldl
- ( \n i ->
- if i == p
- then -1
- else
- if i > p
- then n
- else
- if n /= -1
- then n + 1
- else n
- )
- 0
- inds
+ let f n i
+ | i == p = -1
+ | i > p = n
+ | n /= -1 = n + 1
+ | otherwise = n
+ d = foldl f 0 inds
in [p - d | d /= -1]
harmlessRotation' ::
@@ -993,18 +984,6 @@
stride' <- existentializeExp str
shape' <- existentializeExp shp
return $ LMADDim stride' (fmap Free rot) shape' perm mon
-
--- oshp' = LeafExp (Ext 0)
--- lmad' = LMAD lmadOffset' lmadDims'
--- lmadOffset' = LeafExp (Ext 1)
--- (_, lmadDims', lmadDimSubsts) = foldr generalizeDim (2, [], []) $ lmadDims lmad
--- substs = oshp : lmadOffset lmad' : lmadDimSubsts
-
--- generalizeDim :: (Int, [LMADDim num]) -> LMADDim num -> (Int, [LMADDim num])
--- generalizeDim (i, acc) (LMADDim stride rotate shape perm mon) =
--- (i + 3,
--- LMADDim (LeafExp $ Ext i) (LeafExp $ Ext $ i + 1) (LeafExp $ Ext $ i + 2) perm mon,
--- [stride, rotate, shape])
existentialize _ = return Nothing
-- | When comparing index functions as part of the type check in KernelsMem,
diff --git a/src/Futhark/IR/Mem/Simplify.hs b/src/Futhark/IR/Mem/Simplify.hs
--- a/src/Futhark/IR/Mem/Simplify.hs
+++ b/src/Futhark/IR/Mem/Simplify.hs
@@ -137,10 +137,9 @@
-- Update the branches to contain Copy expressions putting the
-- arrays where they are expected.
- let updateBody body = insertStmsM $ do
+ let updateBody body = buildBody_ $ do
res <- bodyBind body
- resultBodyM
- =<< zipWithM updateResult (patternElements pat) res
+ zipWithM updateResult (patternElements pat) res
updateResult pat_elem (Var v)
| Just mem <- lookup (patElemName pat_elem) arr_to_mem,
(_, MemArray pt shape u (ArrayIn _ ixfun)) <- patElemDec pat_elem = do
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
@@ -85,8 +85,19 @@
pAsterisk = void $ lexeme "*"
pArrow = void $ lexeme "->"
-pNonArray :: Parser (TypeBase shape u)
-pNonArray = Prim <$> pPrimType
+pNonArray :: Parser (TypeBase shape NoUniqueness)
+pNonArray =
+ choice
+ [ Prim <$> pPrimType,
+ "acc"
+ *> parens
+ ( Acc
+ <$> pVName <* pComma
+ <*> pShape <* pComma
+ <*> pTypes
+ <*> pure NoUniqueness
+ )
+ ]
pTypeBase ::
ArrayShape shape =>
@@ -140,6 +151,12 @@
pSubExp :: Parser SubExp
pSubExp = Var <$> pVName <|> Constant <$> pPrimValue
+pSubExps :: Parser [SubExp]
+pSubExps = braces (pSubExp `sepBy` pComma)
+
+pVNames :: Parser [VName]
+pVNames = braces (pVName `sepBy` pComma)
+
pPatternLike :: Parser a -> Parser ([a], [a])
pPatternLike p = braces $ do
xs <- p `sepBy` pComma
@@ -273,6 +290,9 @@
ArrayLit
<$> brackets (pSubExp `sepBy` pComma)
<*> (lexeme ":" *> "[]" *> pType),
+ keyword "update_acc"
+ *> parens
+ (UpdateAcc <$> pVName <* pComma <*> pSubExps <* pComma <*> pSubExps),
--
pConvOp "sext" SExt pIntType pIntType,
pConvOp "zext" ZExt pIntType pIntType,
@@ -440,12 +460,27 @@
<$> pLambda pr <* pComma
<*> braces (pSubExp `sepBy` pComma)
+pWithAcc :: PR lore -> Parser (Exp lore)
+pWithAcc pr =
+ keyword "with_acc"
+ *> parens (WithAcc <$> braces (pInput `sepBy` pComma) <* pComma <*> pLambda pr)
+ where
+ pInput =
+ parens
+ ( (,,)
+ <$> pShape <* pComma
+ <*> pVNames
+ <*> optional (pComma *> pCombFun)
+ )
+ pCombFun = parens ((,) <$> pLambda pr <* pComma <*> pSubExps)
+
pExp :: PR lore -> Parser (Exp lore)
pExp pr =
choice
[ pIf pr,
pApply pr,
pLoop pr,
+ pWithAcc pr,
Op <$> pOp pr,
BasicOp <$> pBasicOp
]
@@ -827,14 +862,24 @@
choice
[ MemPrim <$> pPrimType,
keyword "mem" $> MemMem <*> choice [pSpace, pure DefaultSpace],
- pArray
+ pArrayOrAcc
]
where
- pArray = do
+ pArrayOrAcc = do
u <- pu
shape <- Shape <$> many (brackets pd)
+ choice [pArray u shape, pAcc u]
+ pArray u shape = do
pt <- pPrimType
MemArray pt shape u <$> (lexeme "@" *> pret)
+ pAcc u =
+ keyword "acc"
+ *> parens
+ ( MemAcc <$> pVName <* pComma
+ <*> pShape <* pComma
+ <*> pTypes
+ <*> pure u
+ )
pSpace :: Parser Space
pSpace =
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
@@ -36,9 +36,6 @@
ppExpLore :: ExpDec lore -> Exp lore -> Maybe Doc
ppExpLore _ _ = Nothing
-commastack :: [Doc] -> Doc
-commastack = align . stack . punctuate comma
-
instance Pretty VName where
ppr (VName vn i) = ppr vn <> text "_" <> text (show i)
@@ -65,19 +62,25 @@
ppr (ScalarSpace d t) = text "@" <> mconcat (map (brackets . ppr) d) <> ppr t
instance Pretty u => Pretty (TypeBase Shape u) where
- ppr (Prim et) = ppr et
+ ppr (Prim t) = ppr t
+ ppr (Acc acc ispace ts u) =
+ ppr u <> text "acc" <> apply [ppr acc, ppr ispace, ppTuple' ts]
ppr (Array et (Shape ds) u) =
ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et
ppr (Mem s) = text "mem" <> ppr s
instance Pretty u => Pretty (TypeBase ExtShape u) where
- ppr (Prim et) = ppr et
+ ppr (Prim t) = ppr t
+ ppr (Acc acc ispace ts u) =
+ ppr u <> text "acc" <> apply [ppr acc, ppr ispace, ppTuple' ts]
ppr (Array et (Shape ds) u) =
ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et
ppr (Mem s) = text "mem" <> ppr s
instance Pretty u => Pretty (TypeBase Rank u) where
- ppr (Prim et) = ppr et
+ ppr (Prim t) = ppr t
+ ppr (Acc acc ispace ts u) =
+ ppr u <> text "acc" <> apply [ppr acc, ppr ispace, ppTuple' ts]
ppr (Array et (Rank n) u) =
ppr u <> mconcat (replicate n $ brackets mempty) <> ppr et
ppr (Mem s) = text "mem" <> ppr s
@@ -197,6 +200,8 @@
ppr (Manifest perm e) = text "manifest" <> apply [apply (map ppr perm), ppr e]
ppr (Assert e msg (loc, _)) =
text "assert" <> apply [ppr e, ppr msg, text $ show $ locStr loc]
+ ppr (UpdateAcc acc is v) =
+ text "update_acc" <> apply [ppr acc, ppTuple' is, ppTuple' v]
instance Pretty a => Pretty (ErrorMsg a) where
ppr (ErrorMsg parts) = braces $ align $ commasep $ map p parts
@@ -266,6 +271,18 @@
(ctxparams, ctxinit) = unzip ctx
(valparams, valinit) = unzip val
pprLoopVar (p, a) = ppr p <+> text "in" <+> ppr a
+ ppr (WithAcc inputs lam) =
+ text "with_acc"
+ <> parens (braces (commasep $ map ppInput inputs) <> comma ppr lam)
+ where
+ ppInput (shape, arrs, op) =
+ parens
+ ( ppr shape <> comma <+> ppTuple' arrs
+ <> case op of
+ Nothing -> mempty
+ Just (op', nes) ->
+ comma parens (ppr op' <> comma ppTuple' (map ppr nes))
+ )
instance PrettyLore lore => Pretty (Lambda lore) where
ppr (Lambda [] (Body _ stms []) []) | stms == mempty = text "nilFn"
@@ -307,8 +324,8 @@
ppr (DimSlice i n s) = ppr i <+> text ":+" <+> ppr n <+> text "*" <+> ppr s
ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc
-ppPattern [] bs = braces $ commasep $ map ppr bs
-ppPattern as bs = braces $ commasep (map ppr as) <> semi commasep (map ppr bs)
+ppPattern [] bs = braces $ commastack $ map ppr bs
+ppPattern as bs = braces $ commastack (map ppr as) <> semi commasep (map ppr bs)
-- | Like 'prettyTuple', but produces a 'Doc'.
ppTuple' :: Pretty a => [a] -> Doc
diff --git a/src/Futhark/IR/Primitive.hs b/src/Futhark/IR/Primitive.hs
--- a/src/Futhark/IR/Primitive.hs
+++ b/src/Futhark/IR/Primitive.hs
@@ -69,6 +69,7 @@
doSIToFP,
intToInt64,
intToWord64,
+ flipConvOp,
-- * Comparison Operations
doCmpOp,
@@ -169,7 +170,8 @@
= IntType IntType
| FloatType FloatType
| Bool
- | Cert
+ | -- | An informationless type - still takes up space!
+ Unit
deriving (Eq, Ord, Show)
instance Enum PrimType where
@@ -180,7 +182,7 @@
toEnum 4 = FloatType Float32
toEnum 5 = FloatType Float64
toEnum 6 = Bool
- toEnum _ = Cert
+ toEnum _ = Unit
fromEnum (IntType Int8) = 0
fromEnum (IntType Int16) = 1
@@ -189,24 +191,24 @@
fromEnum (FloatType Float32) = 4
fromEnum (FloatType Float64) = 5
fromEnum Bool = 6
- fromEnum Cert = 7
+ fromEnum Unit = 7
instance Bounded PrimType where
minBound = IntType Int8
- maxBound = Cert
+ maxBound = Unit
instance Pretty PrimType where
ppr (IntType t) = ppr t
ppr (FloatType t) = ppr t
ppr Bool = text "bool"
- ppr Cert = text "cert"
+ ppr Unit = text "unit"
-- | A list of all primitive types.
allPrimTypes :: [PrimType]
allPrimTypes =
map IntType allIntTypes
++ map FloatType allFloatTypes
- ++ [Bool, Cert]
+ ++ [Bool, Unit]
-- | An integer value.
data IntValue
@@ -297,8 +299,8 @@
= IntValue !IntValue
| FloatValue !FloatValue
| BoolValue !Bool
- | -- | The only value of type @cert@.
- Checked
+ | -- | The only value of type 'Unit'.
+ UnitValue
deriving (Eq, Ord, Show)
instance Pretty PrimValue where
@@ -306,14 +308,14 @@
ppr (BoolValue True) = text "true"
ppr (BoolValue False) = text "false"
ppr (FloatValue v) = ppr v
- ppr Checked = text "checked"
+ ppr UnitValue = text "()"
-- | The type of a basic value.
primValueType :: PrimValue -> PrimType
primValueType (IntValue v) = IntType $ intValueType v
primValueType (FloatValue v) = FloatType $ floatValueType v
primValueType BoolValue {} = Bool
-primValueType Checked = Cert
+primValueType UnitValue = Unit
-- | A "blank" value of the given primitive type - this is zero, or
-- whatever is close to it. Don't depend on this value, but use it
@@ -326,7 +328,7 @@
blankPrimValue (FloatType Float32) = FloatValue $ Float32Value 0.0
blankPrimValue (FloatType Float64) = FloatValue $ Float64Value 0.0
blankPrimValue Bool = BoolValue False
-blankPrimValue Cert = Checked
+blankPrimValue Unit = UnitValue
-- | Various unary operators. It is a bit ad-hoc what is a unary
-- operator and what is a built-in function. Perhaps these should all
@@ -851,6 +853,20 @@
doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0 :: Int
doConvOp _ _ = Nothing
+-- | Turn the conversion the other way around. Note that most
+-- conversions are lossy, so there is no guarantee the value will
+-- round-trip.
+flipConvOp :: ConvOp -> ConvOp
+flipConvOp (ZExt from to) = ZExt to from
+flipConvOp (SExt from to) = SExt to from
+flipConvOp (FPConv from to) = FPConv to from
+flipConvOp (FPToUI from to) = UIToFP to from
+flipConvOp (FPToSI from to) = SIToFP to from
+flipConvOp (UIToFP from to) = FPToSI to from
+flipConvOp (SIToFP from to) = FPToSI to from
+flipConvOp (IToB from) = BToI from
+flipConvOp (BToI to) = IToB to
+
-- | Zero-extend the given integer value to the size of the given
-- type. If the type is smaller than the given value, the result is a
-- truncation.
@@ -1208,6 +1224,24 @@
_ -> Nothing
)
),
+ ( "hypot32",
+ ( [FloatType Float32, FloatType Float32],
+ FloatType Float32,
+ \case
+ [FloatValue (Float32Value x), FloatValue (Float32Value y)] ->
+ Just $ FloatValue $ Float32Value $ sqrt (x * x + y * y)
+ _ -> Nothing
+ )
+ ),
+ ( "hypot64",
+ ( [FloatType Float64, FloatType Float64],
+ FloatType Float64,
+ \case
+ [FloatValue (Float64Value x), FloatValue (Float64Value y)] ->
+ Just $ FloatValue $ Float64Value $ sqrt (x * x + y * y)
+ _ -> Nothing
+ )
+ ),
( "isinf32",
( [FloatType Float32],
Bool,
@@ -1369,7 +1403,7 @@
negativeIsh (FloatValue (Float32Value k)) = k < 0
negativeIsh (FloatValue (Float64Value k)) = k < 0
negativeIsh (BoolValue _) = False
-negativeIsh Checked = False
+negativeIsh UnitValue = False
-- | Is the given integer value kind of zero?
zeroIshInt :: IntValue -> Bool
@@ -1401,7 +1435,7 @@
primByteSize (IntType t) = intByteSize t
primByteSize (FloatType t) = floatByteSize t
primByteSize Bool = 1
-primByteSize Cert = 1
+primByteSize Unit = 0
-- | The size of a value of a given integer type in eight-bit bytes.
intByteSize :: Num a => IntType -> a
diff --git a/src/Futhark/IR/Primitive/Parse.hs b/src/Futhark/IR/Primitive/Parse.hs
--- a/src/Futhark/IR/Primitive/Parse.hs
+++ b/src/Futhark/IR/Primitive/Parse.hs
@@ -74,7 +74,8 @@
choice
[ FloatValue <$> pFloatValue,
IntValue <$> pIntValue,
- BoolValue <$> pBoolValue
+ BoolValue <$> pBoolValue,
+ UnitValue <$ "()"
]
"primitive value"
@@ -90,6 +91,6 @@
pPrimType :: Parser PrimType
pPrimType =
- choice [p Bool, p Cert, FloatType <$> pFloatType, IntType <$> pIntType]
+ choice [p Bool, p Unit, FloatType <$> pFloatType, IntType <$> pIntType]
where
p t = keyword (prettyText t) $> t
diff --git a/src/Futhark/IR/Prop.hs b/src/Futhark/IR/Prop.hs
--- a/src/Futhark/IR/Prop.hs
+++ b/src/Futhark/IR/Prop.hs
@@ -128,6 +128,7 @@
safeExp (If _ tbranch fbranch _) =
all (safeExp . stmExp) (bodyStms tbranch)
&& all (safeExp . stmExp) (bodyStms fbranch)
+safeExp WithAcc {} = True -- Although unlikely to matter.
safeExp (Op op) = safeOp op
safeBody :: IsOp (Op lore) => Body lore -> Bool
diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs
--- a/src/Futhark/IR/Prop/Aliases.hs
+++ b/src/Futhark/IR/Prop/Aliases.hs
@@ -82,6 +82,7 @@
basicOpAliases Copy {} = [mempty]
basicOpAliases Manifest {} = [mempty]
basicOpAliases Assert {} = [mempty]
+basicOpAliases UpdateAcc {} = [mempty]
ifAliases :: ([Names], Names) -> ([Names], Names) -> [Names]
ifAliases (als1, cons1) (als2, cons2) =
@@ -112,6 +113,11 @@
merge_names = namesFromList $ map (paramName . fst) $ ctxmerge ++ valmerge
expAliases (Apply _ args t _) =
funcallAliases args $ map declExtTypeOf t
+expAliases (WithAcc inputs lam) =
+ concatMap inputAliases inputs ++ drop num_accs (bodyAliases (lambdaBody lam))
+ where
+ inputAliases (_, arrs, _) = replicate (length arrs) mempty
+ num_accs = length inputs
expAliases (Op op) = opAliases op
returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names]
@@ -123,6 +129,8 @@
mempty
returnType' (Prim _) =
mempty
+ returnType' Acc {} =
+ error "returnAliases Acc"
returnType' Mem {} =
error "returnAliases Mem"
@@ -144,14 +152,30 @@
consumeArg _ = mempty
consumedInExp (If _ tb fb _) =
consumedInBody tb <> consumedInBody fb
-consumedInExp (DoLoop _ merge _ _) =
+consumedInExp (DoLoop _ merge form body) =
mconcat
( map (subExpAliases . snd) $
filter (unique . paramDeclType . fst) merge
)
+ <> consumedInForm form
+ where
+ body_consumed = consumedInBody body
+ varConsumed = (`nameIn` body_consumed) . paramName . fst
+ consumedInForm (ForLoop _ _ _ loopvars) =
+ namesFromList $ map snd $ filter varConsumed loopvars
+ consumedInForm WhileLoop {} =
+ mempty
+consumedInExp (WithAcc inputs lam) =
+ mconcat (map inputConsumed inputs)
+ <> ( consumedByLambda lam
+ `namesSubtract` namesFromList (map paramName (lambdaParams lam))
+ )
+ where
+ inputConsumed (_, arrs, _) = namesFromList arrs
consumedInExp (BasicOp (Update src _ _)) = oneName src
+consumedInExp (BasicOp (UpdateAcc acc _ _)) = oneName acc
+consumedInExp (BasicOp _) = mempty
consumedInExp (Op op) = consumedInOp op
-consumedInExp _ = mempty
-- | The variables consumed by this lambda.
consumedByLambda :: Aliased lore => Lambda lore -> Names
@@ -176,7 +200,8 @@
lookupAliases :: AliasesOf (LetDec lore) => VName -> Scope lore -> Names
lookupAliases v scope =
case M.lookup v scope of
- Just (LetName dec) -> oneName v <> aliasesOf dec
+ Just (LetName dec) ->
+ oneName v <> foldMap (`lookupAliases` scope) (namesToList (aliasesOf dec))
_ -> oneName v
-- | The class of operations that can produce aliasing and consumption
diff --git a/src/Futhark/IR/Prop/Names.hs b/src/Futhark/IR/Prop/Names.hs
--- a/src/Futhark/IR/Prop/Names.hs
+++ b/src/Futhark/IR/Prop/Names.hs
@@ -137,17 +137,23 @@
FreeIn (FParamInfo lore),
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
Walker lore (State FV)
freeWalker =
- identityWalker
+ Walker
{ walkOnSubExp = modify . (<>) . freeIn',
walkOnBody = \scope body -> do
modify $ (<>) $ freeIn' body
modify $ fvBind (namesFromList (M.keys scope)),
walkOnVName = modify . (<>) . fvName,
- walkOnOp = modify . (<>) . freeIn'
+ walkOnOp = modify . (<>) . freeIn',
+ walkOnFParam = modify . (<>) . freeIn',
+ walkOnLParam = modify . (<>) . freeIn',
+ walkOnRetType = modify . (<>) . freeIn',
+ walkOnBranchType = modify . (<>) . freeIn'
}
-- | Return the set of variable names that are free in the given
@@ -159,6 +165,8 @@
FreeIn (LParamInfo lore),
FreeIn (FParamInfo lore),
FreeDec (BodyDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeDec (ExpDec lore)
) =>
Stms lore ->
@@ -192,6 +200,9 @@
instance (FreeIn a, FreeIn b, FreeIn c) => FreeIn (a, b, c) where
freeIn' (a, b, c) = freeIn' a <> freeIn' b <> freeIn' c
+instance (FreeIn a, FreeIn b, FreeIn c, FreeIn d) => FreeIn (a, b, c, d) where
+ freeIn' (a, b, c, d) = freeIn' a <> freeIn' b <> freeIn' c <> freeIn' d
+
instance FreeIn a => FreeIn [a] where
freeIn' = foldMap freeIn'
@@ -202,6 +213,7 @@
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
FreeIn (FunDef lore)
@@ -216,6 +228,8 @@
FreeIn (FParamInfo lore),
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
FreeIn (Lambda lore)
@@ -230,6 +244,8 @@
FreeIn (FParamInfo lore),
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
FreeIn (Body lore)
@@ -243,6 +259,8 @@
FreeIn (FParamInfo lore),
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
FreeIn (Exp lore)
@@ -259,6 +277,8 @@
freeIn' (ctxinits ++ valinits) <> freeIn' form
<> freeIn' (ctxparams ++ valparams)
<> freeIn' loopbody
+ freeIn' (WithAcc inputs lam) =
+ freeIn' inputs <> freeIn' lam
freeIn' e = execState (walkExpM freeWalker e) mempty
instance
@@ -267,6 +287,8 @@
FreeIn (FParamInfo lore),
FreeIn (LParamInfo lore),
FreeIn (LetDec lore),
+ FreeIn (RetType lore),
+ FreeIn (BranchType lore),
FreeIn (Op lore)
) =>
FreeIn (Stm lore)
@@ -309,10 +331,14 @@
freeIn' (Free x) = freeIn' x
freeIn' (Ext _) = mempty
+instance FreeIn PrimType where
+ freeIn' _ = mempty
+
instance FreeIn shape => FreeIn (TypeBase shape u) where
- freeIn' (Array _ shape _) = freeIn' shape
+ freeIn' (Array t shape _) = freeIn' t <> freeIn' shape
freeIn' (Mem s) = freeIn' s
- freeIn' (Prim _) = mempty
+ freeIn' Prim {} = mempty
+ freeIn' (Acc acc ispace ts _) = freeIn' (acc, ispace, ts)
instance FreeIn dec => FreeIn (Param dec) where
freeIn' (Param _ dec) = freeIn' dec
diff --git a/src/Futhark/IR/Prop/TypeOf.hs b/src/Futhark/IR/Prop/TypeOf.hs
--- a/src/Futhark/IR/Prop/TypeOf.hs
+++ b/src/Futhark/IR/Prop/TypeOf.hs
@@ -115,7 +115,9 @@
primOpType (Manifest _ v) =
pure <$> lookupType v
primOpType Assert {} =
- pure [Prim Cert]
+ pure [Prim Unit]
+primOpType (UpdateAcc v _ _) =
+ pure <$> lookupType v
-- | The type of an expression.
expExtType ::
@@ -127,6 +129,14 @@
expExtType (DoLoop ctxmerge valmerge _ _) =
pure $ loopExtType (map (paramIdent . fst) ctxmerge) (map (paramIdent . fst) valmerge)
expExtType (BasicOp op) = staticShapes <$> primOpType op
+expExtType (WithAcc inputs lam) =
+ fmap staticShapes $
+ (<>)
+ <$> (concat <$> traverse inputType inputs)
+ <*> pure (drop num_accs (lambdaReturnType lam))
+ where
+ inputType (_, arrs, _) = traverse lookupType arrs
+ num_accs = length inputs
expExtType (Op op) = opType op
-- | The number of values returned by an expression.
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
@@ -28,8 +28,8 @@
shapeSize,
arraySize,
arraysSize,
- rowType,
elemType,
+ rowType,
transposeType,
rearrangeType,
mapOnExtType,
@@ -78,7 +78,8 @@
-- | Remove shape information from a type.
rankShaped :: ArrayShape shape => TypeBase shape u -> TypeBase Rank u
rankShaped (Array et sz u) = Array et (Rank $ shapeRank sz) u
-rankShaped (Prim et) = Prim et
+rankShaped (Prim pt) = Prim pt
+rankShaped (Acc acc ispace ts u) = Acc acc ispace ts u
rankShaped (Mem space) = Mem space
-- | Return the dimensionality of a type. For non-arrays, this is
@@ -105,6 +106,7 @@
where
ds' = f ds
modifyArrayShape _ (Prim t) = Prim t
+modifyArrayShape _ (Acc acc ispace ts u) = Acc acc ispace ts u
modifyArrayShape _ (Mem space) = Mem space
-- | Set the shape of an array. If the given type is not an
@@ -126,6 +128,7 @@
-- | Return the uniqueness of a type.
uniqueness :: TypeBase shape Uniqueness -> Uniqueness
uniqueness (Array _ _ u) = u
+uniqueness (Acc _ _ _ u) = u
uniqueness _ = Nonunique
-- | @unique t@ is 'True' if the type of the argument is unique.
@@ -140,8 +143,10 @@
-- | As 'staticShapes', but on a single type.
staticShapes1 :: TypeBase Shape u -> TypeBase ExtShape u
-staticShapes1 (Prim bt) =
- Prim bt
+staticShapes1 (Prim t) =
+ Prim t
+staticShapes1 (Acc acc ispace ts u) =
+ Acc acc ispace ts u
staticShapes1 (Array bt (Shape shape) u) =
Array bt (Shape $ map Free shape) u
staticShapes1 (Mem space) =
@@ -163,10 +168,11 @@
TypeBase shape u
arrayOf (Array et size1 _) size2 u =
Array et (size2 <> size1) u
-arrayOf (Prim et) s _
- | 0 <- shapeRank s = Prim et
-arrayOf (Prim et) size u =
- Array et size u
+arrayOf (Prim t) shape u
+ | 0 <- shapeRank shape = Prim t
+ | otherwise = Array t shape u
+arrayOf (Acc acc ispace ts _) _shape u =
+ Acc acc ispace ts u
arrayOf Mem {} _ _ =
error "arrayOf Mem"
@@ -277,15 +283,15 @@
-- | A type is a primitive type if it is not an array or memory block.
primType :: TypeBase shape u -> Bool
-primType Array {} = False
-primType Mem {} = False
-primType _ = True
+primType Prim {} = True
+primType _ = False
--- | Returns the bottommost type of an array. For @[[int]]@, this
--- would be @int@. If the given type is not an array, it is returned.
+-- | Returns the bottommost type of an array. For @[][]i32@, this
+-- would be @i32@. If the given type is not an array, it is returned.
elemType :: TypeBase shape u -> PrimType
elemType (Array t _ _) = t
elemType (Prim t) = t
+elemType Acc {} = error "Acc"
elemType Mem {} = error "elemType Mem"
-- | Swap the two outer dimensions of the type.
@@ -309,10 +315,20 @@
m (TypeBase ExtShape u)
mapOnExtType _ (Prim bt) =
return $ Prim bt
+mapOnExtType f (Acc acc ispace ts u) =
+ Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts <*> pure u
+ where
+ f' v = do
+ x <- f $ Var v
+ case x of
+ Var v' -> pure v'
+ Constant {} -> pure v
mapOnExtType _ (Mem space) =
pure $ Mem space
mapOnExtType f (Array t shape u) =
- Array t <$> (Shape <$> mapM (traverse f) (shapeDims shape)) <*> pure u
+ Array t
+ <$> (Shape <$> mapM (traverse f) (shapeDims shape))
+ <*> pure u
-- | Transform any t'SubExp's in the type.
mapOnType ::
@@ -321,14 +337,26 @@
TypeBase Shape u ->
m (TypeBase Shape u)
mapOnType _ (Prim bt) = return $ Prim bt
+mapOnType f (Acc acc ispace ts u) =
+ Acc <$> f' acc <*> traverse f ispace <*> mapM (mapOnType f) ts <*> pure u
+ where
+ f' v = do
+ x <- f $ Var v
+ case x of
+ Var v' -> pure v'
+ Constant {} -> pure v
mapOnType _ (Mem space) = pure $ Mem space
mapOnType f (Array t shape u) =
- Array t <$> (Shape <$> mapM f (shapeDims shape)) <*> pure u
+ Array t
+ <$> (Shape <$> mapM f (shapeDims shape))
+ <*> pure u
-- | @diet t@ returns a description of how a function parameter of
-- type @t@ might consume its argument.
diet :: TypeBase shape Uniqueness -> Diet
-diet (Prim _) = ObservePrim
+diet Prim {} = ObservePrim
+diet (Acc _ _ _ Unique) = Consume
+diet (Acc _ _ _ Nonunique) = Observe
diet (Array _ _ Unique) = Consume
diet (Array _ _ Nonunique) = Observe
diet Mem {} = Observe
@@ -344,9 +372,7 @@
u2 <= u1
&& t1 == t2
&& shape1 `subShapeOf` shape2
-subtypeOf (Prim t1) (Prim t2) = t1 == t2
-subtypeOf (Mem space1) (Mem space2) = space1 == space2
-subtypeOf _ _ = False
+subtypeOf t1 t2 = t1 == t2
-- | @xs \`subtypesOf\` ys@ is true if @xs@ is the same size as @ys@,
-- and each element in @xs@ is a subtype of the corresponding element
@@ -365,7 +391,8 @@
TypeBase shape NoUniqueness ->
Uniqueness ->
TypeBase shape Uniqueness
-toDecl (Prim bt) _ = Prim bt
+toDecl (Prim t) _ = Prim t
+toDecl (Acc acc ispace ts _) u = Acc acc ispace ts u
toDecl (Array et shape _) u = Array et shape u
toDecl (Mem space) _ = Mem space
@@ -373,7 +400,8 @@
fromDecl ::
TypeBase shape Uniqueness ->
TypeBase shape NoUniqueness
-fromDecl (Prim bt) = Prim bt
+fromDecl (Prim t) = Prim t
+fromDecl (Acc acc ispace ts _) = Acc acc ispace ts NoUniqueness
fromDecl (Array et shape _) = Array et shape NoUniqueness
fromDecl (Mem space) = Mem space
@@ -420,6 +448,7 @@
-- change to the corresponding t'Shape'.
hasStaticShape :: TypeBase ExtShape u -> Maybe (TypeBase Shape u)
hasStaticShape (Prim bt) = Just $ Prim bt
+hasStaticShape (Acc acc ispace ts u) = Just $ Acc acc ispace ts u
hasStaticShape (Mem space) = Just $ Mem space
hasStaticShape (Array bt (Shape shape) u) =
Array bt <$> (Shape <$> mapM isFree shape) <*> pure u
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
@@ -576,7 +576,8 @@
cheapOp _ = True
substNamesInType :: M.Map VName SubExp -> Type -> Type
-substNamesInType _ tp@(Prim _) = tp
+substNamesInType _ t@Prim {} = t
+substNamesInType _ t@Acc {} = t
substNamesInType _ (Mem space) = Mem space
substNamesInType subs (Array btp shp u) =
let shp' = Shape $ map (substNamesInSubExp subs) (shapeDims shp)
@@ -762,7 +763,7 @@
typeCheckSOAC (Screma w arrs (ScremaForm scans reds map_lam)) = do
TC.require [Prim int64] w
arrs' <- TC.checkSOACArrayArgs w arrs
- TC.checkLambda map_lam $ map TC.noArgAliases arrs'
+ TC.checkLambda map_lam arrs'
scan_nes' <- fmap concat $
forM scans $ \(Scan scan_lam scan_nes) -> do
diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs
--- a/src/Futhark/IR/SOACS/Simplify.hs
+++ b/src/Futhark/IR/SOACS/Simplify.hs
@@ -714,6 +714,7 @@
= ArrayIndexing Certificates VName (Slice SubExp)
| ArrayRearrange Certificates VName [Int]
| ArrayRotate Certificates VName [SubExp]
+ | ArrayCopy Certificates VName
| -- | Never constructed.
ArrayVar Certificates VName
deriving (Eq, Ord, Show)
@@ -722,12 +723,14 @@
arrayOpArr (ArrayIndexing _ arr _) = arr
arrayOpArr (ArrayRearrange _ arr _) = arr
arrayOpArr (ArrayRotate _ arr _) = arr
+arrayOpArr (ArrayCopy _ arr) = arr
arrayOpArr (ArrayVar _ arr) = arr
arrayOpCerts :: ArrayOp -> Certificates
arrayOpCerts (ArrayIndexing cs _ _) = cs
arrayOpCerts (ArrayRearrange cs _ _) = cs
arrayOpCerts (ArrayRotate cs _ _) = cs
+arrayOpCerts (ArrayCopy cs _) = cs
arrayOpCerts (ArrayVar cs _) = cs
isArrayOp :: Certificates -> AST.Exp (Wise SOACS) -> Maybe ArrayOp
@@ -737,6 +740,8 @@
Just $ ArrayRearrange cs arr perm
isArrayOp cs (BasicOp (Rotate rots arr)) =
Just $ ArrayRotate cs arr rots
+isArrayOp cs (BasicOp (Copy arr)) =
+ Just $ ArrayCopy cs arr
isArrayOp _ _ =
Nothing
@@ -744,6 +749,7 @@
fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice)
fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr)
fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr)
+fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Copy arr)
fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr)
arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pattern (Wise SOACS), ArrayOp)
@@ -905,6 +911,9 @@
arrayIsMapParam (_, ArrayRotate cs arr rots) =
arr `elem` map_param_names
&& all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn rots)
+ arrayIsMapParam (_, ArrayCopy cs arr) =
+ arr `elem` map_param_names
+ && all (`ST.elem` vtable) (namesToList $ freeIn cs)
arrayIsMapParam (_, ArrayVar {}) =
False
@@ -921,6 +930,8 @@
BasicOp $ Rearrange (0 : map (+ 1) perm) arr
ArrayRotate _ _ rots ->
BasicOp $ Rotate (intConst Int64 0 : rots) arr
+ ArrayCopy {} ->
+ BasicOp $ Copy arr
ArrayVar {} ->
BasicOp $ SubExp $ Var arr
arr_transformed_t <- lookupType arr_transformed
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
@@ -54,6 +54,7 @@
import Control.Monad.State.Strict
import Control.Monad.Writer hiding (mapM_)
import Data.Bifunctor (first)
+import Data.Bitraversable
import Data.List
( elemIndex,
foldl',
@@ -783,9 +784,14 @@
Type ->
m Type
mapOnSegOpType _tv t@Prim {} = pure t
-mapOnSegOpType tv (Array pt shape u) = Array pt <$> f shape <*> pure u
- where
- f (Shape dims) = Shape <$> mapM (mapOnSegOpSubExp tv) dims
+mapOnSegOpType tv (Acc acc ispace ts u) =
+ Acc
+ <$> mapOnSegOpVName tv acc
+ <*> traverse (mapOnSegOpSubExp tv) ispace
+ <*> traverse (bitraverse (traverse (mapOnSegOpSubExp tv)) pure) ts
+ <*> pure u
+mapOnSegOpType tv (Array et shape u) =
+ Array et <$> traverse (mapOnSegOpSubExp tv) shape <*> pure u
mapOnSegOpType _tv (Mem s) = pure $ Mem s
instance
diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs
--- a/src/Futhark/IR/Syntax.hs
+++ b/src/Futhark/IR/Syntax.hs
@@ -399,6 +399,9 @@
-- subexpressions specify how much each dimension is rotated. The
-- length of this list must be equal to the rank of the array.
Rotate [SubExp] VName
+ | -- | Update an accumulator at the given index with the given value.
+ -- Consumes the accumulator and produces a new one.
+ UpdateAcc VName [SubExp] [SubExp]
deriving (Eq, Ord, Show)
-- | The root Futhark expression type. The v'Op' constructor contains
@@ -412,6 +415,14 @@
| -- | @loop {a} = {v} (for i < n|while b) do b@. The merge
-- parameters are divided into context and value part.
DoLoop [(FParam lore, SubExp)] [(FParam lore, SubExp)] (LoopForm lore) (BodyT lore)
+ | -- | Create accumulators backed by the given arrays (which are
+ -- consumed) and pass them to the lambda, which must return the
+ -- updated accumulators and possibly some extra values. The
+ -- accumulators are turned back into arrays. The 'Shape' is the
+ -- write index space. The corresponding arrays must all have this
+ -- shape outermost. This construct is not part of 'BasicOp'
+ -- because we need the @lore@ parameter.
+ WithAcc [(Shape, [VName], Maybe (Lambda lore, [SubExp]))] (Lambda lore)
| Op (Op lore)
deriving instance Decorations lore => Eq (ExpT lore)
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
@@ -191,10 +191,18 @@
data NoUniqueness = NoUniqueness
deriving (Eq, Ord, Show)
--- | A Futhark type is either an array or an element type. When
--- comparing types for equality with '==', shapes must match.
+instance Semigroup NoUniqueness where
+ NoUniqueness <> NoUniqueness = NoUniqueness
+
+instance Monoid NoUniqueness where
+ mempty = NoUniqueness
+
+-- | The type of a value. When comparing types for equality with
+-- '==', shapes must match.
data TypeBase shape u
= Prim PrimType
+ | -- | Token, index space, element type, and uniqueness.
+ Acc VName Shape [Type] u
| Array PrimType shape u
| Mem Space
deriving (Show, Eq, Ord)
@@ -202,6 +210,7 @@
instance Bitraversable TypeBase where
bitraverse f g (Array t shape u) = Array t <$> f shape <*> g u
bitraverse _ _ (Prim pt) = pure $ Prim pt
+ bitraverse _ g (Acc arrs ispace ts u) = Acc arrs ispace ts <$> g u
bitraverse _ _ (Mem s) = pure $ Mem s
instance Bifunctor TypeBase where
diff --git a/src/Futhark/IR/Traversals.hs b/src/Futhark/IR/Traversals.hs
--- a/src/Futhark/IR/Traversals.hs
+++ b/src/Futhark/IR/Traversals.hs
@@ -37,8 +37,8 @@
import Control.Monad
import Control.Monad.Identity
+import Data.Bitraversable
import Data.Foldable (traverse_)
-import qualified Data.Traversable
import Futhark.IR.Prop.Scope
import Futhark.IR.Prop.Types (mapOnType)
import Futhark.IR.Syntax
@@ -123,7 +123,7 @@
mapExpM tv (BasicOp (Reshape shape arrexp)) =
BasicOp
<$> ( Reshape
- <$> mapM (Data.Traversable.traverse (mapOnSubExp tv)) shape
+ <$> mapM (traverse (mapOnSubExp tv)) shape
<*> mapOnVName tv arrexp
)
mapExpM tv (BasicOp (Rearrange perm e)) =
@@ -145,6 +145,19 @@
BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc)
mapExpM tv (BasicOp (Opaque e)) =
BasicOp <$> (Opaque <$> mapOnSubExp tv e)
+mapExpM tv (BasicOp (UpdateAcc v is ses)) =
+ BasicOp
+ <$> ( UpdateAcc
+ <$> mapOnVName tv v
+ <*> mapM (mapOnSubExp tv) is
+ <*> mapM (mapOnSubExp tv) ses
+ )
+mapExpM tv (WithAcc inputs lam) =
+ WithAcc <$> mapM onInput inputs <*> mapOnLambda tv lam
+ where
+ onInput (shape, vs, op) =
+ (,,) <$> mapOnShape tv shape <*> mapM (mapOnVName tv) vs
+ <*> traverse (bitraverse (mapOnLambda tv) (mapM (mapOnSubExp tv))) op
mapExpM tv (DoLoop ctxmerge valmerge form loopbody) = do
ctxparams' <- mapM (mapOnFParam tv) ctxparams
valparams' <- mapM (mapOnFParam tv) valparams
@@ -177,6 +190,17 @@
mapOnLoopForm tv (WhileLoop cond) =
WhileLoop <$> mapOnVName tv cond
+mapOnLambda ::
+ Monad m =>
+ Mapper flore tlore m ->
+ Lambda flore ->
+ m (Lambda tlore)
+mapOnLambda tv (Lambda params body ret) = do
+ params' <- mapM (mapOnLParam tv) params
+ Lambda params'
+ <$> mapOnBody tv (scopeOfLParams params') body
+ <*> mapM (mapOnType (mapOnSubExp tv)) ret
+
-- | Like 'mapExpM', but in the 'Identity' monad.
mapExp :: Mapper flore tlore Identity -> Exp flore -> Exp tlore
mapExp m = runIdentity . mapExpM m
@@ -214,6 +238,10 @@
walkOnType :: Monad m => Walker lore m -> Type -> m ()
walkOnType _ Prim {} = return ()
+walkOnType tv (Acc acc ispace ts _) = do
+ walkOnVName tv acc
+ traverse_ (walkOnSubExp tv) ispace
+ mapM_ (walkOnType tv) ts
walkOnType _ Mem {} = return ()
walkOnType tv (Array _ shape _) = walkOnShape tv shape
@@ -227,6 +255,12 @@
walkOnLoopForm tv (WhileLoop cond) =
walkOnVName tv cond
+walkOnLambda :: Monad m => Walker lore m -> Lambda lore -> m ()
+walkOnLambda tv (Lambda params body ret) = do
+ mapM_ (walkOnLParam tv) params
+ walkOnBody tv (scopeOfLParams params) body
+ mapM_ (walkOnType tv) ret
+
-- | As 'mapExpM', but do not construct a result AST.
walkExpM :: Monad m => Walker lore m -> Exp lore -> m ()
walkExpM tv (BasicOp (SubExp se)) =
@@ -276,6 +310,16 @@
walkOnSubExp tv e >> traverse_ (walkOnSubExp tv) msg
walkExpM tv (BasicOp (Opaque e)) =
walkOnSubExp tv e
+walkExpM tv (BasicOp (UpdateAcc v is ses)) = do
+ walkOnVName tv v
+ mapM_ (walkOnSubExp tv) is
+ mapM_ (walkOnSubExp tv) ses
+walkExpM tv (WithAcc inputs lam) = do
+ forM_ inputs $ \(shape, vs, op) -> do
+ walkOnShape tv shape
+ mapM_ (walkOnVName tv) vs
+ traverse_ (bitraverse (walkOnLambda tv) (mapM (walkOnSubExp tv))) op
+ walkOnLambda tv lam
walkExpM tv (DoLoop ctxmerge valmerge form loopbody) = do
mapM_ (walkOnFParam tv) ctxparams
mapM_ (walkOnFParam tv) valparams
diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs
--- a/src/Futhark/Internalise.hs
+++ b/src/Futhark/Internalise.hs
@@ -63,7 +63,7 @@
internaliseValBind :: E.ValBind -> InternaliseM ()
internaliseValBind fb@(E.ValBind entry fname retdecl (Info (rettype, _)) tparams params body _ attrs loc) = do
localConstsScope $
- bindingParams tparams params $ \shapeparams params' -> do
+ bindingFParams tparams params $ \shapeparams params' -> do
let shapenames = map I.paramName shapeparams
msg <- case retdecl of
@@ -73,14 +73,14 @@
<$> typeExpForError dt
Nothing -> return $ errorMsg ["Function return value does not match shape of declared return type."]
- ((rettype', body_res), body_stms) <- collectStms $ do
+ (body', rettype') <- buildBody $ do
body_res <- internaliseExp (baseString fname <> "_res") body
- rettype_bad <- internaliseReturnType rettype
+ rettype_bad <-
+ internaliseReturnType rettype =<< mapM subExpType body_res
let rettype' = zeroExts rettype_bad
- return (rettype', body_res)
- body' <-
- ensureResultExtShape msg loc (map I.fromDecl rettype') $
- mkBody body_stms body_res
+ body_res' <-
+ ensureResultExtShape msg loc (map I.fromDecl rettype') body_res
+ pure (body_res', rettype')
let all_params = shapeparams ++ concat params'
@@ -114,12 +114,12 @@
generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM ()
generateEntryPoint (E.EntryPoint e_paramts e_rettype) vb = localConstsScope $ do
let (E.ValBind _ ofname _ (Info (rettype, _)) tparams params _ _ attrs loc) = vb
- bindingParams tparams params $ \shapeparams params' -> do
+ bindingFParams tparams params $ \shapeparams params' -> do
entry_rettype <- internaliseEntryReturnType rettype
let entry' = entryPoint (zip e_paramts params') (e_rettype, entry_rettype)
args = map (I.Var . I.paramName) $ concat params'
- entry_body <- insertStmsM $ do
+ entry_body <- buildBody_ $ do
-- Special case the (rare) situation where the entry point is
-- not a function.
maybe_const <- lookupConst ofname
@@ -131,7 +131,7 @@
ctx <-
extractShapeContext (concat entry_rettype)
<$> mapM (fmap I.arrayDims . subExpType) vals
- resultBodyM (ctx ++ vals)
+ pure $ ctx ++ vals
addFunDef $
I.FunDef
@@ -196,7 +196,7 @@
internaliseBody :: String -> E.Exp -> InternaliseM Body
internaliseBody desc e =
- insertStmsM $ resultBody <$> internaliseExp (desc <> "_res") e
+ buildBody_ $ internaliseExp (desc <> "_res") e
bodyFromStms ::
InternaliseM (Result, a) ->
@@ -205,21 +205,8 @@
((res, a), stms) <- collectStms m
(,a) <$> mkBodyM stms res
-internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp]
-internaliseExp desc (E.Parens e _) =
- internaliseExp desc e
-internaliseExp desc (E.QualParens _ e _) =
- internaliseExp desc e
-internaliseExp desc (E.StringLit vs _) =
- fmap pure $
- letSubExp desc $
- I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8
-internaliseExp _ (E.Var (E.QualName _ name) _ _) = do
- subst <- lookupSubst name
- case subst of
- Just substs -> return substs
- Nothing -> pure [I.Var name]
-internaliseExp desc (E.Index e idxs (Info ret, Info retext) loc) = do
+internaliseAppExp :: String -> E.AppExp -> InternaliseM [I.SubExp]
+internaliseAppExp desc (E.Index e idxs loc) = do
vs <- internaliseExpToVars "indexed" e
dims <- case vs of
[] -> return [] -- Will this happen?
@@ -228,91 +215,8 @@
let index v = do
v_t <- lookupType v
return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'
- ses <- certifying cs $ letSubExps desc =<< mapM index vs
- bindExtSizes (E.toStruct ret) retext ses
- return ses
-
--- XXX: we map empty records and tuples to bools, because otherwise
--- arrays of unit will lose their sizes.
-internaliseExp _ (E.TupLit [] _) =
- return [constant True]
-internaliseExp _ (E.RecordLit [] _) =
- return [constant True]
-internaliseExp desc (E.TupLit es _) = concat <$> mapM (internaliseExp desc) es
-internaliseExp desc (E.RecordLit orig_fields _) =
- concatMap snd . sortFields . M.unions <$> mapM internaliseField orig_fields
- where
- internaliseField (E.RecordFieldExplicit name e _) =
- M.singleton name <$> internaliseExp desc e
- internaliseField (E.RecordFieldImplicit name t loc) =
- internaliseField $
- E.RecordFieldExplicit
- (baseName name)
- (E.Var (E.qualName name) t loc)
- loc
-internaliseExp desc (E.ArrayLit es (Info arr_t) loc)
- -- If this is a multidimensional array literal of primitives, we
- -- treat it specially by flattening it out followed by a reshape.
- -- This cuts down on the amount of statements that are produced, and
- -- thus allows us to efficiently handle huge array literals - a
- -- corner case, but an important one.
- | Just ((eshape, e') : es') <- mapM isArrayLiteral es,
- not $ null eshape,
- all ((eshape ==) . fst) es',
- Just basetype <- E.peelArray (length eshape) arr_t = do
- let flat_lit = E.ArrayLit (e' ++ concatMap snd es') (Info basetype) loc
- new_shape = length es : eshape
- flat_arrs <- internaliseExpToVars "flat_literal" flat_lit
- forM flat_arrs $ \flat_arr -> do
- flat_arr_t <- lookupType flat_arr
- let new_shape' =
- reshapeOuter
- (map (DimNew . intConst Int64 . toInteger) new_shape)
- 1
- $ I.arrayShape flat_arr_t
- letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr
- | otherwise = do
- es' <- mapM (internaliseExp "arr_elem") es
- arr_t_ext <- internaliseReturnType (E.toStruct arr_t)
-
- rowtypes <-
- case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of
- Just ts -> pure ts
- Nothing ->
- -- XXX: the monomorphiser may create single-element array
- -- literals with an unknown row type. In those cases we
- -- need to look at the types of the actual elements.
- -- Fixing this in the monomorphiser is a lot more tricky
- -- than just working around it here.
- case es' of
- [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t
- e' : _ -> mapM subExpType e'
-
- let arraylit ks rt = do
- ks' <-
- mapM
- ( ensureShape
- "shape of element differs from shape of first element"
- loc
- rt
- "elem_reshaped"
- )
- ks
- return $ I.BasicOp $ I.ArrayLit ks' rt
-
- letSubExps desc
- =<< if null es'
- then mapM (arraylit []) rowtypes
- else zipWithM arraylit (transpose es') rowtypes
- where
- isArrayLiteral :: E.Exp -> Maybe ([Int], [E.Exp])
- isArrayLiteral (E.ArrayLit inner_es _ _) = do
- (eshape, e) : inner_es' <- mapM isArrayLiteral inner_es
- guard $ all ((eshape ==) . fst) inner_es'
- return (length inner_es : eshape, e ++ concatMap snd inner_es')
- isArrayLiteral e =
- Just ([], [e])
-internaliseExp desc (E.Range start maybe_second end (Info ret, Info retext) loc) = do
+ certifying cs $ letSubExps desc =<< mapM index vs
+internaliseAppExp desc (E.Range start maybe_second end loc) = do
start' <- internaliseExp1 "range_start" start
end' <- internaliseExp1 "range_end" $ case end of
DownToExclusive e -> e
@@ -449,15 +353,11 @@
I.BasicOp $ I.BinOp (SDivUp Int64 I.Unsafe) distance pos_step
se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)
- bindExtSizes (E.toStruct ret) retext [se]
return [se]
-internaliseExp desc (E.Ascript e _ _) =
- internaliseExp desc e
-internaliseExp desc (E.Coerce e (TypeDecl dt (Info et)) (Info ret, Info retext) loc) = do
+internaliseAppExp desc (E.Coerce e (TypeDecl dt (Info et)) loc) = do
ses <- internaliseExp desc e
- ts <- internaliseReturnType et
+ ts <- internaliseReturnType et =<< mapM subExpType ses
dt' <- typeExpForError dt
- bindExtSizes (E.toStruct ret) retext ses
forM (zip ses ts) $ \(e', t') -> do
dims <- arrayDims <$> subExpType e'
let parts =
@@ -467,17 +367,9 @@
++ dt'
++ ["`."]
ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e'
-internaliseExp desc (E.Negate e _) = do
- e' <- internaliseExp1 "negate_arg" e
- et <- subExpType e'
- case et of
- I.Prim (I.IntType t) ->
- letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e'
- I.Prim (I.FloatType t) ->
- letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'
- _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"
-internaliseExp desc e@E.Apply {} = do
- (qfname, args, ret, retext) <- findFuncall e
+internaliseAppExp desc e@E.Apply {} = do
+ (qfname, args) <- findFuncall e
+
-- Argument evaluation is outermost-in so that any existential sizes
-- created by function applications can be brought into scope.
let fname = nameFromString $ pretty $ baseName $ qualLeaf qfname
@@ -485,38 +377,32 @@
arg_desc = nameToString fname ++ "_arg"
-- Some functions are magical (overloaded) and we handle that here.
- ses <-
- case () of
- -- Overloaded functions never take array arguments (except
- -- equality, but those cannot be existential), so we can safely
- -- ignore the existential dimensions.
- ()
- | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->
- internalise desc
- | baseTag (qualLeaf qfname) <= maxIntrinsicTag,
- Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do
- let tag ses = [(se, I.Observe) | se <- ses]
- args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)
- let args'' = concatMap tag args'
- letTupExp' desc $
- I.Apply
- fname
- args''
- [I.Prim rettype]
- (Safe, loc, [])
- | otherwise -> do
- args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)
- fst <$> funcall desc qfname args' loc
-
- bindExtSizes ret retext ses
- return ses
-internaliseExp desc (E.LetPat pat e body (Info ret, Info retext) _) = do
- ses <- internalisePat desc pat e body (internaliseExp desc)
- bindExtSizes (E.toStruct ret) retext ses
- return ses
-internaliseExp _ (E.LetFun ofname _ _ _ _) =
+ case () of
+ -- Overloaded functions never take array arguments (except
+ -- equality, but those cannot be existential), so we can safely
+ -- ignore the existential dimensions.
+ ()
+ | Just internalise <- isOverloadedFunction qfname (map fst args) loc ->
+ internalise desc
+ | baseTag (qualLeaf qfname) <= maxIntrinsicTag,
+ Just (rettype, _) <- M.lookup fname I.builtInFunctions -> do
+ let tag ses = [(se, I.Observe) | se <- ses]
+ args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)
+ let args'' = concatMap tag args'
+ letTupExp' desc $
+ I.Apply
+ fname
+ args''
+ [I.Prim rettype]
+ (Safe, loc, [])
+ | otherwise -> do
+ args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)
+ fst <$> funcall desc qfname args' loc
+internaliseAppExp desc (E.LetPat sizes pat e body _) =
+ internalisePat desc sizes pat e body (internaliseExp desc)
+internaliseAppExp _ (E.LetFun ofname _ _ _) =
error $ "Unexpected LetFun " ++ pretty ofname
-internaliseExp desc (E.DoLoop sparams mergepat mergeexp form loopbody (Info (ret, retext)) loc) = do
+internaliseAppExp desc (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do
ses <- internaliseExp "loop_init" mergeexp
((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <-
collectStms $ handleForm ses form
@@ -541,25 +427,19 @@
let merge = ctxmerge ++ valmerge
merge_ts = map (I.paramType . fst) merge
loopbody'' <-
- localScope (scopeOfFParams $ map fst merge) $
- inScopeOf form' $
- insertStmsM $
- resultBodyM
- =<< ensureArgShapes
- "shape of loop result does not match shapes in loop parameter"
- loc
- (map (I.paramName . fst) ctxmerge)
- merge_ts
- =<< bodyBind loopbody'
+ localScope (scopeOfFParams $ map fst merge) . inScopeOf form' . buildBody_ $
+ ensureArgShapes
+ "shape of loop result does not match shapes in loop parameter"
+ loc
+ (map (I.paramName . fst) ctxmerge)
+ merge_ts
+ =<< bodyBind loopbody'
attrs <- asks envAttrs
- loop_res <-
- map I.Var . dropCond
- <$> attributing
- attrs
- (letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody''))
- bindExtSizes (E.toStruct ret) retext loop_res
- return loop_res
+ map I.Var . dropCond
+ <$> attributing
+ attrs
+ (letTupExp desc (I.DoLoop ctxmerge valmerge form' loopbody''))
where
sparams' = map (`TypeParamDim` mempty) sparams
@@ -585,7 +465,8 @@
i <- newVName "i"
- bindingLoopParams sparams' mergepat $
+ ts <- mapM subExpType mergeinit
+ bindingLoopParams sparams' mergepat ts $
\shapepat mergepat' ->
bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do
let loopvars = zip x_params arr'
@@ -598,12 +479,14 @@
I.Prim (IntType it) -> return it
_ -> error "internaliseExp DoLoop: invalid type"
- bindingLoopParams sparams' mergepat $
+ ts <- mapM subExpType mergeinit
+ bindingLoopParams sparams' mergepat ts $
\shapepat mergepat' ->
forLoop mergepat' shapepat mergeinit $
I.ForLoop (E.identName i) it num_iterations' []
- handleForm mergeinit (E.While cond) =
- bindingLoopParams sparams' mergepat $ \shapepat mergepat' -> do
+ handleForm mergeinit (E.While cond) = do
+ ts <- mapM subExpType mergeinit
+ bindingLoopParams sparams' mergepat ts $ \shapepat mergepat' -> do
mergeinit_ts <- mapM subExpType mergeinit
-- We need to insert 'cond' twice - once for the initial
-- condition (do we enter the loop at all?), and once with the
@@ -636,7 +519,7 @@
shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets
-- Careful not to clobber anything.
- loop_end_cond_body <- renameBody <=< insertStmsM $ do
+ loop_end_cond_body <- renameBody <=< buildBody_ $ do
forM_ (zip shapepat shapeargs) $ \(p, se) ->
unless (se == I.Var (paramName p)) $
letBindNames [paramName p] $ BasicOp $ SubExp se
@@ -649,7 +532,7 @@
| not $ primType $ paramType p ->
Reshape (map DimCoercion $ arrayDims $ paramType p) v
_ -> SubExp se
- resultBody <$> internaliseExp "loop_cond" cond
+ internaliseExp "loop_cond" cond
loop_end_cond <- bodyBind loop_end_cond_body
return
@@ -660,11 +543,147 @@
loop_initial_cond : mergeinit
)
)
-internaliseExp desc (E.LetWith name src idxs ve body t loc) = do
+internaliseAppExp desc (E.LetWith name src idxs ve body loc) = do
let pat = E.Id (E.identName name) (E.identType name) loc
src_t = E.fromStruct <$> E.identType src
e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc
- internaliseExp desc $ E.LetPat pat e body (t, Info []) loc
+ internaliseExp desc $
+ E.AppExp
+ (E.LetPat [] pat e body loc)
+ (Info (AppRes (E.typeOf body) mempty))
+internaliseAppExp desc (E.Match e cs _) = do
+ ses <- internaliseExp (desc ++ "_scrutinee") e
+ case NE.uncons cs of
+ (CasePat pCase eCase _, Nothing) -> do
+ (_, pertinent) <- generateCond pCase ses
+ internalisePat' [] pCase pertinent eCase (internaliseExp desc)
+ (c, Just cs') -> do
+ let CasePat pLast eLast _ = NE.last cs'
+ bFalse <- do
+ (_, pertinent) <- generateCond pLast ses
+ eLast' <- internalisePat' [] pLast pertinent eLast (internaliseBody desc)
+ foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $
+ reverse $ NE.init cs'
+ letTupExp' desc =<< generateCaseIf ses c bFalse
+internaliseAppExp desc (E.If ce te fe _) =
+ letTupExp' desc
+ =<< eIf
+ (BasicOp . SubExp <$> internaliseExp1 "cond" ce)
+ (internaliseBody (desc <> "_t") te)
+ (internaliseBody (desc <> "_f") fe)
+internaliseAppExp _ e@E.BinOp {} =
+ error $ "internaliseAppExp: Unexpected BinOp " ++ pretty e
+
+internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp]
+internaliseExp desc (E.Parens e _) =
+ internaliseExp desc e
+internaliseExp desc (E.QualParens _ e _) =
+ internaliseExp desc e
+internaliseExp desc (E.StringLit vs _) =
+ fmap pure $
+ letSubExp desc $
+ I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8
+internaliseExp _ (E.Var (E.QualName _ name) _ _) = do
+ subst <- lookupSubst name
+ case subst of
+ Just substs -> return substs
+ Nothing -> pure [I.Var name]
+internaliseExp desc (E.AppExp e (Info appres)) = do
+ ses <- internaliseAppExp desc e
+ bindExtSizes appres ses
+ pure ses
+
+-- XXX: we map empty records and tuples to units, because otherwise
+-- arrays of unit will lose their sizes.
+internaliseExp _ (E.TupLit [] _) =
+ return [constant UnitValue]
+internaliseExp _ (E.RecordLit [] _) =
+ return [constant UnitValue]
+internaliseExp desc (E.TupLit es _) = concat <$> mapM (internaliseExp desc) es
+internaliseExp desc (E.RecordLit orig_fields _) =
+ concatMap snd . sortFields . M.unions <$> mapM internaliseField orig_fields
+ where
+ internaliseField (E.RecordFieldExplicit name e _) =
+ M.singleton name <$> internaliseExp desc e
+ internaliseField (E.RecordFieldImplicit name t loc) =
+ internaliseField $
+ E.RecordFieldExplicit
+ (baseName name)
+ (E.Var (E.qualName name) t loc)
+ loc
+internaliseExp desc (E.ArrayLit es (Info arr_t) loc)
+ -- If this is a multidimensional array literal of primitives, we
+ -- treat it specially by flattening it out followed by a reshape.
+ -- This cuts down on the amount of statements that are produced, and
+ -- thus allows us to efficiently handle huge array literals - a
+ -- corner case, but an important one.
+ | Just ((eshape, e') : es') <- mapM isArrayLiteral es,
+ not $ null eshape,
+ all ((eshape ==) . fst) es',
+ Just basetype <- E.peelArray (length eshape) arr_t = do
+ let flat_lit = E.ArrayLit (e' ++ concatMap snd es') (Info basetype) loc
+ new_shape = length es : eshape
+ flat_arrs <- internaliseExpToVars "flat_literal" flat_lit
+ forM flat_arrs $ \flat_arr -> do
+ flat_arr_t <- lookupType flat_arr
+ let new_shape' =
+ reshapeOuter
+ (map (DimNew . intConst Int64 . toInteger) new_shape)
+ 1
+ $ I.arrayShape flat_arr_t
+ letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr
+ | otherwise = do
+ es' <- mapM (internaliseExp "arr_elem") es
+ arr_t_ext <- internaliseType $ E.toStruct arr_t
+
+ rowtypes <-
+ case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of
+ Just ts -> pure ts
+ Nothing ->
+ -- XXX: the monomorphiser may create single-element array
+ -- literals with an unknown row type. In those cases we
+ -- need to look at the types of the actual elements.
+ -- Fixing this in the monomorphiser is a lot more tricky
+ -- than just working around it here.
+ case es' of
+ [] -> error $ "internaliseExp ArrayLit: existential type: " ++ pretty arr_t
+ e' : _ -> mapM subExpType e'
+
+ let arraylit ks rt = do
+ ks' <-
+ mapM
+ ( ensureShape
+ "shape of element differs from shape of first element"
+ loc
+ rt
+ "elem_reshaped"
+ )
+ ks
+ return $ I.BasicOp $ I.ArrayLit ks' rt
+
+ letSubExps desc
+ =<< if null es'
+ then mapM (arraylit []) rowtypes
+ else zipWithM arraylit (transpose es') rowtypes
+ where
+ isArrayLiteral :: E.Exp -> Maybe ([Int], [E.Exp])
+ isArrayLiteral (E.ArrayLit inner_es _ _) = do
+ (eshape, e) : inner_es' <- mapM isArrayLiteral inner_es
+ guard $ all ((eshape ==) . fst) inner_es'
+ return (length inner_es : eshape, e ++ concatMap snd inner_es')
+ isArrayLiteral e =
+ Just ([], [e])
+internaliseExp desc (E.Ascript e _ _) =
+ internaliseExp desc e
+internaliseExp desc (E.Negate e _) = do
+ e' <- internaliseExp1 "negate_arg" e
+ et <- subExpType e'
+ case et of
+ I.Prim (I.IntType t) ->
+ letTupExp' desc $ I.BasicOp $ I.BinOp (I.Sub t I.OverflowWrap) (I.intConst t 0) e'
+ I.Prim (I.FloatType t) ->
+ letTupExp' desc $ I.BasicOp $ I.BinOp (I.FSub t) (I.floatConst t 0) e'
+ _ -> error "Futhark.Internalise.internaliseExp: non-numeric type in Negate"
internaliseExp desc (E.Update src slice ve loc) = do
ves <- internaliseExp "lw_val" ve
srcs <- internaliseExpToVars "src" src
@@ -745,24 +764,6 @@
return []
internaliseExp _ (E.Constr _ _ (Info t) loc) =
error $ "internaliseExp: constructor with type " ++ pretty t ++ " at " ++ locStr loc
-internaliseExp desc (E.Match e cs (Info ret, Info retext) _) = do
- ses <- internaliseExp (desc ++ "_scrutinee") e
- res <-
- case NE.uncons cs of
- (CasePat pCase eCase _, Nothing) -> do
- (_, pertinent) <- generateCond pCase ses
- internalisePat' pCase pertinent eCase (internaliseExp desc)
- (c, Just cs') -> do
- let CasePat pLast eLast _ = NE.last cs'
- bFalse <- do
- (_, pertinent) <- generateCond pLast ses
- eLast' <- internalisePat' pLast pertinent eLast (internaliseBody desc)
- foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $
- reverse $ NE.init cs'
- letTupExp' desc =<< generateCaseIf ses c bFalse
- bindExtSizes (E.toStruct ret) retext res
- return res
-
-- The "interesting" cases are over, now it's mostly boilerplate.
internaliseExp _ (E.Literal v _) =
@@ -781,16 +782,6 @@
E.Scalar (E.Prim (E.FloatType ft)) ->
return [I.Constant $ I.FloatValue $ floatValue ft v]
_ -> error $ "internaliseExp: nonsensical type for float literal: " ++ pretty t
-internaliseExp desc (E.If ce te fe (Info ret, Info retext) _) = do
- ses <-
- letTupExp' desc
- =<< eIf
- (BasicOp . SubExp <$> internaliseExp1 "cond" ce)
- (internaliseBody (desc <> "_t") te)
- (internaliseBody (desc <> "_f") fe)
- bindExtSizes (E.toStruct ret) retext ses
- return ses
-
-- Builtin operators are handled specially because they are
-- overloaded.
internaliseExp desc (E.Project k e (Info rt) _) = do
@@ -802,8 +793,6 @@
map snd $ takeWhile ((/= k) . fst) $ sortFields fs
t -> [t]
take n . drop i' <$> internaliseExp desc e
-internaliseExp _ e@E.BinOp {} =
- error $ "internaliseExp: Unexpected BinOp " ++ pretty e
internaliseExp _ e@E.Lambda {} =
error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e)
internaliseExp _ e@E.OpSection {} =
@@ -825,6 +814,9 @@
_ -> return ()
return arg'
+subExpPrimType :: I.SubExp -> InternaliseM I.PrimType
+subExpPrimType = fmap I.elemType . subExpType
+
generateCond :: E.Pattern -> [I.SubExp] -> InternaliseM (I.SubExp, [I.SubExp])
generateCond orig_p orig_ses = do
(cmps, pertinent, _) <- compares orig_p orig_ses
@@ -837,7 +829,7 @@
PatLitPrim v -> pure $ constant $ internalisePrimValue v
PatLitInt x -> internaliseExp1 "constant" $ E.IntLit x t mempty
PatLitFloat x -> internaliseExp1 "constant" $ E.FloatLit x t mempty
- t' <- elemType <$> subExpType se
+ t' <- subExpPrimType se
cmp <- letSubExp "match_lit" $ I.BasicOp $ I.CmpOp (I.CmpEq t') e' se
return ([cmp], [se], ses)
compares (E.PatternConstr c (Info (E.Scalar (E.Sum fs))) pats _) (se : ses) = do
@@ -888,33 +880,36 @@
generateCaseIf :: [I.SubExp] -> Case -> I.Body -> InternaliseM I.Exp
generateCaseIf ses (CasePat p eCase _) bFail = do
(cond, pertinent) <- generateCond p ses
- eCase' <- internalisePat' p pertinent eCase (internaliseBody "case")
+ eCase' <- internalisePat' [] p pertinent eCase (internaliseBody "case")
eIf (eSubExp cond) (return eCase') (return bFail)
internalisePat ::
String ->
+ [E.SizeBinder VName] ->
E.Pattern ->
E.Exp ->
E.Exp ->
(E.Exp -> InternaliseM a) ->
InternaliseM a
-internalisePat desc p e body m = do
+internalisePat desc sizes p e body m = do
ses <- internaliseExp desc' e
- internalisePat' p ses body m
+ internalisePat' sizes p ses body m
where
desc' = case S.toList $ E.patternIdents p of
[v] -> baseString $ E.identName v
_ -> desc
internalisePat' ::
+ [E.SizeBinder VName] ->
E.Pattern ->
[I.SubExp] ->
E.Exp ->
(E.Exp -> InternaliseM a) ->
InternaliseM a
-internalisePat' p ses body m = do
+internalisePat' sizes p ses body m = do
ses_ts <- mapM subExpType ses
stmPattern p ses_ts $ \pat_names -> do
+ bindExtSizes (AppRes (E.patternType p) (map E.sizeName sizes)) ses
forM_ (zip pat_names ses) $ \(v, se) ->
letBindNames [v] $ I.BasicOp $ I.SubExp se
m body
@@ -1131,13 +1126,13 @@
let params = bucket_param : img_params
rettype = I.Prim int64 : ne_ts
body = mkBody mempty $ map (I.Var . paramName) params
- body' <-
- localScope (scopeOfLParams params) $
+ lam' <-
+ mkLambda params $
ensureResultShape
"Row shape of value array does not match row shape of hist target"
(srclocOf img)
rettype
- body
+ =<< bodyBind body
-- get sizes of histogram and image arrays
w_hist <- arraysSize 0 <$> mapM lookupType hist'
@@ -1159,9 +1154,8 @@
letExp (baseString buckets') $
I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets'
- letTupExp' desc $
- I.Op $
- I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] (I.Lambda params body' rettype) $ buckets'' : img'
+ letTupExp' desc . I.Op $
+ I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] lam' $ buckets'' : img'
internaliseStreamMap ::
String ->
@@ -1216,37 +1210,67 @@
-- Make sure the chunk size parameter comes first.
let lam_params' = chunk_param : lam_acc_params ++ lam_val_params
- body_with_lam0 <-
+ lam' <- mkLambda lam_params' $ do
+ lam_res <- bodyBind lam_body
+ lam_res' <-
+ ensureArgShapes
+ "shape of chunk function result does not match shape of initial value"
+ (srclocOf lam)
+ []
+ (map I.typeOf $ I.lambdaParams lam0')
+ lam_res
ensureResultShape
"shape of result does not match shape of initial value"
(srclocOf lam0)
nes_ts
- <=< insertStmsM
- $ localScope (scopeOfLParams lam_params') $ do
- lam_res <- bodyBind lam_body
- lam_res' <-
- ensureArgShapes
- "shape of chunk function result does not match shape of initial value"
- (srclocOf lam)
- []
- (map I.typeOf $ I.lambdaParams lam0')
- lam_res
- new_lam_res <-
- eLambda lam0' $
- map eSubExp $
+ =<< ( eLambda lam0' . map eSubExp $
map (I.Var . paramName) lam_acc_params ++ lam_res'
- return $ resultBody new_lam_res
+ )
let form = I.Parallel o comm lam0'
- lam' =
- I.Lambda
- { lambdaParams = lam_params',
- lambdaBody = body_with_lam0,
- lambdaReturnType = nes_ts
- }
w <- arraysSize 0 <$> mapM lookupType arrs
letTupExp' desc $ I.Op $ I.Stream w arrs form nes lam'
+internaliseStreamAcc ::
+ String ->
+ E.Exp ->
+ Maybe (E.Exp, E.Exp) ->
+ E.Exp ->
+ E.Exp ->
+ InternaliseM [SubExp]
+internaliseStreamAcc desc dest op lam bs = do
+ dest' <- internaliseExpToVars "scatter_dest" dest
+ bs' <- internaliseExpToVars "scatter_input" bs
+
+ acc_cert_v <- newVName "acc_cert"
+ dest_ts <- mapM lookupType dest'
+ let dest_w = arraysSize 0 dest_ts
+ acc_t = Acc acc_cert_v (Shape [dest_w]) (map rowType dest_ts) NoUniqueness
+ acc_p <- newParam "acc_p" acc_t
+ withacc_lam <- mkLambda [Param acc_cert_v (I.Prim I.Unit), acc_p] $ do
+ lam' <-
+ internaliseMapLambda internaliseLambda lam $
+ map I.Var $ paramName acc_p : bs'
+ w <- arraysSize 0 <$> mapM lookupType bs'
+ letTupExp' "acc_res" $ I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam')
+
+ op' <-
+ case op of
+ Just (op_lam, ne) -> do
+ ne' <- internaliseExp "hist_ne" ne
+ ne_ts <- mapM I.subExpType ne'
+ (lam_params, lam_body, lam_rettype) <-
+ internaliseLambda op_lam $ ne_ts ++ ne_ts
+ idxp <- newParam "idx" $ I.Prim int64
+ let op_lam' = I.Lambda (idxp : lam_params) lam_body lam_rettype
+ return $ Just (op_lam', ne')
+ Nothing ->
+ return Nothing
+
+ destw <- arraysSize 0 <$> mapM lookupType dest'
+ fmap (map I.Var) $
+ letTupExp desc $ WithAcc [(Shape [destw], dest', op')] withacc_lam
+
internaliseExp1 :: String -> E.Exp -> InternaliseM I.SubExp
internaliseExp1 desc e = do
vs <- internaliseExp desc e
@@ -1456,28 +1480,36 @@
letTupExp' desc $ I.BasicOp $ I.CmpOp op x y
findFuncall ::
- E.Exp ->
+ E.AppExp ->
InternaliseM
( E.QualName VName,
- [(E.Exp, Maybe VName)],
- E.StructType,
- [VName]
+ [(E.Exp, Maybe VName)]
)
-findFuncall (E.Var fname (Info t) _) =
- return (fname, [], E.toStruct t, [])
-findFuncall (E.Apply f arg (Info (_, argext)) (Info ret, Info retext) _) = do
- (fname, args, _, _) <- findFuncall f
- return (fname, args ++ [(arg, argext)], E.toStruct ret, retext)
+findFuncall (E.Apply f arg (Info (_, argext)) _)
+ | E.AppExp f_e _ <- f = do
+ (fname, args) <- findFuncall f_e
+ return (fname, args ++ [(arg, argext)])
+ | E.Var fname _ _ <- f =
+ return (fname, [(arg, argext)])
findFuncall e =
error $ "Invalid function expression in application: " ++ pretty e
+-- The type of a body. Watch out: this only works for the degenerate
+-- case where the body does not already return its context.
+bodyExtType :: Body -> InternaliseM [ExtType]
+bodyExtType (Body _ stms res) =
+ existentialiseExtTypes (M.keys stmsscope) . staticShapes
+ <$> extendedScope (traverse subExpType res) stmsscope
+ where
+ stmsscope = scopeOf stms
+
internaliseLambda :: InternaliseLambda
internaliseLambda (E.Parens e _) rowtypes =
internaliseLambda e rowtypes
internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =
bindingLambdaParams params rowtypes $ \params' -> do
body' <- internaliseBody "lam" body
- rettype' <- internaliseLambdaReturnType rettype
+ rettype' <- internaliseLambdaReturnType rettype =<< bodyExtType body'
return (params', body', rettype')
internaliseLambda e _ = error $ "internaliseLambda: unexpected expression:\n" ++ pretty e
@@ -1495,6 +1527,7 @@
handleIntrinsicOps,
handleOps,
handleSOACs,
+ handleAccs,
handleRest
]
msum [h args $ baseString $ qualLeaf qname | h <- handlers]
@@ -1531,10 +1564,14 @@
-- Short-circuiting operators are magical.
handleOps [x, y] "&&" = Just $ \desc ->
internaliseExp desc $
- E.If x y (E.Literal (E.BoolValue False) mempty) (Info $ E.Scalar $ E.Prim E.Bool, Info []) mempty
+ E.AppExp
+ (E.If x y (E.Literal (E.BoolValue False) mempty) mempty)
+ (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])
handleOps [x, y] "||" = Just $ \desc ->
internaliseExp desc $
- E.If x (E.Literal (E.BoolValue True) mempty) y (Info $ E.Scalar $ E.Prim E.Bool, Info []) mempty
+ E.AppExp
+ (E.If x (E.Literal (E.BoolValue True) mempty) y mempty)
+ (Info $ AppRes (E.Scalar $ E.Prim E.Bool) [])
-- Handle equality and inequality specially, to treat the case of
-- arrays.
handleOps [xe, ye] op
@@ -1644,6 +1681,17 @@
internaliseHist desc rf dest op ne buckets img loc
handleSOACs _ _ = Nothing
+ handleAccs [TupLit [dest, f, bs] _] "scatter_stream" = Just $ \desc ->
+ internaliseStreamAcc desc dest Nothing f bs
+ handleAccs [TupLit [dest, op, ne, f, bs] _] "hist_stream" = Just $ \desc ->
+ internaliseStreamAcc desc dest (Just (op, ne)) f bs
+ handleAccs [TupLit [acc, i, v] _] "acc_write" = Just $ \desc -> do
+ acc' <- head <$> internaliseExpToVars "acc" acc
+ i' <- internaliseExp1 "acc_i" i
+ vs <- internaliseExp "acc_v" v
+ fmap pure $ letSubExp desc $ BasicOp $ UpdateAcc acc' [i'] vs
+ handleAccs _ _ = Nothing
+
handleRest [x] "!" = Just $ complementF x
handleRest [x] "opaque" = Just $ \desc ->
mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x
@@ -1809,16 +1857,15 @@
-- This body is pretty boring right now, as every input is exactly the output.
-- But it can get funky later on if fused with something else.
- body <- localScope (scopeOfLParams bodyParams) $
- insertStmsM $ do
- let outs = concat (replicate (length valueNames) indexName) ++ valueNames
- results <- forM outs $ \name ->
- letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name
- ensureResultShape
- "scatter value has wrong size"
- loc
- bodyTypes
- $ resultBody results
+ body <- localScope (scopeOfLParams bodyParams) . buildBody_ $ do
+ let outs = concat (replicate (length valueNames) indexName) ++ valueNames
+ results <- forM outs $ \name ->
+ letSubExp "write_res" $ I.BasicOp $ I.SubExp $ I.Var name
+ ensureResultShape
+ "scatter value has wrong size"
+ loc
+ bodyTypes
+ results
let lam =
I.Lambda
@@ -1885,9 +1932,9 @@
-- importantly should be done after function calls, but also
-- everything else that can produce existentials in the source
-- language.
-bindExtSizes :: E.StructType -> [VName] -> [SubExp] -> InternaliseM ()
-bindExtSizes ret retext ses = do
- ts <- internaliseType ret
+bindExtSizes :: AppRes -> [SubExp] -> InternaliseM ()
+bindExtSizes (AppRes ret retext) ses = do
+ ts <- internaliseType $ E.toStruct ret
ses_ts <- mapM subExpType ses
let combine t1 t2 =
@@ -1960,8 +2007,7 @@
-- Create scratch arrays for the result.
blanks <- forM arr_ts $ \arr_t ->
letExp "partition_dest" $
- I.BasicOp $
- Scratch (elemType arr_t) (w : drop 1 (I.arrayDims arr_t))
+ I.BasicOp $ Scratch (I.elemType arr_t) (w : drop 1 (I.arrayDims arr_t))
-- Now write into the result.
write_lam <- do
diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs
--- a/src/Futhark/Internalise/AccurateSizes.hs
+++ b/src/Futhark/Internalise/AccurateSizes.hs
@@ -19,17 +19,23 @@
import Futhark.Util (takeLast)
shapeMapping ::
- HasScope SOACS m =>
+ (HasScope SOACS m, Monad m) =>
[FParam] ->
[Type] ->
m (M.Map VName SubExp)
shapeMapping all_params value_arg_types =
- mconcat <$> zipWithM f value_params value_arg_types
+ mconcat <$> zipWithM f (map paramType value_params) value_arg_types
where
value_params = takeLast (length value_arg_types) all_params
- f (Param _ t1@Array {}) t2@Array {} =
+ f t1@Array {} t2@Array {} =
pure $ M.fromList $ mapMaybe match $ zip (arrayDims t1) (arrayDims t2)
+ f (Acc acc1 ispace1 ts1 _) (Acc acc2 ispace2 ts2 _) = do
+ let ispace_m =
+ M.fromList . mapMaybe match $
+ zip (shapeDims ispace1) (shapeDims ispace2)
+ arr_sizes_m <- mconcat <$> zipWithM f ts1 ts2
+ pure $ M.singleton acc1 (Var acc2) <> ispace_m <> arr_sizes_m
f _ _ =
pure mempty
@@ -56,8 +62,8 @@
ErrorMsg SubExp ->
SrcLoc ->
[Type] ->
- Body ->
- InternaliseM Body
+ Result ->
+ InternaliseM Result
ensureResultShape msg loc =
ensureResultExtShape msg loc . staticShapes
@@ -65,33 +71,28 @@
ErrorMsg SubExp ->
SrcLoc ->
[ExtType] ->
- Body ->
- InternaliseM Body
-ensureResultExtShape msg loc rettype body =
- insertStmsM $ do
- reses <-
- bodyBind
- =<< ensureResultExtShapeNoCtx msg loc rettype body
- ts <- mapM subExpType reses
- let ctx = extractShapeContext rettype $ map arrayDims ts
- mkBodyM mempty $ ctx ++ reses
+ Result ->
+ InternaliseM Result
+ensureResultExtShape msg loc rettype res = do
+ res' <- ensureResultExtShapeNoCtx msg loc rettype res
+ ts <- mapM subExpType res'
+ let ctx = extractShapeContext rettype $ map arrayDims ts
+ pure $ ctx ++ res'
ensureResultExtShapeNoCtx ::
ErrorMsg SubExp ->
SrcLoc ->
[ExtType] ->
- Body ->
- InternaliseM Body
-ensureResultExtShapeNoCtx msg loc rettype body =
- insertStmsM $ do
- es <- bodyBind body
- es_ts <- mapM subExpType es
- let ext_mapping = shapeExtMapping rettype es_ts
- rettype' = foldr (uncurry fixExt) rettype $ M.toList ext_mapping
- assertProperShape t se =
- let name = "result_proper_shape"
- in ensureExtShape msg loc t name se
- resultBodyM =<< zipWithM assertProperShape rettype' es
+ Result ->
+ InternaliseM Result
+ensureResultExtShapeNoCtx msg loc rettype es = do
+ es_ts <- mapM subExpType es
+ let ext_mapping = shapeExtMapping rettype es_ts
+ rettype' = foldr (uncurry fixExt) rettype $ M.toList ext_mapping
+ assertProperShape t se =
+ let name = "result_proper_shape"
+ in ensureExtShape msg loc t name se
+ zipWithM assertProperShape rettype' es
ensureExtShape ::
ErrorMsg SubExp ->
diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs
--- a/src/Futhark/Internalise/Bindings.hs
+++ b/src/Futhark/Internalise/Bindings.hs
@@ -2,7 +2,7 @@
-- | Internalising bindings.
module Futhark.Internalise.Bindings
- ( bindingParams,
+ ( bindingFParams,
bindingLoopParams,
bindingLambdaParams,
stmPattern,
@@ -11,18 +11,19 @@
import Control.Monad.Reader hiding (mapM)
import qualified Data.Map.Strict as M
+import Data.Maybe
import qualified Futhark.IR.SOACS as I
import Futhark.Internalise.Monad
import Futhark.Internalise.TypesValues
import Futhark.Util
import Language.Futhark as E hiding (matchDims)
-bindingParams ::
+bindingFParams ::
[E.TypeParam] ->
[E.Pattern] ->
([I.FParam] -> [[I.FParam]] -> InternaliseM a) ->
InternaliseM a
-bindingParams tparams params m = do
+bindingFParams tparams params m = do
flattened_params <- mapM flattenPattern params
let params_idents = concat flattened_params
params_ts <-
@@ -33,20 +34,27 @@
let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]
shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params]
- bindingFlatPattern params_idents (concat params_ts) $ \valueparams ->
- I.localScope (I.scopeOfFParams $ shape_params ++ concat valueparams) $
+ bindingFlatPattern params_idents (concat params_ts) $ \valueparams -> do
+ let (certparams, valueparams') = unzip $ map fixAccParam (concat valueparams)
+ I.localScope (I.scopeOfFParams $ catMaybes certparams ++ shape_params ++ valueparams') $
substitutingVars shape_subst $
- m shape_params $
- chunks num_param_ts (concat valueparams)
+ m (catMaybes certparams ++ shape_params) $ chunks num_param_ts valueparams'
+ where
+ fixAccParam (I.Param pv (I.Acc acc ispace ts u)) =
+ ( Just (I.Param acc $ I.Prim I.Unit),
+ I.Param pv (I.Acc acc ispace ts u)
+ )
+ fixAccParam p = (Nothing, p)
bindingLoopParams ::
[E.TypeParam] ->
E.Pattern ->
+ [I.Type] ->
([I.FParam] -> [I.FParam] -> InternaliseM a) ->
InternaliseM a
-bindingLoopParams tparams pat m = do
+bindingLoopParams tparams pat ts m = do
pat_idents <- flattenPattern pat
- pat_ts <- internaliseLoopParamType (E.patternStructType pat)
+ pat_ts <- internaliseLoopParamType (E.patternStructType pat) ts
let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]
shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params]
@@ -126,11 +134,11 @@
flattenPattern' $ E.Id name t loc
flattenPattern' (E.Id v (Info t) loc) =
return [E.Ident v (Info t) loc]
- -- XXX: treat empty tuples and records as bool.
+ -- XXX: treat empty tuples and records as unit.
flattenPattern' (E.TuplePattern [] loc) =
- flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc)
+ flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc)
flattenPattern' (E.RecordPattern [] loc) =
- flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc)
+ flattenPattern' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc)
flattenPattern' (E.TuplePattern pats _) =
concat <$> mapM flattenPattern' pats
flattenPattern' (E.RecordPattern fs loc) =
diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs
--- a/src/Futhark/Internalise/Defunctionalise.hs
+++ b/src/Futhark/Internalise/Defunctionalise.hs
@@ -140,8 +140,8 @@
Literal (SignedValue (Int64Value (fromIntegral d))) loc
Nothing ->
Var v (replaceTypeSizes substs <$> t) loc
- onExp substs (Coerce e tdecl t loc) =
- Coerce (onExp substs e) tdecl' (first (fmap (replaceTypeSizes substs)) t) loc
+ onExp substs (AppExp (Coerce e tdecl loc) (Info (AppRes t ext))) =
+ AppExp (Coerce (onExp substs e) tdecl' loc) (Info (AppRes (replaceTypeSizes substs t) ext))
where
tdecl' =
TypeDecl
@@ -475,11 +475,14 @@
defuncExp (ArrayLit es t@(Info t') loc) = do
es' <- mapM defuncExp' es
return (ArrayLit es' t loc, Dynamic t')
-defuncExp (Range e1 me incl t@(Info t', _) loc) = do
+defuncExp (AppExp (Range e1 me incl loc) res) = do
e1' <- defuncExp' e1
me' <- mapM defuncExp' me
incl' <- mapM defuncExp' incl
- return (Range e1' me' incl' t loc, Dynamic t')
+ return
+ ( AppExp (Range e1' me' incl' loc) res,
+ Dynamic $ appResType $ unInfo res
+ )
defuncExp e@(Var qn (Info t) loc) = do
sv <- lookupVar (toStruct t) (qualLeaf qn)
case sv of
@@ -500,12 +503,12 @@
(e0', sv) <- defuncExp e0
return (Ascript e0' tydecl loc, sv)
| otherwise = defuncExp e0
-defuncExp (Coerce e0 tydecl t loc)
+defuncExp (AppExp (Coerce e0 tydecl loc) res)
| orderZero (typeOf e0) = do
(e0', sv) <- defuncExp e0
- return (Coerce e0' tydecl t loc, sv)
+ return (AppExp (Coerce e0' tydecl loc) res, sv)
| otherwise = defuncExp e0
-defuncExp (LetPat pat e1 e2 (Info t, retext) loc) = do
+defuncExp (AppExp (LetPat sizes pat e1 e2 loc) (Info (AppRes t retext))) = do
(e1', sv1) <- defuncExp e1
let env = matchPatternSV pat sv1
pat' = updatePattern pat sv1
@@ -516,24 +519,24 @@
let mapping = dimMapping' (typeOf e2) t
subst v = fromMaybe v $ M.lookup v mapping
t' = first (fmap subst) $ typeOf e2'
- return (LetPat pat' e1' e2' (Info t', retext) loc, sv2)
-defuncExp (LetFun vn _ _ _ _) =
+ return (AppExp (LetPat sizes pat' e1' e2' loc) (Info (AppRes t' retext)), sv2)
+defuncExp (AppExp (LetFun vn _ _ _) _) =
error $ "defuncExp: Unexpected LetFun: " ++ prettyName vn
-defuncExp (If e1 e2 e3 tp loc) = do
+defuncExp (AppExp (If e1 e2 e3 loc) res) = do
(e1', _) <- defuncExp e1
(e2', sv) <- defuncExp e2
(e3', _) <- defuncExp e3
- return (If e1' e2' e3' tp loc, sv)
-defuncExp e@(Apply f@(Var f' _ _) arg d (t, ext) loc)
+ return (AppExp (If e1' e2' e3' loc) res, sv)
+defuncExp e@(AppExp (Apply f@(Var f' _ _) arg d loc) res)
| baseTag (qualLeaf f') <= maxIntrinsicTag,
TupLit es tuploc <- arg = do
-- defuncSoacExp also works fine for non-SOACs.
es' <- mapM defuncSoacExp es
return
- ( Apply f (TupLit es' tuploc) d (t, ext) loc,
+ ( AppExp (Apply f (TupLit es' tuploc) d loc) res,
Dynamic $ typeOf e
)
-defuncExp e@Apply {} = defuncApply 0 e
+defuncExp e@(AppExp Apply {} _) = defuncApply 0 e
defuncExp (Negate e0 loc) = do
(e0', sv) <- defuncExp e0
return (Negate e0' loc, sv)
@@ -546,7 +549,7 @@
defuncExp OpSectionRight {} = error "defuncExp: unexpected operator section."
defuncExp ProjectSection {} = error "defuncExp: unexpected projection section."
defuncExp IndexSection {} = error "defuncExp: unexpected projection section."
-defuncExp (DoLoop sparams pat e1 form e3 ret loc) = do
+defuncExp (AppExp (DoLoop sparams pat e1 form e3 loc) res) = do
(e1', sv1) <- defuncExp e1
let env1 = matchPatternSV pat sv1
(form', env2) <- case form of
@@ -560,11 +563,11 @@
e2' <- localEnv env1 $ defuncExp' e2
return (While e2', mempty)
(e3', sv) <- localEnv (env1 <> env2) $ defuncExp e3
- return (DoLoop sparams pat e1' form' e3' ret loc, sv)
+ return (AppExp (DoLoop sparams pat e1' form' e3' loc) res, sv)
where
envFromIdent (Ident vn (Info tp) _) =
M.singleton vn $ Binding Nothing $ Dynamic tp
-defuncExp e@BinOp {} =
+defuncExp e@(AppExp BinOp {} _) =
error $ "defuncExp: unexpected binary operator: " ++ pretty e
defuncExp (Project vn e0 tp@(Info tp') loc) = do
(e0', sv0) <- defuncExp e0
@@ -574,18 +577,21 @@
Nothing -> error "Invalid record projection."
Dynamic _ -> return (Project vn e0' tp loc, Dynamic tp')
_ -> error $ "Projection of an expression with static value " ++ show sv0
-defuncExp (LetWith id1 id2 idxs e1 body t loc) = do
+defuncExp (AppExp (LetWith id1 id2 idxs e1 body loc) res) = do
e1' <- defuncExp' e1
idxs' <- mapM defuncDimIndex idxs
let id1_binding = Binding Nothing $ Dynamic $ unInfo $ identType id1
(body', sv) <-
localEnv (M.singleton (identName id1) id1_binding) $
defuncExp body
- return (LetWith id1 id2 idxs' e1' body' t loc, sv)
-defuncExp expr@(Index e0 idxs info loc) = do
+ return (AppExp (LetWith id1 id2 idxs' e1' body' loc) res, sv)
+defuncExp expr@(AppExp (Index e0 idxs loc) res) = do
e0' <- defuncExp' e0
idxs' <- mapM defuncDimIndex idxs
- return (Index e0' idxs' info loc, Dynamic $ typeOf expr)
+ return
+ ( AppExp (Index e0' idxs' loc) res,
+ Dynamic $ typeOf expr
+ )
defuncExp (Update e1 idxs e2 loc) = do
(e1', sv) <- defuncExp e1
idxs' <- mapM defuncDimIndex idxs
@@ -647,12 +653,12 @@
++ pretty t
++ " at "
++ locStr loc
-defuncExp (Match e cs t loc) = do
+defuncExp (AppExp (Match e cs loc) res) = do
(e', sv) <- defuncExp e
csPairs <- mapM (defuncCase sv) cs
let cs' = fmap fst csPairs
sv' = snd $ NE.head csPairs
- return (Match e' cs' t loc, sv')
+ return (AppExp (Match e' cs' loc) res, sv')
defuncExp (Attr info e loc) = do
(e', sv) <- defuncExp e
return (Attr info e' loc, sv)
@@ -708,12 +714,9 @@
let e' =
foldl'
( \e1 (e2, t2, argtypes) ->
- Apply
- e1
- e2
- (Info (diet t2, Nothing))
- (Info (foldFunType argtypes ret), Info [])
- mempty
+ AppExp
+ (Apply e1 e2 (Info (diet t2, Nothing)) mempty)
+ (Info (AppRes (foldFunType argtypes ret) []))
)
e
$ zip3 vars (map snd ps) (drop 1 $ tails $ map snd ps)
@@ -773,7 +776,10 @@
where
bound = bound_sizes <> foldMap patternNames params
tv = identityMapper {mapOnPatternType = bitraverse onDim pure}
- onDim AnyDim = do
+ onDim (AnyDim (Just v)) = do
+ modify $ S.insert v
+ pure $ NamedDim $ qualName v
+ onDim (AnyDim Nothing) = do
v <- lift $ newVName "size"
modify $ S.insert v
pure $ NamedDim $ qualName v
@@ -788,11 +794,11 @@
-- but a new lifted function is created if a dynamic function is only partially
-- applied.
defuncApply :: Int -> Exp -> DefM (Exp, StaticVal)
-defuncApply depth e@(Apply e1 e2 d t@(Info ret, Info ext) loc) = do
+defuncApply depth e@(AppExp (Apply e1 e2 d loc) t@(Info (AppRes ret ext))) = do
let (argtypes, _) = unfoldFunType ret
(e1', sv1) <- defuncApply (depth + 1) e1
(e2', sv2) <- defuncExp e2
- let e' = Apply e1' e2' d t loc
+ let e' = AppExp (Apply e1' e2' d loc) t
case sv1 of
LambdaSV pat e0_t e0 closure_env -> do
let env' = matchPatternSV pat sv2
@@ -830,7 +836,7 @@
-- result slightly more human-readable.
liftedName i (Var f _ _) =
"defunc_" ++ show i ++ "_" ++ baseString (qualLeaf f)
- liftedName i (Apply f _ _ _ _) =
+ liftedName i (AppExp (Apply f _ _ _) _) =
liftedName (i + 1) f
liftedName _ _ = "defunc"
@@ -865,25 +871,22 @@
-- FIXME: what if this application returns both a function
-- and a value?
callret
- | orderZero ret = (Info ret, Info ext)
- | otherwise = (Info rettype, Info ext)
+ | orderZero ret = AppRes ret ext
+ | otherwise = AppRes rettype ext
return
( Parens
- ( Apply
+ ( AppExp
( Apply
- fname''
- e1'
- (Info (Observe, Nothing))
- ( Info $ Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype,
- Info []
+ ( AppExp
+ (Apply fname'' e1' (Info (Observe, Nothing)) loc)
+ (Info $ AppRes (Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype) [])
)
+ e2'
+ d
loc
)
- e2'
- d
- callret
- loc
+ (Info callret)
)
mempty,
sv
@@ -898,9 +901,9 @@
-- FIXME: what if this application returns both a function
-- and a value?
callret
- | orderZero ret = (Info ret, Info ext)
- | otherwise = (Info restype, Info ext)
- apply_e = Apply e1' e2' d callret loc
+ | orderZero ret = AppRes ret ext
+ | otherwise = AppRes restype ext
+ apply_e = AppExp (Apply e1' e2' d loc) (Info callret)
return (apply_e, sv)
-- Propagate the 'IntrinsicsSV' until we reach the outermost application,
-- where we construct a dynamic static value with the appropriate type.
@@ -1018,7 +1021,7 @@
bound_here = S.fromList dims <> S.map identName (foldMap patternIdents pats)
anyDimIfNotBound (NamedDim v)
| qualLeaf v `S.member` bound_here = NamedDim v
- | otherwise = AnyDim
+ | otherwise = AnyDim $ Just $ qualLeaf v
anyDimIfNotBound d = d
rettype_st = first anyDimIfNotBound $ toStruct rettype
diff --git a/src/Futhark/Internalise/FreeVars.hs b/src/Futhark/Internalise/FreeVars.hs
--- a/src/Futhark/Internalise/FreeVars.hs
+++ b/src/Futhark/Internalise/FreeVars.hs
@@ -66,25 +66,25 @@
freeVarsField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty
ArrayLit es t _ ->
foldMap freeVars es <> sizes (typeDimNames $ unInfo t)
- Range e me incl _ _ ->
+ AppExp (Range e me incl _) _ ->
freeVars e <> foldMap freeVars me <> foldMap freeVars incl
Var qn (Info t) _ -> NameSet $ M.singleton (qualLeaf qn) $ toStruct t
Ascript e t _ -> freeVars e <> sizes (typeDimNames $ unInfo $ expandedType t)
- Coerce e t _ _ -> freeVars e <> sizes (typeDimNames $ unInfo $ expandedType t)
- LetPat pat e1 e2 _ _ ->
+ AppExp (Coerce e t _) _ -> freeVars e <> sizes (typeDimNames $ unInfo $ expandedType t)
+ AppExp (LetPat let_sizes pat e1 e2 _) _ ->
freeVars e1
<> ( (sizes (patternDimNames pat) <> freeVars e2)
- `withoutM` patternVars pat
+ `withoutM` (patternVars pat <> foldMap (size . sizeName) let_sizes)
)
- LetFun vn (tparams, pats, _, _, e1) e2 _ _ ->
+ AppExp (LetFun vn (tparams, pats, _, _, e1) e2 _) _ ->
( (freeVars e1 <> sizes (foldMap patternDimNames pats))
`without` ( S.map identName (foldMap patternIdents pats)
<> S.fromList (map typeParamName tparams)
)
)
<> (freeVars e2 `without` S.singleton vn)
- If e1 e2 e3 _ _ -> freeVars e1 <> freeVars e2 <> freeVars e3
- Apply e1 e2 _ _ _ -> freeVars e1 <> freeVars e2
+ AppExp (If e1 e2 e3 _) _ -> freeVars e1 <> freeVars e2 <> freeVars e3
+ AppExp (Apply e1 e2 _ _) _ -> freeVars e1 <> freeVars e2
Negate e _ -> freeVars e
Lambda pats e0 _ (Info (_, t)) _ ->
(sizes (foldMap patternDimNames pats) <> freeVars e0 <> sizes (typeDimNames t))
@@ -94,7 +94,7 @@
OpSectionRight _ _ e _ _ _ -> freeVars e
ProjectSection {} -> mempty
IndexSection idxs _ _ -> foldMap freeDimIndex idxs
- DoLoop sparams pat e1 form e3 _ _ ->
+ AppExp (DoLoop sparams pat e1 form e3 _) _ ->
let (e2fv, e2ident) = formVars form
in freeVars e1
<> ( (e2fv <> freeVars e3)
@@ -104,21 +104,21 @@
formVars (For v e2) = (freeVars e2, ident v)
formVars (ForIn p e2) = (freeVars e2, patternVars p)
formVars (While e2) = (freeVars e2, mempty)
- BinOp (qn, _) (Info qn_t) (e1, _) (e2, _) _ _ _ ->
+ AppExp (BinOp (qn, _) (Info qn_t) (e1, _) (e2, _) _) _ ->
NameSet (M.singleton (qualLeaf qn) $ toStruct qn_t)
<> freeVars e1
<> freeVars e2
Project _ e _ _ -> freeVars e
- LetWith id1 id2 idxs e1 e2 _ _ ->
+ AppExp (LetWith id1 id2 idxs e1 e2 _) _ ->
ident id2 <> foldMap freeDimIndex idxs <> freeVars e1
<> (freeVars e2 `without` S.singleton (identName id1))
- Index e idxs _ _ -> freeVars e <> foldMap freeDimIndex idxs
+ AppExp (Index e idxs _) _ -> freeVars e <> foldMap freeDimIndex idxs
Update e1 idxs e2 _ -> freeVars e1 <> foldMap freeDimIndex idxs <> freeVars e2
RecordUpdate e1 _ e2 _ _ -> freeVars e1 <> freeVars e2
Assert e1 e2 _ _ -> freeVars e1 <> freeVars e2
Constr _ es _ _ -> foldMap freeVars es
Attr _ e _ -> freeVars e
- Match e cs _ _ -> freeVars e <> foldMap caseFV cs
+ AppExp (Match e cs _) _ -> freeVars e <> foldMap caseFV cs
where
caseFV (CasePat p eCase _) =
(sizes (patternDimNames p) <> freeVars eCase)
diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs
--- a/src/Futhark/Internalise/Lambdas.hs
+++ b/src/Futhark/Internalise/Lambdas.hs
@@ -28,14 +28,12 @@
argtypes <- mapM I.subExpType args
let rowtypes = map I.rowType argtypes
(params, body, rettype) <- internaliseLambda lam rowtypes
- body' <-
- localScope (scopeOfLParams params) $
- ensureResultShape
- (ErrorMsg [ErrorString "not all iterations produce same shape"])
- (srclocOf lam)
- rettype
- body
- return $ I.Lambda params body' rettype
+ mkLambda params $
+ ensureResultShape
+ (ErrorMsg [ErrorString "not all iterations produce same shape"])
+ (srclocOf lam)
+ rettype
+ =<< bodyBind body
internaliseStreamMapLambda ::
InternaliseLambda ->
@@ -54,15 +52,13 @@
body <- runBodyBinder $ do
letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size
return orig_body
- body' <- localScope (scopeOfLParams params) $
- insertStmsM $ do
- letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size
- ensureResultShape
- (ErrorMsg [ErrorString "not all iterations produce same shape"])
- (srclocOf lam)
- (map outer rettype)
- body
- return $ I.Lambda (chunk_param : params) body' (map outer rettype)
+ mkLambda (chunk_param : params) $ do
+ letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size
+ ensureResultShape
+ (ErrorMsg [ErrorString "not all iterations produce same shape"])
+ (srclocOf lam)
+ (map outer rettype)
+ =<< bodyBind body
internaliseFoldLambda ::
InternaliseLambda ->
@@ -78,16 +74,13 @@
| (t, shape) <- zip rettype acctypes
]
-- The result of the body must have the exact same shape as the
- -- initial accumulator. We accomplish this with an assertion and
- -- reshape().
- body' <-
- localScope (scopeOfLParams params) $
- ensureResultShape
- (ErrorMsg [ErrorString "shape of result does not match shape of initial value"])
- (srclocOf lam)
- rettype'
- body
- return $ I.Lambda params body' rettype'
+ -- initial accumulator.
+ mkLambda params $
+ ensureResultShape
+ (ErrorMsg [ErrorString "shape of result does not match shape of initial value"])
+ (srclocOf lam)
+ rettype'
+ =<< bodyBind body
internaliseStreamLambda ::
InternaliseLambda ->
diff --git a/src/Futhark/Internalise/LiftLambdas.hs b/src/Futhark/Internalise/LiftLambdas.hs
--- a/src/Futhark/Internalise/LiftLambdas.hs
+++ b/src/Futhark/Internalise/LiftLambdas.hs
@@ -63,22 +63,10 @@
existentials :: Exp -> S.Set VName
existentials e =
let here = case e of
- Apply _ _ (Info (_, pdim)) (_, Info ext) _ ->
- S.fromList (maybeToList pdim ++ ext)
- If _ _ _ (_, Info ext) _ ->
- S.fromList ext
- LetPat _ _ _ (_, Info ext) _ ->
- S.fromList ext
- Coerce _ _ (_, Info ext) _ ->
- S.fromList ext
- Range _ _ _ (_, Info ext) _ ->
- S.fromList ext
- Index _ _ (_, Info ext) _ ->
- S.fromList ext
- Match _ _ (_, Info ext) _ ->
- S.fromList ext
- DoLoop _ _ _ _ _ (Info (_, ext)) _ ->
- S.fromList ext
+ AppExp (Apply _ _ (Info (_, pdim)) _) (Info res) ->
+ S.fromList (maybeToList pdim ++ appResExt res)
+ AppExp _ (Info res) ->
+ S.fromList (appResExt res)
_ ->
mempty
@@ -144,12 +132,12 @@
apply :: Exp -> [(VName, StructType)] -> Exp
apply f [] = f
apply f (p : rem_ps) =
- let inner_ret = (Info (fromStruct (augType rem_ps)), Info mempty)
- inner = Apply f (freeVar p) (Info (Observe, Nothing)) inner_ret mempty
+ let inner_ret = AppRes (fromStruct (augType rem_ps)) mempty
+ inner = AppExp (Apply f (freeVar p) (Info (Observe, Nothing)) mempty) (Info inner_ret)
in apply inner rem_ps
transformExp :: Exp -> LiftM Exp
-transformExp (LetFun fname (tparams, params, _, Info ret, funbody) body _ _) = do
+transformExp (AppExp (LetFun fname (tparams, params, _, Info ret, funbody) body _) _) = do
funbody' <- transformExp funbody
fname' <- newVName $ "lifted_" ++ baseString fname
lifted_call <- liftFunction fname' tparams params ret funbody'
diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs
--- a/src/Futhark/Internalise/Monomorphise.hs
+++ b/src/Futhark/Internalise/Monomorphise.hs
@@ -147,12 +147,19 @@
= -- | The integer encodes an equivalence class, so we can keep
-- track of sizes that are statically identical.
MonoKnown Int
- | MonoAnon
- deriving (Eq, Ord, Show)
+ | MonoAnon (Maybe VName)
+ deriving (Show)
+-- We treat all MonoAnon as identical.
+instance Eq MonoSize where
+ MonoKnown x == MonoKnown y = x == y
+ MonoAnon _ == MonoAnon _ = True
+ _ == _ = False
+
instance Pretty MonoSize where
ppr (MonoKnown i) = text "?" <> ppr i
- ppr MonoAnon = text "?"
+ ppr (MonoAnon Nothing) = mempty
+ ppr (MonoAnon (Just v)) = text "?" <> pprName v
instance Pretty (ShapeDecl MonoSize) where
ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds)
@@ -167,8 +174,8 @@
where
onDim bound _ (NamedDim d)
-- A locally bound size.
- | qualLeaf d `S.member` bound = pure MonoAnon
- onDim _ _ AnyDim = pure MonoAnon
+ | qualLeaf d `S.member` bound = pure $ MonoAnon $ Just $ qualLeaf d
+ onDim _ _ (AnyDim v) = pure $ MonoAnon v
onDim _ _ d = do
(i, m) <- get
case M.lookup d m of
@@ -220,12 +227,9 @@
applySizeArg (i, f) size_arg =
( i -1,
- Apply
- f
- size_arg
- (Info (Observe, Nothing))
- (Info (foldFunType (replicate i i64) (fromStruct t)), Info [])
- loc
+ AppExp
+ (Apply f size_arg (Info (Observe, Nothing)) loc)
+ (Info $ AppRes (foldFunType (replicate i i64) (fromStruct t)) [])
)
applySizeArgs fname' t' size_args =
@@ -266,12 +270,133 @@
return (sizes, params')
where
tv = identityMapper {mapOnPatternType = bitraverse onDim pure}
- onDim AnyDim = do
+ onDim (AnyDim _) = do
v <- lift $ newVName "size"
modify (v :)
pure $ NamedDim $ qualName v
onDim d = pure d
+transformAppRes :: AppRes -> MonoM AppRes
+transformAppRes (AppRes t ext) =
+ AppRes <$> transformType t <*> pure ext
+
+transformAppExp :: AppExp -> AppRes -> MonoM Exp
+transformAppExp (Range e1 me incl loc) res = do
+ e1' <- transformExp e1
+ me' <- mapM transformExp me
+ incl' <- mapM transformExp incl
+ return $ AppExp (Range e1' me' incl' loc) (Info res)
+transformAppExp (Coerce e tp loc) res =
+ AppExp <$> (Coerce <$> transformExp e <*> pure tp <*> pure loc) <*> pure (Info res)
+transformAppExp (LetPat sizes pat e1 e2 loc) res = do
+ (pat', rr) <- transformPattern pat
+ AppExp
+ <$> ( LetPat sizes pat' <$> transformExp e1
+ <*> withRecordReplacements rr (transformExp e2)
+ <*> pure loc
+ )
+ <*> pure (Info res)
+transformAppExp (LetFun fname (tparams, params, retdecl, Info ret, body) e loc) res
+ | not $ null tparams = do
+ -- Retrieve the lifted monomorphic function bindings that are produced,
+ -- filter those that are monomorphic versions of the current let-bound
+ -- function and insert them at this point, and propagate the rest.
+ rr <- asks envRecordReplacements
+ let funbind = PolyBinding rr (fname, tparams, params, ret, [], body, mempty, loc)
+ pass $ do
+ (e', bs) <- listen $ extendEnv fname funbind $ transformExp e
+ -- Do not remember this one for next time we monomorphise this
+ -- function.
+ modifyLifts $ filter ((/= fname) . fst . fst)
+ let (bs_local, bs_prop) = Seq.partition ((== fname) . fst) bs
+ return (unfoldLetFuns (map snd $ toList bs_local) e', const bs_prop)
+ | otherwise = do
+ body' <- transformExp body
+ AppExp
+ <$> (LetFun fname (tparams, params, retdecl, Info ret, body') <$> transformExp e <*> pure loc)
+ <*> pure (Info res)
+transformAppExp (If e1 e2 e3 loc) res =
+ AppExp <$> (If <$> transformExp e1 <*> transformExp e2 <*> transformExp e3 <*> pure loc) <*> pure (Info res)
+transformAppExp (Apply e1 e2 d loc) res =
+ AppExp <$> (Apply <$> transformExp e1 <*> transformExp e2 <*> pure d <*> pure loc) <*> pure (Info res)
+transformAppExp (DoLoop sparams pat e1 form e3 loc) res = do
+ e1' <- transformExp e1
+ form' <- case form of
+ For ident e2 -> For ident <$> transformExp e2
+ ForIn pat2 e2 -> ForIn pat2 <$> transformExp e2
+ While e2 -> While <$> transformExp e2
+ e3' <- transformExp e3
+ -- Maybe monomorphisation introduced new arrays to the loop, and
+ -- maybe they have AnyDim sizes. This is not allowed. Invent some
+ -- sizes for them.
+ (pat_sizes, pat') <- sizesForPat pat
+ return $ AppExp (DoLoop (sparams ++ pat_sizes) pat' e1' form' e3' loc) (Info res)
+transformAppExp (BinOp (fname, _) (Info t) (e1, d1) (e2, d2) loc) (AppRes ret ext) = do
+ fname' <- transformFName loc fname $ toStruct t
+ e1' <- transformExp e1
+ e2' <- transformExp e2
+ if orderZero (typeOf e1') && orderZero (typeOf e2')
+ then return $ applyOp fname' e1' e2'
+ else do
+ -- We have to flip the arguments to the function, because
+ -- operator application is left-to-right, while function
+ -- application is outside-in. This matters when the arguments
+ -- produce existential sizes. There are later places in the
+ -- compiler where we transform BinOp to Apply, but anything that
+ -- involves existential sizes will necessarily go through here.
+ (x_param_e, x_param) <- makeVarParam e1'
+ (y_param_e, y_param) <- makeVarParam e2'
+ -- XXX: the type annotations here are wrong, but hopefully it
+ -- doesn't matter as there will be an outer AppExp to handle
+ -- them.
+ return $
+ AppExp
+ ( LetPat
+ []
+ x_param
+ e1'
+ ( AppExp
+ (LetPat [] y_param e2' (applyOp fname' x_param_e y_param_e) loc)
+ (Info $ AppRes ret mempty)
+ )
+ mempty
+ )
+ (Info (AppRes ret mempty))
+ where
+ applyOp fname' x y =
+ AppExp
+ ( Apply
+ ( AppExp
+ (Apply fname' x (Info (Observe, snd (unInfo d1))) loc)
+ (Info $ AppRes ret mempty)
+ )
+ y
+ (Info (Observe, snd (unInfo d2)))
+ loc
+ )
+ (Info (AppRes ret ext))
+
+ makeVarParam arg = do
+ let argtype = typeOf arg
+ x <- newNameFromString "binop_p"
+ return
+ ( Var (qualName x) (Info argtype) mempty,
+ Id x (Info $ fromStruct argtype) mempty
+ )
+transformAppExp (LetWith id1 id2 idxs e1 body loc) res = do
+ idxs' <- mapM transformDimIndex idxs
+ e1' <- transformExp e1
+ body' <- transformExp body
+ return $ AppExp (LetWith id1 id2 idxs' e1' body' loc) (Info res)
+transformAppExp (Index e0 idxs loc) res =
+ AppExp
+ <$> (Index <$> transformExp e0 <*> mapM transformDimIndex idxs <*> pure loc)
+ <*> pure (Info res)
+transformAppExp (Match e cs loc) res =
+ AppExp
+ <$> (Match <$> transformExp e <*> mapM transformCase cs <*> pure loc)
+ <*> pure (Info res)
+
-- Monomorphization of expressions.
transformExp :: Exp -> MonoM Exp
transformExp e@Literal {} = return e
@@ -298,11 +423,9 @@
loc
transformExp (ArrayLit es t loc) =
ArrayLit <$> mapM transformExp es <*> traverse transformType t <*> pure loc
-transformExp (Range e1 me incl tp loc) = do
- e1' <- transformExp e1
- me' <- mapM transformExp me
- incl' <- mapM transformExp incl
- return $ Range e1' me' incl' tp loc
+transformExp (AppExp e res) = do
+ noticeDims $ appResType $ unInfo res
+ transformAppExp e =<< transformAppRes (unInfo res)
transformExp (Var fname (Info t) loc) = do
maybe_fs <- lookupRecordReplacement $ qualLeaf fname
case maybe_fs of
@@ -317,47 +440,6 @@
transformFName loc fname (toStruct t')
transformExp (Ascript e tp loc) =
Ascript <$> transformExp e <*> pure tp <*> pure loc
-transformExp (Coerce e tp (Info t, ext) loc) = do
- noticeDims t
- Coerce <$> transformExp e <*> pure tp
- <*> ((,) <$> (Info <$> transformType t) <*> pure ext)
- <*> pure loc
-transformExp (LetPat pat e1 e2 (Info t, retext) loc) = do
- (pat', rr) <- transformPattern pat
- t' <- transformType t
- LetPat pat' <$> transformExp e1
- <*> withRecordReplacements rr (transformExp e2)
- <*> pure (Info t', retext)
- <*> pure loc
-transformExp (LetFun fname (tparams, params, retdecl, Info ret, body) e e_t loc)
- | not $ null tparams = do
- -- Retrieve the lifted monomorphic function bindings that are produced,
- -- filter those that are monomorphic versions of the current let-bound
- -- function and insert them at this point, and propagate the rest.
- rr <- asks envRecordReplacements
- let funbind = PolyBinding rr (fname, tparams, params, ret, [], body, mempty, loc)
- pass $ do
- (e', bs) <- listen $ extendEnv fname funbind $ transformExp e
- -- Do not remember this one for next time we monomorphise this
- -- function.
- modifyLifts $ filter ((/= fname) . fst . fst)
- let (bs_local, bs_prop) = Seq.partition ((== fname) . fst) bs
- return (unfoldLetFuns (map snd $ toList bs_local) e', const bs_prop)
- | otherwise = do
- body' <- transformExp body
- LetFun fname (tparams, params, retdecl, Info ret, body')
- <$> transformExp e <*> traverse transformType e_t <*> pure loc
-transformExp (If e1 e2 e3 (tp, retext) loc) = do
- e1' <- transformExp e1
- e2' <- transformExp e2
- e3' <- transformExp e3
- tp' <- traverse transformType tp
- return $ If e1' e2' e3' (tp', retext) loc
-transformExp (Apply e1 e2 d (ret, ext) loc) = do
- e1' <- transformExp e1
- e2' <- transformExp e2
- ret' <- traverse transformType ret
- return $ Apply e1' e2' d (ret', ext) loc
transformExp (Negate e loc) =
Negate <$> transformExp e <*> pure loc
transformExp (Lambda params e0 decl tp loc) = do
@@ -394,72 +476,9 @@
loc
transformExp (ProjectSection fields (Info t) loc) =
desugarProjectSection fields t loc
-transformExp (IndexSection idxs (Info t) loc) =
- desugarIndexSection idxs t loc
-transformExp (DoLoop sparams pat e1 form e3 ret loc) = do
- e1' <- transformExp e1
- form' <- case form of
- For ident e2 -> For ident <$> transformExp e2
- ForIn pat2 e2 -> ForIn pat2 <$> transformExp e2
- While e2 -> While <$> transformExp e2
- e3' <- transformExp e3
- -- Maybe monomorphisation introduced new arrays to the loop, and
- -- maybe they have AnyDim sizes. This is not allowed. Invent some
- -- sizes for them.
- (pat_sizes, pat') <- sizesForPat pat
- return $ DoLoop (sparams ++ pat_sizes) pat' e1' form' e3' ret loc
-transformExp (BinOp (fname, _) (Info t) (e1, d1) (e2, d2) tp ext loc) = do
- fname' <- transformFName loc fname $ toStruct t
- e1' <- transformExp e1
- e2' <- transformExp e2
- if orderZero (typeOf e1') && orderZero (typeOf e2')
- then return $ applyOp fname' e1' e2'
- else do
- -- We have to flip the arguments to the function, because
- -- operator application is left-to-right, while function
- -- application is outside-in. This matters when the arguments
- -- produce existential sizes. There are later places in the
- -- compiler where we transform BinOp to Apply, but anything that
- -- involves existential sizes will necessarily go through here.
- (x_param_e, x_param) <- makeVarParam e1'
- (y_param_e, y_param) <- makeVarParam e2'
- return $
- LetPat
- x_param
- e1'
- ( LetPat
- y_param
- e2'
- (applyOp fname' x_param_e y_param_e)
- (tp, Info mempty)
- mempty
- )
- (tp, Info mempty)
- mempty
- where
- applyOp fname' x y =
- Apply
- ( Apply
- fname'
- x
- (Info (Observe, snd (unInfo d1)))
- ( Info (foldFunType [fromStruct $ fst (unInfo d2)] (unInfo tp)),
- Info mempty
- )
- loc
- )
- y
- (Info (Observe, snd (unInfo d2)))
- (tp, ext)
- loc
-
- makeVarParam arg = do
- let argtype = typeOf arg
- x <- newNameFromString "binop_p"
- return
- ( Var (qualName x) (Info argtype) mempty,
- Id x (Info $ fromStruct argtype) mempty
- )
+transformExp (IndexSection idxs (Info t) loc) = do
+ idxs' <- mapM transformDimIndex idxs
+ desugarIndexSection idxs' t loc
transformExp (Project n e tp loc) = do
maybe_fs <- case e of
Var qn _ _ -> lookupRecordReplacement (qualLeaf qn)
@@ -471,14 +490,6 @@
_ -> do
e' <- transformExp e
return $ Project n e' tp loc
-transformExp (LetWith id1 id2 idxs e1 body (Info t) loc) = do
- idxs' <- mapM transformDimIndex idxs
- e1' <- transformExp e1
- body' <- transformExp body
- t' <- transformType t
- return $ LetWith id1 id2 idxs' e1' body' (Info t') loc
-transformExp (Index e0 idxs info loc) =
- Index <$> transformExp e0 <*> mapM transformDimIndex idxs <*> pure info <*> pure loc
transformExp (Update e1 idxs e2 loc) =
Update <$> transformExp e1 <*> mapM transformDimIndex idxs
<*> transformExp e2
@@ -492,10 +503,6 @@
Assert <$> transformExp e1 <*> transformExp e2 <*> pure desc <*> pure loc
transformExp (Constr name all_es t loc) =
Constr name <$> mapM transformExp all_es <*> pure t <*> pure loc
-transformExp (Match e cs (t, retext) loc) =
- Match <$> transformExp e <*> mapM transformCase cs
- <*> ((,) <$> traverse transformType t <*> pure retext)
- <*> pure loc
transformExp (Attr info e loc) =
Attr info <$> transformExp e <*> pure loc
@@ -526,12 +533,14 @@
(v1, wrap_left, e1, p1) <- makeVarParam e_left $ fromStruct xtype
(v2, wrap_right, e2, p2) <- makeVarParam e_right $ fromStruct ytype
let apply_left =
- Apply
- op
- e1
- (Info (Observe, xext))
- (Info $ Scalar $ Arrow mempty yp (fromStruct ytype) t, Info [])
- loc
+ AppExp
+ ( Apply
+ op
+ e1
+ (Info (Observe, xext))
+ loc
+ )
+ (Info $ AppRes (Scalar $ Arrow mempty yp (fromStruct ytype) t) [])
rettype' =
let onDim (NamedDim d)
| Named p <- xp, qualLeaf d == p = NamedDim $ qualName v1
@@ -539,12 +548,14 @@
onDim d = d
in first onDim rettype
body =
- Apply
- apply_left
- e2
- (Info (Observe, yext))
- (Info rettype', Info retext)
- loc
+ AppExp
+ ( Apply
+ apply_left
+ e2
+ (Info (Observe, yext))
+ loc
+ )
+ (Info $ AppRes rettype' retext)
rettype'' = toStruct rettype'
return $ wrap_left $ wrap_right $ Lambda (p1 ++ p2) body Nothing (Info (mempty, rettype'')) loc
where
@@ -559,7 +570,7 @@
makeVarParam (Just e) argtype = do
(v, pat, var_e) <- patAndVar argtype
let wrap body =
- LetPat pat e body (Info (typeOf body), Info mempty) mempty
+ AppExp (LetPat [] pat e body mempty) (Info $ AppRes (typeOf body) mempty)
return (v, wrap, var_e, [])
makeVarParam Nothing argtype = do
(v, pat, var_e) <- patAndVar argtype
@@ -586,7 +597,7 @@
desugarIndexSection :: [DimIndex] -> PatternType -> SrcLoc -> MonoM Exp
desugarIndexSection idxs (Scalar (Arrow _ _ t1 t2)) loc = do
p <- newVName "index_i"
- let body = Index (Var (qualName p) (Info t1) loc) idxs (Info t2, Info []) loc
+ let body = AppExp (Index (Var (qualName p) (Info t1) loc) idxs loc) (Info (AppRes t2 []))
return $ Lambda [Id p (Info t1) mempty] body Nothing (Info (mempty, toStruct t2)) loc
desugarIndexSection _ t _ = error $ "desugarIndexSection: not a function type: " ++ pretty t
@@ -601,7 +612,7 @@
unfoldLetFuns :: [ValBind] -> Exp -> Exp
unfoldLetFuns [] e = e
unfoldLetFuns (ValBind _ fname _ (Info (rettype, _)) dim_params params body _ _ loc : rest) e =
- LetFun fname (dim_params, params, Nothing, Info rettype, body) e' (Info e_t) loc
+ AppExp (LetFun fname (dim_params, params, Nothing, Info rettype, body) e' loc) (Info $ AppRes e_t mempty)
where
e' = unfoldLetFuns rest e
e_t = typeOf e'
@@ -614,10 +625,7 @@
(,) <$> newVName (nameToString f) <*> transformType ft
return
( RecordPattern
- ( zip
- (map fst fs')
- (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc)
- )
+ (zip (map fst fs') (zipWith3 Id fs_ks (map Info fs_ts) $ repeat loc))
loc,
M.singleton v $ M.fromList $ zip (map fst fs') $ zip fs_ks fs_ts
)
@@ -708,7 +716,7 @@
replaceRecordReplacements rr $ do
let bind_t = foldFunType (map patternStructType params) rettype
(substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams t
- let substs' = M.map Subst substs
+ let substs' = M.map (Subst []) substs
rettype' = substTypesAny (`M.lookup` substs') rettype
substPatternType =
substTypesAny (fmap (fmap fromStruct) . (`M.lookup` substs'))
@@ -788,7 +796,10 @@
| Just t1' <- peelArray (arrayRank t1) t1,
Just t2' <- peelArray (arrayRank t1) t2 =
sub t1' t2'
- sub (Scalar (TypeVar _ _ v _)) t = addSubst v t
+ sub (Scalar (TypeVar _ _ v _)) t =
+ -- Cannot substitute intrinsic abstract types.
+ unless (baseTag (typeLeaf v) <= maxIntrinsicTag) $
+ addSubst v t
sub (Scalar (Record fields1)) (Scalar (Record fields2)) =
zipWithM_
sub
@@ -822,7 +833,7 @@
return $ NamedDim $ qualName d
Just d ->
return $ NamedDim $ qualName d
- onDim MonoAnon = return AnyDim
+ onDim (MonoAnon v) = pure $ AnyDim v
-- Perform a given substitution on the types in a pattern.
substPattern :: Bool -> (PatternType -> PatternType) -> Pattern -> Pattern
@@ -847,29 +858,29 @@
-- Remove all type variables and type abbreviations from a value binding.
removeTypeVariables :: Bool -> ValBind -> MonoM ValBind
removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _ _) = do
- subs <- asks $ M.map TypeSub . envTypeBindings
+ subs <- asks $ M.map substFromAbbr . envTypeBindings
let mapper =
ASTMapper
{ mapOnExp = astMap mapper,
mapOnName = pure,
mapOnQualName = pure,
- mapOnStructType = pure . substituteTypes subs,
- mapOnPatternType = pure . substituteTypes subs
+ mapOnStructType = pure . applySubst (`M.lookup` subs),
+ mapOnPatternType = pure . applySubst (`M.lookup` subs)
}
body' <- astMap mapper body
return
valbind
- { valBindRetType = Info (substituteTypes subs rettype, retext),
- valBindParams = map (substPattern entry $ substituteTypes subs) pats,
+ { valBindRetType = Info (applySubst (`M.lookup` subs) rettype, retext),
+ valBindParams = map (substPattern entry $ applySubst (`M.lookup` subs)) pats,
valBindBody = body'
}
removeTypeVariablesInType :: StructType -> MonoM StructType
removeTypeVariablesInType t = do
- subs <- asks $ M.map TypeSub . envTypeBindings
- return $ substituteTypes subs t
+ subs <- asks $ M.map substFromAbbr . envTypeBindings
+ return $ applySubst (`M.lookup` subs) t
transformValBind :: ValBind -> MonoM Env
transformValBind valbind = do
@@ -883,16 +894,17 @@
foldFunType
(map patternStructType (valBindParams valbind))
$ fst $ unInfo $ valBindRetType valbind
- (name, _, valbind'') <- monomorphiseBinding True valbind' $ monoType t
+ (name, infer, valbind'') <- monomorphiseBinding True valbind' $ monoType t
tell $ Seq.singleton (name, valbind'' {valBindEntryPoint = valBindEntryPoint valbind})
+ addLifted (valBindName valbind) (monoType t) (name, infer)
return mempty {envPolyBindings = M.singleton (valBindName valbind) valbind'}
transformTypeBind :: TypeBind -> MonoM Env
transformTypeBind (TypeBind name l tparams tydecl _ _) = do
- subs <- asks $ M.map TypeSub . envTypeBindings
+ subs <- asks $ M.map substFromAbbr . envTypeBindings
noticeDims $ unInfo $ expandedType tydecl
- let tp = substituteTypes subs . unInfo $ expandedType tydecl
+ let tp = applySubst (`M.lookup` subs) . unInfo $ expandedType tydecl
tbinding = TypeAbbr l tparams tp
return mempty {envTypeBindings = M.singleton name tbinding}
diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs
--- a/src/Futhark/Internalise/TypesValues.hs
+++ b/src/Futhark/Internalise/TypesValues.hs
@@ -32,7 +32,7 @@
internaliseUniqueness E.Nonunique = I.Nonunique
internaliseUniqueness E.Unique = I.Unique
-type TypeState = Int
+newtype TypeState = TypeState {typeCounter :: Int}
newtype InternaliseTypeM a
= InternaliseTypeM (StateT TypeState InternaliseM a)
@@ -45,7 +45,7 @@
InternaliseTypeM a ->
InternaliseM a
runInternaliseTypeM (InternaliseTypeM m) =
- evalStateT m 0
+ evalStateT m $ TypeState 0
internaliseParamTypes ::
[E.TypeBase (E.DimDecl VName) ()] ->
@@ -56,22 +56,35 @@
onType = fromMaybe bad . hasStaticShape
bad = error $ "internaliseParamTypes: " ++ pretty ts
+-- We need to fix up the arrays for any Acc return values or loop
+-- parameters. We look at the concrete types for this, since the Acc
+-- parameter name in the second list will just be something we made up.
+fixupTypes :: [TypeBase shape1 u1] -> [TypeBase shape2 u2] -> [TypeBase shape2 u2]
+fixupTypes = zipWith fixup
+ where
+ fixup (Acc acc ispace ts _) (Acc _ _ _ u2) = Acc acc ispace ts u2
+ fixup _ t = t
+
internaliseLoopParamType ::
E.TypeBase (E.DimDecl VName) () ->
+ [TypeBase shape u] ->
InternaliseM [I.TypeBase Shape Uniqueness]
-internaliseLoopParamType et =
- concat <$> internaliseParamTypes [et]
+internaliseLoopParamType et ts =
+ fixupTypes ts . concat <$> internaliseParamTypes [et]
internaliseReturnType ::
E.TypeBase (E.DimDecl VName) () ->
+ [TypeBase shape u] ->
InternaliseM [I.TypeBase ExtShape Uniqueness]
-internaliseReturnType et =
- runInternaliseTypeM (internaliseTypeM et)
+internaliseReturnType et ts =
+ fixupTypes ts <$> runInternaliseTypeM (internaliseTypeM et)
internaliseLambdaReturnType ::
E.TypeBase (E.DimDecl VName) () ->
+ [TypeBase shape u] ->
InternaliseM [I.TypeBase Shape NoUniqueness]
-internaliseLambdaReturnType = fmap (map fromDecl) . internaliseLoopParamType
+internaliseLambdaReturnType et ts =
+ map fromDecl <$> internaliseLoopParamType et ts
-- | As 'internaliseReturnType', but returns components of a top-level
-- tuple type piecemeal.
@@ -79,11 +92,10 @@
E.TypeBase (E.DimDecl VName) () ->
InternaliseM [[I.TypeBase ExtShape Uniqueness]]
internaliseEntryReturnType et =
- runInternaliseTypeM $
- mapM internaliseTypeM $
- case E.isTupleRecord et of
- Just ets | not $ null ets -> ets
- _ -> [et]
+ runInternaliseTypeM . mapM internaliseTypeM $
+ case E.isTupleRecord et of
+ Just ets | not $ null ets -> ets
+ _ -> [et]
internaliseType ::
E.TypeBase (E.DimDecl VName) () ->
@@ -92,8 +104,8 @@
newId :: InternaliseTypeM Int
newId = do
- i <- get
- put $ i + 1
+ i <- gets typeCounter
+ modify $ \s -> s {typeCounter = i + 1}
return i
internaliseDim ::
@@ -101,7 +113,7 @@
InternaliseTypeM ExtSize
internaliseDim d =
case d of
- E.AnyDim -> Ext <$> newId
+ E.AnyDim _ -> Ext <$> newId
E.ConstDim n -> return $ Free $ intConst I.Int64 $ toInteger n
E.NamedDim name -> namedDim name
where
@@ -123,11 +135,18 @@
E.Scalar (E.Prim bt) ->
return [I.Prim $ internalisePrimType bt]
E.Scalar (E.Record ets)
- -- XXX: we map empty records to bools, because otherwise
+ -- XXX: we map empty records to units, because otherwise
-- arrays of unit will lose their sizes.
- | null ets -> return [I.Prim I.Bool]
+ | null ets -> return [I.Prim I.Unit]
| otherwise ->
concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets)
+ E.Scalar (E.TypeVar _ u tn [E.TypeArgType arr_t _])
+ | baseTag (E.typeLeaf tn) <= E.maxIntrinsicTag,
+ baseString (E.typeLeaf tn) == "acc" -> do
+ ts <- map (fromDecl . onAccType) <$> internaliseTypeM arr_t
+ acc_param <- liftInternaliseM $ newVName "acc_cert"
+ let acc_t = Acc acc_param (Shape [arraysSize 0 ts]) (map rowType ts) $ internaliseUniqueness u
+ return [acc_t]
E.Scalar E.TypeVar {} ->
error "internaliseTypeM: cannot handle type variable."
E.Scalar E.Arrow {} ->
@@ -139,6 +158,9 @@
return $ I.Prim (I.IntType I.Int8) : ts
where
internaliseShape = mapM internaliseDim . E.shapeDims
+
+ onAccType = fromMaybe bad . hasStaticShape
+ bad = error $ "internaliseTypeM Acc: " ++ pretty orig_t
internaliseConstructors ::
M.Map Name [I.TypeBase ExtShape Uniqueness] ->
diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs
--- a/src/Futhark/Optimise/Fusion.hs
+++ b/src/Futhark/Optimise/Fusion.hs
@@ -804,10 +804,6 @@
foldM fusionGatherExp fres $ map (BasicOp . SubExp) res
fusionGatherExp :: FusedRes -> Exp -> FusionGM FusedRes
------------------------------------------
----- Index/If ----
------------------------------------------
-
fusionGatherExp fres (DoLoop ctx val form loop_body) = do
fres' <- addNamesToInfusible fres $ freeIn form <> freeIn ctx <> freeIn val
let form_idents =
@@ -834,6 +830,9 @@
let both_res = then_res <> else_res
fres' <- fusionGatherSubExp fres cond
mergeFusionRes fres' both_res
+fusionGatherExp fres (WithAcc inps lam) = do
+ (_, fres') <- fusionGatherLam (mempty, fres) lam
+ addNamesToInfusible fres' $ freeIn inps
-----------------------------------------------------------------------------------
--- Errors: all SOACs, (because normalization ensures they appear
diff --git a/src/Futhark/Optimise/Fusion/LoopKernel.hs b/src/Futhark/Optimise/Fusion/LoopKernel.hs
--- a/src/Futhark/Optimise/Fusion/LoopKernel.hs
+++ b/src/Futhark/Optimise/Fusion/LoopKernel.hs
@@ -593,7 +593,7 @@
inp2_arr
res_lam'' = res_lam' {lambdaParams = chunk1 : lambdaParams res_lam'}
unfus_accs = take (length nes1) outVars
- unfus_arrs = filter (`nameIn` unfus_set) outVars
+ unfus_arrs = filter (`notElem` unfus_accs) $ filter (`nameIn` unfus_set) outVars
res_form <- mergeForms form2 form1
return
( unfus_accs ++ out_kernms ++ unfus_arrs,
diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs
--- a/src/Futhark/Optimise/InliningDeadFun.hs
+++ b/src/Futhark/Optimise/InliningDeadFun.hs
@@ -227,7 +227,7 @@
Let pat (withAttrs (attrsForAssert attrs) aux) $
case caller_safety of
Safe -> BasicOp $ Assert cond desc (loc, locs ++ more_locs)
- Unsafe -> BasicOp $ SubExp $ Constant Checked
+ Unsafe -> BasicOp $ SubExp $ Constant UnitValue
onStm (Let pat aux (Op soac)) =
Let pat (withAttrs attrs' aux) $
Op $
diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs
--- a/src/Futhark/Optimise/Simplify.hs
+++ b/src/Futhark/Optimise/Simplify.hs
@@ -47,7 +47,10 @@
(UT.usages $ foldMap freeIn funs)
(mempty, consts)
- funs' <- parPass (simplifyFun' consts_vtable) funs
+ -- We deepen the vtable so it will look like the constants are in an
+ -- "outer loop"; this communicates useful information to some
+ -- simplification rules (e.g. seee issue #1302).
+ funs' <- parPass (simplifyFun' $ ST.deepen consts_vtable) funs
let funs_uses = UT.usages $ foldMap freeIn funs'
(_, consts'') <- simplifyConsts funs_uses (mempty, consts')
diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs
--- a/src/Futhark/Optimise/Simplify/Engine.hs
+++ b/src/Futhark/Optimise/Simplify/Engine.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -384,11 +385,13 @@
emptyOfType :: MonadBinder m => [VName] -> Type -> m (Exp (Lore m))
emptyOfType _ Mem {} =
error "emptyOfType: Cannot hoist non-existential memory."
+emptyOfType _ Acc {} =
+ error "emptyOfType: Cannot hoist accumulator."
emptyOfType _ (Prim pt) =
return $ BasicOp $ SubExp $ Constant $ blankPrimValue pt
-emptyOfType ctx_names (Array pt shape _) = do
+emptyOfType ctx_names (Array et shape _) = do
let dims = map zeroIfContext $ shapeDims shape
- return $ BasicOp $ Scratch pt dims
+ return $ BasicOp $ Scratch et dims
where
zeroIfContext (Var v) | v `elem` ctx_names = intConst Int32 0
zeroIfContext se = se
@@ -531,11 +534,9 @@
Result ->
SimpleM lore (Body (Wise lore))
constructBody stms res =
- fmap fst $
- runBinder $
- insertStmsM $ do
- addStms stms
- resultBodyM res
+ fmap fst . runBinder . buildBody_ $ do
+ addStms stms
+ pure res
type SimplifiedBody lore a = ((a, UT.UsageTable), Stms (Wise lore))
@@ -835,6 +836,18 @@
simplifyExp (Op op) = do
(op', stms) <- simplifyOp op
return (Op op', stms)
+simplifyExp (WithAcc inputs lam) = do
+ (inputs', inputs_stms) <- fmap unzip . forM inputs $ \(shape, arrs, op) -> do
+ (op', op_stms) <- case op of
+ Nothing ->
+ pure (Nothing, mempty)
+ Just (op_lam, nes) -> do
+ (op_lam', op_lam_stms) <- simplifyLambda op_lam
+ nes' <- simplify nes
+ return (Just (op_lam', nes'), op_lam_stms)
+ (,op_stms) <$> ((,,op') <$> simplify shape <*> simplify arrs)
+ (lam', lam_stms) <- simplifyLambda lam
+ pure (WithAcc inputs' lam', mconcat inputs_stms <> lam_stms)
-- Special case for simplification of commutative BinOps where we
-- arrange the operands in sorted order. This can make expressions
@@ -961,10 +974,14 @@
simplify (ScalarSpace ds t) = ScalarSpace <$> simplify ds <*> pure t
simplify s = pure s
+instance Simplifiable PrimType where
+ simplify = pure
+
instance Simplifiable shape => Simplifiable (TypeBase shape u) where
- simplify (Array et shape u) = do
- shape' <- simplify shape
- return $ Array et shape' u
+ simplify (Array et shape u) =
+ Array <$> simplify et <*> simplify shape <*> pure u
+ simplify (Acc acc ispace ts u) =
+ Acc <$> simplify acc <*> simplify ispace <*> simplify ts <*> pure u
simplify (Mem space) =
Mem <$> simplify space
simplify (Prim bt) =
@@ -1019,7 +1036,7 @@
check idd = do
vv <- ST.lookupSubExp idd <$> askVtable
case vv of
- Just (Constant Checked, Certificates cs) -> return cs
+ Just (Constant _, Certificates cs) -> return cs
Just (Var idd', _) -> return [idd']
_ -> return [idd]
diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs
--- a/src/Futhark/Optimise/Simplify/Rules.hs
+++ b/src/Futhark/Optimise/Simplify/Rules.hs
@@ -22,7 +22,7 @@
import Control.Monad
import Data.Either
-import Data.List (find)
+import Data.List (find, unzip4, zip4)
import qualified Data.Map.Strict as M
import Data.Maybe
import Futhark.Analysis.PrimExp.Convert
@@ -41,12 +41,14 @@
topDownRules =
[ RuleGeneric constantFoldPrimFun,
RuleIf ruleIf,
- RuleIf hoistBranchInvariant
+ RuleIf hoistBranchInvariant,
+ RuleGeneric withAccTopDown
]
bottomUpRules :: BinderOps lore => [BottomUpRule lore]
bottomUpRules =
[ RuleIf removeDeadBranchResult,
+ RuleGeneric withAccBottomUp,
RuleBasicOp simplifyIndex
]
@@ -68,17 +70,18 @@
where
-- We need to make sure we can even consume the original. The big
-- missing piece here is that we cannot do copy removal inside of
- -- 'map' and other SOACs, but those cases tend to be handled in
- -- later representations anyway.
- consumable = case M.lookup v $ ST.toScope vtable of
- Just (FParamName info) -> unique $ declTypeOf info
- _ -> fromMaybe False $ do
- e <- ST.lookup v vtable
- pat <- stmPattern <$> ST.entryStm e
- guard $ ST.entryDepth e == ST.loopDepth vtable
- pe <- find ((== v) . patElemName) (patternElements pat)
- guard $ aliasesOf pe == mempty
- pure True
+ -- 'map' and other SOACs, but that is handled by SOAC-specific rules.
+ consumable = fromMaybe False $ do
+ e <- ST.lookup v vtable
+ guard $ ST.entryDepth e == ST.loopDepth vtable
+ consumableStm e `mplus` consumableFParam e
+ consumableFParam =
+ Just . maybe False (unique . declTypeOf) . ST.entryFParam
+ consumableStm e = do
+ pat <- stmPattern <$> ST.entryStm e
+ pe <- find ((== v) . patElemName) (patternElements pat)
+ guard $ aliasesOf pe == mempty
+ pure True
removeUnnecessaryCopy _ _ _ _ = Skip
constantFoldPrimFun :: BinderOps lore => TopDownRuleGeneric lore
@@ -258,10 +261,10 @@
hoisted pe (Left i) = return $ Left $ Just (i, Var $ patElemName pe)
hoisted _ Right {} = return $ Left Nothing
- reshapeBodyResults body rets = insertStmsM $ do
+ reshapeBodyResults body rets = buildBody_ $ do
ses <- bodyBind body
let (ctx_ses, val_ses) = splitFromEnd (length rets) ses
- resultBodyM . (ctx_ses ++) =<< zipWithM reshapeResult val_ses rets
+ (ctx_ses ++) <$> zipWithM reshapeResult val_ses rets
reshapeResult (Var v) t@Array {} = do
v_t <- lookupType v
let newshape = arrayDims $ removeExistentials t v_t
@@ -296,6 +299,106 @@
rettype' = pick rettype
in Simplify $ letBind (Pattern [] pat') $ If e1 tb' fb' $ IfDec rettype' ifsort
| otherwise = Skip
+
+withAccTopDown :: BinderOps lore => TopDownRuleGeneric lore
+-- A WithAcc with no accumulators is sent to Valhalla.
+withAccTopDown _ (Let pat aux (WithAcc [] lam)) = Simplify . auxing aux $ do
+ lam_res <- bodyBind $ lambdaBody lam
+ forM_ (zip (patternNames pat) lam_res) $ \(v, se) ->
+ letBindNames [v] $ BasicOp $ SubExp se
+-- Identify those results in 'lam' that are free and move them out.
+withAccTopDown vtable (Let pat aux (WithAcc inputs lam)) = Simplify . auxing aux $ do
+ let (cert_params, acc_params) =
+ splitAt (length inputs) $ lambdaParams lam
+ (acc_res, nonacc_res) =
+ splitFromEnd num_nonaccs $ bodyResult $ lambdaBody lam
+ (acc_pes, nonacc_pes) =
+ splitFromEnd num_nonaccs $ patternElements pat
+
+ -- Look at accumulator results.
+ (acc_pes', inputs', params', acc_res') <-
+ fmap (unzip4 . catMaybes) . mapM tryMoveAcc $
+ zip4
+ (chunks (map inputArrs inputs) acc_pes)
+ inputs
+ (zip cert_params acc_params)
+ acc_res
+ let (cert_params', acc_params') = unzip params'
+
+ -- Look at non-accumulator results.
+ (nonacc_pes', nonacc_res') <-
+ unzip . catMaybes <$> mapM tryMoveNonAcc (zip nonacc_pes nonacc_res)
+
+ when (concat acc_pes' == acc_pes && nonacc_pes' == nonacc_pes) cannotSimplify
+
+ lam' <-
+ mkLambda (cert_params' ++ acc_params') $
+ bodyBind $ (lambdaBody lam) {bodyResult = acc_res' <> nonacc_res'}
+
+ letBind (Pattern [] (concat acc_pes' <> nonacc_pes')) $ WithAcc inputs' lam'
+ where
+ num_nonaccs = length (lambdaReturnType lam) - length inputs
+ inputArrs (_, arrs, _) = length arrs
+
+ tryMoveAcc (pes, (_, arrs, _), (_, acc_p), Var v)
+ | paramName acc_p == v = do
+ forM_ (zip pes arrs) $ \(pe, arr) ->
+ letBindNames [patElemName pe] $ BasicOp $ SubExp $ Var arr
+ pure Nothing
+ tryMoveAcc x =
+ pure $ Just x
+
+ tryMoveNonAcc (pe, Var v)
+ | v `ST.elem` vtable = do
+ letBindNames [patElemName pe] $ BasicOp $ SubExp $ Var v
+ pure Nothing
+ tryMoveNonAcc (pe, Constant v) = do
+ letBindNames [patElemName pe] $ BasicOp $ SubExp $ Constant v
+ pure Nothing
+ tryMoveNonAcc x =
+ pure $ Just x
+withAccTopDown _ _ = Skip
+
+withAccBottomUp :: BinderOps lore => BottomUpRuleGeneric lore
+-- Eliminate dead results.
+withAccBottomUp (_, utable) (Let pat aux (WithAcc inputs lam))
+ | not $ all (`UT.used` utable) $ patternNames pat = Simplify $ do
+ let (acc_res, nonacc_res) =
+ splitFromEnd num_nonaccs $ bodyResult $ lambdaBody lam
+ (acc_pes, nonacc_pes) =
+ splitFromEnd num_nonaccs $ patternElements pat
+ (cert_params, acc_params) =
+ splitAt (length inputs) $ lambdaParams lam
+
+ -- Eliminate unused accumulator results
+ let (acc_pes', inputs', param_pairs, acc_res') =
+ unzip4 . filter keepAccRes $
+ zip4
+ (chunks (map inputArrs inputs) acc_pes)
+ inputs
+ (zip cert_params acc_params)
+ acc_res
+ (cert_params', acc_params') = unzip param_pairs
+
+ -- Eliminate unused non-accumulator results
+ let (nonacc_pes', nonacc_res') =
+ unzip $ filter keepNonAccRes $ zip nonacc_pes nonacc_res
+
+ when (concat acc_pes' == acc_pes && nonacc_pes' == nonacc_pes) cannotSimplify
+
+ let pes' = concat acc_pes' ++ nonacc_pes'
+
+ lam' <- mkLambda (cert_params' ++ acc_params') $ do
+ void $ bodyBind $ lambdaBody lam
+ pure $ acc_res' ++ nonacc_res'
+
+ auxing aux $ letBind (Pattern [] pes') $ WithAcc inputs' lam'
+ where
+ num_nonaccs = length (lambdaReturnType lam) - length inputs
+ inputArrs (_, arrs, _) = length arrs
+ keepAccRes (pes, _, _, _) = any ((`UT.used` utable) . patElemName) pes
+ keepNonAccRes (pe, _) = patElemName pe `UT.used` utable
+withAccBottomUp _ _ = Skip
-- Some helper functions
diff --git a/src/Futhark/Optimise/Simplify/Rules/Loop.hs b/src/Futhark/Optimise/Simplify/Rules/Loop.hs
--- a/src/Futhark/Optimise/Simplify/Rules/Loop.hs
+++ b/src/Futhark/Optimise/Simplify/Rules/Loop.hs
@@ -223,9 +223,9 @@
if maybe_loop_vars == map Just loop_vars
then cannotSimplify
else do
- body' <- insertStmsM $ do
+ body' <- buildBody_ $ do
addStms $ mconcat body_prefix_stms
- resultBodyM =<< bodyBind body
+ bodyBind body
auxing aux $
letBind pat $
DoLoop
@@ -296,10 +296,9 @@
Simplify $ do
i' <- newVName $ baseString i
let form' = ForLoop i' it' n' []
- body' <- insertStmsM $
- inScopeOf form' $ do
- letBindNames [i] $ BasicOp $ ConvOp (SExt it' Int64) (Var i')
- pure body
+ body' <- insertStmsM . inScopeOf form' $ do
+ letBindNames [i] $ BasicOp $ ConvOp (SExt it' Int64) (Var i')
+ pure body
auxing aux $
certifying cs $
letBind pat $ DoLoop ctx val form' body'
diff --git a/src/Futhark/Optimise/Simplify/Rules/Simple.hs b/src/Futhark/Optimise/Simplify/Rules/Simple.hs
--- a/src/Futhark/Optimise/Simplify/Rules/Simple.hs
+++ b/src/Futhark/Optimise/Simplify/Rules/Simple.hs
@@ -246,7 +246,7 @@
-- If expression is true then just replace assertion.
simplifyAssert :: SimpleRule lore
simplifyAssert _ _ (Assert (Constant (BoolValue True)) _ _) =
- constRes Checked
+ constRes UnitValue
simplifyAssert _ _ _ =
Nothing
diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs
--- a/src/Futhark/Optimise/Sink.hs
+++ b/src/Futhark/Optimise/Sink.hs
@@ -49,7 +49,6 @@
import Data.Bifunctor
import Data.List (foldl')
import qualified Data.Map as M
-import qualified Data.Set as S
import qualified Futhark.Analysis.Alias as Alias
import qualified Futhark.Analysis.SymbolTable as ST
import Futhark.IR.Aliases
@@ -61,7 +60,7 @@
type Sinking lore = M.Map VName (Stm lore)
-type Sunk = S.Set VName
+type Sunk = Names
type Sinker lore a = SymbolTable lore -> Sinking lore -> a -> (a, Sunk)
@@ -91,8 +90,8 @@
Sinker lore (Op lore) ->
Sinker lore (Body lore)
optimiseBranch onOp vtable sinking (Body dec stms res) =
- let (stms', stms_sunk) = optimiseStms onOp vtable sinking' stms $ freeIn res
- in ( Body dec (sunk_stms <> stms') res,
+ let (stms', stms_sunk) = optimiseStms onOp vtable sinking' (sunk_stms <> stms) $ freeIn res
+ in ( Body dec stms' res,
sunk <> stms_sunk
)
where
@@ -102,7 +101,7 @@
sunkHere v stm =
v `nameIn` free_in_stms
&& all (`ST.available` vtable) (namesToList (freeIn stm))
- sunk = S.fromList $ concatMap (patternNames . stmPattern) sunk_stms
+ sunk = namesFromList $ foldMap (patternNames . stmPattern) sunk_stms
optimiseStms ::
Constraints lore =>
@@ -131,7 +130,7 @@
maybe True (== 1) $ M.lookup (patElemName pe) multiplicities =
let (stms', sunk) =
optimiseStms' vtable' (M.insert (patElemName pe) stm sinking) stms
- in if patElemName pe `S.member` sunk
+ in if patElemName pe `nameIn` sunk
then (stms', sunk)
else (stm : stms', sunk)
| If cond tbranch fbranch ret <- stmExp stm =
diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs
--- a/src/Futhark/Pass/ExpandAllocations.hs
+++ b/src/Futhark/Pass/ExpandAllocations.hs
@@ -69,6 +69,12 @@
transformBody :: Body KernelsMem -> ExpandM (Body KernelsMem)
transformBody (Body () stms res) = Body () <$> transformStms stms <*> pure res
+transformLambda :: Lambda KernelsMem -> ExpandM (Lambda KernelsMem)
+transformLambda (Lambda params body ret) =
+ Lambda params
+ <$> localScope (scopeOfLParams params) (transformBody body)
+ <*> pure ret
+
transformStms :: Stms KernelsMem -> ExpandM (Stms KernelsMem)
transformStms stms =
inScopeOf stms $ mconcat <$> mapM transformStm (stmsToList stms)
@@ -104,12 +110,6 @@
{ mapOnBody = \scope -> localScope scope . transformBody
}
-nameInfoConv :: NameInfo KernelsMem -> NameInfo KernelsMem
-nameInfoConv (LetName mem_info) = LetName mem_info
-nameInfoConv (FParamName mem_info) = FParamName mem_info
-nameInfoConv (LParamName mem_info) = LParamName mem_info
-nameInfoConv (IndexName it) = IndexName it
-
transformExp :: Exp KernelsMem -> ExpandM (Stms KernelsMem, Exp KernelsMem)
transformExp (Op (Inner (SegOp (SegMap lvl space ts kbody)))) = do
(alloc_stms, (_, kbody')) <- transformScanRed lvl space [] kbody
@@ -143,6 +143,47 @@
where
lams = map histOp ops
onOp op lam = op {histOp = lam}
+transformExp (WithAcc inputs lam) = do
+ lam' <- transformLambda lam
+ (input_alloc_stms, inputs') <- unzip <$> mapM onInput inputs
+ pure
+ ( mconcat input_alloc_stms,
+ WithAcc inputs' lam'
+ )
+ where
+ onInput (shape, arrs, Nothing) =
+ pure (mempty, (shape, arrs, Nothing))
+ onInput (shape, arrs, Just (op_lam, nes)) = do
+ bound_outside <- asks $ namesFromList . M.keys
+ let -- XXX: fake a SegLevel, which we don't have here. We will not
+ -- use it for anything, as we will not allow irregular
+ -- allocations inside the update function.
+ lvl = SegThread (Count $ intConst Int64 0) (Count $ intConst Int64 0) SegNoVirt
+ (op_lam', lam_allocs) =
+ extractLambdaAllocations (lvl, [0]) bound_outside mempty op_lam
+ variantAlloc (_, Var v, _) = not $ v `nameIn` bound_outside
+ variantAlloc _ = False
+ (variant_allocs, invariant_allocs) = M.partition variantAlloc lam_allocs
+
+ case M.elems variant_allocs of
+ (_, v, _) : _ ->
+ throwError $
+ "Cannot handle un-sliceable allocation size: " ++ pretty v
+ ++ "\nLikely cause: irregular nested operations inside accumulator update operator."
+ [] ->
+ return ()
+
+ let num_is = shapeRank shape
+ is = map paramName $ take num_is $ lambdaParams op_lam
+ (alloc_stms, alloc_offsets) <-
+ genericExpandedInvariantAllocations (const (shape, map le64 is)) invariant_allocs
+
+ scope <- askScope
+ let scope' = scopeOf op_lam <> scope
+ either throwError pure $
+ runOffsetM scope' alloc_offsets $ do
+ op_lam'' <- offsetMemoryInLambda op_lam'
+ return (alloc_stms, (shape, arrs, Just (op_lam'', nes)))
transformExp e =
return (mempty, e)
@@ -154,13 +195,14 @@
ExpandM (Stms KernelsMem, ([Lambda KernelsMem], KernelBody KernelsMem))
transformScanRed lvl space ops kbody = do
bound_outside <- asks $ namesFromList . M.keys
- let (kbody', kbody_allocs) =
- extractKernelBodyAllocations lvl bound_outside bound_in_kernel kbody
- (ops', ops_allocs) = unzip $ map (extractLambdaAllocations lvl bound_outside mempty) ops
+ let user = (lvl, [le64 $ segFlat space])
+ (kbody', kbody_allocs) =
+ extractKernelBodyAllocations user bound_outside bound_in_kernel kbody
+ (ops', ops_allocs) = unzip $ map (extractLambdaAllocations user bound_outside mempty) ops
variantAlloc (_, Var v, _) = not $ v `nameIn` bound_outside
variantAlloc _ = False
- allocs = kbody_allocs <> mconcat ops_allocs
- (variant_allocs, invariant_allocs) = M.partition variantAlloc allocs
+ (variant_allocs, invariant_allocs) =
+ M.partition variantAlloc $ kbody_allocs <> mconcat ops_allocs
badVariant (_, Var v, _) = not $ v `nameIn` bound_in_kernel
badVariant _ = False
@@ -209,7 +251,7 @@
invariant_allocs
scope <- askScope
- let scope' = scopeOfSegSpace space <> M.map nameInfoConv scope
+ let scope' = scopeOfSegSpace space <> scope
either throwError pure $
runOffsetM scope' alloc_offsets $ do
kbody'' <- offsetMemoryInKernelBody kbody'
@@ -224,19 +266,18 @@
ExpandM (RebaseMap, Stms KernelsMem)
memoryRequirements lvl space kstms variant_allocs invariant_allocs = do
(num_threads, num_threads_stms) <-
- runBinder $
- letSubExp "num_threads" $
- BasicOp $
- BinOp
- (Mul Int64 OverflowUndef)
- (unCount $ segNumGroups lvl)
- (unCount $ segGroupSize lvl)
+ runBinder . letSubExp "num_threads" . BasicOp $
+ BinOp
+ (Mul Int64 OverflowUndef)
+ (unCount $ segNumGroups lvl)
+ (unCount $ segGroupSize lvl)
(invariant_alloc_stms, invariant_alloc_offsets) <-
inScopeOf num_threads_stms $
expandedInvariantAllocations
- (num_threads, segNumGroups lvl, segGroupSize lvl)
- space
+ num_threads
+ (segNumGroups lvl)
+ (segGroupSize lvl)
invariant_allocs
(variant_alloc_stms, variant_alloc_offsets) <-
@@ -252,12 +293,16 @@
num_threads_stms <> invariant_alloc_stms <> variant_alloc_stms
)
+-- | Identifying the spot where an allocation occurs in terms of its
+-- level and unique thread ID.
+type User = (SegLevel, [TPrimExp Int64 VName])
+
-- | A description of allocations that have been extracted, and how
-- much memory (and which space) is needed.
-type Extraction = M.Map VName (SegLevel, SubExp, Space)
+type Extraction = M.Map VName (User, SubExp, Space)
extractKernelBodyAllocations ::
- SegLevel ->
+ User ->
Names ->
Names ->
KernelBody KernelsMem ->
@@ -269,27 +314,27 @@
\stms kbody -> kbody {kernelBodyStms = stms}
extractBodyAllocations ::
- SegLevel ->
+ User ->
Names ->
Names ->
Body KernelsMem ->
(Body KernelsMem, Extraction)
-extractBodyAllocations lvl bound_outside bound_kernel =
- extractGenericBodyAllocations lvl bound_outside bound_kernel bodyStms $
+extractBodyAllocations user bound_outside bound_kernel =
+ extractGenericBodyAllocations user bound_outside bound_kernel bodyStms $
\stms body -> body {bodyStms = stms}
extractLambdaAllocations ::
- SegLevel ->
+ User ->
Names ->
Names ->
Lambda KernelsMem ->
(Lambda KernelsMem, Extraction)
-extractLambdaAllocations lvl bound_outside bound_kernel lam = (lam {lambdaBody = body'}, allocs)
+extractLambdaAllocations user bound_outside bound_kernel lam = (lam {lambdaBody = body'}, allocs)
where
- (body', allocs) = extractBodyAllocations lvl bound_outside bound_kernel $ lambdaBody lam
+ (body', allocs) = extractBodyAllocations user bound_outside bound_kernel $ lambdaBody lam
extractGenericBodyAllocations ::
- SegLevel ->
+ User ->
Names ->
Names ->
(body -> Stms KernelsMem) ->
@@ -298,12 +343,12 @@
( body,
Extraction
)
-extractGenericBodyAllocations lvl bound_outside bound_kernel get_stms set_stms body =
+extractGenericBodyAllocations user bound_outside bound_kernel get_stms set_stms body =
let bound_kernel' = bound_kernel <> boundByStms (get_stms body)
(stms, allocs) =
runWriter $
fmap catMaybes $
- mapM (extractStmAllocations lvl bound_outside bound_kernel') $
+ mapM (extractStmAllocations user bound_outside bound_kernel') $
stmsToList $ get_stms body
in (set_stms (stmsFromList stms) body, allocs)
@@ -315,122 +360,114 @@
notScalar _ = True
extractStmAllocations ::
- SegLevel ->
+ User ->
Names ->
Names ->
Stm KernelsMem ->
Writer Extraction (Maybe (Stm KernelsMem))
-extractStmAllocations lvl bound_outside bound_kernel (Let (Pattern [] [patElem]) _ (Op (Alloc size space)))
+extractStmAllocations user bound_outside bound_kernel (Let (Pattern [] [patElem]) _ (Op (Alloc size space)))
| expandable space && expandableSize size
-- FIXME: the '&& notScalar space' part is a hack because we
-- don't otherwise hoist the sizes out far enough, and we
-- promise to be super-duper-careful about not having variant
-- scalar allocations.
|| (boundInKernel size && notScalar space) = do
- tell $ M.singleton (patElemName patElem) (lvl, size, space)
+ tell $ M.singleton (patElemName patElem) (user, size, space)
return Nothing
where
expandableSize (Var v) = v `nameIn` bound_outside || v `nameIn` bound_kernel
expandableSize Constant {} = True
boundInKernel (Var v) = v `nameIn` bound_kernel
boundInKernel Constant {} = False
-extractStmAllocations lvl bound_outside bound_kernel stm = do
- e <- mapExpM (expMapper lvl) $ stmExp stm
+extractStmAllocations user bound_outside bound_kernel stm = do
+ e <- mapExpM (expMapper user) $ stmExp stm
return $ Just $ stm {stmExp = e}
where
- expMapper lvl' =
+ expMapper user' =
identityMapper
- { mapOnBody = const $ onBody lvl',
- mapOnOp = onOp
+ { mapOnBody = const $ onBody user',
+ mapOnOp = onOp user'
}
- onBody lvl' body = do
- let (body', allocs) = extractBodyAllocations lvl' bound_outside bound_kernel body
+ onBody user' body = do
+ let (body', allocs) = extractBodyAllocations user' bound_outside bound_kernel body
tell allocs
return body'
- onOp (Inner (SegOp op)) =
- Inner . SegOp <$> mapSegOpM (opMapper (segLevel op)) op
- onOp op = return op
+ onOp (_, user_ids) (Inner (SegOp op)) =
+ Inner . SegOp <$> mapSegOpM (opMapper user'') op
+ where
+ user'' =
+ (segLevel op, user_ids ++ [le64 (segFlat (segSpace op))])
+ onOp _ op = return op
- opMapper lvl' =
+ opMapper user' =
identitySegOpMapper
- { mapOnSegOpLambda = onLambda lvl',
- mapOnSegOpBody = onKernelBody lvl'
+ { mapOnSegOpLambda = onLambda user',
+ mapOnSegOpBody = onKernelBody user'
}
- onKernelBody lvl' body = do
- let (body', allocs) = extractKernelBodyAllocations lvl' bound_outside bound_kernel body
+ onKernelBody user' body = do
+ let (body', allocs) = extractKernelBodyAllocations user' bound_outside bound_kernel body
tell allocs
return body'
- onLambda lvl' lam = do
- body <- onBody lvl' $ lambdaBody lam
+ onLambda user' lam = do
+ body <- onBody user' $ lambdaBody lam
return lam {lambdaBody = body}
-expandedInvariantAllocations ::
- ( SubExp,
- Count NumGroups SubExp,
- Count GroupSize SubExp
- ) ->
- SegSpace ->
- Extraction ->
- ExpandM (Stms KernelsMem, RebaseMap)
-expandedInvariantAllocations
- ( num_threads,
- Count num_groups,
- Count group_size
- )
- segspace
- invariant_allocs = do
- -- We expand the invariant allocations by adding an inner dimension
- -- equal to the number of kernel threads.
- (alloc_bnds, rebases) <- unzip <$> mapM expand (M.toList invariant_allocs)
+genericExpandedInvariantAllocations ::
+ (User -> (Shape, [TPrimExp Int64 VName])) -> Extraction -> ExpandM (Stms KernelsMem, RebaseMap)
+genericExpandedInvariantAllocations getNumUsers invariant_allocs = do
+ -- We expand the invariant allocations by adding an inner dimension
+ -- equal to the number of kernel threads.
+ (rebases, alloc_stms) <- runBinder $ mapM expand $ M.toList invariant_allocs
- return (mconcat alloc_bnds, mconcat rebases)
- where
- expand (mem, (lvl, per_thread_size, space)) = do
- total_size <- newVName "total_size"
- let sizepat = Pattern [] [PatElem total_size $ MemPrim int64]
- allocpat = Pattern [] [PatElem mem $ MemMem space]
- num_users = case lvl of
- SegThread {} -> num_threads
- SegGroup {} -> num_groups
- return
- ( stmsFromList
- [ Let sizepat (defAux ()) $
- BasicOp $ BinOp (Mul Int64 OverflowUndef) num_users per_thread_size,
- Let allocpat (defAux ()) $
- Op $ Alloc (Var total_size) space
- ],
- M.singleton mem $ newBase lvl
- )
+ return (alloc_stms, mconcat rebases)
+ where
+ expand (mem, (user, per_thread_size, space)) = do
+ let num_users = fst $ getNumUsers user
+ allocpat = Pattern [] [PatElem mem $ MemMem space]
+ total_size <-
+ letExp "total_size" <=< toExp . product $
+ pe64 per_thread_size : map pe64 (shapeDims num_users)
+ letBind allocpat $ Op $ Alloc (Var total_size) space
+ pure $ M.singleton mem $ newBase user
- untouched d = DimSlice 0 d 1
+ untouched d = DimSlice 0 d 1
- newBase SegThread {} (old_shape, _) =
- let num_dims = length old_shape
- perm = num_dims : [0 .. num_dims -1]
- root_ixfun =
- IxFun.iota
- ( old_shape
- ++ [ pe64 num_groups * pe64 group_size
- ]
- )
- permuted_ixfun = IxFun.permute root_ixfun perm
- offset_ixfun =
- IxFun.slice permuted_ixfun $
- DimFix (le64 (segFlat segspace)) :
- map untouched old_shape
- in offset_ixfun
- newBase SegGroup {} (old_shape, _) =
- let root_ixfun = IxFun.iota (pe64 num_groups : old_shape)
- offset_ixfun =
- IxFun.slice root_ixfun $
- DimFix (le64 (segFlat segspace)) :
- map untouched old_shape
- in offset_ixfun
+ newBase user@(SegThread {}, _) (old_shape, _) =
+ let (users_shape, user_ids) = getNumUsers user
+ num_dims = length old_shape
+ perm = [num_dims .. num_dims + shapeRank users_shape -1] ++ [0 .. num_dims -1]
+ root_ixfun = IxFun.iota (old_shape ++ map pe64 (shapeDims users_shape))
+ permuted_ixfun = IxFun.permute root_ixfun perm
+ offset_ixfun =
+ IxFun.slice permuted_ixfun $
+ map DimFix user_ids ++ map untouched old_shape
+ in offset_ixfun
+ newBase user@(SegGroup {}, _) (old_shape, _) =
+ let (users_shape, user_ids) = getNumUsers user
+ root_ixfun = IxFun.iota $ map pe64 (shapeDims users_shape) ++ old_shape
+ offset_ixfun =
+ IxFun.slice root_ixfun $
+ map DimFix user_ids ++ map untouched old_shape
+ in offset_ixfun
+expandedInvariantAllocations ::
+ SubExp ->
+ Count NumGroups SubExp ->
+ Count GroupSize SubExp ->
+ Extraction ->
+ ExpandM (Stms KernelsMem, RebaseMap)
+expandedInvariantAllocations num_threads (Count num_groups) (Count group_size) =
+ genericExpandedInvariantAllocations getNumUsers
+ where
+ getNumUsers (SegThread {}, [gtid]) = (Shape [num_threads], [gtid])
+ getNumUsers (SegThread {}, [gid, ltid]) = (Shape [num_groups, group_size], [gid, ltid])
+ getNumUsers (SegGroup {}, [gid]) = (Shape [num_groups], [gid])
+ getNumUsers user = error $ "getNumUsers: unhandled " ++ show user
+
expandedVariantAllocations ::
SubExp ->
SegSpace ->
@@ -725,6 +762,7 @@
unMem :: MemInfo d u ret -> Maybe (TypeBase (ShapeBase d) u)
unMem (MemPrim pt) = Just $ Prim pt
unMem (MemArray pt shape u _) = Just $ Array pt shape u
+unMem (MemAcc acc ispace ts u) = Just $ Acc acc ispace ts u
unMem MemMem {} = Nothing
unAllocScope :: Scope KernelsMem -> Scope Kernels.Kernels
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
@@ -57,7 +57,7 @@
import Futhark.Optimise.Simplify.Lore (mkWiseBody)
import Futhark.Pass
import Futhark.Tools
-import Futhark.Util (splitFromEnd, takeLast)
+import Futhark.Util (splitAt3, splitFromEnd, takeLast)
data AllocStm
= SizeComputation VName (PrimExp VName)
@@ -77,7 +77,7 @@
letBindNames [name] $ BasicOp $ Copy src
class
- (MonadFreshNames m, HasScope lore m, Mem lore) =>
+ (MonadFreshNames m, LocalScope lore m, Mem lore) =>
Allocator lore m
where
addAllocStm :: AllocStm -> m ()
@@ -248,6 +248,7 @@
Functor,
Monad,
HasScope lore,
+ LocalScope lore,
MonadWriter [AllocStm],
MonadFreshNames
)
@@ -278,9 +279,9 @@
arraySizeInBytesExpM :: Allocator lore m => Type -> m (PrimExp VName)
arraySizeInBytesExpM t = do
dims <- mapM dimAllocationSize (arrayDims t)
- let dim_prod_i64 = product $ map pe64 dims
- elm_size_i64 = primByteSize $ elemType t
- return $ untyped $ dim_prod_i64 * elm_size_i64
+ let dim_prod = product $ map pe64 dims
+ elm_size = elemSize t
+ return $ untyped $ dim_prod * elm_size
arraySizeInBytes :: Allocator lore m => Type -> m SubExp
arraySizeInBytes = computeSize "bytes" <=< arraySizeInBytesExpM
@@ -334,7 +335,7 @@
(vals, (exts, mems)) <-
runWriterT $
forM (zip3 validents rts hints) $ \(ident, rt, hint) -> do
- let shape = arrayShape $ identType ident
+ let ident_shape = arrayShape $ identType ident
case rt of
MemPrim _ -> do
summary <- lift $ summaryForBindage (identType ident) hint
@@ -349,7 +350,7 @@
return $
PatElem (identName ident) $
- MemArray bt shape u $
+ MemArray bt ident_shape u $
ArrayIn mem ixfn
MemArray _ extshape _ Nothing
| Just _ <- knownShape extshape -> do
@@ -364,8 +365,10 @@
tell ([], [PatElem (identName memid) $ MemMem space])
return $
PatElem (identName ident) $
- MemArray bt shape u $
+ MemArray bt ident_shape u $
ArrayIn (identName memid) ixfn
+ MemAcc acc ispace ts u ->
+ return $ PatElem (identName ident) $ MemAcc acc ispace ts u
_ -> error "Impossible case reached in allocsForPattern!"
return
@@ -437,20 +440,21 @@
return $ MemPrim bt
summaryForBindage (Mem space) _ =
return $ MemMem space
-summaryForBindage t@(Array bt shape u) NoHint = do
+summaryForBindage (Acc acc ispace ts u) _ =
+ return $ MemAcc acc ispace ts u
+summaryForBindage t@(Array pt shape u) NoHint = do
m <- allocForArray t =<< askDefaultSpace
- return $ directIxFun bt shape u m t
-summaryForBindage t (Hint ixfun space) = do
- let bt = elemType t
+ return $ directIxFun pt shape u m t
+summaryForBindage t@(Array pt _ _) (Hint ixfun space) = do
bytes <-
computeSize "bytes" $
untyped $
product
[ product $ IxFun.base ixfun,
- primByteSize (elemType t)
+ fromIntegral (primByteSize pt :: Int64)
]
m <- allocateMemory "mem" bytes space
- return $ MemArray bt (arrayShape t) NoUniqueness $ ArrayIn m ixfun
+ return $ MemArray pt (arrayShape t) NoUniqueness $ ArrayIn m ixfun
lookupMemSpace :: (HasScope lore m, Monad m) => VName -> m Space
lookupMemSpace v = do
@@ -486,16 +490,18 @@
(FParam tolore)
allocInFParam param pspace =
case paramDeclType param of
- Array bt shape u -> do
+ Array pt shape u -> do
let memname = baseString (paramName param) <> "_mem"
ixfun = IxFun.iota $ map pe64 $ shapeDims shape
mem <- lift $ newVName memname
tell ([], [Param mem $ MemMem pspace])
- return param {paramDec = MemArray bt shape u $ ArrayIn mem ixfun}
- Prim bt ->
- return param {paramDec = MemPrim bt}
+ return param {paramDec = MemArray pt shape u $ ArrayIn mem ixfun}
+ Prim pt ->
+ return param {paramDec = MemPrim pt}
Mem space ->
return param {paramDec = MemMem space}
+ Acc acc ispace ts u ->
+ return param {paramDec = MemAcc acc ispace ts u}
allocInMergeParams ::
( Allocable fromlore tolore,
@@ -529,7 +535,7 @@
(AllocM fromlore tolore)
(FParam tolore, SubExp -> WriterT ([SubExp], [SubExp]) (AllocM fromlore tolore) SubExp)
allocInMergeParam (mergeparam, Var v)
- | Array bt shape u <- paramDeclType mergeparam = do
+ | Array pt shape u <- paramDeclType mergeparam = do
(mem', _) <- lift $ lookupArraySummary v
mem_space <- lift $ lookupMemSpace mem'
@@ -538,10 +544,11 @@
(ctx_params, param_ixfun_substs) <-
unzip
<$> mapM
- ( \_ -> do
+ ( \e -> do
+ let e_t = primExpType $ untyped e
vname <- lift $ newVName "ctx_param_ext"
return
- ( Param vname $ MemPrim int64,
+ ( Param vname $ MemPrim e_t,
fmap Free $ pe64 $ Var vname
)
)
@@ -559,7 +566,7 @@
tell ([], [Param mem_name $ MemMem mem_space])
return
- ( mergeparam {paramDec = MemArray bt shape u $ ArrayIn mem_name param_ixfun},
+ ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name param_ixfun},
ensureArrayIn mem_space
)
allocInMergeParam (mergeparam, _) = doDefault mergeparam =<< lift askDefaultSpace
@@ -643,12 +650,16 @@
AllocM fromlore tolore (VName, SubExp)
allocLinearArray space s v = do
t <- lookupType v
- mem <- allocForArray t space
- v' <- newIdent (s ++ "_linear") t
- let ixfun = directIxFun (elemType t) (arrayShape t) NoUniqueness mem t
- let pat = Pattern [] [PatElem (identName v') ixfun]
- addStm $ Let pat (defAux ()) $ BasicOp $ Copy v
- return (mem, Var $ identName v')
+ case t of
+ Array pt shape u -> do
+ mem <- allocForArray t space
+ v' <- newIdent (s ++ "_linear") t
+ let ixfun = directIxFun pt shape u mem t
+ pat = Pattern [] [PatElem (identName v') ixfun]
+ addStm $ Let pat (defAux ()) $ BasicOp $ Copy v
+ return (mem, Var $ identName v')
+ _ ->
+ error $ "allocLinearArray: " ++ pretty t
funcallArgs ::
( Allocable fromlore tolore,
@@ -691,17 +702,17 @@
Pass "explicit allocations" "Transform program to explicit memory representation" $
intraproceduralTransformationWithConsts onStms allocInFun
where
- onStms stms = runAllocM handleOp hints $ allocInStms stms pure
+ onStms stms =
+ runAllocM handleOp hints $ collectStms_ $ allocInStms stms $ pure ()
allocInFun consts (FunDef entry attrs fname rettype params fbody) =
runAllocM handleOp hints $
inScopeOf consts $
allocInFParams (zip params $ repeat DefaultSpace) $ \params' -> do
fbody' <-
- insertStmsM $
- allocInFunBody
- (map (const $ Just DefaultSpace) rettype)
- fbody
+ allocInFunBody
+ (map (const $ Just DefaultSpace) rettype)
+ fbody
return $ FunDef entry attrs fname (memoryInDeclExtType rettype) params' fbody'
explicitAllocationsInStmsGeneric ::
@@ -715,19 +726,21 @@
m (Stms tolore)
explicitAllocationsInStmsGeneric handleOp hints stms = do
scope <- askScope
- runAllocM handleOp hints $ localScope scope $ allocInStms stms return
+ runAllocM handleOp hints $
+ localScope scope $ collectStms_ $ allocInStms stms $ pure ()
memoryInDeclExtType :: [DeclExtType] -> [FunReturns]
-memoryInDeclExtType ts = evalState (mapM addMem ts) $ startOfFreeIDRange ts
+memoryInDeclExtType dets = evalState (mapM addMem dets) $ startOfFreeIDRange dets
where
addMem (Prim t) = return $ MemPrim t
addMem Mem {} = error "memoryInDeclExtType: too much memory"
- addMem (Array bt shape u) = do
+ addMem (Array pt shape u) = do
i <- get <* modify (+ 1)
return $
- MemArray bt shape u $
+ MemArray pt shape u $
ReturnsNewBlock DefaultSpace i $
IxFun.iota $ map convert $ shapeDims shape
+ addMem (Acc acc ispace ts u) = return $ MemAcc acc ispace ts u
convert (Ext i) = le64 $ Ext i
convert (Free v) = Free <$> pe64 v
@@ -745,6 +758,7 @@
info <- lookupMemInfo v
case info of
MemPrim {} -> return []
+ MemAcc {} -> return []
MemMem {} -> return [] -- should not happen
MemArray _ _ _ (ArrayIn mem _) -> return [Var mem]
@@ -754,13 +768,11 @@
Body fromlore ->
AllocM fromlore tolore (Body tolore)
allocInFunBody space_oks (Body _ bnds res) =
- allocInStms bnds $ \bnds' -> do
- (res'', allocs) <- collectStms $ do
- res' <- zipWithM ensureDirect space_oks' res
- let (ctx_res, val_res) = splitFromEnd num_vals res'
- mem_ctx_res <- concat <$> mapM bodyReturnMemCtx val_res
- return $ ctx_res <> mem_ctx_res <> val_res
- return $ Body () (bnds' <> allocs) res''
+ buildBody_ . allocInStms bnds $ do
+ res' <- zipWithM ensureDirect space_oks' res
+ let (ctx_res, val_res) = splitFromEnd num_vals res'
+ mem_ctx_res <- concat <$> mapM bodyReturnMemCtx val_res
+ pure $ ctx_res <> mem_ctx_res <> val_res
where
num_vals = length space_oks
space_oks' = replicate (length res - num_vals) Nothing ++ space_oks
@@ -770,37 +782,34 @@
Maybe Space ->
SubExp ->
AllocM fromlore tolore SubExp
-ensureDirect _ se@Constant {} = return se
-ensureDirect space_ok (Var v) = do
- bt <- primType <$> lookupType v
- if bt
- then return $ Var v
- else do
+ensureDirect space_ok se = do
+ se_info <- subExpMemInfo se
+ case (se_info, se) of
+ (MemArray {}, Var v) -> do
(_, v') <- ensureDirectArray space_ok v
return v'
+ _ ->
+ return se
allocInStms ::
(Allocable fromlore tolore) =>
Stms fromlore ->
- (Stms tolore -> AllocM fromlore tolore a) ->
+ AllocM fromlore tolore a ->
AllocM fromlore tolore a
-allocInStms origstms m = allocInStms' (stmsToList origstms) mempty
+allocInStms origstms m = allocInStms' $ stmsToList origstms
where
- allocInStms' [] stms' =
- m stms'
- allocInStms' (x : xs) stms' = do
- allocstms <- allocInStm' x
- localScope (scopeOf allocstms) $ do
- let stms_substs = foldMap sizeSubst allocstms
- stms_consts = foldMap stmConsts allocstms
- f env =
- env
- { chunkMap = stms_substs <> chunkMap env,
- envConsts = stms_consts <> envConsts env
- }
- local f $ allocInStms' xs (stms' <> allocstms)
- allocInStm' stm =
- collectStms_ $ auxing (stmAux stm) $ allocInStm stm
+ allocInStms' [] = m
+ allocInStms' (stm : stms) = do
+ allocstms <- collectStms_ $ auxing (stmAux stm) $ allocInStm stm
+ addStms allocstms
+ let stms_substs = foldMap sizeSubst allocstms
+ stms_consts = foldMap stmConsts allocstms
+ f env =
+ env
+ { chunkMap = stms_substs <> chunkMap env,
+ envConsts = stms_consts <> envConsts env
+ }
+ local f $ allocInStms' stms
allocInStm ::
(Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>
@@ -813,6 +822,15 @@
bnd <- allocsForStm sizeidents validents e'
addStm bnd
+allocInLambda ::
+ Allocable fromlore tolore =>
+ [LParam tolore] ->
+ Body fromlore ->
+ AllocM fromlore tolore (Lambda tolore)
+allocInLambda params body =
+ mkLambda params . allocInStms (bodyStms body) $
+ pure $ bodyResult body
+
allocInExp ::
(Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) =>
Exp fromlore ->
@@ -824,10 +842,10 @@
form' <- allocInLoopForm form
localScope (scopeOf form') $ do
(valinit_ctx, valinit') <- mk_loop_val valinit
- body' <- insertStmsM $
- allocInStms bodybnds $ \bodybnds' -> do
- ((val_ses, valres'), val_retbnds) <- collectStms $ mk_loop_val valres
- return $ Body () (bodybnds' <> val_retbnds) (ctxres ++ val_ses ++ valres')
+ body' <-
+ buildBody_ . allocInStms bodybnds $ do
+ (val_ses, valres') <- mk_loop_val valres
+ pure $ ctxres ++ val_ses ++ valres'
return $
DoLoop
(zip (ctxparams' ++ new_ctx_params) (ctxinit ++ valinit_ctx))
@@ -907,10 +925,61 @@
Body fromlore ->
AllocM fromlore tolore (Body tolore, [Maybe IxFun])
allocInIfBody num_vals (Body _ bnds res) =
- allocInStms bnds $ \bnds' -> do
+ buildBody . allocInStms bnds $ do
let (_, val_res) = splitFromEnd num_vals res
mem_ixfs <- mapM subExpIxFun val_res
- return (Body () bnds' res, mem_ixfs)
+ pure (res, mem_ixfs)
+allocInExp (WithAcc inputs bodylam) =
+ WithAcc <$> mapM onInput inputs <*> onLambda bodylam
+ where
+ onLambda lam = do
+ params <- forM (lambdaParams lam) $ \(Param pv t) ->
+ case t of
+ Prim Unit -> pure $ Param pv $ MemPrim Unit
+ Acc acc ispace ts u -> pure $ Param pv $ MemAcc acc ispace ts u
+ _ -> error $ "Unexpected WithAcc lambda param: " ++ pretty (Param pv t)
+ allocInLambda params (lambdaBody lam)
+
+ onInput (shape, arrs, op) =
+ (shape,arrs,) <$> traverse (onOp shape arrs) op
+
+ onOp accshape arrs (lam, nes) = do
+ let num_vs = length (lambdaReturnType lam)
+ num_is = shapeRank accshape
+ (i_params, x_params, y_params) =
+ splitAt3 num_is num_vs $ lambdaParams lam
+ i_params' = map ((`Param` MemPrim int64) . paramName) i_params
+ is = map (DimFix . Var . paramName) i_params'
+ x_params' <- zipWithM (onXParam is) x_params arrs
+ y_params' <- zipWithM (onYParam is) y_params arrs
+ lam' <-
+ allocInLambda
+ (i_params' <> x_params' <> y_params')
+ (lambdaBody lam)
+ return (lam', nes)
+
+ mkP p pt shape u mem ixfun is =
+ Param p . MemArray pt shape u . ArrayIn mem . IxFun.slice ixfun $
+ fmap (fmap pe64) $ is ++ map sliceDim (shapeDims shape)
+
+ onXParam _ (Param p (Prim t)) _ =
+ return $ Param p (MemPrim t)
+ onXParam is (Param p (Array pt shape u)) arr = do
+ (mem, ixfun) <- lookupArraySummary arr
+ return $ mkP p pt shape u mem ixfun is
+ onXParam _ p _ =
+ error $ "Cannot handle MkAcc param: " ++ pretty p
+
+ onYParam _ (Param p (Prim t)) _ =
+ return $ Param p (MemPrim t)
+ onYParam is (Param p (Array pt shape u)) arr = do
+ arr_t <- lookupType arr
+ mem <- allocForArray arr_t DefaultSpace
+ let base_dims = map pe64 $ arrayDims arr_t
+ ixfun = IxFun.iota base_dims
+ pure $ mkP p pt shape u mem ixfun is
+ onYParam _ p _ =
+ error $ "Cannot handle MkAcc param: " ++ pretty p
allocInExp e = mapExpM alloc e
where
alloc =
@@ -1006,6 +1075,7 @@
ReturnsNewBlock space' 0 $
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
@@ -1052,16 +1122,18 @@
allocInLoopVar (p, a) = do
(mem, ixfun) <- lookupArraySummary a
case paramType p of
- Array bt shape u -> do
+ Array pt shape u -> do
dims <- map pe64 . arrayDims <$> lookupType a
let ixfun' =
IxFun.slice ixfun $
fullSliceNum dims [DimFix $ le64 i]
- return (p {paramDec = MemArray bt shape u $ ArrayIn mem ixfun'}, a)
+ return (p {paramDec = MemArray pt shape u $ ArrayIn mem ixfun'}, a)
Prim bt ->
return (p {paramDec = MemPrim bt}, a)
Mem space ->
return (p {paramDec = MemMem space}, a)
+ Acc acc ispace ts u ->
+ return (p {paramDec = MemAcc acc ispace ts u}, a)
class SizeSubst op where
opSizeSubst :: PatternT dec -> op -> ChunkMap
diff --git a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs
--- a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs
+++ b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs
@@ -21,19 +21,17 @@
KernelBody fromlore ->
AllocM fromlore tolore (KernelBody tolore)
allocInKernelBody (KernelBody () stms res) =
- allocInStms stms $ \stms' -> return $ KernelBody () stms' res
+ uncurry (flip (KernelBody ()))
+ <$> collectStms (allocInStms stms (pure res))
allocInLambda ::
Allocable fromlore tolore =>
[LParam tolore] ->
Body fromlore ->
- [Type] ->
AllocM fromlore tolore (Lambda tolore)
-allocInLambda params body rettype = do
- body' <- localScope (scopeOfLParams params) $
- allocInStms (bodyStms body) $ \bnds' ->
- return $ Body () bnds' $ bodyResult body
- return $ Lambda params body' rettype
+allocInLambda params body =
+ mkLambda params . allocInStms (bodyStms body) $
+ pure $ bodyResult body
allocInBinOpParams ::
Allocable fromlore tolore =>
@@ -47,7 +45,7 @@
where
alloc x y =
case paramType x of
- Array bt shape u -> do
+ Array pt shape u -> do
twice_num_threads <-
letSubExp "twice_num_threads" $
BasicOp $ BinOp (Mul Int64 OverflowUndef) num_threads $ intConst Int64 2
@@ -64,8 +62,8 @@
IxFun.slice ixfun_base $
fullSliceNum base_dims [DimFix other_id]
return
- ( x {paramDec = MemArray bt shape u $ ArrayIn mem ixfun_x},
- y {paramDec = MemArray bt shape u $ ArrayIn mem ixfun_y}
+ ( x {paramDec = MemArray pt shape u $ ArrayIn mem ixfun_x},
+ y {paramDec = MemArray pt shape u $ ArrayIn mem ixfun_y}
)
Prim bt ->
return
@@ -77,6 +75,12 @@
( x {paramDec = MemMem space},
y {paramDec = MemMem space}
)
+ -- This next case will never happen.
+ Acc acc ispace ts u ->
+ return
+ ( x {paramDec = MemAcc acc ispace ts u},
+ y {paramDec = MemAcc acc ispace ts u}
+ )
allocInBinOpLambda ::
Allocable fromlore tolore =>
@@ -92,7 +96,4 @@
(acc_params', arr_params') <-
allocInBinOpParams num_threads index_x index_y acc_params arr_params
- allocInLambda
- (acc_params' ++ arr_params')
- (lambdaBody lam)
- (lambdaReturnType lam)
+ allocInLambda (acc_params' ++ arr_params') (lambdaBody lam)
diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs
--- a/src/Futhark/Pass/ExtractKernels.hs
+++ b/src/Futhark/Pass/ExtractKernels.hs
@@ -163,6 +163,7 @@
import Control.Monad.Identity
import Control.Monad.RWS.Strict
import Control.Monad.Reader
+import Data.Bifunctor (first)
import Data.Maybe
import qualified Futhark.IR.Kernels as Out
import Futhark.IR.Kernels.Kernel
@@ -264,10 +265,9 @@
transformStms path $ stmsToList bnds' <> bnds
unbalancedLambda :: Lambda -> Bool
-unbalancedLambda lam =
- unbalancedBody
- (namesFromList $ map paramName $ lambdaParams lam)
- $ lambdaBody lam
+unbalancedLambda orig_lam =
+ unbalancedBody (namesFromList $ map paramName $ lambdaParams orig_lam) $
+ lambdaBody orig_lam
where
subExpBound (Var i) bound = i `nameIn` bound
subExpBound (Constant _) _ = False
@@ -284,6 +284,8 @@
unbalancedStm _ Op {} =
False
unbalancedStm _ DoLoop {} = False
+ unbalancedStm bound (WithAcc _ lam) =
+ unbalancedBody bound (lambdaBody lam)
unbalancedStm bound (If cond tbranch fbranch _) =
cond `subExpBound` bound
&& (unbalancedBody bound tbranch || unbalancedBody bound fbranch)
@@ -341,6 +343,12 @@
If cond alt alt_body $
IfDec (staticShapes (patternTypes pat)) IfEquiv
+transformLambda :: KernelPath -> Lambda -> DistribM (Out.Lambda Out.Kernels)
+transformLambda path (Lambda params body ret) =
+ Lambda params
+ <$> localScope (scopeOfLParams params) (transformBody path body)
+ <*> pure ret
+
transformStm :: KernelPath -> Stm -> DistribM KernelsStms
transformStm _ stm
| "sequential" `inAttrs` stmAuxAttrs (stmAux stm) =
@@ -353,6 +361,12 @@
tb' <- transformBody path tb
fb' <- transformBody path fb
return $ oneStm $ Let pat aux $ If c tb' fb' rt
+transformStm path (Let pat aux (WithAcc inputs lam)) =
+ oneStm . Let pat aux
+ <$> (WithAcc (map transformInput inputs) <$> transformLambda path lam)
+ where
+ transformInput (shape, arrs, op) =
+ (shape, arrs, fmap (first soacsLambdaToKernels) op)
transformStm path (Let pat aux (DoLoop ctx val form body)) =
localScope
( castScope (scopeOf form)
@@ -728,84 +742,125 @@
Lambda ->
DistribM (Out.Stms Out.Kernels)
onMap' loopnest path mk_seq_stms mk_par_stms pat lam = do
- let nest_ws = kernelNestWidths loopnest
- res = map Var $ patternNames pat
- aux = loopNestingAux $ innermostKernelNesting loopnest
- attrs = stmAuxAttrs aux
+ -- Some of the control flow here looks a bit convoluted because we
+ -- are trying to avoid generating unneeded threshold parameters,
+ -- which means we need to do all the pruning checks up front.
types <- askScope
- ((outer_suff, outer_suff_key), outer_suff_stms) <-
- sufficientParallelism "suff_outer_par" nest_ws path Nothing
intra <-
if onlyExploitIntra (stmAuxAttrs aux)
|| (worthIntraGroup lam && mayExploitIntra attrs)
then flip runReaderT types $ intraGroupParallelise loopnest lam
else return Nothing
- seq_body <-
- renameBody =<< mkBody
- <$> mk_seq_stms ((outer_suff_key, True) : path) <*> pure res
- let seq_alts =
- [ (outer_suff, seq_body)
- | worthSequentialising lam,
- mayExploitOuter attrs
- ]
case intra of
- Nothing -> do
- par_body <-
- renameBody =<< mkBody
- <$> mk_par_stms ((outer_suff_key, False) : path) <*> pure res
+ _ | "sequential_inner" `inAttrs` attrs -> do
+ seq_body <- renameBody =<< mkBody <$> mk_seq_stms path <*> pure res
+ kernelAlternatives pat seq_body []
+ --
+ Nothing
+ | Just m <- mkSeqAlts -> do
+ (outer_suff, outer_suff_key, outer_suff_stms, seq_body) <- m
+ par_body <-
+ renameBody =<< mkBody
+ <$> mk_par_stms ((outer_suff_key, False) : path) <*> pure res
+ (outer_suff_stms <>) <$> kernelAlternatives pat par_body [(outer_suff, seq_body)]
+ --
+ | otherwise -> do
+ par_body <- renameBody =<< mkBody <$> mk_par_stms path <*> pure res
+ kernelAlternatives pat par_body []
+ --
+ Just intra'@(_, _, log, intra_prelude, intra_stms)
+ | onlyExploitIntra attrs -> do
+ addLog log
+ group_par_body <- renameBody $ mkBody intra_stms res
+ (intra_prelude <>) <$> kernelAlternatives pat group_par_body []
+ --
+ | otherwise -> do
+ addLog log
- if "sequential_inner" `inAttrs` attrs
- then kernelAlternatives pat seq_body []
- else (outer_suff_stms <>) <$> kernelAlternatives pat par_body seq_alts
- Just ((_intra_min_par, intra_avail_par), group_size, log, intra_prelude, intra_stms) -> do
- addLog log
- -- We must check that all intra-group parallelism fits in a group.
- ((intra_ok, intra_suff_key), intra_suff_stms) <- do
- ((intra_suff, suff_key), check_suff_stms) <-
- sufficientParallelism
- "suff_intra_par"
- [intra_avail_par]
- ((outer_suff_key, False) : path)
- (Just intraMinInnerPar)
+ case mkSeqAlts of
+ Nothing -> do
+ (group_par_body, intra_ok, intra_suff_key, intra_suff_stms) <-
+ checkSuffIntraPar path intra'
- runBinder $ do
- addStms intra_prelude
+ par_body <-
+ renameBody =<< mkBody
+ <$> mk_par_stms ((intra_suff_key, False) : path) <*> pure res
- max_group_size <-
- letSubExp "max_group_size" $ Op $ SizeOp $ Out.GetSizeMax Out.SizeGroup
- fits <-
- letSubExp "fits" $
- BasicOp $
- CmpOp (CmpSle Int64) group_size max_group_size
+ (intra_suff_stms <>)
+ <$> kernelAlternatives pat par_body [(intra_ok, group_par_body)]
+ Just m -> do
+ (outer_suff, outer_suff_key, outer_suff_stms, seq_body) <- m
- addStms check_suff_stms
+ (group_par_body, intra_ok, intra_suff_key, intra_suff_stms) <-
+ checkSuffIntraPar ((outer_suff_key, False) : path) intra'
- intra_ok <- letSubExp "intra_suff_and_fits" $ BasicOp $ BinOp LogAnd fits intra_suff
- return (intra_ok, suff_key)
+ par_body <-
+ renameBody =<< mkBody
+ <$> mk_par_stms
+ ( [ (outer_suff_key, False),
+ (intra_suff_key, False)
+ ]
+ ++ path
+ )
+ <*> pure res
- group_par_body <- renameBody $ mkBody intra_stms res
+ ((outer_suff_stms <> intra_suff_stms) <>)
+ <$> kernelAlternatives
+ pat
+ par_body
+ [(outer_suff, seq_body), (intra_ok, group_par_body)]
+ where
+ nest_ws = kernelNestWidths loopnest
+ res = map Var $ patternNames pat
+ aux = loopNestingAux $ innermostKernelNesting loopnest
+ attrs = stmAuxAttrs aux
- par_body <-
- renameBody =<< mkBody
- <$> mk_par_stms
- ( [ (outer_suff_key, False),
- (intra_suff_key, False)
- ]
- ++ path
- )
- <*> pure res
+ mkSeqAlts
+ | worthSequentialising lam,
+ mayExploitOuter attrs = Just $ do
+ ((outer_suff, outer_suff_key), outer_suff_stms) <- checkSuffOuterPar
+ seq_body <-
+ renameBody =<< mkBody
+ <$> mk_seq_stms ((outer_suff_key, True) : path) <*> pure res
+ pure (outer_suff, outer_suff_key, outer_suff_stms, seq_body)
+ | otherwise =
+ Nothing
- if "sequential_inner" `inAttrs` attrs
- then kernelAlternatives pat seq_body []
- else
- if onlyExploitIntra attrs
- then (intra_suff_stms <>) <$> kernelAlternatives pat group_par_body []
- else
- ((outer_suff_stms <> intra_suff_stms) <>)
- <$> kernelAlternatives pat par_body (seq_alts ++ [(intra_ok, group_par_body)])
+ checkSuffOuterPar =
+ sufficientParallelism "suff_outer_par" nest_ws path Nothing
+
+ checkSuffIntraPar
+ path'
+ ((_intra_min_par, intra_avail_par), group_size, _, intra_prelude, intra_stms) = do
+ -- We must check that all intra-group parallelism fits in a group.
+ ((intra_ok, intra_suff_key), intra_suff_stms) <- do
+ ((intra_suff, suff_key), check_suff_stms) <-
+ sufficientParallelism
+ "suff_intra_par"
+ [intra_avail_par]
+ path'
+ (Just intraMinInnerPar)
+
+ runBinder $ do
+ addStms intra_prelude
+
+ max_group_size <-
+ letSubExp "max_group_size" $ Op $ SizeOp $ Out.GetSizeMax Out.SizeGroup
+ fits <-
+ letSubExp "fits" $
+ BasicOp $
+ CmpOp (CmpSle Int64) group_size max_group_size
+
+ addStms check_suff_stms
+
+ intra_ok <- letSubExp "intra_suff_and_fits" $ BasicOp $ BinOp LogAnd fits intra_suff
+ return (intra_ok, suff_key)
+
+ group_par_body <- renameBody $ mkBody intra_stms res
+ pure (group_par_body, intra_ok, intra_suff_key, intra_suff_stms)
onInnerMap ::
KernelPath ->
diff --git a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs
--- a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs
+++ b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs
@@ -24,6 +24,7 @@
import Data.List ()
import Futhark.Analysis.PrimExp
import Futhark.IR
+import Futhark.IR.Prop.Aliases
import Futhark.IR.SegOp
import Futhark.MonadFreshNames
import Futhark.Tools
@@ -37,7 +38,8 @@
BinderOps lore,
LetDec lore ~ Type,
ExpDec lore ~ (),
- BodyDec lore ~ ()
+ BodyDec lore ~ (),
+ CanBeAliased (Op lore)
)
data ThreadRecommendation = ManyThreads | NoRecommendation SegVirt
@@ -243,7 +245,10 @@
readKernelInput inp = do
let pe = PatElem (kernelInputName inp) $ kernelInputType inp
arr_t <- lookupType $ kernelInputArray inp
- letBind (Pattern [] [pe]) $
- BasicOp $
- Index (kernelInputArray inp) $
- fullSlice arr_t $ map DimFix $ kernelInputIndices inp
+ letBind (Pattern [] [pe]) . BasicOp $
+ case arr_t of
+ Acc {} ->
+ SubExp $ Var $ kernelInputArray inp
+ _ ->
+ Index (kernelInputArray inp) $
+ fullSlice arr_t $ map DimFix $ kernelInputIndices inp
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
@@ -322,9 +322,13 @@
isParallelStm stm =
isMap (stmExp stm)
&& not ("sequential" `inAttrs` stmAuxAttrs (stmAux stm))
- isMap Op {} = True
+ isMap BasicOp {} = False
+ isMap Apply {} = False
+ isMap If {} = False
isMap (DoLoop _ _ ForLoop {} body) = bodyContainsParallelism body
- isMap _ = False
+ isMap (DoLoop _ _ WhileLoop {} _) = False
+ isMap (WithAcc _ lam) = bodyContainsParallelism $ lambdaBody lam
+ isMap Op {} = True
lambdaContainsParallelism :: Lambda SOACS -> Bool
lambdaContainsParallelism = bodyContainsParallelism . lambdaBody
@@ -436,6 +440,30 @@
return acc'
_ ->
addStmToAcc stm acc
+maybeDistributeStm stm@(Let pat _ (WithAcc inputs lam)) acc
+ | lambdaContainsParallelism lam =
+ distributeSingleStm acc stm >>= \case
+ Just (kernels, res, nest, acc')
+ | not $
+ freeIn (drop num_accs (lambdaReturnType lam))
+ `namesIntersect` boundInKernelNest nest,
+ Just (perm, pat_unused) <- permutationAndMissing pat res ->
+ -- We need to pretend pat_unused was used anyway, by adding
+ -- it to the kernel nest.
+ localScope (typeEnvFromDistAcc acc') $ do
+ nest' <- expandKernelNest pat_unused nest
+ types <- asksScope scopeForSOACs
+ addPostStms kernels
+ let withacc = WithAccStm perm pat inputs lam
+ stms <-
+ (`runReaderT` types) $
+ fmap snd . simplifyStms =<< interchangeWithAcc nest' withacc
+ onTopLevelStms stms
+ return acc'
+ _ ->
+ addStmToAcc stm acc
+ where
+ num_accs = length inputs
maybeDistributeStm (Let pat aux (Op (Screma w arrs form))) acc
| Just [Reduce comm lam nes] <- isReduceSOAC form,
Just m <- irwim pat w comm lam $ zip nes arrs = do
@@ -604,33 +632,6 @@
=<< segmentedUpdateKernel nest' perm (stmAuxCerts aux) arr slice v
return acc'
_ -> addStmToAcc stm acc
--- XXX? This rule is present to avoid the case where an in-place
--- update is distributed as its own kernel, as this would mean thread
--- then writes the entire array that it updated. This is problematic
--- because the in-place updates is O(1), but writing the array is
--- O(n). It is OK if the in-place update is preceded, followed, or
--- nested inside a sequential loop or similar, because that will
--- probably be O(n) by itself. As a hack, we only distribute if there
--- does not appear to be a loop following. The better solution is to
--- depend on memory block merging for this optimisation, but it is not
--- ready yet.
-maybeDistributeStm (Let pat aux (BasicOp (Update arr [DimFix i] v))) acc
- | [t] <- patternTypes pat,
- arrayRank t == 1,
- not $ any (amortises . stmExp) $ distStms acc = do
- let w = arraySize 0 t
- et = stripArray 1 t
- lam =
- Lambda
- { lambdaParams = [],
- lambdaReturnType = [Prim int64, et],
- lambdaBody = mkBody mempty [i, v]
- }
- maybeDistributeStm (Let pat aux $ Op $ Scatter (intConst Int64 1) lam [] [(Shape [w], 1, arr)]) acc
- where
- amortises DoLoop {} = True
- amortises Op {} = True
- amortises _ = False
maybeDistributeStm stm@(Let _ aux (BasicOp (Concat d x xs w))) acc =
distributeSingleStm acc stm >>= \case
Just (kernels, _, nest, acc') ->
diff --git a/src/Futhark/Pass/ExtractKernels/Interchange.hs b/src/Futhark/Pass/ExtractKernels/Interchange.hs
--- a/src/Futhark/Pass/ExtractKernels/Interchange.hs
+++ b/src/Futhark/Pass/ExtractKernels/Interchange.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-- | It is well known that fully parallel loops can always be
@@ -12,10 +13,12 @@
interchangeLoops,
Branch (..),
interchangeBranch,
+ WithAccStm (..),
+ interchangeWithAcc,
)
where
-import Control.Monad.RWS.Strict
+import Control.Monad.Identity
import Data.List (find)
import Data.Maybe
import Futhark.IR.SOACS
@@ -173,3 +176,104 @@
(loop', bnds) <-
runBinder $ foldM interchangeBranch1 loop $ reverse $ kernelNestLoops nest
return $ bnds <> oneStm (branchStm loop')
+
+data WithAccStm
+ = WithAccStm [Int] Pattern [(Shape, [VName], Maybe (Lambda, [SubExp]))] Lambda
+
+withAccStm :: WithAccStm -> Stm
+withAccStm (WithAccStm _ pat inputs lam) =
+ Let pat (defAux ()) $ WithAcc inputs lam
+
+interchangeWithAcc1 ::
+ (MonadBinder m, Lore m ~ SOACS) =>
+ WithAccStm ->
+ LoopNesting ->
+ m WithAccStm
+interchangeWithAcc1
+ (WithAccStm perm _withacc_pat inputs acc_lam)
+ (MapNesting map_pat map_aux w params_and_arrs) = do
+ inputs' <- mapM onInput inputs
+ let lam_params = lambdaParams acc_lam
+ iota_p <- newParam "iota_p" $ Prim int64
+ acc_lam' <- trLam (Var (paramName iota_p)) <=< mkLambda lam_params $ do
+ iota_w <-
+ letExp "acc_inter_iota" . BasicOp $
+ Iota w (intConst Int64 0) (intConst Int64 1) Int64
+ let (params, arrs) = unzip params_and_arrs
+ maplam_ret = lambdaReturnType acc_lam
+ maplam = Lambda (iota_p : params) (lambdaBody acc_lam) maplam_ret
+ auxing map_aux . letTupExp' "withacc_inter" $
+ Op $ Screma w (iota_w : arrs) (mapSOAC maplam)
+ let pat = Pattern [] $ rearrangeShape perm $ patternValueElements map_pat
+ perm' = [0 .. patternSize pat -1]
+ pure $ WithAccStm perm' pat inputs' acc_lam'
+ where
+ num_accs = length inputs
+ acc_certs = map paramName $ take num_accs $ lambdaParams acc_lam
+ onArr v =
+ pure . maybe v snd $
+ find ((== v) . paramName . fst) params_and_arrs
+ onInput (shape, arrs, op) =
+ (Shape [w] <> shape,,) <$> mapM onArr arrs <*> traverse onOp op
+
+ onOp (op_lam, nes) = do
+ -- We need to add an additional index parameter because we are
+ -- extending the index space of the accumulator.
+ idx_p <- newParam "idx" $ Prim int64
+ pure (op_lam {lambdaParams = idx_p : lambdaParams op_lam}, nes)
+
+ trType :: TypeBase shape u -> TypeBase shape u
+ trType (Acc acc ispace ts u)
+ | acc `elem` acc_certs =
+ Acc acc (Shape [w] <> ispace) ts u
+ trType t = t
+
+ trParam :: Param (TypeBase shape u) -> Param (TypeBase shape u)
+ trParam = fmap trType
+
+ trLam i (Lambda params body ret) =
+ localScope (scopeOfLParams params) $
+ Lambda (map trParam params) <$> trBody i body <*> pure (map trType ret)
+
+ trBody i (Body dec stms res) =
+ inScopeOf stms $ Body dec <$> traverse (trStm i) stms <*> pure res
+
+ trStm i (Let pat aux e) =
+ Let (fmap trType pat) aux <$> trExp i e
+
+ trSOAC i = mapSOACM mapper
+ where
+ mapper =
+ identitySOACMapper {mapOnSOACLambda = trLam i}
+
+ trExp i (WithAcc acc_inputs lam) =
+ WithAcc acc_inputs <$> trLam i lam
+ trExp i (BasicOp (UpdateAcc acc is ses)) = do
+ acc_t <- lookupType acc
+ pure $ case acc_t of
+ Acc cert _ _ _
+ | cert `elem` acc_certs ->
+ BasicOp $ UpdateAcc acc (i : is) ses
+ _ ->
+ BasicOp $ UpdateAcc acc is ses
+ trExp i e = mapExpM mapper e
+ where
+ mapper =
+ identityMapper
+ { mapOnBody = \scope -> localScope scope . trBody i,
+ mapOnRetType = pure . trType,
+ mapOnBranchType = pure . trType,
+ mapOnFParam = pure . trParam,
+ mapOnLParam = pure . trParam,
+ mapOnOp = trSOAC i
+ }
+
+interchangeWithAcc ::
+ (MonadFreshNames m, HasScope SOACS m) =>
+ KernelNest ->
+ WithAccStm ->
+ m (Stms SOACS)
+interchangeWithAcc nest withacc = do
+ (withacc', stms) <-
+ runBinder $ foldM interchangeWithAcc1 withacc $ reverse $ kernelNestLoops nest
+ return $ stms <> oneStm (withAccStm withacc')
diff --git a/src/Futhark/Pass/ExtractKernels/Intragroup.hs b/src/Futhark/Pass/ExtractKernels/Intragroup.hs
--- a/src/Futhark/Pass/ExtractKernels/Intragroup.hs
+++ b/src/Futhark/Pass/ExtractKernels/Intragroup.hs
@@ -110,7 +110,7 @@
used_inps = filter inputIsUsed inps
addStms w_stms
- read_input_stms <- runBinder_ $ mapM readKernelInput used_inps
+ read_input_stms <- runBinder_ $ mapM readGroupKernelInput used_inps
space <- mkSegSpace ispace
return (intra_avail_par, space, read_input_stms)
@@ -135,21 +135,33 @@
first_nest = fst knest
aux = loopNestingAux first_nest
-data Acc = Acc
+readGroupKernelInput ::
+ (DistLore (Lore m), MonadBinder m) =>
+ KernelInput ->
+ m ()
+readGroupKernelInput inp
+ | Array {} <- kernelInputType inp = do
+ v <- newVName $ baseString $ kernelInputName inp
+ readKernelInput inp {kernelInputName = v}
+ letBindNames [kernelInputName inp] $ BasicOp $ Copy v
+ | otherwise =
+ readKernelInput inp
+
+data IntraAcc = IntraAcc
{ accMinPar :: S.Set [SubExp],
accAvailPar :: S.Set [SubExp],
accLog :: Log
}
-instance Semigroup Acc where
- Acc min_x avail_x log_x <> Acc min_y avail_y log_y =
- Acc (min_x <> min_y) (avail_x <> avail_y) (log_x <> log_y)
+instance Semigroup IntraAcc where
+ IntraAcc min_x avail_x log_x <> IntraAcc min_y avail_y log_y =
+ IntraAcc (min_x <> min_y) (avail_x <> avail_y) (log_x <> log_y)
-instance Monoid Acc where
- mempty = Acc mempty mempty mempty
+instance Monoid IntraAcc where
+ mempty = IntraAcc mempty mempty mempty
type IntraGroupM =
- BinderT Out.Kernels (RWS () Acc VNameSource)
+ BinderT Out.Kernels (RWS () IntraAcc VNameSource)
instance MonadLogger IntraGroupM where
addLog log = tell mempty {accLog = log}
@@ -157,7 +169,7 @@
runIntraGroupM ::
(MonadFreshNames m, HasScope Out.Kernels m) =>
IntraGroupM () ->
- m (Acc, Out.Stms Out.Kernels)
+ m (IntraAcc, Out.Stms Out.Kernels)
runIntraGroupM m = do
scope <- castScope <$> askScope
modifyNameSource $ \src ->
@@ -266,8 +278,8 @@
runBinderT (sequentialStreamWholeArray pat w accs lam arrs) types
let replace (Var v) | v == paramName chunk_size_param = w
replace se = se
- replaceSets (Acc x y log) =
- Acc (S.map (map replace) x) (S.map (map replace) y) log
+ replaceSets (IntraAcc x y log) =
+ IntraAcc (S.map (map replace) x) (S.map (map replace) y) log
censor replaceSets $ intraGroupStms lvl stream_bnds
Op (Scatter w lam ivs dests) -> do
write_i <- newVName "write_i"
@@ -306,7 +318,7 @@
Body ->
m ([[SubExp]], [[SubExp]], Log, Out.KernelBody Out.Kernels)
intraGroupParalleliseBody lvl body = do
- (Acc min_ws avail_ws log, kstms) <-
+ (IntraAcc min_ws avail_ws log, kstms) <-
runIntraGroupM $ intraGroupStms lvl $ bodyStms body
return
( S.toList min_ws,
diff --git a/src/Futhark/Pass/ExtractMulticore.hs b/src/Futhark/Pass/ExtractMulticore.hs
--- a/src/Futhark/Pass/ExtractMulticore.hs
+++ b/src/Futhark/Pass/ExtractMulticore.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Futhark.Pass.ExtractMulticore (extractMulticore) where
@@ -7,6 +8,7 @@
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
+import Data.Bitraversable
import Futhark.Analysis.Rephrase
import Futhark.IR
import Futhark.IR.MC
@@ -46,8 +48,10 @@
indexArray :: VName -> LParam SOACS -> VName -> Stm MC
indexArray i (Param p t) arr =
- Let (Pattern [] [PatElem p t]) (defAux ()) $
- BasicOp $ Index arr $ DimFix (Var i) : map sliceDim (arrayDims t)
+ Let (Pattern [] [PatElem p t]) (defAux ()) . BasicOp $
+ case t of
+ Acc {} -> SubExp $ Var arr
+ _ -> Index arr $ DimFix (Var i) : map sliceDim (arrayDims t)
mapLambdaToBody ::
(Body SOACS -> ExtractM (Body MC)) ->
@@ -117,6 +121,12 @@
transformStm (Let pat aux (If cond tbranch fbranch ret)) =
oneStm . Let pat aux
<$> (If cond <$> transformBody tbranch <*> transformBody fbranch <*> pure ret)
+transformStm (Let pat aux (WithAcc inputs lam)) =
+ oneStm . Let pat aux
+ <$> (WithAcc <$> mapM transformInput inputs <*> transformLambda lam)
+ where
+ transformInput (shape, arrs, op) =
+ (shape,arrs,) <$> traverse (bitraverse transformLambda pure) op
transformStm (Let pat aux (Op op)) =
fmap (certify (stmAuxCerts aux)) <$> transformSOAC pat (stmAuxAttrs aux) op
diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs
--- a/src/Futhark/Pass/KernelBabysitting.hs
+++ b/src/Futhark/Pass/KernelBabysitting.hs
@@ -282,7 +282,8 @@
not $ null rem_slice,
allDimAreSlice rem_slice,
Nothing <- M.lookup arr expmap,
- not $ tooSmallSlice (primByteSize (elemType t)) rem_slice,
+ pt <- elemType t,
+ not $ tooSmallSlice (primByteSize pt) rem_slice,
is /= map Var (take (length is) thread_gids) || length is == length thread_gids,
not (null thread_gids || null is),
not (last thread_gids `nameIn` (freeIn is <> freeIn rem_slice)) ->
@@ -293,7 +294,8 @@
-- dimensions will be traversed sequentially.
| (is, rem_slice) <- splitSlice slice,
not $ null rem_slice,
- not $ tooSmallSlice (primByteSize (elemType t)) rem_slice,
+ pt <- elemType t,
+ not $ tooSmallSlice (primByteSize pt) rem_slice,
is /= map Var (take (length is) thread_gids) || length is == length thread_gids,
any isThreadLocal (namesToList $ freeIn is) -> do
let perm = coalescingPermutation (length is) $ arrayRank t
diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs
--- a/src/Futhark/Pkg/Types.hs
+++ b/src/Futhark/Pkg/Types.hs
@@ -70,13 +70,13 @@
-- @hash@ (typically the Git commit ID). This function detects such
-- versions.
isCommitVersion :: SemVer -> Maybe T.Text
-isCommitVersion (SemVer 0 0 0 [_] [Str s NE.:| []]) = Just s
+isCommitVersion (SemVer 0 0 0 [_] (Just s)) = Just s
isCommitVersion _ = Nothing
-- | @commitVersion timestamp commit@ constructs a commit version.
commitVersion :: T.Text -> T.Text -> SemVer
commitVersion time commit =
- SemVer 0 0 0 [Str time NE.:| []] [Str commit NE.:| []]
+ SemVer 0 0 0 [Str time NE.:| []] (Just commit)
-- | Unfortunately, Data.Versions has a buggy semver parser that
-- collapses consecutive zeroes in the metadata field. So, we define
@@ -94,8 +94,8 @@
digitsP = read <$> ((T.unpack <$> string "0") <|> some digitChar)
preRel = maybe [] pure <$> optional preRel'
preRel' = char '-' *> (pure . Str . T.pack <$> some digitChar)
- metaData = maybe [] pure <$> optional metaData'
- metaData' = char '+' *> (pure . Str . T.pack <$> some alphaNumChar)
+ metaData = optional metaData'
+ metaData' = char '+' *> (T.pack <$> some alphaNumChar)
-- | The dependencies of a (revision of a) package is a mapping from
-- package paths to minimum versions (and an optional hash pinning).
diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs
--- a/src/Futhark/Script.hs
+++ b/src/Futhark/Script.hs
@@ -119,7 +119,7 @@
[ inParens sep (mkTuple <$> (parseExp sep `sepBy` pComma)),
inBraces sep (Record <$> (pField `sepBy` pComma)),
Call <$> lexeme sep parseFunc <*> many (parseExp sep),
- constV =<< lexeme sep V.parsePrimValue,
+ Const <$> V.parseValue sep,
StringLit . T.pack <$> lexeme sep ("\"" *> manyTill charLiteral "\"")
]
where
@@ -139,9 +139,6 @@
fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent)
where
constituent c = isAlphaNum c || c == '_'
-
- constV v =
- maybe (fail "invalid value read") (pure . Const) $ V.putValue v
prettyFailure :: CmdFailure -> T.Text
prettyFailure (CmdFailure bef aft) =
diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs
--- a/src/Futhark/Test/Values.hs
+++ b/src/Futhark/Test/Values.hs
@@ -496,16 +496,16 @@
readFloat32 = readFloat lexFloat32
where
lexFloat32 [F32LIT x] = Just x
- lexFloat32 [ID "f32", PROJ_FIELD "inf"] = Just $ 1 / 0
- lexFloat32 [ID "f32", PROJ_FIELD "nan"] = Just $ 0 / 0
+ lexFloat32 [ID "f32", DOT, ID "inf"] = Just $ 1 / 0
+ lexFloat32 [ID "f32", DOT, ID "nan"] = Just $ 0 / 0
lexFloat32 _ = Nothing
readFloat64 :: ReadValue Double
readFloat64 = readFloat lexFloat64
where
lexFloat64 [F64LIT x] = Just x
- lexFloat64 [ID "f64", PROJ_FIELD "inf"] = Just $ 1 / 0
- lexFloat64 [ID "f64", PROJ_FIELD "nan"] = Just $ 0 / 0
+ lexFloat64 [ID "f64", DOT, ID "inf"] = Just $ 1 / 0
+ lexFloat64 [ID "f64", DOT, ID "nan"] = Just $ 0 / 0
lexFloat64 _ = Nothing
readBool :: ReadValue Bool
diff --git a/src/Futhark/Test/Values/Parser.hs b/src/Futhark/Test/Values/Parser.hs
--- a/src/Futhark/Test/Values/Parser.hs
+++ b/src/Futhark/Test/Values/Parser.hs
@@ -63,7 +63,7 @@
parseIntConst :: Parser F.PrimValue
parseIntConst = do
x <- parseInteger
- notFollowedBy $ "f32" <|> "f64" <|> "."
+ notFollowedBy $ "f32" <|> "f64" <|> "." <|> "e"
choice
[ signedV F.Int8Value x "i8",
signedV F.Int16Value x "i16",
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
@@ -20,9 +20,11 @@
import Control.Monad.Except
import Control.Monad.State
-import Data.List (zip4)
+import Data.List (find, zip4)
import qualified Data.Map.Strict as M
+import qualified Futhark.Analysis.Alias as Alias
import qualified Futhark.IR as AST
+import Futhark.IR.Prop.Aliases
import Futhark.IR.SOACS
import Futhark.MonadFreshNames
import Futhark.Tools
@@ -34,7 +36,8 @@
( Bindable lore,
BinderOps lore,
LetDec SOACS ~ LetDec lore,
- LParamInfo SOACS ~ LParamInfo lore
+ LParamInfo SOACS ~ LParamInfo lore,
+ CanBeAliased (Op lore)
)
-- | First-order-transform a single function, with the given scope
@@ -48,7 +51,7 @@
(body', _) <- modifyNameSource $ runState $ runBinderT m consts_scope
return $ FunDef entry attrs fname rettype params body'
where
- m = localScope (scopeOfFParams params) $ insertStmsM $ transformBody body
+ m = localScope (scopeOfFParams params) $ transformBody body
-- | First-order-transform these top-level constants.
transformConsts ::
@@ -67,16 +70,17 @@
LocalScope (Lore m) m,
Bindable (Lore m),
BinderOps (Lore m),
- LParamInfo SOACS ~ LParamInfo (Lore m)
+ LParamInfo SOACS ~ LParamInfo (Lore m),
+ CanBeAliased (Op (Lore m))
)
transformBody ::
(Transformer m, LetDec (Lore m) ~ LetDec SOACS) =>
Body ->
m (AST.Body (Lore m))
-transformBody (Body () bnds res) = insertStmsM $ do
- mapM_ transformStmRecursively bnds
- return $ resultBody res
+transformBody (Body () stms res) = buildBody_ $ do
+ mapM_ transformStmRecursively stms
+ pure res
-- | First transform any nested t'Body' or t'Lambda' elements, then
-- apply 'transformSOAC' if the expression is a SOAC.
@@ -101,6 +105,18 @@
mapOnOp = error "Unhandled Op in first order transform"
}
+-- Produce scratch "arrays" for the Map and Scan outputs of Screma.
+-- "Arrays" is in quotes because some of those may be accumulators.
+resultArray :: Transformer m => [VName] -> [Type] -> m [VName]
+resultArray arrs ts = do
+ arrs_ts <- mapM lookupType arrs
+ let oneArray t@Acc {}
+ | Just (v, _) <- find ((== t) . snd) (zip arrs arrs_ts) =
+ pure v
+ oneArray t =
+ letExp "result" =<< eBlank t
+ mapM oneArray ts
+
-- | Transform a single 'SOAC' into a do-loop. The body of the lambda
-- is untouched, and may or may not contain further 'SOAC's depending
-- on the given lore.
@@ -110,30 +126,30 @@
SOAC (Lore m) ->
m ()
transformSOAC pat (Screma w arrs form@(ScremaForm scans reds map_lam)) = do
- -- Start by combining all the reduction parts into a single operator
+ -- See Note [Translation of Screma].
+ --
+ -- Start by combining all the reduction and scan parts into a single
+ -- operator
let Reduce _ red_lam red_nes = singleReduce reds
Scan scan_lam scan_nes = singleScan scans
(scan_arr_ts, _red_ts, map_arr_ts) =
splitAt3 (length scan_nes) (length red_nes) $ scremaType w form
- scan_arrs <- resultArray scan_arr_ts
- map_arrs <- resultArray map_arr_ts
- -- We construct a loop that contains several groups of merge
- -- parameters:
- --
- -- (0) scan accumulator.
- -- (1) scan results.
- -- (2) reduce results (and accumulator).
- -- (3) map results.
- --
- -- Inside the loop, the parameters to map_lam become for-in
- -- parameters.
+ scan_arrs <- resultArray [] scan_arr_ts
+ map_arrs <- resultArray arrs map_arr_ts
scanacc_params <- mapM (newParam "scanacc" . flip toDecl Nonunique) $ lambdaReturnType scan_lam
scanout_params <- mapM (newParam "scanout" . flip toDecl Unique) scan_arr_ts
redout_params <- mapM (newParam "redout" . flip toDecl Nonunique) $ lambdaReturnType red_lam
mapout_params <- mapM (newParam "mapout" . flip toDecl Unique) map_arr_ts
+ arr_ts <- mapM lookupType arrs
+ let paramForAcc (Acc c _ _ _) = find (f . paramType) mapout_params
+ where
+ f (Acc c2 _ _ _) = c == c2
+ f _ = False
+ paramForAcc _ = Nothing
+
let merge =
concat
[ zip scanacc_params scan_nes,
@@ -143,52 +159,62 @@
]
i <- newVName "i"
let loopform = ForLoop i Int64 w []
+ lam_cons = consumedByLambda $ Alias.analyseLambda mempty map_lam
- loop_body <- runBodyBinder $
- localScope (scopeOfFParams $ map fst merge) $
- inScopeOf loopform $ do
- forM_ (zip (lambdaParams map_lam) arrs) $ \(p, arr) -> do
- arr_t <- lookupType arr
- letBindNames [paramName p] $
- BasicOp $
- Index arr $
- fullSlice arr_t [DimFix $ Var i]
+ loop_body <- runBodyBinder
+ . localScope (scopeOfFParams (map fst merge) <> scopeOf loopform)
+ $ do
+ -- Bind the parameters to the lambda.
+ forM_ (zip3 (lambdaParams map_lam) arrs arr_ts) $ \(p, arr, arr_t) ->
+ case paramForAcc arr_t of
+ Just acc_out_p ->
+ letBindNames [paramName p] . BasicOp $
+ SubExp $ Var $ paramName acc_out_p
+ Nothing
+ | paramName p `nameIn` lam_cons -> do
+ p' <-
+ letExp (baseString (paramName p)) $
+ BasicOp $
+ Index arr $ fullSlice arr_t [DimFix $ Var i]
+ letBindNames [paramName p] $ BasicOp $ Copy p'
+ | otherwise ->
+ letBindNames [paramName p] $
+ BasicOp $
+ Index arr $ fullSlice arr_t [DimFix $ Var i]
- -- Insert the statements of the lambda. We have taken care to
- -- ensure that the parameters are bound at this point.
- mapM_ addStm $ bodyStms $ lambdaBody map_lam
- -- Split into scan results, reduce results, and map results.
- let (scan_res, red_res, map_res) =
- splitAt3 (length scan_nes) (length red_nes) $
- bodyResult $ lambdaBody map_lam
+ -- Insert the statements of the lambda. We have taken care to
+ -- ensure that the parameters are bound at this point.
+ mapM_ addStm $ bodyStms $ lambdaBody map_lam
+ -- Split into scan results, reduce results, and map results.
+ let (scan_res, red_res, map_res) =
+ splitAt3 (length scan_nes) (length red_nes) $
+ bodyResult $ lambdaBody map_lam
- scan_res' <-
- eLambda scan_lam $
- map (pure . BasicOp . SubExp) $
- map (Var . paramName) scanacc_params ++ scan_res
- red_res' <-
- eLambda red_lam $
- map (pure . BasicOp . SubExp) $
- map (Var . paramName) redout_params ++ red_res
+ scan_res' <-
+ eLambda scan_lam $
+ map (pure . BasicOp . SubExp) $
+ map (Var . paramName) scanacc_params ++ scan_res
+ red_res' <-
+ eLambda red_lam $
+ map (pure . BasicOp . SubExp) $
+ map (Var . paramName) redout_params ++ red_res
- -- Write the scan accumulator to the scan result arrays.
- scan_outarrs <-
- letwith (map paramName scanout_params) (pexp (Var i)) $
- map (BasicOp . SubExp) scan_res'
+ -- Write the scan accumulator to the scan result arrays.
+ scan_outarrs <-
+ letwith (map paramName scanout_params) (Var i) scan_res'
- -- Write the map results to the map result arrays.
- map_outarrs <-
- letwith (map paramName mapout_params) (pexp (Var i)) $
- map (BasicOp . SubExp) map_res
+ -- Write the map results to the map result arrays.
+ map_outarrs <-
+ letwith (map paramName mapout_params) (Var i) map_res
- return $
- resultBody $
- concat
- [ scan_res',
- map Var scan_outarrs,
- red_res',
- map Var map_outarrs
- ]
+ return $
+ resultBody $
+ concat
+ [ scan_res',
+ map Var scan_outarrs,
+ red_res',
+ map Var map_outarrs
+ ]
-- We need to discard the final scan accumulators, as they are not
-- bound in the original pattern.
@@ -211,9 +237,9 @@
<$> newParam "stream_mapout" (toDecl t' Unique)
<*> letSubExp "stream_mapout_scratch" scratch
- let merge =
- zip (map (fmap (`toDecl` Nonunique)) fold_params) nes
- ++ mapout_merge
+ let onType t@Acc {} = t `toDecl` Unique
+ onType t = t `toDecl` Nonunique
+ merge = zip (map (fmap onType) fold_params) nes ++ mapout_merge
merge_params = map fst merge
mapout_params = map fst mapout_merge
@@ -289,56 +315,51 @@
let merge = loopMerge hists_out $ concatMap (map Var . histDest) ops
-- Bind lambda-bodies for operators.
- loopBody <- runBodyBinder $
- localScope
- ( M.insert iter (IndexName Int64) $
- scopeOfFParams $ map fst merge
- )
- $ do
- -- Bind images to parameters of bucket function.
- imgs' <- forM imgs $ \img -> do
- img_t <- lookupType img
- letSubExp "pixel" $ BasicOp $ Index img $ fullSlice img_t [DimFix $ Var iter]
- imgs'' <- bindLambda bucket_fun $ map (BasicOp . SubExp) imgs'
+ let iter_scope = M.insert iter (IndexName Int64) $ scopeOfFParams $ map fst merge
+ loopBody <- runBodyBinder . localScope iter_scope $ do
+ -- Bind images to parameters of bucket function.
+ imgs' <- forM imgs $ \img -> do
+ img_t <- lookupType img
+ letSubExp "pixel" $ BasicOp $ Index img $ fullSlice img_t [DimFix $ Var iter]
+ imgs'' <- bindLambda bucket_fun $ map (BasicOp . SubExp) imgs'
- -- Split out values from bucket function.
- let lens = length ops
- inds = 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
+ -- Split out values from bucket function.
+ let lens = length ops
+ inds = 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
- -- Check whether the indexes are in-bound. If they are not, we
- -- return the histograms unchanged.
- let outside_bounds_branch = insertStmsM $ resultBodyM $ map Var hist
- oob = case hist of
- [] -> eSubExp $ constant True
- arr : _ -> eOutOfBounds arr [eSubExp idx]
+ hists_out'' <- forM (zip4 hists_out' ops inds vals) $ \(hist, op, idx, val) -> do
+ -- Check whether the indexes are in-bound. If they are not, we
+ -- return the histograms unchanged.
+ let outside_bounds_branch = buildBody_ $ pure $ map Var hist
+ oob = case hist of
+ [] -> eSubExp $ constant True
+ arr : _ -> eOutOfBounds arr [eSubExp idx]
- letTupExp "new_histo"
- <=< eIf oob outside_bounds_branch
- $ 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]
+ 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]
- -- Apply operator.
- h_val' <-
- bindLambda (histOp op) $
- map (BasicOp . SubExp) $ h_val ++ val
+ -- Apply operator.
+ h_val' <-
+ bindLambda (histOp op) $
+ map (BasicOp . SubExp) $ h_val ++ val
- -- Write values back to histograms.
- hist' <- forM (zip hist h_val') $ \(arr, v) -> do
- arr_t <- lookupType arr
- letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $
- BasicOp $ SubExp v
+ -- Write values back to histograms.
+ hist' <- forM (zip hist h_val') $ \(arr, v) -> do
+ arr_t <- lookupType arr
+ letInPlace "hist_out" arr (fullSlice arr_t [DimFix idx]) $
+ BasicOp $ SubExp v
- return $ resultBody $ map Var hist'
+ pure $ map Var hist'
- return $ resultBody $ map Var $ concat hists_out''
+ return $ resultBody $ map Var $ concat hists_out''
-- Wrap up the above into a for-loop.
letBind pat $ DoLoop [] merge (ForLoop iter Int64 len []) loopBody
@@ -350,7 +371,8 @@
BinderOps lore,
LocalScope somelore m,
SameScope somelore lore,
- LetDec lore ~ LetDec SOACS
+ LetDec lore ~ LetDec SOACS,
+ CanBeAliased (Op lore)
) =>
Lambda ->
m (AST.Lambda lore)
@@ -361,27 +383,16 @@
transformBody body
return $ Lambda params body' rettype
-resultArray :: Transformer m => [Type] -> m [VName]
-resultArray = mapM oneArray
- where
- oneArray t = letExp "result" $ BasicOp $ Scratch (elemType t) (arrayDims t)
-
-letwith ::
- Transformer m =>
- [VName] ->
- m (AST.Exp (Lore m)) ->
- [AST.Exp (Lore m)] ->
- m [VName]
+letwith :: Transformer m => [VName] -> SubExp -> [SubExp] -> m [VName]
letwith ks i vs = do
- vs' <- letSubExps "values" vs
- i' <- letSubExp "i" =<< i
let update k v = do
k_t <- lookupType k
- letInPlace "lw_dest" k (fullSlice k_t [DimFix i']) $ BasicOp $ SubExp v
- zipWithM update ks vs'
-
-pexp :: Applicative f => SubExp -> f (AST.Exp lore)
-pexp = pure . BasicOp . SubExp
+ case k_t of
+ Acc {} ->
+ letExp "lw_acc" $ BasicOp $ SubExp v
+ _ ->
+ letInPlace "lw_dest" k (fullSlice k_t [DimFix i]) $ BasicOp $ SubExp v
+ zipWithM update ks vs
bindLambda ::
Transformer m =>
@@ -403,3 +414,46 @@
[ (Param pname $ toDecl ptype u, val)
| ((Ident pname ptype, u), val) <- zip vars vals
]
+
+-- Note [Translation of Screma]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Screma is the most general SOAC. It is translated by constructing
+-- a loop that contains several groups of parameters, in this order:
+--
+-- (0) Scan accumulator, initialised with neutral element.
+-- (1) Scan results, initialised with Scratch.
+-- (2) Reduce results (also functioning as accumulators),
+-- initialised with neutral element.
+-- (3) Map results, mostly initialised with Scratch.
+--
+-- However, category (3) is a little more tricky in the case where one
+-- of the results is an Acc. In that case, the result is not an
+-- array, but another Acc. Any Acc result of a Map must correspond to
+-- an Acc that is an input to the map, and the result is initialised
+-- to be that input. This requires a 1:1 relationship between Acc
+-- inputs and Acc outputs, which the type checker should enforce.
+-- There is no guarantee that the map results appear in any particular
+-- order (e.g. accumulator results before non-accumulator results), so
+-- we need to do a little sleuthing to establish the relationship.
+--
+-- Inside the loop, the non-Acc parameters to map_lam become for-in
+-- parameters. Acc parameters refer to the loop parameters for the
+-- corresponding Map result instead.
+--
+-- Intuitively, a Screma(w,
+-- (scan_op, scan_ne),
+-- (red_op, red_ne),
+-- map_fn,
+-- {acc_input, arr_input})
+--
+-- then becomes
+--
+-- loop (scan_acc, scan_arr, red_acc, map_acc, map_arr) =
+-- for i < w, x in arr_input do
+-- let (a,b,map_acc',d) = map_fn(map_acc, x)
+-- let scan_acc' = scan_op(scan_acc, a)
+-- let scan_arr[i] = scan_acc'
+-- let red_acc' = red_op(red_acc, b)
+-- let map_arr[i] = d
+-- in (scan_acc', scan_arr', red_acc', map_acc', map_arr)
diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs
--- a/src/Futhark/Transform/Rename.hs
+++ b/src/Futhark/Transform/Rename.hs
@@ -246,6 +246,8 @@
rename (Let pat elore e) = Let <$> rename pat <*> rename elore <*> rename e
instance Renameable lore => Rename (Exp lore) where
+ rename (WithAcc inputs lam) =
+ WithAcc <$> rename inputs <*> rename lam
rename (DoLoop ctx val form loopbody) = do
let (ctxparams, ctxinit) = unzip ctx
(valparams, valinit) = unzip val
@@ -303,15 +305,15 @@
mapOnOp = rename
}
-instance
- Rename shape =>
- Rename (TypeBase shape u)
- where
- rename (Array et size u) = do
- size' <- rename size
- return $ Array et size' u
- rename (Prim et) = return $ Prim et
+instance Rename PrimType where
+ rename = pure
+
+instance Rename shape => Rename (TypeBase shape u) where
+ rename (Array et size u) = Array <$> rename et <*> rename size <*> pure u
+ rename (Prim t) = return $ Prim t
rename (Mem space) = pure $ Mem space
+ rename (Acc acc ispace ts u) =
+ Acc <$> rename acc <*> rename ispace <*> rename ts <*> pure u
instance Renameable lore => Rename (Lambda lore) where
rename (Lambda params body ret) =
diff --git a/src/Futhark/Transform/Substitute.hs b/src/Futhark/Transform/Substitute.hs
--- a/src/Futhark/Transform/Substitute.hs
+++ b/src/Futhark/Transform/Substitute.hs
@@ -147,10 +147,20 @@
instance Substitute Names where
substituteNames = mapNames . substituteNames
+instance Substitute PrimType where
+ substituteNames _ t = t
+
instance Substitute shape => Substitute (TypeBase shape u) where
- substituteNames _ (Prim et) = Prim et
+ substituteNames _ (Prim et) =
+ Prim et
+ substituteNames substs (Acc acc ispace ts u) =
+ Acc
+ (substituteNames substs acc)
+ (substituteNames substs ispace)
+ (substituteNames substs ts)
+ u
substituteNames substs (Array et sz u) =
- Array et (substituteNames substs sz) u
+ Array (substituteNames substs et) (substituteNames substs sz) u
substituteNames _ (Mem space) =
Mem space
diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs
--- a/src/Futhark/TypeCheck.hs
+++ b/src/Futhark/TypeCheck.hs
@@ -56,7 +56,7 @@
import Control.Monad.RWS.Strict
import Control.Parallel.Strategies
-import Data.List (find, intercalate, sort)
+import Data.List (find, intercalate, isPrefixOf, sort)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
@@ -117,8 +117,8 @@
show (DupPatternError name) =
"Variable " ++ pretty name ++ " bound twice in pattern."
show (InvalidPatternError pat t desc) =
- "Pattern " ++ pretty pat
- ++ " cannot match value of type "
+ "Pattern\n" ++ pretty pat
+ ++ "\ncannot match value of type\n"
++ prettyTuple t
++ end
where
@@ -361,7 +361,7 @@
consume :: Checkable lore => Names -> TypeM lore ()
consume als = do
scope <- askScope
- let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)
+ let isArray = maybe False (not . primType . typeOf) . (`M.lookup` scope)
occur [consumption $ namesFromList $ filter isArray $ namesToList als]
collectOccurences :: TypeM lore a -> TypeM lore (a, Occurences)
@@ -527,6 +527,21 @@
Array {} -> return t
_ -> bad $ NotAnArray v t
+checkAccIdent ::
+ Checkable lore =>
+ VName ->
+ TypeM lore (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.
@@ -583,7 +598,7 @@
map declExtTypeOf rettype,
funParamsToNameInfos params
)
- consumable
+ (Just consumable)
$ do
checkFunParams params
checkRetType rettype
@@ -627,13 +642,13 @@
[DeclExtType],
[(VName, NameInfo (Aliases lore))]
) ->
- [(VName, Names)] ->
+ Maybe [(VName, Names)] ->
TypeM lore [Names] ->
TypeM lore ()
checkFun' (fname, rettype, params) consumable check = do
checkNoDuplicateParams
binding (M.fromList params) $
- consumeOnlyParams consumable $ do
+ maybe id consumeOnlyParams consumable $ do
body_aliases <- check
scope <- askScope
let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)
@@ -809,7 +824,7 @@
bad $ TypeError "The target of an Update must not alias the value to be written."
mapM_ checkDimIndex idxes
- require [Prim (elemType src_t) `arrayOfShape` Shape (sliceDims idxes)] se
+ require [arrayOf (Prim (elemType src_t)) (Shape (sliceDims idxes)) NoUniqueness] se
consume =<< lookupAliases src
checkBasicOp (Iota e x s et) = do
require [Prim int64] e
@@ -884,7 +899,30 @@
checkPart ErrorString {} = return ()
checkPart (ErrorInt32 x) = require [Prim int32] x
checkPart (ErrorInt64 x) = require [Prim int64] 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 lore =>
[Param DeclType] ->
@@ -934,7 +972,7 @@
"Expected apply result type " ++ pretty rettype_derived
++ " but annotation is "
++ pretty rettype_annot
- checkFuncall (Just fname) paramtypes argflows
+ consumeArgs paramtypes argflows
checkExp (DoLoop ctxmerge valmerge form loopbody) = do
let merge = ctxmerge ++ valmerge
(mergepat, mergeexps) = unzip merge
@@ -949,51 +987,7 @@
return ()
binding (scopeOf form) $ do
- case form of
- ForLoop loopvar it boundexp loopvars -> do
- iparam <- primFParam loopvar $ IntType it
- let funparams = iparam : mergepat
- paramts = map paramDeclType funparams
-
- forM_ loopvars $ \(p, a) -> do
- a_t <- lookupType a
- observe a
- case peelArray 1 a_t of
- Just a_t_r -> do
- checkLParamLore (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
- _ ->
- bad $
- TypeError $
- "Cannot loop over " ++ pretty a
- ++ " of type "
- ++ pretty a_t
-
- boundarg <- checkArg boundexp
- checkFuncall Nothing paramts $ boundarg : 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 funparams = mergepat
- paramts = map paramDeclType funparams
- checkFuncall Nothing paramts mergeargs
+ form_consumable <- checkForm merge mergeargs form
let rettype = map paramDeclType mergepat
consumable =
@@ -1001,6 +995,7 @@
| param <- mergepat,
unique $ paramDeclType param
]
+ ++ form_consumable
context "Inside the loop body" $
checkFun'
@@ -1008,7 +1003,7 @@
staticShapes rettype,
funParamsToNameInfos mergepat
)
- consumable
+ (Just consumable)
$ do
checkFunParams mergepat
checkBodyLore $ snd $ bodyDec loopbody
@@ -1026,6 +1021,97 @@
scopeOf $ bodyStms loopbody
map (`namesSubtract` bound_here)
<$> mapM subExpAliasesM (bodyResult loopbody)
+ where
+ checkLoopVar (p, a) = do
+ a_t <- lookupType a
+ observe a
+ case peelArray 1 a_t of
+ Just a_t_r -> do
+ checkLParamLore (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 merge 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 merge 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
+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
@@ -1035,33 +1121,34 @@
SubExp ->
[VName] ->
TypeM lore [Arg]
-checkSOACArrayArgs width vs =
- forM vs $ \v -> do
- (vt, v') <- checkSOACArrayArg v
- let argSize = arraySize 0 vt
- unless (argSize == width) $
- bad $
- TypeError $
- "SOAC argument " ++ pretty v ++ " has outer size "
- ++ pretty argSize
- ++ ", but width of SOAC is "
- ++ pretty width
- return v'
+checkSOACArrayArgs width = mapM checkSOACArrayArg
where
- checkSOACArrayArg ident = do
- (t, als) <- checkArg $ Var ident
- case peelArray 1 t of
- Nothing ->
- bad $
- TypeError $
- "SOAC argument " ++ pretty ident ++ " is not an array"
- Just rt -> return (t, (rt, als))
+ 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 lore =>
TypeBase Shape u ->
TypeM lore ()
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 ::
@@ -1122,7 +1209,7 @@
TypeM lore a ->
TypeM lore a
checkStm stm@(Let pat (StmAux (Certificates cs) _ (_, dec)) e) m = do
- context "When checking certificates" $ mapM_ (requireI [Prim Cert]) cs
+ context "When checking certificates" $ mapM_ (requireI [Prim Unit]) cs
context "When checking expression annotation" $ checkExpLore dec
context ("When matching\n" ++ message " " pat ++ "\nwith\n" ++ message " " e) $
matchPattern pat e
@@ -1256,31 +1343,37 @@
checkFuncall fname paramts args = do
let argts = map argType args
unless (validApply paramts argts) $
- bad $
- ParameterMismatch
- fname
- (map fromDecl paramts)
- $ map argType args
+ bad $ ParameterMismatch fname (map fromDecl paramts) $ map argType args
+ consumeArgs paramts args
+
+consumeArgs ::
+ [DeclType] ->
+ [Arg] ->
+ TypeM lore ()
+consumeArgs paramts args =
forM_ (zip (map diet paramts) args) $ \(d, (_, als)) ->
occur [consumption (consumeArg als d)]
where
consumeArg als Consume = als
consumeArg _ _ = mempty
-checkLambda ::
- Checkable lore =>
- Lambda (Aliases lore) ->
- [Arg] ->
- TypeM lore ()
-checkLambda (Lambda params body rettype) args = do
+-- The boolean indicates whether we only allow consumption of
+-- parameters.
+checkAnyLambda ::
+ Checkable lore => Bool -> Lambda (Aliases lore) -> [Arg] -> TypeM lore ()
+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)
- args
- let consumable = zip (map paramName params) (map argAliases args)
+ $ 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,
@@ -1303,6 +1396,9 @@
++ "\nbut expected to take "
++ show (length args)
++ " arguments."
+
+checkLambda :: Checkable lore => Lambda (Aliases lore) -> [Arg] -> TypeM lore ()
+checkLambda = checkAnyLambda True
checkPrimExp :: Checkable lore => PrimExp VName -> TypeM lore ()
checkPrimExp ValueExp {} = return ()
diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs
--- a/src/Futhark/Util.hs
+++ b/src/Futhark/Util.hs
@@ -47,6 +47,7 @@
UserString,
EncodedString,
zEncodeString,
+ atMostChars,
)
where
@@ -411,3 +412,8 @@
else '0' : hex_str
where
hex_str = showHex (ord c) "U"
+
+atMostChars :: Int -> String -> String
+atMostChars n s
+ | length s > n = take (n -3) s ++ "..."
+ | otherwise = s
diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs
--- a/src/Futhark/Util/Pretty.hs
+++ b/src/Futhark/Util/Pretty.hs
@@ -17,6 +17,7 @@
nestedBlock,
textwrap,
shorten,
+ commastack,
)
where
@@ -90,3 +91,7 @@
| otherwise = text s
where
s = pretty a
+
+-- | Like 'commasep', but a newline after every comma.
+commastack :: [Doc] -> Doc
+commastack = align . stack . punctuate comma
diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs
--- a/src/Language/Futhark.hs
+++ b/src/Language/Futhark.hs
@@ -5,6 +5,7 @@
module Language.Futhark.Pretty,
Ident,
DimIndex,
+ AppExp,
Exp,
Pattern,
ModExp,
@@ -37,6 +38,9 @@
-- | An expression with type information.
type Exp = ExpBase Info VName
+
+-- | An application expression with type information.
+type AppExp = AppExpBase Info VName
-- | A pattern with type information.
type Pattern = PatternBase Info VName
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
@@ -243,9 +243,10 @@
| -- Stores the full shape.
ValueRecord (M.Map Name Value)
| ValueFun (Value -> EvalM Value)
- | ValueSum ValueShape Name [Value]
-
--- Stores the full shape.
+ | -- Stores the full shape.
+ ValueSum ValueShape Name [Value]
+ | -- The update function and the array.
+ ValueAcc (Value -> Value -> EvalM Value) !(Array Int Value)
instance Eq Value where
ValuePrim (SignedValue x) == ValuePrim (SignedValue y) =
@@ -259,6 +260,7 @@
ValueArray _ x == ValueArray _ y = x == y
ValueRecord x == ValueRecord y = x == y
ValueSum _ n1 vs1 == ValueSum _ n2 vs2 = n1 == n2 && vs1 == vs2
+ ValueAcc _ x == ValueAcc _ y = x == y
_ == _ = False
instance Pretty Value where
@@ -273,6 +275,7 @@
in brackets $ cat $ punctuate separator (map ppr elements)
pprPrec _ (ValueRecord m) = prettyRecord m
pprPrec _ ValueFun {} = text "#"
+ pprPrec _ ValueAcc {} = text "#"
pprPrec p (ValueSum _ n vs) =
parensIf (p > 0) $ text "#" <> sep (ppr n : map (pprPrec 1) vs)
@@ -743,16 +746,11 @@
ValueFun $ \v -> do
env' <- matchPattern env p v
-- Fix up the last sizes, if any.
- let env''
+ let p_t = evalType env $ patternStructType p
+ env''
| null missing_sizes = env'
| otherwise =
- env'
- <> i64Env
- ( resolveExistentials
- missing_sizes
- (patternStructType p)
- (valueShape v)
- )
+ env' <> i64Env (resolveExistentials missing_sizes p_t (valueShape v))
evalFunction env'' missing_sizes ps body rettype
evalFunctionBinding ::
@@ -803,36 +801,8 @@
resolveExistentials retext (evalType env $ toStruct ret) $ valueShape v
return v
-eval :: Env -> Exp -> EvalM Value
-eval _ (Literal v _) = return $ ValuePrim v
-eval env (Parens e _) = eval env e
-eval env (QualParens (qv, _) e loc) = do
- m <- evalModuleVar env qv
- case m of
- ModuleFun {} -> error $ "Local open of module function at " ++ locStr loc
- Module m' -> eval (m' <> env) e
-eval env (TupLit vs _) = toTuple <$> mapM (eval env) vs
-eval env (RecordLit fields _) =
- ValueRecord . M.fromList <$> mapM evalField fields
- where
- evalField (RecordFieldExplicit k e _) = do
- v <- eval env e
- return (k, v)
- evalField (RecordFieldImplicit k t loc) = do
- v <- eval env $ Var (qualName k) t loc
- return (baseName k, v)
-eval _ (StringLit vs _) =
- return $
- toArray' ShapeLeaf $
- map (ValuePrim . UnsignedValue . Int8Value . fromIntegral) vs
-eval env (ArrayLit [] (Info t) _) = do
- t' <- typeValueShape env $ toStruct t
- return $ toArray t' []
-eval env (ArrayLit (v : vs) _ _) = do
- v' <- eval env v
- vs' <- mapM (eval env) vs
- return $ toArray' (valueShape v') (v' : vs')
-eval env (Range start maybe_second end (Info t, Info retext) loc) = do
+evalAppExp :: Env -> AppExp -> EvalM Value
+evalAppExp env (Range start maybe_second end loc) = do
start' <- asInteger <$> eval env start
maybe_second' <- traverse (fmap asInteger . eval env) maybe_second
end' <- traverse (fmap asInteger . eval env) end
@@ -856,18 +826,16 @@
(x -1, second' - start', start' <= x && second' > start')
if ok
- then
- returned env t retext $
- toArray' ShapeLeaf $ map toInt [start', start' + step .. end_adj]
+ then pure $ toArray' ShapeLeaf $ map toInt [start', start' + step .. end_adj]
else bad loc env $ badRange start' maybe_second' end'
where
toInt =
- case stripArray 1 t of
+ case typeOf start of
Scalar (Prim (Signed t')) ->
ValuePrim . SignedValue . intValue t'
Scalar (Prim (Unsigned t')) ->
ValuePrim . UnsignedValue . intValue t'
- _ -> error $ "Nonsensical range type: " ++ show t
+ t -> error $ "Nonsensical range type: " ++ show t
badRange start' maybe_second' end' =
"Range " ++ pretty start'
@@ -881,10 +849,8 @@
UpToExclusive x -> "..<" ++ pretty x
)
++ " is invalid."
-eval env (Var qv (Info t) _) = evalTermVar env qv (toStruct t)
-eval env (Ascript e _ _) = eval env e
-eval env (Coerce e td (Info ret, Info retext) loc) = do
- v <- returned env ret retext =<< eval env e
+evalAppExp env (Coerce e td loc) = do
+ v <- eval env e
let t = evalType env $ unInfo $ expandedType td
case checkShape (structTypeShape (envShapes env) t) (valueShape v) of
Just _ -> return v
@@ -896,36 +862,23 @@
<> "` (`"
<> pretty t
<> "`)"
-eval env (LetPat p e body (Info ret, Info retext) _) = do
+evalAppExp env (LetPat sizes p e body _) = do
v <- eval env e
env' <- matchPattern env p v
- returned env ret retext =<< eval env' body
-eval env (LetFun f (tparams, ps, _, Info ret, fbody) body _ _) = do
+ let p_t = evalType env $ patternStructType p
+ v_s = valueShape v
+ env'' = env' <> i64Env (resolveExistentials (map sizeName sizes) p_t v_s)
+ eval env'' body
+evalAppExp env (LetFun f (tparams, ps, _, Info ret, fbody) body _) = do
binding <- evalFunctionBinding env tparams ps ret [] fbody
eval (env {envTerm = M.insert f binding $ envTerm env}) body
-eval _ (IntLit v (Info t) _) =
- case t of
- Scalar (Prim (Signed it)) ->
- return $ ValuePrim $ SignedValue $ intValue it v
- Scalar (Prim (Unsigned it)) ->
- return $ ValuePrim $ UnsignedValue $ intValue it v
- Scalar (Prim (FloatType ft)) ->
- return $ ValuePrim $ FloatValue $ floatValue ft v
- _ -> error $ "eval: nonsensical type for integer literal: " ++ pretty t
-eval _ (FloatLit v (Info t) _) =
- case t of
- Scalar (Prim (FloatType ft)) ->
- return $ ValuePrim $ FloatValue $ floatValue ft v
- _ -> error $ "eval: nonsensical type for float literal: " ++ pretty t
-eval
+evalAppExp
env
( BinOp
(op, _)
op_t
(x, Info (_, xext))
(y, Info (_, yext))
- (Info t)
- (Info retext)
loc
)
| baseString (qualLeaf op) == "&&" = do
@@ -942,17 +895,141 @@
op' <- eval env $ Var op op_t loc
x' <- evalArg env x xext
y' <- evalArg env y yext
- returned env t retext =<< apply2 loc env op' x' y'
-eval env (If cond e1 e2 (Info ret, Info retext) _) = do
+ apply2 loc env op' x' y'
+evalAppExp env (If cond e1 e2 _) = do
cond' <- asBool <$> eval env cond
- returned env ret retext
- =<< if cond' then eval env e1 else eval env e2
-eval env (Apply f x (Info (_, ext)) (Info t, Info retext) loc) = do
+ if cond' then eval env e1 else eval env e2
+evalAppExp env (Apply f x (Info (_, ext)) loc) = do
-- It is important that 'x' is evaluated first in order to bring any
-- sizes into scope that may be used in the type of 'f'.
x' <- evalArg env x ext
f' <- eval env f
- returned env t retext =<< apply loc env f' x'
+ apply loc env f' x'
+evalAppExp env (Index e is loc) = do
+ is' <- mapM (evalDimIndex env) is
+ arr <- eval env e
+ evalIndex loc env is' arr
+evalAppExp env (LetWith dest src is v body loc) = do
+ let Ident src_vn (Info src_t) _ = src
+ dest' <-
+ maybe oob return
+ =<< updateArray <$> mapM (evalDimIndex env) is
+ <*> evalTermVar env (qualName src_vn) (toStruct src_t)
+ <*> eval env v
+ let t = T.BoundV [] $ toStruct $ unInfo $ identType dest
+ eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body
+ where
+ oob = bad loc env "Bad update"
+evalAppExp env (DoLoop sparams pat init_e form body _) = do
+ init_v <- eval env init_e
+ case form of
+ For iv bound -> do
+ bound' <- asSigned <$> eval env bound
+ forLoop (identName iv) bound' (zero bound') init_v
+ ForIn in_pat in_e -> do
+ (_, in_vs) <- fromArray <$> eval env in_e
+ foldM (forInLoop in_pat) init_v in_vs
+ While cond ->
+ whileLoop cond init_v
+ where
+ withLoopParams v =
+ let sparams' =
+ resolveExistentials
+ sparams
+ (patternStructType pat)
+ (valueShape v)
+ in matchPattern (i64Env sparams' <> env) pat v
+
+ inc = (`P.doAdd` Int64Value 1)
+ zero = (`P.doMul` Int64Value 0)
+
+ forLoop iv bound i v
+ | i >= bound = return v
+ | otherwise = do
+ env' <- withLoopParams v
+ forLoop iv bound (inc i)
+ =<< eval
+ ( valEnv
+ ( M.singleton
+ iv
+ ( Just $ T.BoundV [] $ Scalar $ Prim $ Signed Int64,
+ ValuePrim (SignedValue i)
+ )
+ )
+ <> env'
+ )
+ body
+
+ whileLoop cond v = do
+ env' <- withLoopParams v
+ continue <- asBool <$> eval env' cond
+ if continue
+ then whileLoop cond =<< eval env' body
+ else return v
+
+ forInLoop in_pat v in_v = do
+ env' <- withLoopParams v
+ env'' <- matchPattern env' in_pat in_v
+ eval env'' body
+evalAppExp env (Match e cs _) = do
+ v <- eval env e
+ match v (NE.toList cs)
+ where
+ match _ [] =
+ error "Pattern match failure."
+ match v (c : cs') = do
+ c' <- evalCase v env c
+ case c' of
+ Just v' -> return v'
+ Nothing -> match v cs'
+
+eval :: Env -> Exp -> EvalM Value
+eval _ (Literal v _) = return $ ValuePrim v
+eval env (Parens e _) = eval env e
+eval env (QualParens (qv, _) e loc) = do
+ m <- evalModuleVar env qv
+ case m of
+ ModuleFun {} -> error $ "Local open of module function at " ++ locStr loc
+ Module m' -> eval (m' <> env) e
+eval env (TupLit vs _) = toTuple <$> mapM (eval env) vs
+eval env (RecordLit fields _) =
+ ValueRecord . M.fromList <$> mapM evalField fields
+ where
+ evalField (RecordFieldExplicit k e _) = do
+ v <- eval env e
+ return (k, v)
+ evalField (RecordFieldImplicit k t loc) = do
+ v <- eval env $ Var (qualName k) t loc
+ return (baseName k, v)
+eval _ (StringLit vs _) =
+ return $
+ toArray' ShapeLeaf $
+ map (ValuePrim . UnsignedValue . Int8Value . fromIntegral) vs
+eval env (ArrayLit [] (Info t) _) = do
+ t' <- typeValueShape env $ toStruct t
+ return $ toArray t' []
+eval env (ArrayLit (v : vs) _ _) = do
+ v' <- eval env v
+ vs' <- mapM (eval env) vs
+ return $ toArray' (valueShape v') (v' : vs')
+eval env (AppExp e (Info (AppRes t retext))) =
+ returned env t retext =<< evalAppExp env e
+eval env (Var qv (Info t) _) = evalTermVar env qv (toStruct t)
+eval env (Ascript e _ _) = eval env e
+eval _ (IntLit v (Info t) _) =
+ case t of
+ Scalar (Prim (Signed it)) ->
+ return $ ValuePrim $ SignedValue $ intValue it v
+ Scalar (Prim (Unsigned it)) ->
+ return $ ValuePrim $ UnsignedValue $ intValue it v
+ Scalar (Prim (FloatType ft)) ->
+ return $ ValuePrim $ FloatValue $ floatValue ft v
+ _ -> error $ "eval: nonsensical type for integer literal: " ++ pretty t
+eval _ (FloatLit v (Info t) _) =
+ case t of
+ Scalar (Prim (FloatType ft)) ->
+ return $ ValuePrim $ FloatValue $ floatValue ft v
+ _ -> error $ "eval: nonsensical type for float literal: " ++ pretty t
eval env (Negate e _) = do
ev <- eval env e
ValuePrim <$> case ev of
@@ -967,10 +1044,6 @@
ValuePrim (FloatValue (Float32Value v)) -> return $ FloatValue $ Float32Value (- v)
ValuePrim (FloatValue (Float64Value v)) -> return $ FloatValue $ Float64Value (- v)
_ -> error $ "Cannot negate " ++ pretty ev
-eval env (Index e is (Info t, Info retext) loc) = do
- is' <- mapM (evalDimIndex env) is
- arr <- eval env e
- returned env t retext =<< evalIndex loc env is' arr
eval env (Update src is v loc) =
maybe oob return
=<< updateArray <$> mapM (evalDimIndex env) is <*> eval env src <*> eval env v
@@ -984,18 +1057,6 @@
| Just f_v <- M.lookup f src' =
ValueRecord $ M.insert f (update f_v fs v') src'
update _ _ _ = error "eval RecordUpdate: invalid value."
-eval env (LetWith dest src is v body _ loc) = do
- let Ident src_vn (Info src_t) _ = src
- dest' <-
- maybe oob return
- =<< updateArray <$> mapM (evalDimIndex env) is
- <*> evalTermVar env (qualName src_vn) (toStruct src_t)
- <*> eval env v
- let t = T.BoundV [] $ toStruct $ unInfo $ identType dest
- eval (valEnv (M.singleton (identName dest) (Just t, dest')) <> env) body
- where
- oob = bad loc env "Bad update"
-
-- We treat zero-parameter lambdas as simply an expression to
-- evaluate immediately. Note that this is *not* the same as a lambda
-- that takes an empty tuple '()' as argument! Zero-parameter lambdas
@@ -1023,58 +1084,6 @@
walk (ValueRecord fs) f
| Just v' <- M.lookup f fs = return v'
walk _ _ = error "Value does not have expected field."
-eval env (DoLoop sparams pat init_e form body (Info (ret, retext)) _) = do
- init_v <- eval env init_e
- returned env ret retext
- =<< case form of
- For iv bound -> do
- bound' <- asSigned <$> eval env bound
- forLoop (identName iv) bound' (zero bound') init_v
- ForIn in_pat in_e -> do
- (_, in_vs) <- fromArray <$> eval env in_e
- foldM (forInLoop in_pat) init_v in_vs
- While cond ->
- whileLoop cond init_v
- where
- withLoopParams v =
- let sparams' =
- resolveExistentials
- sparams
- (patternStructType pat)
- (valueShape v)
- in matchPattern (i64Env sparams' <> env) pat v
-
- inc = (`P.doAdd` Int64Value 1)
- zero = (`P.doMul` Int64Value 0)
-
- forLoop iv bound i v
- | i >= bound = return v
- | otherwise = do
- env' <- withLoopParams v
- forLoop iv bound (inc i)
- =<< eval
- ( valEnv
- ( M.singleton
- iv
- ( Just $ T.BoundV [] $ Scalar $ Prim $ Signed Int64,
- ValuePrim (SignedValue i)
- )
- )
- <> env'
- )
- body
-
- whileLoop cond v = do
- env' <- withLoopParams v
- continue <- asBool <$> eval env' cond
- if continue
- then whileLoop cond =<< eval env' body
- else return v
-
- forInLoop in_pat v in_v = do
- env' <- withLoopParams v
- env'' <- matchPattern env' in_pat in_v
- eval env'' body
eval env (Project f e _ _) = do
v <- eval env e
case v of
@@ -1088,17 +1097,6 @@
vs <- mapM (eval env) es
shape <- typeValueShape env $ toStruct t
return $ ValueSum shape c vs
-eval env (Match e cs (Info ret, Info retext) _) = do
- v <- eval env e
- returned env ret retext =<< match v (NE.toList cs)
- where
- match _ [] =
- error "Pattern match failure."
- match v (c : cs') = do
- c' <- evalCase v env c
- case c' of
- Just v' -> return v'
- Nothing -> match v cs'
eval env (Attr _ e _) = eval env e
evalCase ::
@@ -1137,7 +1135,7 @@
onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ first onDim t
onDim (NamedDim v) = NamedDim $ replaceQ v
onDim (ConstDim x) = ConstDim x
- onDim AnyDim = AnyDim
+ onDim (AnyDim v) = AnyDim v
evalModuleVar :: Env -> QualName VName -> EvalM Module
evalModuleVar env qv =
@@ -1296,7 +1294,7 @@
putV (P.IntValue x) = SignedValue x
putV (P.FloatValue x) = FloatValue x
putV (P.BoolValue x) = BoolValue x
- putV P.Checked = BoolValue True
+ putV P.UnitValue = BoolValue True
getS (SignedValue x) = Just $ P.IntValue x
getS _ = Nothing
@@ -1337,6 +1335,13 @@
Just [x, y, z] -> f x y z
_ -> error $ "Expected triple; got: " ++ pretty v
+ fun5t f =
+ TermValue Nothing $
+ ValueFun $ \v ->
+ case fromTuple v of
+ Just [x, y, z, a, b] -> f x y z a b
+ _ -> error $ "Expected pentuple; got: " ++ pretty v
+
fun6t f =
TermValue Nothing $
ValueFun $ \v ->
@@ -1628,6 +1633,50 @@
insertAt 0 x (l : ls) = (x : l) : ls
insertAt i x (l : ls) = l : insertAt (i -1) x ls
insertAt _ _ ls = ls
+ def "scatter_stream" = Just $
+ fun3t $ \dest f vs ->
+ case (dest, vs) of
+ ( ValueArray dest_shape dest_arr,
+ ValueArray _ vs_arr
+ ) -> do
+ let acc = ValueAcc (\_ x -> pure x) dest_arr
+ acc' <- foldM (apply2 noLoc mempty f) acc vs_arr
+ case acc' of
+ ValueAcc _ dest_arr' ->
+ return $ ValueArray dest_shape dest_arr'
+ _ ->
+ error $ "scatter_stream produced: " ++ pretty acc'
+ _ ->
+ error $ "scatter_stream expects array, but got: " ++ pretty (dest, vs)
+ def "hist_stream" = Just $
+ fun5t $ \dest op _ne f vs ->
+ case (dest, vs) of
+ ( ValueArray dest_shape dest_arr,
+ ValueArray _ vs_arr
+ ) -> do
+ let acc = ValueAcc (apply2 noLoc mempty op) dest_arr
+ acc' <- foldM (apply2 noLoc mempty f) acc vs_arr
+ case acc' of
+ ValueAcc _ dest_arr' ->
+ return $ ValueArray dest_shape dest_arr'
+ _ ->
+ error $ "hist_stream produced: " ++ pretty acc'
+ _ ->
+ error $ "hist_stream expects array, but got: " ++ pretty (dest, vs)
+ def "acc_write" = Just $
+ fun3t $ \acc i v ->
+ case (acc, i) of
+ ( ValueAcc op acc_arr,
+ ValuePrim (SignedValue (Int64Value i'))
+ ) ->
+ if i' >= 0 && i' < arrayLength acc_arr
+ then do
+ let x = acc_arr ! fromIntegral i'
+ res <- op x v
+ pure $ ValueAcc op $ acc_arr // [(fromIntegral i', res)]
+ else pure acc
+ _ ->
+ error $ "acc_write invalid arguments: " ++ pretty (acc, i, v)
def "unzip" = Just $
fun1 $ \x -> do
let ShapeDim _ (ShapeRecord fs) = valueShape x
@@ -1685,6 +1734,7 @@
fun1 $ \v -> do
break
return v
+ def "acc" = Nothing
def s | nameFromString s `M.member` namesToPrimTypes = Nothing
def s = error $ "Missing intrinsic: " ++ s
diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x
--- a/src/Language/Futhark/Parser/Lexer.x
+++ b/src/Language/Futhark/Parser/Lexer.x
@@ -93,6 +93,7 @@
"..>" { tokenC TWO_DOTS_GT }
"..." { tokenC THREE_DOTS }
".." { tokenC TWO_DOTS }
+ "." { tokenC DOT }
@intlit i8 { tokenM $ return . I8LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }
@intlit i16 { tokenM $ return . I16LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }
@@ -126,8 +127,7 @@
@binop { tokenM $ return . symbol [] . nameFromText }
@qualbinop { tokenM $ \s -> do (qs,k) <- mkQualId s; return (symbol qs k) }
- "." (@identifier|[0-9]+) { tokenM $ return . PROJ_FIELD . nameFromText . T.drop 1 }
- "." "[" { tokenC PROJ_INDEX }
+ "." [0-9]+ { tokenS $ PROJ_INTFIELD . nameFromText . T.drop 1 }
{
keyword :: T.Text -> Token
@@ -291,8 +291,7 @@
| QUALUNOP [Name] Name
| SYMBOL BinOp [Name] Name
| CONSTRUCTOR Name
- | PROJ_FIELD Name
- | PROJ_INDEX
+ | PROJ_INTFIELD Name
| INTLIT Integer
| STRINGLIT String
@@ -317,6 +316,7 @@
| APOSTROPHE_THEN_TILDE
| BACKTICK
| HASH_LBRACKET
+ | DOT
| TWO_DOTS
| TWO_DOTS_LT
| TWO_DOTS_GT
diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y
--- a/src/Language/Futhark/Parser/Parser.y
+++ b/src/Language/Futhark/Parser/Parser.y
@@ -77,8 +77,7 @@
constructor { L _ (CONSTRUCTOR _) }
- '.field' { L _ (PROJ_FIELD _) }
- '.[' { L _ PROJ_INDEX }
+ '.int' { L _ (PROJ_INTFIELD _) }
intlit { L _ (INTLIT _) }
i8lit { L _ (I8LIT _) }
@@ -95,6 +94,7 @@
stringlit { L _ (STRINGLIT _) }
charlit { L _ (CHARLIT _) }
+ '.' { L $$ DOT }
'..' { L $$ TWO_DOTS }
'...' { L $$ THREE_DOTS }
'..<' { L $$ TWO_DOTS_LT }
@@ -328,6 +328,13 @@
: Spec Specs { $1 : $2 }
| { [] }
+SizeBinder :: { SizeBinder Name }
+ : '[' id ']' { let L _ (ID name) = $2 in SizeBinder name (srcspan $1 $>) }
+
+SizeBinders1 :: { [SizeBinder Name] }
+ : SizeBinder SizeBinders1 { $1 : $2 }
+ | SizeBinder { [$1] }
+
TypeParam :: { TypeParamBase Name }
: '[' id ']' { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) }
| '\'' id { let L _ (ID name) = $2 in TypeParamType Unlifted name (srcspan $1 $>) }
@@ -535,18 +542,18 @@
-- array slices).
Exp :: { UncheckedExp }
: Exp ':' TypeExpDecl { Ascript $1 $3 (srcspan $1 $>) }
- | Exp ':>' TypeExpDecl { Coerce $1 $3 (NoInfo,NoInfo) (srcspan $1 $>) }
+ | Exp ':>' TypeExpDecl { AppExp (Coerce $1 $3 (srcspan $1 $>)) NoInfo }
| Exp2 %prec ':' { $1 }
Exp2 :: { UncheckedExp }
: if Exp then Exp else Exp %prec ifprec
- { If $2 $4 $6 (NoInfo,NoInfo) (srcspan $1 $>) }
+ { AppExp (If $2 $4 $6 (srcspan $1 $>)) NoInfo }
| loop Pattern LoopForm do Exp %prec ifprec
- {% fmap (\t -> DoLoop [] $2 t $3 $5 NoInfo (srcspan $1 $>)) (patternExp $2) }
+ {% fmap (\t -> AppExp (DoLoop [] $2 t $3 $5 (srcspan $1 $>)) NoInfo) (patternExp $2) }
| loop Pattern '=' Exp LoopForm do Exp %prec ifprec
- { DoLoop [] $2 $4 $5 $7 NoInfo (srcspan $1 $>) }
+ { AppExp (DoLoop [] $2 $4 $5 $7 (srcspan $1 $>)) NoInfo }
| LetExp %prec letprec { $1 }
@@ -585,14 +592,14 @@
| Exp2 '<|...' Exp2 { binOp $1 $2 $3 }
| Exp2 '<' Exp2 { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 }
- | Exp2 '`' QualName '`' Exp2 { BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo NoInfo (srcspan $1 $>) }
+ | Exp2 '`' QualName '`' Exp2 { AppExp (BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) (srcspan $1 $>)) NoInfo }
- | Exp2 '...' Exp2 { Range $1 Nothing (ToInclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }
- | Exp2 '..<' Exp2 { Range $1 Nothing (UpToExclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }
- | Exp2 '..>' Exp2 { Range $1 Nothing (DownToExclusive $3) (NoInfo,NoInfo) (srcspan $1 $>) }
- | Exp2 '..' Exp2 '...' Exp2 { Range $1 (Just $3) (ToInclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }
- | Exp2 '..' Exp2 '..<' Exp2 { Range $1 (Just $3) (UpToExclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }
- | Exp2 '..' Exp2 '..>' Exp2 { Range $1 (Just $3) (DownToExclusive $5) (NoInfo,NoInfo) (srcspan $1 $>) }
+ | Exp2 '...' Exp2 { AppExp (Range $1 Nothing (ToInclusive $3) (srcspan $1 $>)) NoInfo }
+ | Exp2 '..<' Exp2 { AppExp (Range $1 Nothing (UpToExclusive $3) (srcspan $1 $>)) NoInfo }
+ | Exp2 '..>' Exp2 { AppExp (Range $1 Nothing (DownToExclusive $3) (srcspan $1 $>)) NoInfo }
+ | Exp2 '..' Exp2 '...' Exp2 { AppExp (Range $1 (Just $3) (ToInclusive $5) (srcspan $1 $>)) NoInfo }
+ | Exp2 '..' Exp2 '..<' Exp2 { AppExp (Range $1 (Just $3) (UpToExclusive $5) (srcspan $1 $>)) NoInfo }
+ | Exp2 '..' Exp2 '..>' Exp2 { AppExp (Range $1 (Just $3) (DownToExclusive $5) (srcspan $1 $>)) NoInfo }
| Exp2 '..' Atom {% twoDotsRange $2 }
| Atom '..' Exp2 {% twoDotsRange $2 }
| '-' Exp2
@@ -633,7 +640,7 @@
{ foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))
(Parens $2 (srcspan $1 ($3:map snd $>)))
$4 }
- | '(' Exp ')[' DimIndices ']' { Index (Parens $2 $1) $4 (NoInfo, NoInfo) (srcspan $1 $>) }
+ | '(' Exp ')[' DimIndices ']' { AppExp (Index (Parens $2 $1) $4 (srcspan $1 $>)) NoInfo }
| '(' Exp ',' Exps1 ')' { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }
| '(' ')' { TupLit [] (srcspan $1 $>) }
| '[' Exps1 ']' { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }
@@ -642,7 +649,7 @@
| QualVarSlice FieldAccesses
{ let ((v, vloc),slice,loc) = $1
in foldl (\x (y, _) -> Project y x NoInfo (srcspan x (srclocOf x)))
- (Index (Var v NoInfo vloc) slice (NoInfo, NoInfo) (srcspan vloc loc))
+ (AppExp (Index (Var v NoInfo vloc) slice (srcspan vloc loc)) NoInfo)
$2 }
| QualName
{ Var (fst $1) NoInfo (snd $1) }
@@ -669,8 +676,8 @@
| '(' FieldAccess FieldAccesses ')'
{ ProjectSection (map fst ($2:$3)) NoInfo (srcspan $1 $>) }
- | '(' '.[' DimIndices ']' ')'
- { IndexSection $3 NoInfo (srcspan $1 $>) }
+ | '(' '.' '[' DimIndices ']' ')'
+ { IndexSection $4 NoInfo (srcspan $1 $>) }
PrimLit :: { (PrimValue, SrcLoc) }
@@ -700,7 +707,8 @@
| Exp { ([], $1) }
FieldAccess :: { (Name, SrcLoc) }
- : '.field' { let L loc (PROJ_FIELD f) = $1 in (f, loc) }
+ : '.' id { let L loc (ID f) = $2 in (f, loc) }
+ | '.int' { let L loc (PROJ_INTFIELD x) = $1 in (x, loc) }
FieldAccesses :: { [(Name, SrcLoc)] }
: FieldAccess FieldAccesses { $1 : $2 }
@@ -722,17 +730,20 @@
| Field { [$1] }
LetExp :: { UncheckedExp }
- : let Pattern '=' Exp LetBody
- { LetPat $2 $4 $5 (NoInfo, NoInfo) (srcspan $1 $>) }
+ : let SizeBinders1 Pattern '=' Exp LetBody
+ { AppExp (LetPat $2 $3 $5 $6 (srcspan $1 $>)) NoInfo }
+ | let Pattern '=' Exp LetBody
+ { AppExp (LetPat [] $2 $4 $5 (srcspan $1 $>)) NoInfo }
| let id TypeParams FunParams1 maybeAscription(TypeExpDecl) '=' Exp LetBody
{ let L _ (ID name) = $2
- in LetFun name ($3, fst $4 : snd $4, (fmap declaredType $5), NoInfo, $7)
- $8 NoInfo (srcspan $1 $>) }
+ in AppExp (LetFun name ($3, fst $4 : snd $4, (fmap declaredType $5), NoInfo, $7)
+ $8 (srcspan $1 $>))
+ NoInfo}
| let VarSlice '=' Exp LetBody
{ let ((v,_),slice,loc) = $2; ident = Ident v NoInfo loc
- in LetWith ident ident slice $4 $5 NoInfo (srcspan $1 $>) }
+ in AppExp (LetWith ident ident slice $4 $5 (srcspan $1 $>)) NoInfo }
LetBody :: { UncheckedExp }
: in Exp %prec letprec { $2 }
@@ -742,7 +753,7 @@
MatchExp :: { UncheckedExp }
: match Exp Cases
{ let loc = srcspan $1 (NE.toList $>)
- in Match $2 $> (NoInfo, NoInfo) loc }
+ in AppExp (Match $2 $> loc) NoInfo }
Cases :: { NE.NonEmpty (CaseBase NoInfo Name) }
: Case %prec caseprec { $1 NE.:| [] }
@@ -1088,13 +1099,13 @@
applyExp es =
foldM ap (head es) (tail es)
where
- ap (Index e is _ floc) (ArrayLit xs _ xloc) =
+ ap (AppExp (Index e is floc) _) (ArrayLit xs _ xloc) =
parseErrorAt (srcspan floc xloc) $
Just $ pretty $ "Incorrect syntax for multi-dimensional indexing."
"Use" <+> align (ppr index)
- where index = Index e (is++map DimFix xs) (NoInfo, NoInfo) xloc
+ where index = AppExp (Index e (is++map DimFix xs) xloc) NoInfo
ap f x =
- return $ Apply f x NoInfo (NoInfo, NoInfo) (srcspan f x)
+ return $ AppExp (Apply f x NoInfo (srcspan f x)) NoInfo
patternExp :: UncheckedPattern -> ParserMonad UncheckedExp
patternExp (Id v _ loc) = return $ Var (qualName v) NoInfo loc
@@ -1111,8 +1122,7 @@
binOpName (L loc (SYMBOL _ qs op)) = (QualName qs op, loc)
binOp x (L loc (SYMBOL _ qs op)) y =
- BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) NoInfo NoInfo $
- srcspan x y
+ AppExp (BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) (srcspan x y)) NoInfo
getTokens :: ParserMonad ([L Token], Pos)
getTokens = lift $ lift get
diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs
--- a/src/Language/Futhark/Pretty.hs
+++ b/src/Language/Futhark/Pretty.hs
@@ -32,9 +32,6 @@
import Language.Futhark.Syntax
import Prelude
-commastack :: [Doc] -> Doc
-commastack = align . stack . punctuate comma
-
-- | A class for types that are variable names in the Futhark source
-- language. This is used instead of a mere 'Pretty' instance because
-- in the compiler frontend we want to print VNames differently
@@ -100,7 +97,8 @@
ppr (FloatValue v) = ppr v
instance IsName vn => Pretty (DimDecl vn) where
- ppr AnyDim = mempty
+ ppr (AnyDim Nothing) = mempty
+ ppr (AnyDim (Just v)) = text "?" <> pprName v
ppr (NamedDim v) = ppr v
ppr (ConstDim n) = ppr n
@@ -211,11 +209,83 @@
ppr (DimSlice i Nothing Nothing) =
maybe mempty ppr i <> text ":"
+instance IsName vn => Pretty (SizeBinder vn) where
+ ppr (SizeBinder v _) = brackets $ pprName v
+
letBody :: (Eq vn, IsName vn, Annot f) => ExpBase f vn -> Doc
-letBody body@LetPat {} = ppr body
-letBody body@LetFun {} = ppr body
+letBody body@(AppExp LetPat {} _) = ppr body
+letBody body@(AppExp LetFun {} _) = ppr body
letBody body = text "in" <+> align (ppr body)
+instance (Eq vn, IsName vn, Annot f) => Pretty (AppExpBase f vn) where
+ ppr = pprPrec (-1)
+ pprPrec p (Coerce e t _) =
+ parensIf (p /= -1) $ pprPrec 0 e <+> text ":>" <+> align (pprPrec 0 t)
+ pprPrec p (BinOp (bop, _) _ (x, _) (y, _) _) = prettyBinOp p bop x y
+ pprPrec _ (Match e cs _) = text "match" <+> ppr e (stack . map ppr) (NE.toList cs)
+ pprPrec _ (DoLoop sizeparams pat initexp form loopbody _) =
+ text "loop"
+ <+> align
+ ( spread (map (brackets . pprName) sizeparams)
+ <+/> ppr pat <+> equals
+ <+/> ppr initexp
+ <+/> ppr form <+> text "do"
+ )
+ indent 2 (ppr loopbody)
+ pprPrec _ (Index e idxs _) =
+ pprPrec 9 e <> brackets (commasep (map ppr idxs))
+ pprPrec p (LetPat sizes pat e body _) =
+ parensIf (p /= -1) $
+ align $
+ text "let" <+> spread (map ppr sizes) <+> align (ppr pat)
+ <+> ( if linebreak
+ then equals indent 2 (ppr e)
+ else equals <+> align (ppr e)
+ )
+ letBody body
+ where
+ linebreak = case e of
+ AppExp {} -> True
+ Attr {} -> True
+ ArrayLit {} -> False
+ _ -> hasArrayLit e
+ pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _) =
+ text "let" <+> pprName fname <+> spread (map ppr tparams ++ map ppr params)
+ <> retdecl' <+> equals
+ indent 2 (ppr e)
+ letBody body
+ where
+ retdecl' = case (ppr <$> unAnnot rettype) `mplus` (ppr <$> retdecl) of
+ Just rettype' -> colon <+> align rettype'
+ Nothing -> mempty
+ pprPrec _ (LetWith dest src idxs ve body _)
+ | dest == src =
+ text "let" <+> ppr dest <> list (map ppr idxs)
+ <+> equals
+ <+> align (ppr ve)
+ letBody body
+ | otherwise =
+ text "let" <+> ppr dest <+> equals <+> ppr src
+ <+> text "with"
+ <+> brackets (commasep (map ppr idxs))
+ <+> text "="
+ <+> align (ppr ve)
+ letBody body
+ pprPrec p (Range start maybe_step end _) =
+ parensIf (p /= -1) $
+ ppr start
+ <> maybe mempty ((text ".." <>) . ppr) maybe_step
+ <> case end of
+ DownToExclusive end' -> text "..>" <> ppr end'
+ ToInclusive end' -> text "..." <> ppr end'
+ UpToExclusive end' -> text "..<" <> ppr end'
+ pprPrec _ (If c t f _) =
+ text "if" <+> ppr c
+ text "then" <+> align (ppr t)
+ text "else" <+> align (ppr f)
+ pprPrec p (Apply f arg _ _) =
+ parensIf (p >= 10) $ pprPrec 0 f <+/> pprPrec 10 arg
+
instance (Eq vn, IsName vn, Annot f) => Pretty (ExpBase f vn) where
ppr = pprPrec (-1)
pprPrec _ (Var name t _) = ppr name <> inst
@@ -229,8 +299,6 @@
pprPrec _ (QualParens (v, _) e _) = ppr v <> text "." <> align (parens $ ppr e)
pprPrec p (Ascript e t _) =
parensIf (p /= -1) $ pprPrec 0 e <+> text ":" <+> align (pprPrec 0 t)
- pprPrec p (Coerce e t _ _) =
- parensIf (p /= -1) $ pprPrec 0 e <+> text ":>" <+> align (pprPrec 0 t)
pprPrec _ (Literal v _) = ppr v
pprPrec _ (IntLit v _ _) = ppr v
pprPrec _ (FloatLit v _ _) = ppr v
@@ -253,64 +321,8 @@
_ -> mempty
pprPrec _ (StringLit s _) =
text $ show $ decode s
- pprPrec p (Range start maybe_step end _ _) =
- parensIf (p /= -1) $
- ppr start
- <> maybe mempty ((text ".." <>) . ppr) maybe_step
- <> case end of
- DownToExclusive end' -> text "..>" <> ppr end'
- ToInclusive end' -> text "..." <> ppr end'
- UpToExclusive end' -> text "..<" <> ppr end'
- pprPrec p (BinOp (bop, _) _ (x, _) (y, _) _ _ _) = prettyBinOp p bop x y
pprPrec _ (Project k e _ _) = ppr e <> text "." <> ppr k
- pprPrec _ (If c t f _ _) =
- text "if" <+> ppr c
- text "then" <+> align (ppr t)
- text "else" <+> align (ppr f)
- pprPrec p (Apply f arg _ _ _) =
- parensIf (p >= 10) $ pprPrec 0 f <+/> pprPrec 10 arg
pprPrec _ (Negate e _) = text "-" <> ppr e
- pprPrec p (LetPat pat e body _ _) =
- parensIf (p /= -1) $
- align $
- text "let" <+> align (ppr pat)
- <+> ( if linebreak
- then equals indent 2 (ppr e)
- else equals <+> align (ppr e)
- )
- letBody body
- where
- linebreak = case e of
- DoLoop {} -> True
- LetPat {} -> True
- LetWith {} -> True
- If {} -> True
- Match {} -> True
- Attr {} -> True
- ArrayLit {} -> False
- _ -> hasArrayLit e
- pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _ _) =
- text "let" <+> pprName fname <+> spread (map ppr tparams ++ map ppr params)
- <> retdecl' <+> equals
- indent 2 (ppr e)
- letBody body
- where
- retdecl' = case (ppr <$> unAnnot rettype) `mplus` (ppr <$> retdecl) of
- Just rettype' -> colon <+> align rettype'
- Nothing -> mempty
- pprPrec _ (LetWith dest src idxs ve body _ _)
- | dest == src =
- text "let" <+> ppr dest <> list (map ppr idxs)
- <+> equals
- <+> align (ppr ve)
- letBody body
- | otherwise =
- text "let" <+> ppr dest <+> equals <+> ppr src
- <+> text "with"
- <+> brackets (commasep (map ppr idxs))
- <+> text "="
- <+> align (ppr ve)
- letBody body
pprPrec _ (Update src idxs ve _) =
ppr src <+> text "with"
<+> brackets (commasep (map ppr idxs))
@@ -321,8 +333,6 @@
<+> mconcat (intersperse (text ".") (map ppr fs))
<+> text "="
<+> align (ppr ve)
- pprPrec _ (Index e idxs _ _) =
- pprPrec 9 e <> brackets (commasep (map ppr idxs))
pprPrec _ (Assert e1 e2 _ _) = text "assert" <+> pprPrec 10 e1 <+> pprPrec 10 e2
pprPrec p (Lambda params body rettype _ _) =
parensIf (p /= -1) $
@@ -340,19 +350,10 @@
p name = text "." <> ppr name
pprPrec _ (IndexSection idxs _ _) =
parens $ text "." <> brackets (commasep (map ppr idxs))
- pprPrec _ (DoLoop sizeparams pat initexp form loopbody _ _) =
- text "loop"
- <+> align
- ( spread (map (brackets . pprName) sizeparams)
- <+/> ppr pat <+> equals
- <+/> ppr initexp
- <+/> ppr form <+> text "do"
- )
- indent 2 (ppr loopbody)
pprPrec _ (Constr n cs _ _) = text "#" <> ppr n <+> sep (map ppr cs)
- pprPrec _ (Match e cs _ _) = text "match" <+> ppr e (stack . map ppr) (NE.toList cs)
pprPrec _ (Attr attr e _) =
text "#[" <> ppr attr <> text "]" pprPrec (-1) e
+ pprPrec i (AppExp e _) = pprPrec i e
instance Pretty AttrInfo where
ppr (AttrAtom attr) = ppr attr
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
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides various simple ways to query and manipulate
@@ -55,7 +56,6 @@
primByteSize,
-- * Operations on types
- rank,
peelArray,
stripArray,
arrayOf,
@@ -82,8 +82,6 @@
isSizeParam,
combineTypeShapes,
matchDims,
- unscopeType,
- onRecordField,
-- | Values of these types are produces by the parser. They use
-- unadorned names and have no type information, apart from that
-- which is syntactically required.
@@ -164,7 +162,7 @@
-- | Change all size annotations to be 'AnyDim'.
anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as
-anySizes = first $ const AnyDim
+anySizes = first $ const $ AnyDim Nothing
-- | Where does this dimension occur?
data DimPos
@@ -537,11 +535,6 @@
primByteSize (FloatType ft) = Primitive.floatByteSize ft
primByteSize Bool = 1
--- | Construct a 'ShapeDecl' with the given number of 'AnyDim'
--- dimensions.
-rank :: Int -> ShapeDecl (DimDecl VName)
-rank n = ShapeDecl $ replicate n AnyDim
-
-- | The type is leaving a scope, so clean up any aliases that
-- reference the bound variables, and turn any dimensions that name
-- them into AnyDim instead.
@@ -550,22 +543,11 @@
where
unbind (AliasBound v) | v `S.member` bound_here = AliasFree v
unbind a = a
- onDim (NamedDim qn) | qualLeaf qn `S.member` bound_here = AnyDim
+ onDim (NamedDim qn)
+ | qualLeaf qn `S.member` bound_here =
+ AnyDim $ Just $ qualLeaf qn
onDim d = d
--- | Perform some operation on a given record field. Returns
--- 'Nothing' if that field does not exist.
-onRecordField ::
- (TypeBase dim als -> TypeBase dim als) ->
- [Name] ->
- TypeBase dim als ->
- Maybe (TypeBase dim als)
-onRecordField f [] t = Just $ f t
-onRecordField f (k : ks) (Scalar (Record m)) = do
- t <- onRecordField f ks =<< M.lookup k m
- Just $ Scalar $ Record $ M.insert k t m
-onRecordField _ _ _ = Nothing
-
-- | The type of an Futhark term. The aliasing will refer to itself, if
-- the term is a non-tuple-typed variable.
typeOf :: ExpBase Info VName -> PatternType
@@ -591,23 +573,13 @@
Unique
(Prim (Unsigned Int8))
(ShapeDecl [ConstDim $ genericLength vs])
-typeOf (Range _ _ _ (Info t, _) _) = t
-typeOf (BinOp _ _ _ _ (Info t) _ _) = t
typeOf (Project _ _ (Info t) _) = t
-typeOf (If _ _ _ (Info t, _) _) = t
typeOf (Var _ (Info t) _) = t
typeOf (Ascript e _ _) = typeOf e
-typeOf (Coerce _ _ (Info t, _) _) = t
-typeOf (Apply _ _ _ (Info t, _) _) = t
typeOf (Negate e _) = typeOf e
-typeOf (LetPat _ _ _ (Info t, _) _) = t
-typeOf (LetFun _ _ _ (Info t) _) = t
-typeOf (LetWith _ _ _ _ _ (Info t) _) = t
-typeOf (Index _ _ (Info t, _) _) = t
typeOf (Update e _ _ _) = typeOf e `setAliases` mempty
typeOf (RecordUpdate _ _ _ (Info t) _) = t
typeOf (Assert _ e _ _) = typeOf e
-typeOf (DoLoop _ _ _ _ _ (Info (t, _)) _) = t
typeOf (Lambda params _ _ (Info (als, t)) _) =
unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als
where
@@ -626,11 +598,8 @@
typeOf (ProjectSection _ (Info t) _) = t
typeOf (IndexSection _ (Info t) _) = t
typeOf (Constr _ _ (Info t) _) = t
-typeOf (Match _ cs (Info t, _) _) =
- unscopeType (foldMap unscopeSet cs) t
- where
- unscopeSet (CasePat p _ _) = S.map identName $ patternIdents p
typeOf (Attr _ e _) = typeOf e
+typeOf (AppExp _ (Info res)) = appResType res
-- | @foldFunType ts ret@ creates a function type ('Arrow') that takes
-- @ts@ as parameters and returns @ret@.
@@ -790,217 +759,308 @@
++ map FloatType [minBound .. maxBound]
]
--- | The nature of something predefined. These can either be
--- monomorphic or overloaded. An overloaded builtin is a list valid
--- types it can be instantiated with, to the parameter and result
--- type, with 'Nothing' representing the overloaded parameter type.
+-- | The nature of something predefined. For functions, these can
+-- either be monomorphic or overloaded. An overloaded builtin is a
+-- list valid types it can be instantiated with, to the parameter and
+-- result type, with 'Nothing' representing the overloaded parameter
+-- type.
data Intrinsic
= IntrinsicMonoFun [PrimType] PrimType
| IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType)
| IntrinsicPolyFun [TypeParamBase VName] [StructType] StructType
- | IntrinsicType PrimType
+ | IntrinsicType Liftedness [TypeParamBase VName] StructType
| IntrinsicEquality -- Special cased.
+intrinsicAcc :: (VName, Intrinsic)
+intrinsicAcc =
+ ( acc_v,
+ IntrinsicType SizeLifted [TypeParamType Unlifted t_v mempty] $
+ Scalar $ TypeVar () Nonunique (TypeName [] acc_v) [arg]
+ )
+ where
+ acc_v = VName "acc" 10
+ t_v = VName "t" 11
+ arg = TypeArgType (Scalar (TypeVar () Nonunique (TypeName [] t_v) [])) mempty
+
-- | A map of all built-ins.
intrinsics :: M.Map VName Intrinsic
intrinsics =
- M.fromList $
- zipWith namify [10 ..] $
- map primFun (M.toList Primitive.primFuns)
- ++ [("opaque", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)]
- ++ map unOpFun Primitive.allUnOps
- ++ map binOpFun Primitive.allBinOps
- ++ map cmpOpFun Primitive.allCmpOps
- ++ map convOpFun Primitive.allConvOps
- ++ map signFun Primitive.allIntTypes
- ++ map unsignFun Primitive.allIntTypes
- ++ map
- intrinsicType
- ( map Signed [minBound .. maxBound]
- ++ map Unsigned [minBound .. maxBound]
- ++ map FloatType [minBound .. maxBound]
- ++ [Bool]
- )
- ++
- -- This overrides the ! from Primitive.
- [ ( "!",
- IntrinsicOverloadedFun
- ( map Signed [minBound .. maxBound]
- ++ map Unsigned [minBound .. maxBound]
- ++ [Bool]
- )
- [Nothing]
- Nothing
- )
- ]
- ++
- -- The reason for the loop formulation is to ensure that we
- -- get a missing case warning if we forget a case.
- mapMaybe mkIntrinsicBinOp [minBound .. maxBound]
- ++ [ ( "flatten",
- IntrinsicPolyFun
- [tp_a]
- [Array () Nonunique t_a (rank 2)]
- $ Array () Nonunique t_a (rank 1)
- ),
- ( "unflatten",
- IntrinsicPolyFun
- [tp_a]
- [ Scalar $ Prim $ Signed Int64,
- Scalar $ Prim $ Signed Int64,
- Array () Nonunique t_a (rank 1)
- ]
- $ Array () Nonunique t_a (rank 2)
- ),
- ( "concat",
- IntrinsicPolyFun
- [tp_a]
- [arr_a, arr_a]
- uarr_a
- ),
- ( "rotate",
- IntrinsicPolyFun
- [tp_a]
- [Scalar $ Prim $ Signed Int64, arr_a]
- arr_a
- ),
- ("transpose", IntrinsicPolyFun [tp_a] [arr_2d_a] arr_2d_a),
- ( "scatter",
- IntrinsicPolyFun
- [tp_a]
- [ Array () Unique t_a (rank 1),
- Array () Nonunique (Prim $ Signed Int64) (rank 1),
- Array () Nonunique t_a (rank 1)
- ]
- $ Array () Unique t_a (rank 1)
- ),
- ( "scatter_2d",
- IntrinsicPolyFun
- [tp_a]
- [ uarr_2d_a,
- Array () Nonunique (tupInt64 2) (rank 1),
- Array () Nonunique t_a (rank 1)
- ]
- uarr_2d_a
- ),
- ( "scatter_3d",
- IntrinsicPolyFun
- [tp_a]
- [ uarr_3d_a,
- Array () Nonunique (tupInt64 3) (rank 1),
- Array () Nonunique t_a (rank 1)
- ]
- uarr_3d_a
- ),
- ("zip", IntrinsicPolyFun [tp_a, tp_b] [arr_a, arr_b] uarr_a_b),
- ("unzip", IntrinsicPolyFun [tp_a, tp_b] [arr_a_b] t_arr_a_arr_b),
- ( "hist",
- IntrinsicPolyFun
- [tp_a]
- [ Scalar $ Prim $ Signed Int64,
- uarr_a,
- Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
- Scalar t_a,
- Array () Nonunique (Prim $ Signed Int64) (rank 1),
- arr_a
- ]
- uarr_a
- ),
- ("map", IntrinsicPolyFun [tp_a, tp_b] [Scalar t_a `arr` Scalar t_b, arr_a] uarr_b),
- ( "reduce",
- IntrinsicPolyFun
- [tp_a]
- [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a]
- $ Scalar t_a
- ),
- ( "reduce_comm",
- IntrinsicPolyFun
- [tp_a]
- [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a]
- $ Scalar t_a
- ),
- ( "scan",
- IntrinsicPolyFun
- [tp_a]
- [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a]
- uarr_a
- ),
- ( "partition",
- IntrinsicPolyFun
- [tp_a]
- [ Scalar (Prim $ Signed Int32),
- Scalar t_a `arr` Scalar (Prim $ Signed Int64),
- arr_a
- ]
- $ tupleRecord [uarr_a, Array () Unique (Prim $ Signed Int64) (rank 1)]
- ),
- ( "map_stream",
- IntrinsicPolyFun
- [tp_a, tp_b]
- [Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb), arr_a]
- uarr_b
- ),
- ( "map_stream_per",
- IntrinsicPolyFun
- [tp_a, tp_b]
- [Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb), arr_a]
- uarr_b
- ),
- ( "reduce_stream",
- IntrinsicPolyFun
- [tp_a, tp_b]
- [ Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b),
- Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),
- arr_a
- ]
- $ Scalar t_b
- ),
- ( "reduce_stream_per",
- IntrinsicPolyFun
- [tp_a, tp_b]
- [ Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b),
- Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),
- arr_a
- ]
- $ Scalar t_b
- ),
- ("trace", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a),
- ("break", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)
- ]
+ (M.fromList [intrinsicAcc] <>) $
+ M.fromList $
+ zipWith namify [20 ..] $
+ map primFun (M.toList Primitive.primFuns)
+ ++ [("opaque", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)]
+ ++ map unOpFun Primitive.allUnOps
+ ++ map binOpFun Primitive.allBinOps
+ ++ map cmpOpFun Primitive.allCmpOps
+ ++ map convOpFun Primitive.allConvOps
+ ++ map signFun Primitive.allIntTypes
+ ++ map unsignFun Primitive.allIntTypes
+ ++ map
+ intrinsicPrim
+ ( map Signed [minBound .. maxBound]
+ ++ map Unsigned [minBound .. maxBound]
+ ++ map FloatType [minBound .. maxBound]
+ ++ [Bool]
+ )
+ ++
+ -- This overrides the ! from Primitive.
+ [ ( "!",
+ IntrinsicOverloadedFun
+ ( map Signed [minBound .. maxBound]
+ ++ map Unsigned [minBound .. maxBound]
+ ++ [Bool]
+ )
+ [Nothing]
+ Nothing
+ )
+ ]
+ ++
+ -- The reason for the loop formulation is to ensure that we
+ -- get a missing case warning if we forget a case.
+ mapMaybe mkIntrinsicBinOp [minBound .. maxBound]
+ ++ [ ( "flatten",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m]
+ [Array () Nonunique t_a (shape [n, m])]
+ $ Array () Nonunique t_a (ShapeDecl [AnyDim Nothing])
+ ),
+ ( "unflatten",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [ Scalar $ Prim $ Signed Int64,
+ Scalar $ Prim $ Signed Int64,
+ Array () Nonunique t_a (shape [n])
+ ]
+ $ Array () Nonunique t_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing]
+ ),
+ ( "concat",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m]
+ [arr_a $ shape [n], arr_a $ shape [m]]
+ $ uarr_a $ ShapeDecl [AnyDim Nothing]
+ ),
+ ( "rotate",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [Scalar $ Prim $ Signed Int64, arr_a $ shape [n]]
+ $ arr_a $ shape [n]
+ ),
+ ( "transpose",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m]
+ [arr_a $ shape [n, m]]
+ $ arr_a $ shape [m, n]
+ ),
+ ( "scatter",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_l]
+ [ Array () Unique t_a (shape [n]),
+ Array () Nonunique (Prim $ Signed Int64) (shape [l]),
+ Array () Nonunique t_a (shape [l])
+ ]
+ $ Array () Unique t_a (shape [n])
+ ),
+ ( "scatter_2d",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m, sp_l]
+ [ uarr_a $ shape [n, m],
+ Array () Nonunique (tupInt64 2) (shape [l]),
+ Array () Nonunique t_a (shape [l])
+ ]
+ $ uarr_a $ shape [n, m]
+ ),
+ ( "scatter_3d",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m, sp_k, sp_l]
+ [ uarr_a $ shape [n, m, k],
+ Array () Nonunique (tupInt64 3) (shape [l]),
+ Array () Nonunique t_a (shape [l])
+ ]
+ (uarr_a $ shape [n, m, k])
+ ),
+ ( "zip",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [arr_a (shape [n]), arr_b (shape [n])]
+ $ tuple_uarr (Scalar t_a) (Scalar t_b) $ shape [n]
+ ),
+ ( "unzip",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [tuple_arr (Scalar t_a) (Scalar t_b) $ shape [n]]
+ ( Scalar . Record . M.fromList $
+ zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]]
+ )
+ ),
+ ( "hist",
+ IntrinsicPolyFun
+ [tp_a, sp_n, sp_m]
+ [ Scalar $ Prim $ Signed Int64,
+ uarr_a $ shape [n],
+ 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])
+ ]
+ (uarr_a $ shape [n])
+ ),
+ ( "map",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [ Scalar t_a `arr` Scalar t_b,
+ arr_a $ shape [n]
+ ]
+ $ uarr_b $ shape [n]
+ ),
+ ( "reduce",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ arr_a $ shape [n]
+ ]
+ $ Scalar t_a
+ ),
+ ( "reduce_comm",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ arr_a $ shape [n]
+ ]
+ $ Scalar t_a
+ ),
+ ( "scan",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ arr_a $ shape [n]
+ ]
+ $ uarr_a $ shape [n]
+ ),
+ ( "partition",
+ IntrinsicPolyFun
+ [tp_a, sp_n]
+ [ Scalar (Prim $ Signed Int32),
+ Scalar t_a `arr` Scalar (Prim $ Signed Int64),
+ arr_a $ shape [n]
+ ]
+ ( tupleRecord
+ [ uarr_a $ ShapeDecl [AnyDim Nothing],
+ Array () Unique (Prim $ Signed Int64) (shape [n])
+ ]
+ )
+ ),
+ ( "map_stream",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb),
+ arr_a $ shape [n]
+ ]
+ $ uarr_b $ shape [n]
+ ),
+ ( "map_stream_per",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb),
+ arr_a $ shape [n]
+ ]
+ (uarr_b $ shape [n])
+ ),
+ ( "reduce_stream",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [ Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b),
+ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),
+ arr_a $ shape [n]
+ ]
+ $ Scalar t_b
+ ),
+ ( "reduce_stream_per",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_n]
+ [ Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b),
+ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),
+ arr_a $ shape [n]
+ ]
+ $ Scalar t_b
+ ),
+ ( "acc_write",
+ IntrinsicPolyFun
+ [sp_k, tp_a]
+ [ Scalar $ accType arr_ka,
+ Scalar (Prim $ Signed Int64),
+ Scalar t_a
+ ]
+ $ Scalar $ accType arr_ka
+ ),
+ ( "scatter_stream",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_k, sp_n]
+ [ uarr_ka,
+ Scalar (accType arr_ka)
+ `arr` ( Scalar t_b
+ `arr` Scalar (accType $ arr_a $ shape [k])
+ ),
+ arr_b $ shape [n]
+ ]
+ uarr_ka
+ ),
+ ( "hist_stream",
+ IntrinsicPolyFun
+ [tp_a, tp_b, sp_k, sp_n]
+ [ uarr_a $ shape [k],
+ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),
+ Scalar t_a,
+ Scalar (accType arr_ka)
+ `arr` ( Scalar t_b
+ `arr` Scalar (accType $ arr_a $ shape [k])
+ ),
+ arr_b $ shape [n]
+ ]
+ $ uarr_a $ shape [k]
+ ),
+ ("trace", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a),
+ ("break", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)
+ ]
where
- tv_a = VName (nameFromString "a") 0
- t_a = TypeVar () Nonunique (typeName tv_a) []
- arr_a = Array () Nonunique t_a (rank 1)
- arr_2d_a = Array () Nonunique t_a (rank 2)
- uarr_2d_a = Array () Unique t_a (rank 2)
- uarr_3d_a = Array () Unique t_a (rank 3)
- uarr_a = Array () Unique t_a (rank 1)
- tp_a = TypeParamType Unlifted tv_a mempty
+ [a, b, n, m, k, l, p] = zipWith VName (map nameFromString ["a", "b", "n", "m", "k", "l", "p"]) [0 ..]
- tv_b = VName (nameFromString "b") 1
- t_b = TypeVar () Nonunique (typeName tv_b) []
- arr_b = Array () Nonunique t_b (rank 1)
- uarr_b = Array () Unique t_b (rank 1)
- tp_b = TypeParamType Unlifted tv_b mempty
+ t_a = TypeVar () Nonunique (typeName a) []
+ arr_a = Array () Nonunique t_a
+ uarr_a = Array () Unique t_a
+ tp_a = TypeParamType Unlifted a mempty
- arr_a_b =
+ t_b = TypeVar () Nonunique (typeName b) []
+ arr_b = Array () Nonunique t_b
+ uarr_b = Array () Unique t_b
+ tp_b = TypeParamType Unlifted b mempty
+
+ [sp_n, sp_m, sp_k, sp_l, _sp_p] = map (`TypeParamDim` mempty) [n, m, k, l, p]
+
+ shape = ShapeDecl . map (NamedDim . qualName)
+
+ tuple_arr x y =
Array
()
Nonunique
- (Record (M.fromList $ zip tupleFieldNames [Scalar t_a, Scalar t_b]))
- (rank 1)
- uarr_a_b = arr_a_b `setUniqueness` Unique
- t_arr_a_arr_b = Scalar $ Record $ M.fromList $ zip tupleFieldNames [arr_a, arr_b]
+ (Record (M.fromList $ zip tupleFieldNames [x, y]))
+ tuple_uarr x y s = tuple_arr x y s `setUniqueness` Unique
arr x y = Scalar $ Arrow mempty Unnamed x y
- kv = VName (nameFromString "k") 2
- arr_ka = Array () Nonunique t_a (ShapeDecl [NamedDim $ qualName kv])
- arr_kb = Array () Nonunique t_b (ShapeDecl [NamedDim $ qualName kv])
- karr x y = Scalar $ Arrow mempty (Named kv) x y
+ arr_ka = Array () Nonunique t_a (ShapeDecl [NamedDim $ qualName k])
+ uarr_ka = Array () Unique t_a (ShapeDecl [NamedDim $ qualName k])
+ arr_kb = Array () Nonunique t_b (ShapeDecl [NamedDim $ qualName k])
+ karr x y = Scalar $ Arrow mempty (Named k) x y
- namify i (k, v) = (VName (nameFromString k) i, v)
+ accType t =
+ TypeVar () Unique (typeName (fst intrinsicAcc)) [TypeArgType t mempty]
+ namify i (x, y) = (VName (nameFromString x) i, y)
+
primFun (name, (ts, t, _)) =
(name, IntrinsicMonoFun (map unPrim ts) $ unPrim t)
@@ -1027,9 +1087,9 @@
unPrim (Primitive.IntType t) = Signed t
unPrim (Primitive.FloatType t) = FloatType t
unPrim Primitive.Bool = Bool
- unPrim Primitive.Cert = Bool
+ unPrim Primitive.Unit = Bool
- intrinsicType t = (pretty t, IntrinsicType t)
+ intrinsicPrim t = (pretty t, IntrinsicType Unlifted [] $ Scalar $ Prim t)
anyIntType =
map Signed [minBound .. maxBound]
@@ -1070,11 +1130,9 @@
intrinsicBinOp Geq = ordering
intrinsicBinOp _ = Nothing
- tupInt64 n =
- Record $
- M.fromList $
- zip tupleFieldNames $
- replicate n $ Scalar $ Prim $ Signed Int64
+ tupInt64 x =
+ Record . M.fromList . zip tupleFieldNames $
+ 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/Query.hs b/src/Language/Futhark/Query.hs
--- a/src/Language/Futhark/Query.hs
+++ b/src/Language/Futhark/Query.hs
@@ -44,6 +44,10 @@
boundLoc (BoundModuleType loc) = loc
boundLoc (BoundType loc) = loc
+sizeDefs :: SizeBinder VName -> Defs
+sizeDefs (SizeBinder v loc) =
+ M.singleton v $ DefBound $ BoundTerm (Scalar (Prim (Signed Int64))) (locOf loc)
+
patternDefs :: Pattern -> Defs
patternDefs (Id vn (Info t) loc) =
M.singleton vn $ DefBound $ BoundTerm (toStruct t) (locOf loc)
@@ -87,18 +91,18 @@
extra =
case e of
- LetPat pat _ _ _ _ ->
- patternDefs pat
+ AppExp (LetPat sizes pat _ _ _) _ ->
+ foldMap sizeDefs sizes <> patternDefs pat
Lambda params _ _ _ _ ->
mconcat (map patternDefs params)
- LetFun name (tparams, params, _, Info ret, _) _ _ loc ->
+ AppExp (LetFun name (tparams, params, _, Info ret, _) _ loc) _ ->
let name_t = foldFunType (map patternStructType params) ret
in M.singleton name (DefBound $ BoundTerm name_t (locOf loc))
<> mconcat (map typeParamDefs tparams)
<> mconcat (map patternDefs params)
- LetWith v _ _ _ _ _ _ ->
+ AppExp (LetWith v _ _ _ _ _) _ ->
identDefs v
- DoLoop _ merge _ form _ _ _ ->
+ AppExp (DoLoop _ merge _ form _ _) _ ->
patternDefs merge
<> case form of
For i _ -> identDefs i
@@ -264,16 +268,16 @@
atPosInExp Literal {} _ = Nothing
atPosInExp IntLit {} _ = Nothing
atPosInExp FloatLit {} _ = Nothing
-atPosInExp (LetPat pat _ _ _ _) pos
+atPosInExp (AppExp (LetPat _ pat _ _ _) _) pos
| pat `contains` pos = atPosInPattern pat pos
-atPosInExp (LetWith a b _ _ _ _ _) pos
+atPosInExp (AppExp (LetWith a b _ _ _ _) _) pos
| a `contains` pos = Just $ RawAtName (qualName $ identName a) (locOf a)
| b `contains` pos = Just $ RawAtName (qualName $ identName b) (locOf b)
-atPosInExp (DoLoop _ merge _ _ _ _ _) pos
+atPosInExp (AppExp (DoLoop _ merge _ _ _ _) _) pos
| merge `contains` pos = atPosInPattern merge pos
atPosInExp (Ascript _ tdecl _) pos
| tdecl `contains` pos = atPosInTypeExp (declaredType tdecl) pos
-atPosInExp (Coerce _ tdecl _ _) pos
+atPosInExp (AppExp (Coerce _ tdecl _) _) pos
| tdecl `contains` pos = atPosInTypeExp (declaredType tdecl) pos
atPosInExp e pos = do
guard $ e `contains` pos
diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs
--- a/src/Language/Futhark/Syntax.hs
+++ b/src/Language/Futhark/Syntax.hs
@@ -5,9 +5,11 @@
{-# LANGUAGE Strict #-}
-- | The Futhark source language AST definition. Many types, such as
--- 'ExpBase'@, are parametrised by type and name representation. See
--- the @https://futhark.readthedocs.org@ for a language reference, or
--- this module may be a little hard to understand.
+-- 'ExpBase'@, are parametrised by type and name representation.
+-- E.g. in a value of type @ExpBase f vn@, annotations are wrapped in
+-- the functor @f@, and all names are of type @vn@. See the
+-- @https://futhark.readthedocs.org@ for a language reference, or this
+-- module may be a little hard to understand.
module Language.Futhark.Syntax
( module Language.Futhark.Core,
@@ -51,6 +53,9 @@
IdentBase (..),
Inclusiveness (..),
DimIndexBase (..),
+ SizeBinder (..),
+ AppExpBase (..),
+ AppRes (..),
ExpBase (..),
FieldBase (..),
CaseBase (..),
@@ -125,14 +130,13 @@
Show (f (PatternType, [VName])),
Show (f (StructType, [VName])),
Show (f EntryPoint),
- Show (f Int),
Show (f StructType),
Show (f (StructType, Maybe VName)),
Show (f (PName, StructType)),
Show (f (PName, StructType, Maybe VName)),
Show (f (Aliasing, StructType)),
Show (f (M.Map VName VName)),
- Show (f Uniqueness)
+ Show (f AppRes)
) =>
Showable f vn
@@ -247,16 +251,15 @@
NamedDim (QualName vn)
| -- | The size is a constant.
ConstDim Int
- | -- | No dimension declaration.
- AnyDim
+ | -- | No known size - but still possibly given a unique name, so we
+ -- can recognise e.g. @type square [n] = [n][n]i32@ and make
+ -- @square []@ do the right thing. If @Nothing@, then this is a
+ -- name distinct from any other.
+ AnyDim (Maybe vn)
deriving (Show)
-deriving instance Eq (DimDecl Name)
-
deriving instance Eq (DimDecl VName)
-deriving instance Ord (DimDecl Name)
-
deriving instance Ord (DimDecl VName)
instance Functor DimDecl where
@@ -268,13 +271,13 @@
instance Traversable DimDecl where
traverse f (NamedDim qn) = NamedDim <$> traverse f qn
traverse _ (ConstDim x) = pure $ ConstDim x
- traverse _ AnyDim = pure AnyDim
+ traverse f (AnyDim v) = AnyDim <$> traverse f v
-- Note that the notion of unifyDims here is intentionally not what we
-- use when we do real type unification in the type checker.
instance ArrayDim (DimDecl VName) where
- unifyDims AnyDim y = Just y
- unifyDims x AnyDim = Just x
+ unifyDims AnyDim {} y = Just y
+ unifyDims x AnyDim {} = Just x
unifyDims (NamedDim x) (NamedDim y) | x == y = Just $ NamedDim x
unifyDims (ConstDim x) (ConstDim y) | x == y = Just $ ConstDim x
unifyDims _ _ = Nothing
@@ -671,11 +674,109 @@
instance Traversable QualName where
traverse f (QualName qs v) = QualName <$> traverse f qs <*> f v
+-- | A binding of a size in a pattern (essentially a size parameter in
+-- a @let@ expression).
+data SizeBinder vn = SizeBinder {sizeName :: !vn, sizeLoc :: !SrcLoc}
+ deriving (Eq, Ord, Show)
+
+instance Located (SizeBinder vn) where
+ locOf = locOf . sizeLoc
+
+-- | An "application expression" is a semantic (not syntactic)
+-- grouping of expressions that have "funcall-like" semantics, mostly
+-- meaning that they can return existential sizes. In our type
+-- theory, these are all thought to be bound to names (*Administrative
+-- Normal Form*), but as this is not practical in a real language, we
+-- instead use an annotation ('AppRes') that stores the information we
+-- need, so we can pretend that an application expression was really
+-- bound to a name.
+data AppExpBase f vn
+ = -- | The @Maybe VName@ is a possible existential size
+ -- that is instantiated by this argument..
+ Apply
+ (ExpBase f vn)
+ (ExpBase f vn)
+ (f (Diet, Maybe VName))
+ SrcLoc
+ | -- | Size coercion: @e :> t@.
+ Coerce (ExpBase f vn) (TypeDeclBase f vn) SrcLoc
+ | Range
+ (ExpBase f vn)
+ (Maybe (ExpBase f vn))
+ (Inclusiveness (ExpBase f vn))
+ SrcLoc
+ | LetPat
+ [SizeBinder vn]
+ (PatternBase f vn)
+ (ExpBase f vn)
+ (ExpBase f vn)
+ SrcLoc
+ | LetFun
+ vn
+ ( [TypeParamBase vn],
+ [PatternBase f vn],
+ Maybe (TypeExp vn),
+ f StructType,
+ ExpBase f vn
+ )
+ (ExpBase f vn)
+ SrcLoc
+ | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) SrcLoc
+ | DoLoop
+ [VName] -- Size parameters.
+ (PatternBase f vn) -- Merge variable pattern.
+ (ExpBase f vn) -- Initial values of merge variables.
+ (LoopFormBase f vn) -- Do or while loop.
+ (ExpBase f vn) -- Loop body.
+ SrcLoc
+ | BinOp
+ (QualName vn, SrcLoc)
+ (f PatternType)
+ (ExpBase f vn, f (StructType, Maybe VName))
+ (ExpBase f vn, f (StructType, Maybe VName))
+ SrcLoc
+ | LetWith
+ (IdentBase f vn)
+ (IdentBase f vn)
+ [DimIndexBase f vn]
+ (ExpBase f vn)
+ (ExpBase f vn)
+ SrcLoc
+ | Index (ExpBase f vn) [DimIndexBase f vn] SrcLoc
+ | -- | A match expression.
+ Match (ExpBase f vn) (NE.NonEmpty (CaseBase f vn)) SrcLoc
+
+deriving instance Showable f vn => Show (AppExpBase f vn)
+
+deriving instance Eq (AppExpBase NoInfo VName)
+
+deriving instance Ord (AppExpBase NoInfo VName)
+
+instance Located (AppExpBase f vn) where
+ locOf (Range _ _ _ pos) = locOf pos
+ locOf (BinOp _ _ _ _ loc) = locOf loc
+ locOf (If _ _ _ loc) = locOf loc
+ locOf (Coerce _ _ loc) = locOf loc
+ locOf (Apply _ _ _ loc) = locOf loc
+ locOf (LetPat _ _ _ _ loc) = locOf loc
+ locOf (LetFun _ _ _ loc) = locOf loc
+ locOf (LetWith _ _ _ _ _ loc) = locOf loc
+ locOf (Index _ _ loc) = locOf loc
+ locOf (DoLoop _ _ _ _ _ loc) = locOf loc
+ locOf (Match _ _ loc) = locOf loc
+
+-- | An annotation inserted by the type checker on constructs that are
+-- "function calls" (either literally or conceptually). This
+-- annotation encodes the result type, as well as any existential
+-- sizes that are generated here.
+data AppRes = AppRes
+ { appResType :: PatternType,
+ appResExt :: [VName]
+ }
+ deriving (Eq, Ord, Show)
+
-- | The Futhark expression language.
--
--- In a value of type @Exp f vn@, annotations are wrapped in the
--- functor @f@, and all names are of type @vn@.
---
-- This allows us to encode whether or not the expression has been
-- type-checked in the Haskell type of the expression. Specifically,
-- the parser will produce expressions of type @Exp 'NoInfo' 'Name'@,
@@ -690,6 +791,7 @@
| -- | A string literal is just a fancy syntax for an array
-- of bytes.
StringLit [Word8] SrcLoc
+ | Var (QualName vn) (f PatternType) SrcLoc
| -- | A parenthesized expression.
Parens (ExpBase f vn) SrcLoc
| QualParens (QualName vn, SrcLoc) (ExpBase f vn) SrcLoc
@@ -700,48 +802,19 @@
| -- | Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@.
-- Second arg is the row type of the rows of the array.
ArrayLit [ExpBase f vn] (f PatternType) SrcLoc
- | Range
- (ExpBase f vn)
- (Maybe (ExpBase f vn))
- (Inclusiveness (ExpBase f vn))
- (f PatternType, f [VName])
- SrcLoc
- | Var (QualName vn) (f PatternType) SrcLoc
- | -- | Type ascription: @e : t@.
- Ascript (ExpBase f vn) (TypeDeclBase f vn) SrcLoc
- | -- | Size coercion: @e :> t@.
- Coerce (ExpBase f vn) (TypeDeclBase f vn) (f PatternType, f [VName]) SrcLoc
- | LetPat
- (PatternBase f vn)
- (ExpBase f vn)
- (ExpBase f vn)
- (f PatternType, f [VName])
- SrcLoc
- | LetFun
- vn
- ( [TypeParamBase vn],
- [PatternBase f vn],
- Maybe (TypeExp vn),
- f StructType,
- ExpBase f vn
- )
- (ExpBase f vn)
- (f PatternType)
- SrcLoc
- | If (ExpBase f vn) (ExpBase f vn) (ExpBase f vn) (f PatternType, f [VName]) SrcLoc
- | -- | The @Maybe VName@ is a possible existential size
- -- that is instantiated by this argument..
- --
- -- The @[VName]@ are the existential sizes that come
- -- into being at this call site.
- Apply
- (ExpBase f vn)
- (ExpBase f vn)
- (f (Diet, Maybe VName))
- (f PatternType, f [VName])
- SrcLoc
+ | -- | An attribute applied to the following expression.
+ Attr AttrInfo (ExpBase f vn) SrcLoc
+ | Project Name (ExpBase f vn) (f PatternType) SrcLoc
| -- | Numeric negation (ugly special case; Haskell did it first).
Negate (ExpBase f vn) SrcLoc
+ | -- | Fail if the first expression does not return true,
+ -- and return the value of the second expression if it
+ -- does.
+ Assert (ExpBase f vn) (ExpBase f vn) (f String) SrcLoc
+ | -- | An n-ary value constructor.
+ Constr Name [ExpBase f vn] (f PatternType) SrcLoc
+ | Update (ExpBase f vn) [DimIndexBase f vn] (ExpBase f vn) SrcLoc
+ | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f PatternType) SrcLoc
| Lambda
[PatternBase f vn]
(ExpBase f vn)
@@ -770,49 +843,9 @@
ProjectSection [Name] (f PatternType) SrcLoc
| -- | Array indexing as a section: @(.[i,j])@.
IndexSection [DimIndexBase f vn] (f PatternType) SrcLoc
- | DoLoop
- [VName] -- Size parameters.
- (PatternBase f vn) -- Merge variable pattern.
- (ExpBase f vn) -- Initial values of merge variables.
- (LoopFormBase f vn) -- Do or while loop.
- (ExpBase f vn) -- Loop body.
- (f (PatternType, [VName])) -- Return type.
- SrcLoc
- | BinOp
- (QualName vn, SrcLoc)
- (f PatternType)
- (ExpBase f vn, f (StructType, Maybe VName))
- (ExpBase f vn, f (StructType, Maybe VName))
- (f PatternType)
- (f [VName])
- SrcLoc
- | Project Name (ExpBase f vn) (f PatternType) SrcLoc
- | -- Primitive array operations
- LetWith
- (IdentBase f vn)
- (IdentBase f vn)
- [DimIndexBase f vn]
- (ExpBase f vn)
- (ExpBase f vn)
- (f PatternType)
- SrcLoc
- | Index (ExpBase f vn) [DimIndexBase f vn] (f PatternType, f [VName]) SrcLoc
- | Update (ExpBase f vn) [DimIndexBase f vn] (ExpBase f vn) SrcLoc
- | RecordUpdate (ExpBase f vn) [Name] (ExpBase f vn) (f PatternType) SrcLoc
- | -- | Fail if the first expression does not return true,
- -- and return the value of the second expression if it
- -- does.
- Assert (ExpBase f vn) (ExpBase f vn) (f String) SrcLoc
- | -- | An n-ary value constructor.
- Constr Name [ExpBase f vn] (f PatternType) SrcLoc
- | -- | A match expression.
- Match
- (ExpBase f vn)
- (NE.NonEmpty (CaseBase f vn))
- (f PatternType, f [VName])
- SrcLoc
- | -- | An attribute applied to the following expression.
- Attr AttrInfo (ExpBase f vn) SrcLoc
+ | -- | Type ascription: @e : t@.
+ Ascript (ExpBase f vn) (TypeDeclBase f vn) SrcLoc
+ | AppExp (AppExpBase f vn) (f AppRes)
deriving instance Showable f vn => Show (ExpBase f vn)
@@ -831,18 +864,9 @@
locOf (Project _ _ _ pos) = locOf pos
locOf (ArrayLit _ _ pos) = locOf pos
locOf (StringLit _ loc) = locOf loc
- locOf (Range _ _ _ _ pos) = locOf pos
- locOf (BinOp _ _ _ _ _ _ loc) = locOf loc
- locOf (If _ _ _ _ pos) = locOf pos
locOf (Var _ _ loc) = locOf loc
locOf (Ascript _ _ loc) = locOf loc
- locOf (Coerce _ _ _ loc) = locOf loc
locOf (Negate _ pos) = locOf pos
- locOf (Apply _ _ _ _ loc) = locOf loc
- locOf (LetPat _ _ _ _ loc) = locOf loc
- locOf (LetFun _ _ _ _ loc) = locOf loc
- locOf (LetWith _ _ _ _ _ _ loc) = locOf loc
- locOf (Index _ _ _ loc) = locOf loc
locOf (Update _ _ _ pos) = locOf pos
locOf (RecordUpdate _ _ _ _ pos) = locOf pos
locOf (Lambda _ _ _ _ loc) = locOf loc
@@ -851,11 +875,10 @@
locOf (OpSectionRight _ _ _ _ _ loc) = locOf loc
locOf (ProjectSection _ _ loc) = locOf loc
locOf (IndexSection _ _ loc) = locOf loc
- locOf (DoLoop _ _ _ _ _ _ loc) = locOf loc
locOf (Assert _ _ _ loc) = locOf loc
locOf (Constr _ _ _ loc) = locOf loc
- locOf (Match _ _ _ loc) = locOf loc
locOf (Attr _ _ loc) = locOf loc
+ locOf (AppExp e _) = locOf e
-- | An entry in a record literal.
data FieldBase f vn
diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs
--- a/src/Language/Futhark/Traversals.hs
+++ b/src/Language/Futhark/Traversals.hs
@@ -63,6 +63,57 @@
-- into subexpressions. The mapping is done left-to-right.
astMap :: Monad m => ASTMapper m -> x -> m x
+instance ASTMappable (AppExpBase Info VName) where
+ astMap tv (Range start next end loc) =
+ Range <$> mapOnExp tv start <*> traverse (mapOnExp tv) next
+ <*> traverse (mapOnExp tv) end
+ <*> pure loc
+ astMap tv (If c texp fexp loc) =
+ If <$> mapOnExp tv c <*> mapOnExp tv texp <*> mapOnExp tv fexp <*> pure loc
+ astMap tv (Match e cases loc) =
+ Match <$> mapOnExp tv e <*> astMap tv cases <*> pure loc
+ astMap tv (Apply f arg d loc) =
+ Apply <$> mapOnExp tv f <*> mapOnExp tv arg <*> pure d <*> pure loc
+ astMap tv (LetPat sizes pat e body loc) =
+ LetPat <$> astMap tv sizes <*> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body <*> pure loc
+ astMap tv (LetFun name (fparams, params, ret, t, e) body loc) =
+ LetFun <$> mapOnName tv name
+ <*> ( (,,,,) <$> mapM (astMap tv) fparams <*> mapM (astMap tv) params
+ <*> traverse (astMap tv) ret
+ <*> traverse (mapOnStructType tv) t
+ <*> mapOnExp tv e
+ )
+ <*> mapOnExp tv body
+ <*> pure loc
+ astMap tv (LetWith dest src idxexps vexp body loc) =
+ LetWith
+ <$> astMap tv dest
+ <*> astMap tv src
+ <*> mapM (astMap tv) idxexps
+ <*> mapOnExp tv vexp
+ <*> mapOnExp tv body
+ <*> pure loc
+ astMap tv (Coerce e tdecl loc) =
+ Coerce <$> mapOnExp tv e <*> astMap tv tdecl <*> pure loc
+ astMap tv (BinOp (fname, fname_loc) t (x, Info (xt, xext)) (y, Info (yt, yext)) loc) =
+ BinOp <$> ((,) <$> mapOnQualName tv fname <*> pure fname_loc)
+ <*> traverse (mapOnPatternType tv) t
+ <*> ( (,) <$> mapOnExp tv x
+ <*> (Info <$> ((,) <$> mapOnStructType tv xt <*> pure xext))
+ )
+ <*> ( (,) <$> mapOnExp tv y
+ <*> (Info <$> ((,) <$> mapOnStructType tv yt <*> pure yext))
+ )
+ <*> pure loc
+ astMap tv (DoLoop sparams mergepat mergeexp form loopbody loc) =
+ DoLoop <$> mapM (mapOnName tv) sparams <*> astMap tv mergepat
+ <*> mapOnExp tv mergeexp
+ <*> astMap tv form
+ <*> mapOnExp tv loopbody
+ <*> pure loc
+ astMap tv (Index arr idxexps loc) =
+ Index <$> mapOnExp tv arr <*> mapM (astMap tv) idxexps <*> pure loc
+
instance ASTMappable (ExpBase Info VName) where
astMap tv (Var name t loc) =
Var <$> mapOnQualName tv name <*> traverse (mapOnPatternType tv) t
@@ -87,62 +138,10 @@
RecordLit <$> astMap tv fields <*> pure loc
astMap tv (ArrayLit els t loc) =
ArrayLit <$> mapM (mapOnExp tv) els <*> traverse (mapOnPatternType tv) t <*> pure loc
- astMap tv (Range start next end (t, ext) loc) =
- Range <$> mapOnExp tv start <*> traverse (mapOnExp tv) next
- <*> traverse (mapOnExp tv) end
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
astMap tv (Ascript e tdecl loc) =
Ascript <$> mapOnExp tv e <*> astMap tv tdecl <*> pure loc
- astMap tv (Coerce e tdecl (t, ext) loc) =
- Coerce <$> mapOnExp tv e <*> astMap tv tdecl
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
- astMap tv (BinOp (fname, fname_loc) t (x, Info (xt, xext)) (y, Info (yt, yext)) (Info rt) ext loc) =
- BinOp <$> ((,) <$> mapOnQualName tv fname <*> pure fname_loc)
- <*> traverse (mapOnPatternType tv) t
- <*> ( (,) <$> mapOnExp tv x
- <*> (Info <$> ((,) <$> mapOnStructType tv xt <*> pure xext))
- )
- <*> ( (,) <$> mapOnExp tv y
- <*> (Info <$> ((,) <$> mapOnStructType tv yt <*> pure yext))
- )
- <*> (Info <$> mapOnPatternType tv rt)
- <*> pure ext
- <*> pure loc
astMap tv (Negate x loc) =
Negate <$> mapOnExp tv x <*> pure loc
- astMap tv (If c texp fexp (t, ext) loc) =
- If <$> mapOnExp tv c <*> mapOnExp tv texp <*> mapOnExp tv fexp
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
- astMap tv (Apply f arg d (Info t, ext) loc) =
- Apply <$> mapOnExp tv f <*> mapOnExp tv arg <*> pure d
- <*> ((,) <$> (Info <$> mapOnPatternType tv t) <*> pure ext)
- <*> pure loc
- astMap tv (LetPat pat e body (t, ext) loc) =
- LetPat <$> astMap tv pat <*> mapOnExp tv e <*> mapOnExp tv body
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
- astMap tv (LetFun name (fparams, params, ret, t, e) body body_t loc) =
- LetFun <$> mapOnName tv name
- <*> ( (,,,,) <$> mapM (astMap tv) fparams <*> mapM (astMap tv) params
- <*> traverse (astMap tv) ret
- <*> traverse (mapOnStructType tv) t
- <*> mapOnExp tv e
- )
- <*> mapOnExp tv body
- <*> traverse (mapOnPatternType tv) body_t
- <*> pure loc
- astMap tv (LetWith dest src idxexps vexp body t loc) =
- LetWith
- <$> astMap tv dest
- <*> astMap tv src
- <*> mapM (astMap tv) idxexps
- <*> mapOnExp tv vexp
- <*> mapOnExp tv body
- <*> traverse (mapOnPatternType tv) t
- <*> pure loc
astMap tv (Update src slice v loc) =
Update <$> mapOnExp tv src <*> mapM (astMap tv) slice
<*> mapOnExp tv v
@@ -154,10 +153,6 @@
<*> pure loc
astMap tv (Project field e t loc) =
Project field <$> mapOnExp tv e <*> traverse (mapOnPatternType tv) t <*> pure loc
- astMap tv (Index arr idxexps (t, ext) loc) =
- Index <$> mapOnExp tv arr <*> mapM (astMap tv) idxexps
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
astMap tv (Assert e1 e2 desc loc) =
Assert <$> mapOnExp tv e1 <*> mapOnExp tv e2 <*> pure desc <*> pure loc
astMap tv (Lambda params body ret t loc) =
@@ -196,21 +191,12 @@
IndexSection <$> mapM (astMap tv) idxs
<*> traverse (mapOnPatternType tv) t
<*> pure loc
- astMap tv (DoLoop sparams mergepat mergeexp form loopbody (Info (ret, ext)) loc) =
- DoLoop <$> mapM (mapOnName tv) sparams <*> astMap tv mergepat
- <*> mapOnExp tv mergeexp
- <*> astMap tv form
- <*> mapOnExp tv loopbody
- <*> (Info <$> ((,) <$> mapOnPatternType tv ret <*> pure ext))
- <*> pure loc
astMap tv (Constr name es ts loc) =
Constr name <$> traverse (mapOnExp tv) es <*> traverse (mapOnPatternType tv) ts <*> pure loc
- astMap tv (Match e cases (t, ext) loc) =
- Match <$> mapOnExp tv e <*> astMap tv cases
- <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext)
- <*> pure loc
astMap tv (Attr attr e loc) =
Attr attr <$> mapOnExp tv e <*> pure loc
+ astMap tv (AppExp e res) =
+ AppExp <$> astMap tv e <*> astMap tv res
instance ASTMappable (LoopFormBase Info VName) where
astMap tv (For i bound) = For <$> astMap tv i <*> mapOnExp tv bound
@@ -247,7 +233,7 @@
instance ASTMappable (DimDecl VName) where
astMap tv (NamedDim vn) = NamedDim <$> mapOnQualName tv vn
astMap _ (ConstDim k) = pure $ ConstDim k
- astMap _ AnyDim = pure AnyDim
+ astMap tv (AnyDim vn) = AnyDim <$> traverse (mapOnName tv) vn
instance ASTMappable (TypeParamBase VName) where
astMap = traverse . mapOnName
@@ -267,6 +253,10 @@
instance ASTMappable Aliasing where
astMap tv = fmap S.fromList . traverse (astMap tv) . S.toList
+instance ASTMappable AppRes where
+ astMap tv (AppRes t ext) =
+ AppRes <$> mapOnPatternType tv t <*> pure ext
+
type TypeTraverser f t dim1 als1 dim2 als2 =
(TypeName -> f TypeName) ->
(dim1 -> f dim2) ->
@@ -325,6 +315,10 @@
astMap tv (Ident name (Info t) loc) =
Ident <$> mapOnName tv name <*> (Info <$> mapOnPatternType tv t) <*> pure loc
+instance ASTMappable (SizeBinder VName) where
+ astMap tv (SizeBinder name loc) =
+ SizeBinder <$> mapOnName tv name <*> pure loc
+
instance ASTMappable (PatternBase Info VName) where
astMap tv (Id name (Info t) loc) =
Id <$> mapOnName tv name <*> (Info <$> mapOnPatternType tv t) <*> pure loc
@@ -424,44 +418,15 @@
bareExp (StringLit vs loc) = StringLit vs loc
bareExp (RecordLit fields loc) = RecordLit (map bareField fields) loc
bareExp (ArrayLit els _ loc) = ArrayLit (map bareExp els) NoInfo loc
-bareExp (Range start next end _ loc) =
- Range
- (bareExp start)
- (fmap bareExp next)
- (fmap bareExp end)
- (NoInfo, NoInfo)
- loc
bareExp (Ascript e tdecl loc) =
Ascript (bareExp e) (bareTypeDecl tdecl) loc
-bareExp (Coerce e tdecl _ loc) =
- Coerce (bareExp e) (bareTypeDecl tdecl) (NoInfo, NoInfo) loc
-bareExp (BinOp fname _ (x, _) (y, _) _ _ loc) =
- BinOp fname NoInfo (bareExp x, NoInfo) (bareExp y, NoInfo) NoInfo NoInfo loc
bareExp (Negate x loc) = Negate (bareExp x) loc
-bareExp (If c texp fexp _ loc) =
- If (bareExp c) (bareExp texp) (bareExp fexp) (NoInfo, NoInfo) loc
-bareExp (Apply f arg _ _ loc) =
- Apply (bareExp f) (bareExp arg) NoInfo (NoInfo, NoInfo) loc
-bareExp (LetPat pat e body _ loc) =
- LetPat (barePat pat) (bareExp e) (bareExp body) (NoInfo, NoInfo) loc
-bareExp (LetFun name (fparams, params, ret, _, e) body _ loc) =
- LetFun name (fparams, map barePat params, ret, NoInfo, bareExp e) (bareExp body) NoInfo loc
-bareExp (LetWith (Ident dest _ destloc) (Ident src _ srcloc) idxexps vexp body _ loc) =
- LetWith
- (Ident dest NoInfo destloc)
- (Ident src NoInfo srcloc)
- (map bareDimIndex idxexps)
- (bareExp vexp)
- (bareExp body)
- NoInfo
- loc
bareExp (Update src slice v loc) =
Update (bareExp src) (map bareDimIndex slice) (bareExp v) loc
bareExp (RecordUpdate src fs v _ loc) =
RecordUpdate (bareExp src) fs (bareExp v) NoInfo loc
-bareExp (Project field e _ loc) = Project field (bareExp e) NoInfo loc
-bareExp (Index arr slice _ loc) =
- Index (bareExp arr) (map bareDimIndex slice) (NoInfo, NoInfo) loc
+bareExp (Project field e _ loc) =
+ Project field (bareExp e) NoInfo loc
bareExp (Assert e1 e2 _ loc) = Assert (bareExp e1) (bareExp e2) NoInfo loc
bareExp (Lambda params body ret _ loc) =
Lambda (map barePat params) (bareExp body) ret NoInfo loc
@@ -473,18 +438,46 @@
bareExp (ProjectSection fields _ loc) = ProjectSection fields NoInfo loc
bareExp (IndexSection slice _ loc) =
IndexSection (map bareDimIndex slice) NoInfo loc
-bareExp (DoLoop _ mergepat mergeexp form loopbody _ loc) =
- DoLoop
- []
- (barePat mergepat)
- (bareExp mergeexp)
- (bareLoopForm form)
- (bareExp loopbody)
- NoInfo
- loc
bareExp (Constr name es _ loc) =
Constr name (map bareExp es) NoInfo loc
-bareExp (Match e cases _ loc) =
- Match (bareExp e) (fmap bareCase cases) (NoInfo, NoInfo) loc
+bareExp (AppExp appexp _) =
+ AppExp appexp' NoInfo
+ where
+ appexp' =
+ case appexp of
+ Match e cases loc ->
+ Match (bareExp e) (fmap bareCase cases) loc
+ DoLoop _ mergepat mergeexp form loopbody loc ->
+ DoLoop
+ []
+ (barePat mergepat)
+ (bareExp mergeexp)
+ (bareLoopForm form)
+ (bareExp loopbody)
+ loc
+ LetWith (Ident dest _ destloc) (Ident src _ srcloc) idxexps vexp body loc ->
+ LetWith
+ (Ident dest NoInfo destloc)
+ (Ident src NoInfo srcloc)
+ (map bareDimIndex idxexps)
+ (bareExp vexp)
+ (bareExp body)
+ loc
+ BinOp fname _ (x, _) (y, _) loc ->
+ BinOp fname NoInfo (bareExp x, NoInfo) (bareExp y, NoInfo) loc
+ If c texp fexp loc ->
+ If (bareExp c) (bareExp texp) (bareExp fexp) loc
+ Apply f arg _ loc ->
+ Apply (bareExp f) (bareExp arg) NoInfo loc
+ LetPat sizes pat e body loc ->
+ LetPat sizes (barePat pat) (bareExp e) (bareExp body) loc
+ LetFun name (fparams, params, ret, _, e) body loc ->
+ LetFun name (fparams, map barePat params, ret, NoInfo, bareExp e) (bareExp body) loc
+ Range start next end loc ->
+ Range (bareExp start) (fmap bareExp next) (fmap bareExp end) loc
+ Coerce e tdecl loc ->
+ Coerce (bareExp e) (bareTypeDecl tdecl) loc
+ Index arr slice loc ->
+ Index (bareExp arr) (map bareDimIndex slice) loc
bareExp (Attr attr e loc) =
Attr attr (bareExp e) loc
diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs
--- a/src/Language/Futhark/TypeChecker.hs
+++ b/src/Language/Futhark/TypeChecker.hs
@@ -127,8 +127,8 @@
intrinsicsModule = Env mempty initialTypeTable mempty mempty intrinsicsNameMap
- addIntrinsicT (name, IntrinsicType t) =
- Just (name, TypeAbbr Unlifted [] $ Scalar $ Prim t)
+ addIntrinsicT (name, IntrinsicType l ps t) =
+ Just (name, TypeAbbr l ps t)
addIntrinsicT _ =
Nothing
@@ -194,7 +194,7 @@
emptyDimParam :: StructType -> Bool
emptyDimParam = isNothing . traverseDims onDim
where
- onDim _ pos AnyDim | pos `elem` [PosImmediate, PosParam] = Nothing
+ onDim _ pos (AnyDim _) | pos `elem` [PosImmediate, PosParam] = Nothing
onDim _ _ d = Just d
-- In this function, after the recursion, we add the Env of the
diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs
--- a/src/Language/Futhark/TypeChecker/Match.hs
+++ b/src/Language/Futhark/TypeChecker/Match.hs
@@ -14,7 +14,7 @@
import Data.Maybe
import Futhark.Util (maybeHead, nubOrd)
import Futhark.Util.Pretty hiding (bool, group, space)
-import Language.Futhark hiding (ExpBase (Constr), unscopeType)
+import Language.Futhark hiding (ExpBase (Constr))
data Constr
= Constr Name
diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs
--- a/src/Language/Futhark/TypeChecker/Modules.hs
+++ b/src/Language/Futhark/TypeChecker/Modules.hs
@@ -44,13 +44,13 @@
envModTable = M.map (substituteTypesInMod substs) $ envModTable env
}
where
- subT name _
- | Just (TypeSub (TypeAbbr l ps t)) <- M.lookup name substs = TypeAbbr l ps t
- subT _ (TypeAbbr l ps t) = TypeAbbr l ps $ substituteTypes substs t
+ subT name (TypeAbbr l _ _)
+ | Just (Subst ps t) <- substs name = TypeAbbr l ps t
+ subT _ (TypeAbbr l ps t) = TypeAbbr l ps $ applySubst substs t
substituteTypesInBoundV :: TypeSubs -> BoundV -> BoundV
substituteTypesInBoundV substs (BoundV tps t) =
- BoundV tps (substituteTypes substs t)
+ BoundV tps (applySubst substs t)
-- | All names defined anywhere in the 'Env'.
allNamesInEnv :: Env -> S.Set VName
@@ -162,8 +162,8 @@
TypeArgDim (NamedDim $ QualName (map substitute qs) $ substitute v) loc
substituteInTypeArg (TypeArgDim (ConstDim x) loc) =
TypeArgDim (ConstDim x) loc
- substituteInTypeArg (TypeArgDim AnyDim loc) =
- TypeArgDim AnyDim loc
+ substituteInTypeArg (TypeArgDim (AnyDim v) loc) =
+ TypeArgDim (AnyDim v) loc
substituteInTypeArg (TypeArgType t loc) =
TypeArgType (substituteInType t) loc
@@ -191,7 +191,7 @@
StructType ->
TypeM (QualName VName, TySet, Env)
refineEnv loc tset env tname ps t
- | Just (tname', TypeAbbr l cur_ps (Scalar (TypeVar () _ (TypeName qs v) _))) <-
+ | Just (tname', TypeAbbr _ cur_ps (Scalar (TypeVar () _ (TypeName qs v) _))) <-
findTypeDef tname (ModEnv env),
QualName (qualQuals tname') v `M.member` tset =
if paramsMatch cur_ps ps
@@ -200,13 +200,7 @@
( tname',
QualName qs v `M.delete` tset,
substituteTypesInEnv
- ( M.fromList
- [ ( qualLeaf tname',
- TypeSub $ TypeAbbr l cur_ps t
- ),
- (v, TypeSub $ TypeAbbr l ps t)
- ]
- )
+ (flip M.lookup $ M.fromList [(qualLeaf tname', Subst cur_ps t), (v, Subst ps t)])
env
)
else
@@ -303,7 +297,7 @@
emptyDims :: StructType -> Bool
emptyDims = isNothing . traverseDims onDim
where
- onDim _ PosImmediate AnyDim = Nothing
+ onDim _ PosImmediate (AnyDim _) = Nothing
onDim _ _ d = Just d
resolveMTyNames ::
@@ -401,14 +395,12 @@
Either TypeError (M.Map VName VName)
matchMTys orig_mty orig_mty_sig =
matchMTys'
- ( M.map (DimSub . NamedDim) $
- resolveMTyNames orig_mty orig_mty_sig
- )
+ (M.map (SizeSubst . NamedDim) $ resolveMTyNames orig_mty orig_mty_sig)
orig_mty
orig_mty_sig
where
matchMTys' ::
- TypeSubs ->
+ M.Map VName (Subst StructType) ->
MTy ->
MTy ->
SrcLoc ->
@@ -433,14 +425,13 @@
abs_substs <- resolveAbsTypes mod_abs mod sig_abs loc
let abs_subst_to_type =
- old_abs_subst_to_type
- <> M.map (TypeSub . snd) abs_substs
+ old_abs_subst_to_type <> M.map (substFromAbbr . snd) abs_substs
abs_name_substs = M.map (qualLeaf . fst) abs_substs
substs <- matchMods abs_subst_to_type mod sig loc
return (substs <> abs_name_substs)
matchMods ::
- TypeSubs ->
+ M.Map VName (Subst StructType) ->
Mod ->
Mod ->
SrcLoc ->
@@ -466,15 +457,14 @@
loc = do
abs_substs <- resolveAbsTypes mod_abs mod_pmod sig_abs loc
let abs_subst_to_type =
- old_abs_subst_to_type
- <> M.map (TypeSub . snd) abs_substs
+ old_abs_subst_to_type <> M.map (substFromAbbr . snd) abs_substs
abs_name_substs = M.map (qualLeaf . fst) abs_substs
pmod_substs <- matchMods abs_subst_to_type mod_pmod sig_pmod loc
mod_substs <- matchMTys' abs_subst_to_type mod_mod sig_mod loc
return (pmod_substs <> mod_substs <> abs_name_substs)
matchEnvs ::
- TypeSubs ->
+ M.Map VName (Subst StructType) ->
Env ->
Env ->
SrcLoc ->
@@ -503,7 +493,7 @@
-- abstract types first.
val_substs <- fmap M.fromList $
forM (M.toList $ envVtable sig) $ \(name, spec_bv) -> do
- let spec_bv' = substituteTypesInBoundV abs_subst_to_type spec_bv
+ let spec_bv' = substituteTypesInBoundV (`M.lookup` abs_subst_to_type) spec_bv
case findBinding envVtable Term (baseName name) env of
Just (name', bv) -> matchVal loc name spec_bv' name' bv
_ -> missingVal loc (baseName name)
@@ -521,7 +511,7 @@
matchTypeAbbr ::
SrcLoc ->
- TypeSubs ->
+ M.Map VName (Subst StructType) ->
VName ->
Liftedness ->
[TypeParam] ->
@@ -534,7 +524,8 @@
matchTypeAbbr loc abs_subst_to_type spec_name spec_l spec_ps spec_t name l ps t = do
-- We have to create substitutions for the type parameters, too.
unless (length spec_ps == length ps) $ nomatch spec_t
- param_substs <- mconcat <$> zipWithM matchTypeParam spec_ps ps
+ param_substs <-
+ mconcat <$> zipWithM (matchTypeParam (nomatch spec_t)) spec_ps ps
-- Abstract types have a particular restriction to ensure that
-- if we have a value of an abstract type 't [n]', then there is
@@ -551,7 +542,7 @@
<+/> pquote (pprName d)
<+/> textwrap "is not used as an array size in the definition."
- let spec_t' = substituteTypes (param_substs <> abs_subst_to_type) spec_t
+ let spec_t' = applySubst (`M.lookup` (param_substs <> abs_subst_to_type)) spec_t
if spec_t' == t
then return (spec_name, name)
else nomatch spec_t'
@@ -564,22 +555,14 @@
(spec_l, spec_ps, spec_t')
(l, ps, t)
- matchTypeParam (TypeParamDim x _) (TypeParamDim y _) =
- pure $ M.singleton x $ DimSub $ NamedDim $ qualName y
- matchTypeParam (TypeParamType Unlifted x _) (TypeParamType Unlifted y _) =
- pure $
- M.singleton x $
- TypeSub $
- TypeAbbr Unlifted [] $
- Scalar $ TypeVar () Nonunique (typeName y) []
- matchTypeParam (TypeParamType _ x _) (TypeParamType Lifted y _) =
- pure $
- M.singleton x $
- TypeSub $
- TypeAbbr Lifted [] $
- Scalar $ TypeVar () Nonunique (typeName y) []
- matchTypeParam _ _ =
- nomatch spec_t
+ matchTypeParam _ (TypeParamDim x _) (TypeParamDim y _) =
+ pure $ M.singleton x $ SizeSubst $ NamedDim $ qualName y
+ matchTypeParam _ (TypeParamType spec_l x _) (TypeParamType l y _)
+ | spec_l <= l =
+ pure . M.singleton x . Subst [] $
+ Scalar $ TypeVar () Nonunique (typeName y) []
+ matchTypeParam nomatch _ _ =
+ nomatch
matchVal ::
SrcLoc ->
@@ -633,9 +616,9 @@
-- Apply type abbreviations from a_mty to body_mty.
let a_abbrs = mtyTypeAbbrs a_mty
isSub v = case M.lookup v a_abbrs of
- Just abbr -> Just $ TypeSub abbr
- _ -> Just $ DimSub $ NamedDim $ qualName v
+ Just abbr -> Just $ substFromAbbr abbr
+ _ -> Just $ SizeSubst $ NamedDim $ qualName v
type_subst = M.mapMaybe isSub p_subst
- body_mty' = substituteTypesInMTy type_subst body_mty
+ body_mty' = substituteTypesInMTy (`M.lookup` type_subst) body_mty
(body_mty'', body_subst) <- newNamesForMTy body_mty'
return (body_mty'', p_subst, body_subst)
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
@@ -25,6 +25,7 @@
import Control.Monad.State
import Control.Monad.Writer hiding (Sum)
import Data.Bifunctor
+import Data.Bitraversable
import Data.Char (isAscii)
import Data.Either
import Data.List (find, foldl', isPrefixOf, sort)
@@ -35,7 +36,7 @@
import Futhark.IR.Primitive (intByteSize)
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty hiding (bool, group, space)
-import Language.Futhark hiding (unscopeType)
+import Language.Futhark
import Language.Futhark.Semantic (includeToFilePath)
import Language.Futhark.Traversals
import Language.Futhark.TypeChecker.Match
@@ -101,11 +102,11 @@
combineOccurences :: VName -> Usage -> Usage -> TermTypeM Usage
combineOccurences _ (Observed loc) (Observed _) = return $ Observed loc
combineOccurences name (Consumed wloc) (Observed rloc) =
- useAfterConsume (baseName name) rloc wloc
+ useAfterConsume name rloc wloc
combineOccurences name (Observed rloc) (Consumed wloc) =
- useAfterConsume (baseName name) rloc wloc
+ useAfterConsume name rloc wloc
combineOccurences name (Consumed loc1) (Consumed loc2) =
- consumeAfterConsume (baseName name) (max loc1 loc2) (min loc1 loc2)
+ consumeAfterConsume name (max loc1 loc2) (min loc1 loc2)
checkOccurences :: Occurences -> TermTypeM ()
checkOccurences = void . M.traverseWithKey comb . usageMap
@@ -320,6 +321,19 @@
(Maybe (ExpBase NoInfo VName))
deriving (Eq, Ord, Show)
+-- | A description of where an artificial compiler-generated
+-- intermediate name came from.
+data NameReason
+ = -- | Name is the result of a function application.
+ NameAppRes (Maybe (QualName VName)) SrcLoc
+
+nameReason :: SrcLoc -> NameReason -> Doc
+nameReason loc (NameAppRes Nothing apploc) =
+ "result of application at" <+> text (locStrRel loc apploc)
+nameReason loc (NameAppRes fname apploc) =
+ "result of applying" <+> pquote (ppr fname)
+ <+> parens ("at" <+> text (locStrRel loc apploc))
+
-- | The state is a set of constraints and a counter for generating
-- type names. This is distinct from the usual counter we use for
-- generating unique names, as these will be user-visible.
@@ -331,7 +345,8 @@
-- they could not be substituted directly).
-- This happens for function arguments that are
-- not constants or names.
- stateDimTable :: M.Map SizeSource VName
+ stateDimTable :: M.Map SizeSource VName,
+ stateNames :: M.Map VName NameReason
}
newtype TermTypeM a
@@ -417,7 +432,7 @@
termChecking = Nothing,
termLevel = 0
}
- evalRWST m initial_tenv $ TermTypeState mempty 0 mempty
+ evalRWST m initial_tenv $ TermTypeState mempty 0 mempty mempty
liftTypeM :: TypeM a -> TermTypeM a
liftTypeM = TermTypeM . lift
@@ -443,7 +458,7 @@
RigidBound $ prettyOneLine e'
SourceSlice d i j s ->
RigidSlice d $ prettyOneLine $ DimSlice i j s
- d <- newDimVar loc (Rigid rsrc) "argdim"
+ d <- newDimVar loc (Rigid rsrc) "n"
modify $ \s -> s {stateDimTable = M.insert e d $ stateDimTable s}
return
( NamedDim $ qualName d,
@@ -548,7 +563,7 @@
Nothing ->
typeError loc mempty $
"Unknown variable" <+> pquote (ppr qn) <> "."
- Just (WasConsumed wloc) -> useAfterConsume (baseName name) loc wloc
+ Just (WasConsumed wloc) -> useAfterConsume name loc wloc
Just (BoundV _ tparams t)
| "_" `isPrefixOf` baseString name -> underscoreUse loc qn
| otherwise -> do
@@ -664,7 +679,7 @@
case tparam of
TypeParamType x _ _ -> do
constrain v $ NoConstraint x $ mkUsage' loc
- return (v, Subst $ Scalar $ TypeVar mempty Nonunique (typeName v) [])
+ return (v, Subst [] $ Scalar $ TypeVar mempty Nonunique (typeName v) [])
TypeParamDim {} -> do
constrain v $ Size Nothing $ mkUsage' loc
return (v, SizeSubst $ NamedDim $ qualName v)
@@ -682,16 +697,18 @@
--- Errors
-useAfterConsume :: Name -> SrcLoc -> SrcLoc -> TermTypeM a
-useAfterConsume name rloc wloc =
+useAfterConsume :: VName -> SrcLoc -> SrcLoc -> TermTypeM a
+useAfterConsume name rloc wloc = do
+ name' <- describeVar rloc name
typeError rloc mempty $
- "Variable" <+> pquote (pprName name) <+> "previously consumed at"
+ "Using" <+> name' <> ", but this was consumed at"
<+> text (locStrRel rloc wloc) <> ". (Possibly through aliasing.)"
-consumeAfterConsume :: Name -> SrcLoc -> SrcLoc -> TermTypeM a
-consumeAfterConsume name loc1 loc2 =
+consumeAfterConsume :: VName -> SrcLoc -> SrcLoc -> TermTypeM a
+consumeAfterConsume name loc1 loc2 = do
+ name' <- describeVar loc1 name
typeError loc2 mempty $
- "Variable" <+> pprName name <+> "previously consumed at"
+ "Consuming" <+> name' <> ", but this was previously consumed at"
<+> text (locStrRel loc2 loc1) <> "."
badLetWithValue :: (Pretty arr, Pretty src) => arr -> src -> SrcLoc -> TermTypeM a
@@ -768,56 +785,73 @@
patLitMkType (PatLitPrim v) _ =
pure $ Scalar $ Prim $ primValueType v
+nonrigidFor :: [SizeBinder VName] -> StructType -> TermTypeM StructType
+nonrigidFor [] t = pure t -- Minor optimisation.
+nonrigidFor sizes t = evalStateT (bitraverse onDim pure t) mempty
+ where
+ onDim (NamedDim (QualName _ v))
+ | Just size <- find ((== v) . sizeName) sizes = do
+ prev <- gets $ lookup v
+ case prev of
+ Nothing -> do
+ v' <- lift $ newID $ baseName v
+ lift $ constrain v' $ Size Nothing $ mkUsage' $ srclocOf size
+ modify ((v, v') :)
+ pure $ NamedDim $ qualName v'
+ Just v' ->
+ pure $ NamedDim $ qualName v'
+ onDim d = pure d
+
checkPattern' ::
+ [SizeBinder VName] ->
UncheckedPattern ->
InferredType ->
TermTypeM Pattern
-checkPattern' (PatternParens p loc) t =
- PatternParens <$> checkPattern' p t <*> pure loc
-checkPattern' (Id name _ loc) _
+checkPattern' sizes (PatternParens p loc) t =
+ PatternParens <$> checkPattern' sizes p t <*> pure loc
+checkPattern' _ (Id name _ loc) _
| name' `elem` doNotShadow =
typeError loc mempty $ "The" <+> text name' <+> "operator may not be redefined."
where
name' = nameToString name
-checkPattern' (Id name NoInfo loc) (Ascribed t) = do
+checkPattern' _ (Id name NoInfo loc) (Ascribed t) = do
name' <- newID name
return $ Id name' (Info t) loc
-checkPattern' (Id name NoInfo loc) NoneInferred = do
+checkPattern' _ (Id name NoInfo loc) NoneInferred = do
name' <- newID name
t <- newTypeVar loc "t"
return $ Id name' (Info t) loc
-checkPattern' (Wildcard _ loc) (Ascribed t) =
+checkPattern' _ (Wildcard _ loc) (Ascribed t) =
return $ Wildcard (Info $ t `setUniqueness` Nonunique) loc
-checkPattern' (Wildcard NoInfo loc) NoneInferred = do
+checkPattern' _ (Wildcard NoInfo loc) NoneInferred = do
t <- newTypeVar loc "t"
return $ Wildcard (Info t) loc
-checkPattern' (TuplePattern ps loc) (Ascribed t)
+checkPattern' sizes (TuplePattern ps loc) (Ascribed t)
| Just ts <- isTupleRecord t,
length ts == length ps =
- TuplePattern <$> zipWithM checkPattern' ps (map Ascribed ts) <*> pure loc
-checkPattern' p@(TuplePattern ps loc) (Ascribed t) = do
+ TuplePattern
+ <$> zipWithM (checkPattern' sizes) ps (map Ascribed ts)
+ <*> pure loc
+checkPattern' sizes p@(TuplePattern ps loc) (Ascribed t) = do
ps_t <- replicateM (length ps) (newTypeVar loc "t")
unify (mkUsage loc "matching a tuple pattern") (tupleRecord ps_t) $ toStruct t
t' <- normTypeFully t
- checkPattern' p $ Ascribed t'
-checkPattern' (TuplePattern ps loc) NoneInferred =
- TuplePattern <$> mapM (`checkPattern'` NoneInferred) ps <*> pure loc
-checkPattern' (RecordPattern p_fs _) _
+ checkPattern' sizes p $ Ascribed t'
+checkPattern' sizes (TuplePattern ps loc) NoneInferred =
+ TuplePattern <$> mapM (\p -> checkPattern' sizes p NoneInferred) ps <*> pure loc
+checkPattern' _ (RecordPattern p_fs _) _
| Just (f, fp) <- find (("_" `isPrefixOf`) . nameToString . fst) p_fs =
typeError fp mempty $
"Underscore-prefixed fields are not allowed."
"Did you mean" <> dquotes (text (drop 1 (nameToString f)) <> "=_") <> "?"
-checkPattern' (RecordPattern p_fs loc) (Ascribed (Scalar (Record t_fs)))
+checkPattern' sizes (RecordPattern p_fs loc) (Ascribed (Scalar (Record t_fs)))
| sort (map fst p_fs) == sort (M.keys t_fs) =
RecordPattern . M.toList <$> check <*> pure loc
where
check =
- traverse (uncurry checkPattern') $
- M.intersectionWith
- (,)
- (M.fromList p_fs)
- (fmap Ascribed t_fs)
-checkPattern' p@(RecordPattern fields loc) (Ascribed t) = do
+ traverse (uncurry (checkPattern' sizes)) $
+ M.intersectionWith (,) (M.fromList p_fs) (fmap Ascribed t_fs)
+checkPattern' sizes p@(RecordPattern fields loc) (Ascribed t) = do
fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields
when (sort (M.keys fields') /= sort (map fst fields)) $
@@ -825,17 +859,20 @@
unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStruct t
t' <- normTypeFully t
- checkPattern' p $ Ascribed t'
-checkPattern' (RecordPattern fs loc) NoneInferred =
- RecordPattern . M.toList <$> traverse (`checkPattern'` NoneInferred) (M.fromList fs) <*> pure loc
-checkPattern' (PatternAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do
+ checkPattern' sizes p $ Ascribed t'
+checkPattern' sizes (RecordPattern fs loc) NoneInferred =
+ RecordPattern . M.toList
+ <$> traverse (\p -> checkPattern' sizes p NoneInferred) (M.fromList fs)
+ <*> pure loc
+checkPattern' sizes (PatternAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do
(t', st_nodims, _) <- checkTypeExp t
(st, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid st_nodims
let st' = fromStruct st
case maybe_outer_t of
Ascribed outer_t -> do
- unify (mkUsage loc "explicit type ascription") (toStruct st) (toStruct outer_t)
+ st_forunify <- nonrigidFor sizes st
+ unify (mkUsage loc "explicit type ascription") st_forunify (toStruct outer_t)
-- We also have to make sure that uniqueness matches. This is
-- done explicitly, because it is ignored by unification.
@@ -843,7 +880,7 @@
outer_t' <- normTypeFully outer_t
case unifyTypesU unifyUniqueness st'' outer_t' of
Just outer_t'' ->
- PatternAscription <$> checkPattern' p (Ascribed outer_t'')
+ PatternAscription <$> checkPattern' sizes p (Ascribed outer_t'')
<*> pure (TypeDecl t' (Info st))
<*> pure loc
Nothing ->
@@ -851,33 +888,33 @@
"Cannot match type" <+> pquote (ppr outer_t') <+> "with expected type"
<+> pquote (ppr st'') <> "."
NoneInferred ->
- PatternAscription <$> checkPattern' p (Ascribed st')
+ PatternAscription <$> checkPattern' sizes p (Ascribed st')
<*> pure (TypeDecl t' (Info st))
<*> pure loc
where
unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing
-checkPattern' (PatternLit l NoInfo loc) (Ascribed t) = do
+checkPattern' _ (PatternLit l NoInfo loc) (Ascribed t) = do
t' <- patLitMkType l loc
unify (mkUsage loc "matching against literal") t' (toStruct t)
return $ PatternLit l (Info (fromStruct t')) loc
-checkPattern' (PatternLit l NoInfo loc) NoneInferred = do
+checkPattern' _ (PatternLit l NoInfo loc) NoneInferred = do
t' <- patLitMkType l loc
return $ PatternLit l (Info (fromStruct t')) loc
-checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))
+checkPattern' sizes (PatternConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))
| Just ts <- M.lookup n cs = do
- ps' <- zipWithM checkPattern' ps $ map Ascribed ts
+ ps' <- zipWithM (checkPattern' sizes) ps $ map Ascribed ts
return $ PatternConstr n (Info (Scalar (Sum cs))) ps' loc
-checkPattern' (PatternConstr n NoInfo ps loc) (Ascribed t) = do
+checkPattern' sizes (PatternConstr n NoInfo ps loc) (Ascribed t) = do
t' <- newTypeVar loc "t"
- ps' <- mapM (`checkPattern'` NoneInferred) ps
+ ps' <- mapM (\p -> checkPattern' sizes p NoneInferred) ps
mustHaveConstr usage n t' (patternStructType <$> ps')
unify usage t' (toStruct t)
t'' <- normTypeFully t
return $ PatternConstr n (Info t'') ps' loc
where
usage = mkUsage loc "matching against constructor"
-checkPattern' (PatternConstr n NoInfo ps loc) NoneInferred = do
- ps' <- mapM (`checkPattern'` NoneInferred) ps
+checkPattern' sizes (PatternConstr n NoInfo ps loc) NoneInferred = do
+ ps' <- mapM (\p -> checkPattern' sizes p NoneInferred) ps
t <- newTypeVar loc "t"
mustHaveConstr usage n t (patternStructType <$> ps')
return $ PatternConstr n (Info $ fromStruct t) ps' loc
@@ -890,15 +927,25 @@
asTerm v = ((Term, baseName v), qualName v)
checkPattern ::
+ [SizeBinder VName] ->
UncheckedPattern ->
InferredType ->
(Pattern -> TermTypeM a) ->
TermTypeM a
-checkPattern p t m = do
+checkPattern sizes p t m = do
checkForDuplicateNames [p]
- p' <- onFailure (CheckingPattern p t) $ checkPattern' p t
- bindNameMap (patternNameMap p') $ m p'
+ p' <- onFailure (CheckingPattern p t) $ checkPattern' sizes p t
+ let explicit = mustBeExplicitInType $ patternStructType p'
+
+ case filter ((`S.member` explicit) . sizeName) sizes of
+ size : _ ->
+ typeError size mempty $
+ "Cannot bind" <+> ppr size
+ <+> "as it is never used as the size of a concrete (non-function) value."
+ [] ->
+ bindNameMap (patternNameMap p') $ m p'
+
binding :: [Ident] -> TermTypeM a -> TermTypeM a
binding bnds = check . handleVars
where
@@ -1022,7 +1069,7 @@
checkForDuplicateNames orig_ps
checkTypeParams tps $ \tps' -> bindingTypeParams tps' $ do
let descend ps' (p : ps) =
- checkPattern p NoneInferred $ \p' ->
+ checkPattern [] p NoneInferred $ \p' ->
binding (S.toList $ patternIdents p') $ descend (p' : ps') ps
descend ps' [] = do
-- Perform an observation of every type parameter. This
@@ -1033,19 +1080,49 @@
descend [] orig_ps
+bindingSizes :: [SizeBinder Name] -> ([SizeBinder VName] -> TermTypeM a) -> TermTypeM a
+bindingSizes [] m = m [] -- Minor optimisation.
+bindingSizes sizes m = do
+ foldM_ lookForDuplicates mempty sizes
+ bindSpaced (map sizeWithSpace sizes) $ do
+ sizes' <- mapM check sizes
+ binding (map sizeWithType sizes') $ m sizes'
+ where
+ lookForDuplicates prev size
+ | Just prevloc <- M.lookup (sizeName size) prev =
+ typeError size mempty $
+ "Size name also bound at "
+ <> text (locStrRel (srclocOf size) prevloc)
+ <> "."
+ | otherwise =
+ pure $ M.insert (sizeName size) (srclocOf size) prev
+
+ sizeWithSpace size =
+ (Term, sizeName size)
+ sizeWithType size =
+ Ident (sizeName size) (Info (Scalar (Prim (Signed Int64)))) (srclocOf size)
+
+ check (SizeBinder v loc) =
+ SizeBinder <$> checkName Term v loc <*> pure loc
+
bindingPattern ::
+ [SizeBinder VName] ->
PatternBase NoInfo Name ->
InferredType ->
(Pattern -> TermTypeM a) ->
TermTypeM a
-bindingPattern p t m = do
+bindingPattern sizes p t m = do
checkForDuplicateNames [p]
- checkPattern p t $ \p' -> binding (S.toList $ patternIdents p') $ do
+ checkPattern sizes p t $ \p' -> binding (S.toList $ patternIdents p') $ do
-- Perform an observation of every declared dimension. This
-- prevents unused-name warnings for otherwise unused dimensions.
mapM_ observe $ patternDims p'
- m p'
+ let used_sizes = typeDimNames $ patternStructType p'
+ case filter ((`S.notMember` used_sizes) . sizeName) sizes of
+ [] -> m p'
+ size : _ ->
+ typeError size mempty $ "Size" <+> ppr size <+> "unused in pattern."
patternDims :: Pattern -> [Ident]
patternDims (PatternParens p _) = patternDims p
@@ -1053,7 +1130,7 @@
patternDims (PatternAscription p (TypeDecl _ (Info t)) _) =
patternDims p <> mapMaybe (dimIdent (srclocOf p)) (nestedDims t)
where
- dimIdent _ AnyDim = Nothing
+ dimIdent _ (AnyDim _) = Nothing
dimIdent _ (ConstDim _) = Nothing
dimIdent _ NamedDim {} = Nothing
patternDims _ = []
@@ -1090,7 +1167,7 @@
Just (loc, Nonrigid) ->
lift $ NamedDim . qualName <$> newDimVar loc Nonrigid "slice_dim"
Nothing ->
- pure AnyDim
+ pure $ AnyDim Nothing
where
-- The original size does not matter if the slice is fully specified.
orig_d'
@@ -1157,7 +1234,7 @@
SrcLoc ->
UncheckedTypeDecl ->
UncheckedExp ->
- (StructType -> StructType) ->
+ (StructType -> TermTypeM StructType) ->
TermTypeM (TypeDecl, Exp)
checkAscript loc decl e shapef = do
decl' <- checkTypeDecl decl
@@ -1165,9 +1242,8 @@
t <- expTypeFully e'
(decl_t_nonrigid, _) <-
- instantiateEmptyArrayDims loc "impl" Nonrigid $
- shapef $
- unInfo $ expandedType decl'
+ instantiateEmptyArrayDims loc "impl" Nonrigid
+ =<< shapef (unInfo $ expandedType decl')
onFailure (CheckingAscription (unInfo $ expandedType decl') (toStruct t)) $
unify (mkUsage loc "type ascription") decl_t_nonrigid (toStruct t)
@@ -1176,7 +1252,7 @@
-- explicitly, because uniqueness is ignored by unification.
t' <- normTypeFully t
decl_t' <- normTypeFully $ unInfo $ expandedType decl'
- unless (t' `subtypeOf` anySizes decl_t') $
+ unless (toStructural t' `subtypeOf` toStructural decl_t') $
typeError loc mempty $
"Type" <+> pquote (ppr t') <+> "is not a subtype of"
<+> pquote (ppr decl_t') <> "."
@@ -1196,7 +1272,7 @@
| Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped =
if p == PosImmediate || p == PosParam
then inst loc $ qualLeaf d
- else return AnyDim
+ else return $ AnyDim $ Just $ qualLeaf d
onDim _ _ d = return d
inst loc d = do
@@ -1211,16 +1287,38 @@
unAlias (AliasBound v) | v `M.member` unscoped = AliasFree v
unAlias a = a
+-- When a function result is not immediately bound to a name, we need
+-- to invent a name for it so we can track it during aliasing
+-- (uniqueness-error54.fut, uniqueness-error55.fut).
+addResultAliases :: NameReason -> PatternType -> TermTypeM PatternType
+addResultAliases r (Scalar (Record fs)) =
+ Scalar . Record <$> traverse (addResultAliases r) fs
+addResultAliases r (Scalar (Sum fs)) =
+ Scalar . Sum <$> traverse (traverse (addResultAliases r)) fs
+addResultAliases r (Scalar (TypeVar as u tn targs)) = do
+ v <- newID "internal_app_result"
+ modify $ \s -> s {stateNames = M.insert v r $ stateNames s}
+ pure $ Scalar $ TypeVar (S.insert (AliasFree v) as) u tn targs
+addResultAliases _ (Scalar t@Prim {}) = pure (Scalar t)
+addResultAliases _ (Scalar t@Arrow {}) = pure (Scalar t)
+addResultAliases r (Array als u t shape) = do
+ v <- newID "internal_app_result"
+ modify $ \s -> s {stateNames = M.insert v r $ stateNames s}
+ pure $ Array (S.insert (AliasFree v) als) u t shape
+
-- 'checkApplyExp' is like 'checkExp', but tries to find the "root
-- function", for better error messages.
checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)
-checkApplyExp (Apply e1 e2 _ _ loc) = do
+checkApplyExp (AppExp (Apply e1 e2 _ loc) _) = do
(e1', (fname, i)) <- checkApplyExp e1
arg <- checkArg e2
t <- expType e1'
(t1, rt, argext, exts) <- checkApply loc (fname, i) t arg
+ rt' <- addResultAliases (NameAppRes fname loc) rt
return
- ( Apply e1' (argExp arg) (Info (diet t1, argext)) (Info rt, Info exts) loc,
+ ( AppExp
+ (Apply e1' (argExp arg) (Info (diet t1, argext)) loc)
+ (Info $ AppRes rt' exts),
(fname, i + 1)
)
checkApplyExp e = do
@@ -1292,7 +1390,7 @@
et' <- normTypeFully et
t <- arrayOfM loc et' (ShapeDecl [ConstDim $ length all_es]) Unique
return $ ArrayLit (e' : es') (Info t) loc
-checkExp (Range start maybe_step end _ loc) = do
+checkExp (AppExp (Range start maybe_step end loc) _) = do
start' <- require "use in range expression" anySignedType =<< checkExp start
start_t <- toStruct <$> expTypeFully start'
maybe_step' <- case maybe_step of
@@ -1331,20 +1429,20 @@
return (NamedDim $ qualName d, Just d)
t <- arrayOfM loc start_t (ShapeDecl [dim]) Unique
- let ret = (Info (t `setAliases` mempty), Info $ maybeToList retext)
+ let res = AppRes (t `setAliases` mempty) (maybeToList retext)
- return $ Range start' maybe_step' end' ret loc
+ return $ AppExp (Range start' maybe_step' end' loc) (Info res)
checkExp (Ascript e decl loc) = do
- (decl', e') <- checkAscript loc decl e id
+ (decl', e') <- checkAscript loc decl e pure
return $ Ascript e' decl' loc
-checkExp (Coerce e decl _ loc) = do
+checkExp (AppExp (Coerce e decl loc) _) = do
-- We instantiate the declared types with all dimensions as nonrigid
-- fresh type variables, which we then use to unify with the type of
-- 'e'. This lets 'e' have whatever sizes it wants, but the overall
-- type must still match. Eventually we will throw away those sizes
-- (they will end up being unified with various sizes in 'e', which
-- is fine).
- (decl', e') <- checkAscript loc decl e anySizes
+ (decl', e') <- checkAscript loc decl e $ pure . anySizes
-- Now we instantiate the declared type again, but this time we keep
-- around the sizes as existentials. This is the result of the
@@ -1357,8 +1455,8 @@
t' <- matchDims (const pure) t $ fromStruct decl_t_rigid
- return $ Coerce e' decl' (Info t', Info ext) loc
-checkExp (BinOp (op, oploc) NoInfo (e1, _) (e2, _) NoInfo NoInfo loc) = do
+ return $ AppExp (Coerce e' decl' loc) (Info $ AppRes t' ext)
+checkExp (AppExp (BinOp (op, oploc) NoInfo (e1, _) (e2, _) loc) NoInfo) = do
(op', ftype) <- lookupVar oploc op
e1_arg <- checkArg e1
e2_arg <- checkArg e2
@@ -1369,32 +1467,33 @@
(p2_t, rt', p2_ext, retext) <- checkApply loc (Just op', 1) rt e2_arg
return $
- BinOp
- (op', oploc)
- (Info ftype)
- (argExp e1_arg, Info (toStruct p1_t, p1_ext))
- (argExp e2_arg, Info (toStruct p2_t, p2_ext))
- (Info rt')
- (Info retext)
- loc
+ AppExp
+ ( BinOp
+ (op', oploc)
+ (Info ftype)
+ (argExp e1_arg, Info (toStruct p1_t, p1_ext))
+ (argExp e2_arg, Info (toStruct p2_t, p2_ext))
+ loc
+ )
+ (Info (AppRes rt' retext))
checkExp (Project k e NoInfo loc) = do
e' <- checkExp e
t <- expType e'
kt <- mustHaveField (mkUsage loc $ "projection of field " ++ quote (pretty k)) k t
return $ Project k e' (Info kt) loc
-checkExp (If e1 e2 e3 _ loc) =
+checkExp (AppExp (If e1 e2 e3 loc) _) =
sequentially checkCond $ \e1' _ -> do
((e2', e3'), dflow) <- tapOccurences $ checkExp e2 `alternative` checkExp e3
(brancht, retext) <- unifyBranches loc e2' e3'
- let t' = addAliases brancht (`S.difference` S.map AliasBound (allConsumed dflow))
+ let t' = addAliases brancht $ S.filter $ (`S.notMember` allConsumed dflow) . aliasVar
zeroOrderType
(mkUsage loc "returning value of this type from 'if' expression")
"type returned from branch"
t'
- return $ If e1' e2' e3' (Info t', Info retext) loc
+ return $ AppExp (If e1' e2' e3' loc) (Info $ AppRes t' retext)
where
checkCond = do
e1' <- checkExp e1
@@ -1450,8 +1549,8 @@
checkExp (Negate arg loc) = do
arg' <- require "numeric negation" anyNumberType =<< checkExp arg
return $ Negate arg' loc
-checkExp e@Apply {} = fst <$> checkApplyExp e
-checkExp (LetPat pat e body _ loc) =
+checkExp e@(AppExp Apply {} _) = fst <$> checkApplyExp e
+checkExp (AppExp (LetPat sizes pat e body loc) _) =
sequentially (checkExp e) $ \e' e_occs -> do
-- Not technically an ascription, but we want the pattern to have
-- exactly the type of 'e'.
@@ -1462,14 +1561,19 @@
in zeroOrderType (mkUsage loc "consumption in right-hand side of 'let'-binding") msg t
_ -> return ()
- incLevel $
- bindingPattern pat (Ascribed t) $ \pat' -> do
+ incLevel . bindingSizes sizes $ \sizes' ->
+ bindingPattern sizes' pat (Ascribed t) $ \pat' -> do
body' <- checkExp body
(body_t, retext) <-
- unscopeType loc (patternMap pat') =<< expTypeFully body'
+ unscopeType loc (sizesMap sizes' <> patternMap pat') =<< expTypeFully body'
- return $ LetPat pat' e' body' (Info body_t, Info retext) loc
-checkExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body NoInfo loc) =
+ return $ AppExp (LetPat sizes' pat' e' body' loc) (Info $ AppRes body_t retext)
+ where
+ sizesMap = foldMap onSize
+ onSize size =
+ M.singleton (sizeName size) $
+ Ident (sizeName size) (Info (Scalar $ Prim $ Signed Int64)) (srclocOf size)
+checkExp (AppExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body loc) _) =
sequentially (checkBinding (name, maybe_retdecl, tparams, params, e, loc)) $
\(tparams', params', maybe_retdecl', rettype, _, e') closure -> do
closure' <- lexicalClosure params' closure
@@ -1493,18 +1597,20 @@
-- We fake an ident here, but it's OK as it can't be a size
-- anyway.
let fake_ident = Ident name' (Info $ fromStruct ftype) mempty
- (body_t, _) <-
+ (body_t, ext) <-
unscopeType loc (M.singleton name' fake_ident)
=<< expTypeFully body'
return $
- LetFun
- name'
- (tparams', params', maybe_retdecl', Info rettype, e')
- body'
- (Info body_t)
- loc
-checkExp (LetWith dest src idxes ve body NoInfo loc) =
+ AppExp
+ ( LetFun
+ name'
+ (tparams', params', maybe_retdecl', Info rettype, e')
+ body'
+ loc
+ )
+ (Info $ AppRes body_t ext)
+checkExp (AppExp (LetWith dest src idxes ve body loc) _) =
sequentially (checkIdent src) $ \src' _ -> do
(t, _) <- newArrayType (srclocOf src) "src" $ length idxes
unify (mkUsage loc "type of target array") t $ toStruct $ unInfo $ identType src'
@@ -1538,10 +1644,10 @@
bindingIdent dest (src_t `setAliases` S.empty) $ \dest' -> do
body' <- consuming src' $ checkExp body
- (body_t, _) <-
+ (body_t, ext) <-
unscopeType loc (M.singleton (identName dest') dest')
=<< expTypeFully body'
- return $ LetWith dest' src' idxes' ve' body' (Info body_t) loc
+ return $ AppExp (LetWith dest' src' idxes' ve' body' loc) (Info $ AppRes body_t ext)
checkExp (Update src idxes ve loc) = do
(t, _) <- newArrayType (srclocOf src) "src" $ length idxes
idxes' <- mapM checkDimIndex idxes
@@ -1570,22 +1676,30 @@
src' <- checkExp src
ve' <- checkExp ve
a <- expTypeFully src'
- let usage = mkUsage loc "record update"
- r <- foldM (flip $ mustHaveField usage) a fields
+ foldM_ (flip $ mustHaveField usage) a fields
ve_t <- expType ve'
- let r' = anySizes $ toStruct r
- ve_t' = anySizes $ toStruct ve_t
- onFailure (CheckingRecordUpdate fields r' ve_t') $
- unify usage r' ve_t'
- maybe_a' <- onRecordField (const ve_t) fields <$> expTypeFully src'
- case maybe_a' of
- Just a' -> return $ RecordUpdate src' fields ve' (Info a') loc
- Nothing ->
+ updated_t <- updateField fields ve_t =<< expTypeFully src'
+ return $ RecordUpdate src' fields ve' (Info updated_t) loc
+ where
+ usage = mkUsage loc "record update"
+ updateField [] ve_t src_t = do
+ (src_t', _) <- instantiateEmptyArrayDims loc "any" Nonrigid $ anySizes src_t
+ onFailure (CheckingRecordUpdate fields (toStruct src_t') (toStruct ve_t)) $
+ unify usage (toStruct src_t') (toStruct ve_t)
+ -- Important that we return ve_t so that we get the right aliases.
+ pure ve_t
+ updateField (f : fs) ve_t (Scalar (Record m))
+ | Just f_t <- M.lookup f m = do
+ f_t' <- updateField fs ve_t f_t
+ pure $ Scalar $ Record $ M.insert f f_t' m
+ updateField _ _ _ =
typeError loc mempty $
"Full type of"
indent 2 (ppr src)
textwrap " is not known at this point. Add a size annotation to the original record to disambiguate."
-checkExp (Index e idxes _ loc) = do
+
+--
+checkExp (AppExp (Index e idxes loc) _) = do
(t, _) <- newArrayType loc "e" $ length idxes
e' <- unifies "being indexed at" t =<< checkExp e
idxes' <- mapM checkDimIndex idxes
@@ -1598,44 +1712,41 @@
-- will certainly not be aliased.
t'' <- noAliasesIfOverloaded t'
- return $ Index e' idxes' (Info t'', Info retext) loc
+ return $ AppExp (Index e' idxes' loc) (Info $ AppRes t'' retext)
checkExp (Assert e1 e2 NoInfo loc) = do
e1' <- require "being asserted" [Bool] =<< checkExp e1
e2' <- checkExp e2
return $ Assert e1' e2' (Info (pretty e1)) loc
checkExp (Lambda params body rettype_te NoInfo loc) =
- removeSeminullOccurences $
- noUnique $
- incLevel $
- bindingParams [] params $ \_ params' -> do
- rettype_checked <- traverse checkTypeExp rettype_te
- let declared_rettype =
- case rettype_checked of
- Just (_, st, _) -> Just st
- Nothing -> Nothing
- (body', closure) <-
- tapOccurences $ checkFunBody params' body declared_rettype loc
- body_t <- expTypeFully body'
+ removeSeminullOccurences . noUnique . incLevel . bindingParams [] params $ \_ params' -> do
+ rettype_checked <- traverse checkTypeExp rettype_te
+ let declared_rettype =
+ case rettype_checked of
+ Just (_, st, _) -> Just st
+ Nothing -> Nothing
+ (body', closure) <-
+ tapOccurences $ checkFunBody params' body declared_rettype loc
+ body_t <- expTypeFully body'
- params'' <- mapM updateTypes params'
+ params'' <- mapM updateTypes params'
- (rettype', rettype_st) <-
- case rettype_checked of
- Just (te, st, _) ->
- return (Just te, st)
- Nothing -> do
- ret <-
- inferReturnSizes params'' $
- toStruct $
- inferReturnUniqueness params'' body_t
- return (Nothing, ret)
+ (rettype', rettype_st) <-
+ case rettype_checked of
+ Just (te, st, _) ->
+ return (Just te, st)
+ Nothing -> do
+ ret <-
+ inferReturnSizes params'' $
+ toStruct $
+ inferReturnUniqueness params'' body_t
+ return (Nothing, ret)
- checkGlobalAliases params' body_t loc
- verifyFunctionParams Nothing params'
+ checkGlobalAliases params' body_t loc
+ verifyFunctionParams Nothing params'
- closure' <- lexicalClosure params'' closure
+ closure' <- lexicalClosure params'' closure
- return $ Lambda params'' body' rettype' (Info (closure', rettype_st)) loc
+ return $ Lambda params'' body' rettype' (Info (closure', rettype_st)) loc
where
-- Inferring the sizes of the return type of a lambda is a lot
-- like let-generalisation. We wish to remove any rigid sizes
@@ -1657,7 +1768,7 @@
let onDim (NamedDim name)
| not (qualLeaf name `S.member` hidden_sizes) = NamedDim name
- | otherwise = AnyDim
+ | otherwise = AnyDim $ Just $ qualLeaf name
onDim d = d
return $ first onDim ret
@@ -1713,7 +1824,7 @@
idxes' <- mapM checkDimIndex idxes
(t', _) <- sliceShape Nothing idxes' t
return $ IndexSection idxes' (Info $ fromStruct $ Scalar $ Arrow mempty Unnamed t t') loc
-checkExp (DoLoop _ mergepat mergeexp form loopbody NoInfo loc) =
+checkExp (AppExp (DoLoop _ mergepat mergeexp form loopbody loc) _) =
sequentially (checkExp mergeexp) $ \mergeexp' _ -> do
zeroOrderType
(mkUsage (srclocOf mergeexp) "use as loop variable")
@@ -1752,10 +1863,11 @@
pat_t <- normTypeFully $ patternType mergepat'
-- We are ignoring the dimensions here, because any mismatches
-- should be turned into fresh size variables.
+
onFailure (CheckingLoopBody (toStruct (anySizes pat_t)) (toStruct loopbody_t)) $
expect
(mkUsage (srclocOf loopbody) "matching loop body to loop pattern")
- (toStruct (anySizes pat_t))
+ (toStruct (anyTheseSizes new_dims pat_t))
(toStruct loopbody_t)
pat_t' <- normTypeFully pat_t
loopbody_t' <- normTypeFully loopbody_t
@@ -1822,18 +1934,17 @@
uboundexp' <- require "being the bound in a 'for' loop" anySignedType =<< checkExp uboundexp
bound_t <- expTypeFully uboundexp'
bindingIdent i bound_t $ \i' ->
- noUnique $
- bindingPattern mergepat (Ascribed merge_t) $
- \mergepat' -> onlySelfAliasing $
- tapOccurences $ do
- loopbody' <- noSizeEscape $ checkExp loopbody
- (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'
- return
- ( sparams,
- mergepat'',
- For i' uboundexp',
- loopbody'
- )
+ noUnique . bindingPattern [] mergepat (Ascribed merge_t) $
+ \mergepat' -> onlySelfAliasing $
+ tapOccurences $ do
+ loopbody' <- noSizeEscape $ checkExp loopbody
+ (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'
+ return
+ ( sparams,
+ mergepat'',
+ For i' uboundexp',
+ loopbody'
+ )
ForIn xpat e -> do
(arr_t, _) <- newArrayType (srclocOf e) "e" 1
e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e
@@ -1841,41 +1952,37 @@
case t of
_
| Just t' <- peelArray 1 t ->
- bindingPattern xpat (Ascribed t') $ \xpat' ->
- noUnique $
- bindingPattern mergepat (Ascribed merge_t) $
- \mergepat' -> onlySelfAliasing $
- tapOccurences $ do
- loopbody' <- noSizeEscape $ checkExp loopbody
- (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'
- return
- ( sparams,
- mergepat'',
- ForIn xpat' e',
- loopbody'
- )
- | otherwise ->
- typeError (srclocOf e) mempty $
- "Iteratee of a for-in loop must be an array, but expression has type"
- <+> ppr t
- While cond ->
- noUnique $
- bindingPattern mergepat (Ascribed merge_t) $ \mergepat' ->
- onlySelfAliasing $
- tapOccurences $
- sequentially
- ( checkExp cond
- >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool)
- )
- $ \cond' _ -> do
+ bindingPattern [] xpat (Ascribed t') $ \xpat' ->
+ noUnique . bindingPattern [] mergepat (Ascribed merge_t) $
+ \mergepat' -> onlySelfAliasing . tapOccurences $ do
loopbody' <- noSizeEscape $ checkExp loopbody
(sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'
return
( sparams,
mergepat'',
- While cond',
+ ForIn xpat' e',
loopbody'
)
+ | otherwise ->
+ typeError (srclocOf e) mempty $
+ "Iteratee of a for-in loop must be an array, but expression has type"
+ <+> ppr t
+ While cond ->
+ noUnique . bindingPattern [] mergepat (Ascribed merge_t) $ \mergepat' ->
+ onlySelfAliasing . tapOccurences $
+ sequentially
+ ( checkExp cond
+ >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool)
+ )
+ $ \cond' _ -> do
+ loopbody' <- noSizeEscape $ checkExp loopbody
+ (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'
+ return
+ ( sparams,
+ mergepat'',
+ While cond',
+ loopbody'
+ )
mergepat'' <- do
loopbody_t <- expTypeFully loopbody'
@@ -1896,7 +2003,7 @@
consumeMerge mergepat'' =<< expTypeFully mergeexp'
-- dim handling (3)
- let sparams_anydim = M.fromList $ zip sparams $ repeat $ SizeSubst AnyDim
+ let sparams_anydim = M.fromList $ zip sparams $ repeat $ SizeSubst $ AnyDim Nothing
loopt_anydims =
applySubst (`M.lookup` sparams_anydim) $
patternType mergepat''
@@ -1928,8 +2035,17 @@
-- look like we have ambiguous sizes lying around.
modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams
- return $ DoLoop sparams mergepat'' mergeexp' form' loopbody' (Info (loopt', retext)) loc
+ return $
+ AppExp
+ (DoLoop sparams mergepat'' mergeexp' form' loopbody' loc)
+ (Info $ AppRes loopt' retext)
where
+ anyTheseSizes to_hide = first onDim
+ where
+ onDim (NamedDim (QualName _ v))
+ | v `elem` to_hide = AnyDim Nothing
+ onDim d = d
+
convergePattern pat body_cons body_t body_loc = do
let consumed_merge = patternNames pat `S.intersection` body_cons
@@ -2041,7 +2157,7 @@
-- A sum value aliases *anything* that went into its construction.
let als = foldMap aliases ets
return $ Constr name es' (Info $ fromStruct t `addAliases` (<> als)) loc
-checkExp (Match e cs _ loc) =
+checkExp (AppExp (Match e cs loc) _) =
sequentially (checkExp e) $ \e' _ -> do
mt <- expTypeFully e'
(cs', t, retext) <- checkCases mt cs
@@ -2049,7 +2165,7 @@
(mkUsage loc "being returned 'match'")
"type returned from pattern match"
t
- return $ Match e' cs' (Info t, Info retext) loc
+ return $ AppExp (Match e' cs' loc) (Info $ AppRes t retext)
checkExp (Attr info e loc) =
Attr info <$> checkExp e <*> pure loc
@@ -2077,7 +2193,7 @@
CaseBase NoInfo Name ->
TermTypeM (CaseBase Info VName, PatternType, [VName])
checkCase mt (CasePat p e loc) =
- bindingPattern p (Ascribed mt) $ \p' -> do
+ bindingPattern [] p (Ascribed mt) $ \p' -> do
e' <- checkExp e
(t, retext) <- unscopeType loc (patternMap p') =<< expTypeFully e'
return (CasePat p' e' loc, t, retext)
@@ -2112,7 +2228,7 @@
checkUnmatched :: Exp -> TermTypeM ()
checkUnmatched e = void $ checkUnmatched' e >> astMap tv e
where
- checkUnmatched' (Match _ cs _ loc) =
+ checkUnmatched' (AppExp (Match _ cs loc) _) =
let ps = fmap (\(CasePat p _ _) -> p) cs
in case unmatched $ NE.toList ps of
[] -> return ()
@@ -2213,7 +2329,7 @@
[] -> return ()
ext_paramdims -> do
let onDim (NamedDim qn)
- | qualLeaf qn `elem` ext_paramdims = AnyDim
+ | qualLeaf qn `elem` ext_paramdims = AnyDim $ Just $ qualLeaf qn
onDim d = d
typeError loc mempty $
"Anonymous size would appear in function parameter of return type:"
@@ -2249,11 +2365,13 @@
return (tp1', tp2'', argext, ext)
where
sizeSubst (Scalar (Prim (Signed Int64))) e = dimFromArg fname e
- sizeSubst _ _ = return (AnyDim, Nothing)
+ sizeSubst _ _ = return (AnyDim Nothing, Nothing)
checkApply loc fname tfun@(Scalar TypeVar {}) arg = do
tv <- newTypeVar loc "b"
+ -- Change the uniqueness of the argument type because we never want
+ -- to infer that a function is consuming.
unify (mkUsage loc "use as function") (toStruct tfun) $
- Scalar $ Arrow mempty Unnamed (toStruct (argType arg)) tv
+ Scalar $ Arrow mempty Unnamed (toStruct (argType arg) `setUniqueness` Nonunique) tv
tfun' <- normPatternType tfun
checkApply loc fname tfun' arg
checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do
@@ -2427,43 +2545,28 @@
onExp known (Lambda params _ _ _ _)
| bad : _ <- mapMaybe (checkParamCausality known) params =
bad
- onExp known e@(Coerce what _ (_, Info ext) _) = do
- modify (S.fromList ext <>)
- void $ onExp known what
- return e
- onExp known e@(LetPat _ bindee_e body_e (_, Info ext) _) = do
- sequencePoint known bindee_e body_e ext
+ onExp known e@(AppExp (LetPat _ _ bindee_e body_e _) (Info res)) = do
+ sequencePoint known bindee_e body_e $ appResExt res
return e
- onExp known e@(Apply f arg (Info (_, p)) (_, Info ext) _) = do
- sequencePoint known arg f $ maybeToList p ++ ext
+ onExp known e@(AppExp (Apply f arg (Info (_, p)) _) (Info res)) = do
+ sequencePoint known arg f $ maybeToList p ++ appResExt res
return e
onExp
known
- e@(BinOp (f, floc) ft (x, Info (_, xp)) (y, Info (_, yp)) _ (Info ext) _) = do
+ e@(AppExp (BinOp (f, floc) ft (x, Info (_, xp)) (y, Info (_, yp)) _) (Info res)) = do
args_known <-
lift $
execStateT (sequencePoint known x y $ catMaybes [xp, yp]) mempty
void $ onExp (args_known <> known) (Var f ft floc)
- modify ((args_known <> S.fromList ext) <>)
+ modify ((args_known <> S.fromList (appResExt res)) <>)
return e
+ onExp known e@(AppExp e' (Info res)) = do
+ recurse known e'
+ modify (<> S.fromList (appResExt res))
+ pure e
onExp known e = do
recurse known e
-
- case e of
- DoLoop _ _ _ _ _ (Info (_, ext)) _ ->
- modify (<> S.fromList ext)
- If _ _ _ (_, Info ext) _ ->
- modify (<> S.fromList ext)
- Index _ _ (_, Info ext) _ ->
- modify (<> S.fromList ext)
- Match _ _ (_, Info ext) _ ->
- modify (<> S.fromList ext)
- Range _ _ _ (_, Info ext) _ ->
- modify (<> S.fromList ext)
- _ ->
- return ()
-
- return e
+ pure e
recurse known = void . astMap mapper
where
@@ -2636,8 +2739,8 @@
"Type is ambiguous (must be a sum type with constructors:"
<+> ppr (Sum cs) <> ")."
"Add a type annotation to disambiguate the type."
- fixOverloaded (_, Size Nothing usage) =
- typeError usage mempty "Size is ambiguous."
+ fixOverloaded (v, Size Nothing usage) =
+ typeError usage mempty $ "Size" <+> pquote (pprName v) <+> "is ambiguous.\n"
fixOverloaded _ = return ()
hiddenParamNames :: [Pattern] -> Names
@@ -2681,55 +2784,53 @@
Exp
)
checkBinding (fname, maybe_retdecl, tparams, params, body, loc) =
- noUnique $
- incLevel $
- bindingParams tparams params $ \tparams' params' -> do
- when (null params && any isSizeParam tparams) $
- typeError
- loc
- mempty
- "Size parameters are only allowed on bindings that also have value parameters."
+ noUnique . incLevel . bindingParams tparams params $ \tparams' params' -> do
+ when (null params && any isSizeParam tparams) $
+ typeError
+ loc
+ mempty
+ "Size parameters are only allowed on bindings that also have value parameters."
- maybe_retdecl' <- forM maybe_retdecl $ \retdecl -> do
- (retdecl', ret_nodims, _) <- checkTypeExp retdecl
- (ret, _) <- instantiateEmptyArrayDims loc "funret" Nonrigid ret_nodims
- return (retdecl', ret)
+ maybe_retdecl' <- forM maybe_retdecl $ \retdecl -> do
+ (retdecl', ret_nodims, _) <- checkTypeExp retdecl
+ (ret, _) <- instantiateEmptyArrayDims loc "funret" Nonrigid ret_nodims
+ return (retdecl', ret)
- body' <-
- checkFunBody
- params'
- body
- (snd <$> maybe_retdecl')
- (maybe loc srclocOf maybe_retdecl)
+ body' <-
+ checkFunBody
+ params'
+ body
+ (snd <$> maybe_retdecl')
+ (maybe loc srclocOf maybe_retdecl)
- params'' <- mapM updateTypes params'
- body_t <- expTypeFully body'
+ params'' <- mapM updateTypes params'
+ body_t <- expTypeFully body'
- (maybe_retdecl'', rettype) <- case maybe_retdecl' of
- Just (retdecl', ret) -> do
- let rettype_structural = toStructural ret
- checkReturnAlias rettype_structural params'' body_t
+ (maybe_retdecl'', rettype) <- case maybe_retdecl' of
+ Just (retdecl', ret) -> do
+ let rettype_structural = toStructural ret
+ checkReturnAlias rettype_structural params'' body_t
- when (null params) $ nothingMustBeUnique loc rettype_structural
+ when (null params) $ nothingMustBeUnique loc rettype_structural
- ret' <- normTypeFully ret
+ ret' <- normTypeFully ret
- return (Just retdecl', ret')
- Nothing
- | null params ->
- return (Nothing, toStruct $ body_t `setUniqueness` Nonunique)
- | otherwise -> do
- body_t' <- inferredReturnType loc params'' body_t
- return (Nothing, body_t')
+ return (Just retdecl', ret')
+ Nothing
+ | null params ->
+ return (Nothing, toStruct $ body_t `setUniqueness` Nonunique)
+ | otherwise -> do
+ body_t' <- inferredReturnType loc params'' body_t
+ return (Nothing, body_t')
- verifyFunctionParams (Just fname) params''
+ verifyFunctionParams (Just fname) params''
- (tparams'', params''', rettype'', retext) <-
- letGeneralise fname loc tparams' params'' rettype
+ (tparams'', params''', rettype'', retext) <-
+ letGeneralise fname loc tparams' params'' rettype
- checkGlobalAliases params'' body_t loc
+ checkGlobalAliases params'' body_t loc
- return (tparams'', params''', maybe_retdecl'', rettype'', retext, body')
+ return (tparams'', params''', maybe_retdecl'', rettype'', retext, body')
where
checkReturnAlias rettp params' =
foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp
@@ -2894,8 +2995,8 @@
f _ PosReturn (NamedDim v) = tell (mempty, mempty, S.singleton (qualLeaf v))
f _ _ _ = return ()
--- | Find at all type variables in the given type that are covered by
--- the constraints, and produce type parameters that close over them.
+-- | Find all type variables in the given type that are covered by the
+-- constraints, and produce type parameters that close over them.
--
-- The passed-in list of type parameters is always prepended to the
-- produced list of type parameters.
@@ -2914,7 +3015,7 @@
let retToAnyDim v = do
guard $ v `S.member` ret_sizes
UnknowableSize {} <- snd <$> M.lookup v substs
- Just $ SizeSubst AnyDim
+ Just $ SizeSubst $ AnyDim $ Just v
return
( tparams ++ more_tparams,
applySubst retToAnyDim ret,
@@ -3043,7 +3144,7 @@
-- explicitly, because uniqueness is ignored by unification.
rettype' <- normTypeFully rettype
body_t'' <- normTypeFully rettype -- Substs may have changed.
- unless (body_t'' `subtypeOf` anySizes rettype') $
+ unless (toStructural body_t'' `subtypeOf` toStructural rettype') $
typeError (srclocOf body) mempty $
"Body type" indent 2 (ppr body_t'')
"is not a subtype of annotated type"
@@ -3063,6 +3164,13 @@
let als = AliasBound nm `S.insert` aliases t
in occur [observation als loc]
+describeVar :: SrcLoc -> VName -> TermTypeM Doc
+describeVar loc v =
+ gets $
+ maybe ("variable" <+> pquote (pprName v)) (nameReason loc)
+ . M.lookup v
+ . stateNames
+
checkIfConsumable :: SrcLoc -> Aliasing -> TermTypeM ()
checkIfConsumable loc als = do
vtable <- asks $ scopeVtable . termScope
@@ -3071,12 +3179,14 @@
| arrayRank t > 0 -> unique t
| Scalar TypeVar {} <- t -> unique t
| otherwise -> True
- _ -> False
- case filter (not . consumable) $ map aliasVar $ S.toList als of
- v : _ ->
+ Just (BoundV Global _ _) -> False
+ _ -> True
+ -- The sort ensures that AliasBound vars are shown before AliasFree.
+ case map aliasVar $ sort $ filter (not . consumable . aliasVar) $ S.toList als of
+ v : _ -> do
+ v' <- describeVar loc v
typeError loc mempty $
- "Would consume variable" <+> pquote (pprName v)
- <> ", which is not allowed."
+ "Would consume" <+> v' <> ", which is not allowed."
[] -> return ()
-- | Proclaim that we have written to the given variable.
@@ -3124,14 +3234,23 @@
let usage = occurs1 `altOccurences` occurs2
return ((x, y), const usage)
--- | Make all bindings nonunique.
+-- | Enter a context where nothing outside can be consumed (i.e. the
+-- body of a function definition).
noUnique :: TermTypeM a -> TermTypeM a
-noUnique = localScope (\scope -> scope {scopeVtable = M.map set $ scopeVtable scope})
+noUnique m = pass $ do
+ (x, occs) <- listen $ localScope f m
+ checkOccurences occs
+ let (observations, _) = split occs
+ pure (x, const observations)
where
+ f scope = scope {scopeVtable = M.map set $ scopeVtable scope}
+
set (BoundV l tparams t) = BoundV l tparams $ t `setUniqueness` Nonunique
set (OverloadedF ts pts rt) = OverloadedF ts pts rt
set EqualityF = EqualityF
set (WasConsumed loc) = WasConsumed loc
+
+ split = unzip . map (\occ -> (occ {consumed = mempty}, occ {observed = mempty}))
onlySelfAliasing :: TermTypeM a -> TermTypeM a
onlySelfAliasing = localScope (\scope -> scope {scopeVtable = M.mapWithKey set $ scopeVtable scope})
diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs
--- a/src/Language/Futhark/TypeChecker/Types.hs
+++ b/src/Language/Futhark/TypeChecker/Types.hs
@@ -12,15 +12,16 @@
checkForDuplicateNames,
checkTypeParams,
typeParamToArg,
- TypeSub (..),
- TypeSubs,
- substituteTypes,
Subst (..),
+ substFromAbbr,
+ TypeSubs,
+ unionSubs,
Substitutable (..),
substTypesAny,
)
where
+import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
@@ -29,7 +30,7 @@
import qualified Data.Map.Strict as M
import Data.Maybe
import Futhark.Util (nubOrd)
-import Futhark.Util.Pretty
+import Futhark.Util.Pretty hiding ((<|>))
import Language.Futhark
import Language.Futhark.Traversals
import Language.Futhark.TypeChecker.Monad
@@ -37,17 +38,18 @@
-- | @unifyTypes uf t1 t2@ attempts to unify @t1@ and @t2@. If
-- unification cannot happen, 'Nothing' is returned, otherwise a type
-- that combines the aliasing of @t1@ and @t2@ is returned.
--- Uniqueness is unified with @uf@.
+-- Uniqueness is unified with @uf@. Assumes sizes already match, and
+-- always picks the size of the leftmost type.
unifyTypesU ::
(Monoid als, ArrayDim dim) =>
(Uniqueness -> Uniqueness -> Maybe Uniqueness) ->
TypeBase dim als ->
TypeBase dim als ->
Maybe (TypeBase dim als)
-unifyTypesU uf (Array als1 u1 et1 shape1) (Array als2 u2 et2 shape2) =
+unifyTypesU uf (Array als1 u1 et1 shape1) (Array als2 u2 et2 _shape2) =
Array (als1 <> als2) <$> uf u1 u2
<*> unifyScalarTypes uf et1 et2
- <*> unifyShapes shape1 shape2
+ <*> pure shape1
unifyTypesU uf (Scalar t1) (Scalar t2) = Scalar <$> unifyScalarTypes uf t1 t2
unifyTypesU _ _ _ = Nothing
@@ -60,12 +62,19 @@
unifyScalarTypes _ (Prim t1) (Prim t2)
| t1 == t2 = Just $ Prim t1
| otherwise = Nothing
-unifyScalarTypes uf (TypeVar als1 u1 t1 targs1) (TypeVar als2 u2 t2 targs2)
- | t1 == t2 = do
+unifyScalarTypes uf (TypeVar als1 u1 tv1 targs1) (TypeVar als2 u2 tv2 targs2)
+ | tv1 == tv2 = do
u3 <- uf u1 u2
- targs3 <- zipWithM (unifyTypeArgs uf) targs1 targs2
- Just $ TypeVar (als1 <> als2) u3 t1 targs3
+ targs3 <- zipWithM unifyTypeArgs targs1 targs2
+ Just $ TypeVar (als1 <> als2) u3 tv1 targs3
| otherwise = Nothing
+ where
+ unifyTypeArgs (TypeArgDim d1 loc) (TypeArgDim _d2 _) =
+ pure $ TypeArgDim d1 loc
+ unifyTypeArgs (TypeArgType t1 loc) (TypeArgType t2 _) =
+ TypeArgType <$> unifyTypesU uf t1 t2 <*> pure loc
+ unifyTypeArgs _ _ =
+ Nothing
unifyScalarTypes uf (Record ts1) (Record ts2)
| length ts1 == length ts2,
sort (M.keys ts1) == sort (M.keys ts2) =
@@ -84,26 +93,10 @@
(M.intersectionWith (,) cs1 cs2)
unifyScalarTypes _ _ _ = Nothing
-unifyTypeArgs ::
- (ArrayDim dim) =>
- (Uniqueness -> Uniqueness -> Maybe Uniqueness) ->
- TypeArg dim ->
- TypeArg dim ->
- Maybe (TypeArg dim)
-unifyTypeArgs _ (TypeArgDim d1 loc) (TypeArgDim d2 _) =
- TypeArgDim <$> unifyDims d1 d2 <*> pure loc
-unifyTypeArgs uf (TypeArgType t1 loc) (TypeArgType t2 _) =
- TypeArgType <$> unifyTypesU uf t1 t2 <*> pure loc
-unifyTypeArgs _ _ _ =
- Nothing
-
--- | @x \`subtypeOf\` y@ is true if @x@ is a subtype of @y@ (or equal to
--- @y@), meaning @x@ is valid whenever @y@ is.
-subtypeOf ::
- ArrayDim dim =>
- TypeBase dim as1 ->
- TypeBase dim as2 ->
- Bool
+-- | @x \`subtypeOf\` y@ is true if @x@ is a subtype of @y@ (or equal
+-- to @y@), meaning @x@ is valid whenever @y@ is. Ignores sizes.
+-- Mostly used for checking uniqueness.
+subtypeOf :: TypeBase () () -> TypeBase () () -> Bool
subtypeOf t1 t2 = isJust $ unifyTypesU unifyUniqueness (toStruct t1) (toStruct t2)
where
unifyUniqueness u2 u1 = if u2 `subuniqueOf` u1 then Just u1 else Nothing
@@ -171,7 +164,7 @@
<+/> "(might contain function)."
where
checkDimExp DimExpAny =
- return (DimExpAny, AnyDim)
+ return (DimExpAny, AnyDim Nothing)
checkDimExp (DimExpConst k dloc) =
return (DimExpConst k dloc, ConstDim k)
checkDimExp (DimExpNamed v dloc) = do
@@ -221,7 +214,7 @@
(targs', substs) <- unzip <$> zipWithM checkArgApply ps targs
return
( foldl (\x y -> TEApply x y tloc) (TEVar tname' tname_loc) targs',
- substituteTypes (mconcat substs) t,
+ applySubst (`M.lookup` mconcat substs) t,
l
)
where
@@ -240,23 +233,24 @@
v' <- checkNamedDim loc v
return
( TypeArgExpDim (DimExpNamed v' dloc) loc,
- M.singleton pv $ DimSub $ NamedDim v'
+ M.singleton pv $ SizeSubst $ NamedDim v'
)
checkArgApply (TypeParamDim pv _) (TypeArgExpDim (DimExpConst x dloc) loc) =
return
( TypeArgExpDim (DimExpConst x dloc) loc,
- M.singleton pv $ DimSub $ ConstDim x
+ M.singleton pv $ SizeSubst $ ConstDim x
)
- checkArgApply (TypeParamDim pv _) (TypeArgExpDim DimExpAny loc) =
+ checkArgApply (TypeParamDim pv _) (TypeArgExpDim DimExpAny loc) = do
+ d <- newID "d"
return
( TypeArgExpDim DimExpAny loc,
- M.singleton pv $ DimSub AnyDim
+ M.singleton pv $ SizeSubst $ AnyDim $ Just d
)
- checkArgApply (TypeParamType l pv _) (TypeArgExpType te) = do
+ checkArgApply (TypeParamType _ pv _) (TypeArgExpType te) = do
(te', st, _) <- checkTypeExp te
return
( TypeArgExpType te',
- M.singleton pv $ TypeSub $ TypeAbbr l [] st
+ M.singleton pv $ Subst [] st
)
checkArgApply p a =
typeError tloc mempty $
@@ -383,88 +377,32 @@
typeParamToArg (TypeParamType _ v ploc) =
TypeArgType (Scalar $ TypeVar () Nonunique (typeName v) []) ploc
--- | A substitution for when using 'substituteTypes'.
-data TypeSub
- = TypeSub TypeBinding
- | DimSub (DimDecl VName)
- deriving (Show)
-
--- | A collection of type substitutions.
-type TypeSubs = M.Map VName TypeSub
-
--- | Apply type substitutions to the given type.
-substituteTypes :: Monoid als => TypeSubs -> TypeBase (DimDecl VName) als -> TypeBase (DimDecl VName) als
-substituteTypes substs ot = case ot of
- Array als u at shape ->
- arrayOf
- (substituteTypes substs (Scalar at) `setAliases` mempty)
- (substituteInShape shape)
- u
- `addAliases` (<> als)
- Scalar (Prim t) -> Scalar $ Prim t
- Scalar (TypeVar als u v targs)
- | Just (TypeSub (TypeAbbr _ ps t)) <-
- M.lookup (qualLeaf (qualNameFromTypeName v)) substs ->
- applyType ps (t `setAliases` mempty) (map substituteInTypeArg targs)
- `setUniqueness` u `addAliases` (<> als)
- | otherwise -> Scalar $ TypeVar als u v $ map substituteInTypeArg targs
- Scalar (Record ts) ->
- Scalar $ Record $ fmap (substituteTypes substs) ts
- Scalar (Arrow als v t1 t2) ->
- Scalar $ Arrow als v (substituteTypes substs t1) (substituteTypes substs t2)
- Scalar (Sum cs) ->
- Scalar $ Sum $ (fmap . fmap) (substituteTypes substs) cs
- where
- substituteInTypeArg (TypeArgDim d loc) =
- TypeArgDim (substituteInDim d) loc
- substituteInTypeArg (TypeArgType t loc) =
- TypeArgType (substituteTypes substs t) loc
-
- substituteInShape (ShapeDecl ds) =
- ShapeDecl $ map substituteInDim ds
-
- substituteInDim (NamedDim v)
- | Just (DimSub d) <- M.lookup (qualLeaf v) substs = d
- substituteInDim d = d
-
-applyType ::
- Monoid als =>
- [TypeParam] ->
- TypeBase (DimDecl VName) als ->
- [StructTypeArg] ->
- TypeBase (DimDecl VName) als
-applyType ps t args =
- substituteTypes substs t
- where
- substs = M.fromList $ zipWith mkSubst ps args
- -- We are assuming everything has already been type-checked for correctness.
- mkSubst (TypeParamDim pv _) (TypeArgDim (NamedDim v) _) =
- (pv, DimSub $ NamedDim v)
- mkSubst (TypeParamDim pv _) (TypeArgDim (ConstDim x) _) =
- (pv, DimSub $ ConstDim x)
- mkSubst (TypeParamDim pv _) (TypeArgDim AnyDim _) =
- (pv, DimSub AnyDim)
- mkSubst (TypeParamType l pv _) (TypeArgType at _) =
- (pv, TypeSub $ TypeAbbr l [] at)
- mkSubst p a =
- error $ "applyType mkSubst: cannot substitute " ++ pretty a ++ " for " ++ pretty p
-
-- | A type substituion may be a substitution or a yet-unknown
-- substitution (but which is certainly an overloaded primitive
-- type!). The latter is used to remove aliases from types that are
-- yet-unknown but that we know cannot carry aliases (see issue #682).
-data Subst t = Subst t | PrimSubst | SizeSubst (DimDecl VName)
+data Subst t = Subst [TypeParam] t | PrimSubst | SizeSubst (DimDecl VName)
deriving (Show)
+substFromAbbr :: TypeBinding -> Subst StructType
+substFromAbbr (TypeAbbr _ ps t) = Subst ps t
+
+-- | Substitutions to apply in a type.
+type TypeSubs = VName -> Maybe (Subst StructType)
+
+-- | Additively combine two non-intersecting substitutions.
+unionSubs :: TypeSubs -> TypeSubs -> TypeSubs
+unionSubs f g v = g v <|> f v
+
instance Functor Subst where
- fmap f (Subst t) = Subst $ f t
+ fmap f (Subst ps t) = Subst ps $ f t
fmap _ PrimSubst = PrimSubst
fmap _ (SizeSubst v) = SizeSubst v
-- | Class of types which allow for substitution of types with no
-- annotations for type variable names.
class Substitutable a where
- applySubst :: (VName -> Maybe (Subst StructType)) -> a -> a
+ applySubst :: TypeSubs -> a -> a
instance Substitutable (TypeBase (DimDecl VName) ()) where
applySubst = substTypesAny
@@ -492,6 +430,23 @@
mapOnPatternType = return . applySubst f
}
+applyType ::
+ Monoid als =>
+ [TypeParam] ->
+ TypeBase (DimDecl VName) als ->
+ [StructTypeArg] ->
+ TypeBase (DimDecl VName) als
+applyType ps t args = substTypesAny (`M.lookup` substs) t
+ where
+ substs = M.fromList $ zipWith mkSubst ps args
+ -- We are assuming everything has already been type-checked for correctness.
+ mkSubst (TypeParamDim pv _) (TypeArgDim d _) =
+ (pv, SizeSubst d)
+ mkSubst (TypeParamType _ pv _) (TypeArgType at _) =
+ (pv, Subst [] $ second mempty at)
+ mkSubst p a =
+ error $ "applyType mkSubst: cannot substitute " ++ pretty a ++ " for " ++ pretty p
+
-- | Perform substitutions, from type names to types, on a type. Works
-- regardless of what shape and uniqueness information is attached to the type.
substTypesAny ::
@@ -507,13 +462,14 @@
u
`setAliases` als
Scalar (Prim t) -> Scalar $ Prim t
- -- We only substitute for a type variable with no arguments, since
- -- type parameters cannot have higher kind.
Scalar (TypeVar als u v targs) ->
- case lookupSubst $ qualLeaf (qualNameFromTypeName v) of
- Just (Subst t) -> substTypesAny lookupSubst $ t `setUniqueness` u `addAliases` (<> als)
- Just PrimSubst -> Scalar $ TypeVar mempty u v $ map subsTypeArg targs
- _ -> Scalar $ TypeVar als u v $ map subsTypeArg targs
+ let targs' = map subsTypeArg targs
+ in case lookupSubst $ qualLeaf (qualNameFromTypeName v) of
+ Just (Subst ps t) ->
+ applyType ps (t `setAliases` mempty) targs'
+ `setUniqueness` u `addAliases` (<> als)
+ Just PrimSubst -> Scalar $ TypeVar mempty u v targs'
+ _ -> Scalar $ TypeVar als u v targs'
Scalar (Record ts) -> Scalar $ Record $ fmap (substTypesAny lookupSubst) ts
Scalar (Arrow als v t1 t2) ->
Scalar $ Arrow als v (substTypesAny lookupSubst t1) (substTypesAny lookupSubst t2)
diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs
--- a/src/Language/Futhark/TypeChecker/Unify.hs
+++ b/src/Language/Futhark/TypeChecker/Unify.hs
@@ -27,7 +27,6 @@
mustHaveField,
mustBeOneOf,
equalityType,
- normType,
normPatternType,
normTypeFully,
instantiateEmptyArrayDims,
@@ -44,7 +43,9 @@
import Control.Monad.State
import Control.Monad.Writer hiding (Sum)
import Data.Bifoldable (biany)
-import Data.List (intersect)
+import Data.Bifunctor
+import Data.Char (isAscii)
+import Data.List (foldl', intersect)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
@@ -164,7 +165,7 @@
lookupSubst :: VName -> Constraints -> Maybe (Subst StructType)
lookupSubst v constraints = case snd <$> M.lookup v constraints of
- Just (Constraint t _) -> Just $ Subst t
+ Just (Constraint t _) -> Just $ Subst [] $ applySubst (`lookupSubst` constraints) t
Just Overloaded {} -> Just PrimSubst
Just (Size (Just d) _) ->
Just $ SizeSubst $ applySubst (`lookupSubst` constraints) d
@@ -234,7 +235,7 @@
<> text (locStrRel ctx boundloc)
<> "."
prettySource _ _ RigidUnify =
- "is an artificial size invented during unification of functions with anonymous sizes"
+ "is an artificial size invented during unification of functions with anonymous sizes."
prettySource ctx loc (RigidCond t1 t2) =
"is unknown due to conditional expression at "
<> text (locStrRel ctx loc)
@@ -337,15 +338,27 @@
Rigidity ->
TypeBase (DimDecl VName) als ->
m (TypeBase (DimDecl VName) als, [VName])
-instantiateEmptyArrayDims tloc desc r = runWriterT . traverseDims onDim
+instantiateEmptyArrayDims tloc desc r =
+ fmap (second snd) . (`runStateT` mempty) . traverseDims onDim
where
- onDim _ PosImmediate AnyDim = inst
- onDim _ PosParam AnyDim = inst
- onDim _ _ d = return d
- inst = do
- dim <- lift $ newDimVar tloc r desc
- tell [dim]
- return $ NamedDim $ qualName dim
+ onDim _ PosImmediate (AnyDim v) = inst v
+ onDim _ PosParam (AnyDim v) = inst v
+ onDim _ _ d = pure d
+ inst v = do
+ (m, ds) <- get
+ d <- case v of
+ Just v' ->
+ case M.lookup v' m of
+ Just old_d -> pure old_d
+ Nothing -> do
+ d <- lift $ newDimVar tloc r $ takeWhile isAscii $ baseString v'
+ put (M.insert v' d m, d : ds)
+ pure d
+ Nothing -> do
+ d <- lift $ newDimVar tloc r desc
+ put (m, d : ds)
+ pure d
+ pure $ NamedDim $ qualName d
-- | Is the given type variable the name of an abstract type or type
-- parameter, which we cannot substitute?
@@ -395,7 +408,7 @@
unbound = applySubst f
where
f d
- | d `elem` bound = Just $ SizeSubst AnyDim
+ | d `elem` bound = Just $ SizeSubst $ AnyDim $ Just d
| otherwise = Nothing
link ord' v lvl =
@@ -466,22 +479,25 @@
( Scalar (Arrow _ p1 a1 b1),
Scalar (Arrow _ p2 a2 b2)
) -> do
- let (r1, r2) = swap ord (Rigid RigidUnify) Nonrigid
- (a1', a1_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r1 a1
- (a2', a2_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r2 a2
- let bound' = bound <> mapMaybe pname [p1, p2] <> a1_dims <> a2_dims
+ let (r1, r2) = swap ord Nonrigid (Rigid RigidUnify)
+ (b1'', b1_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r1 b1'
+ (b2'', b2_dims) <- instantiateEmptyArrayDims (srclocOf usage) "anonymous" r2 b2'
+ let bound' = bound <> mapMaybe pname [p1, p2] <> b1_dims <> b2_dims
subunify
(not ord)
bound
(breadCrumb (Matching "When matching parameter types.") bcs)
- a1'
- a2'
+ a1
+ a2
subunify
ord
bound'
(breadCrumb (Matching "When matching return types.") bcs)
- b1'
- b2'
+ b1''
+ b2''
+ -- Delete the size variables we introduced to represent
+ -- the existential sizes.
+ modifyConstraints $ \m -> foldl' (flip M.delete) m (b1_dims <> b2_dims)
where
(b1', b2') =
-- Replace one parameter name with the other in the
@@ -551,17 +567,19 @@
expect :: MonadUnify m => Usage -> StructType -> StructType -> m ()
expect usage = unifyWith onDims usage noBreadCrumbs
where
- onDims _ _ _ AnyDim _ = return ()
+ onDims _ _ _ (AnyDim _) _ = return ()
onDims _ _ _ d1 d2
| d1 == d2 = return ()
+ -- We identify existentially bound names by them being nonrigid
+ -- and yet bound. It's OK to unify with those.
onDims bcs bound nonrigid (NamedDim (QualName _ d1)) d2
| Just lvl1 <- nonrigid d1,
- d2 /= AnyDim,
- not $ boundParam bound d2 =
+ not $ isAnyDim d2,
+ not (boundParam bound d2) || (d1 `elem` bound) =
linkVarToDim usage bcs d1 lvl1 d2
onDims bcs bound nonrigid d1 (NamedDim (QualName _ d2))
| Just lvl2 <- nonrigid d2,
- not $ boundParam bound d1 =
+ not (boundParam bound d1) || (d2 `elem` bound) =
linkVarToDim usage bcs d2 lvl2 d1
onDims bcs _ _ d1 d2 = do
notes <- (<>) <$> dimNotes usage d1 <*> dimNotes usage d2
@@ -574,10 +592,13 @@
boundParam bound (NamedDim (QualName _ d)) = d `elem` bound
boundParam _ _ = False
+ isAnyDim (AnyDim _) = True
+ isAnyDim _ = False
+
hasEmptyDims :: StructType -> Bool
hasEmptyDims = biany empty (const False)
where
- empty AnyDim = True
+ empty (AnyDim _) = True
empty _ = False
occursCheck ::
@@ -645,34 +666,30 @@
scopeCheck usage bcs vn lvl tp
constraints <- getConstraints
- let tp' = removeUniqueness tp
- modifyConstraints $ M.insert vn (lvl, Constraint tp' usage)
+ modifyConstraints $ M.insert vn (lvl, Constraint tp usage)
case snd <$> M.lookup vn constraints of
- Just (NoConstraint l unlift_usage)
- | l < Lifted -> do
- let bcs' =
- breadCrumb
- ( Matching $
- "When verifying that" <+> pquote (pprName vn)
- <+> textwrap "is not instantiated with a function type, due to"
- <+> ppr unlift_usage
- )
- bcs
-
- arrayElemTypeWith usage bcs' tp'
+ Just (NoConstraint Unlifted unlift_usage) -> do
+ let bcs' =
+ breadCrumb
+ ( Matching $
+ "When verifying that" <+> pquote (pprName vn)
+ <+> textwrap "is not instantiated with a function type, due to"
+ <+> ppr unlift_usage
+ )
+ bcs
- when (l == Unlifted) $ do
- when (hasEmptyDims tp') $
- unifyError usage mempty bcs $
- "Type variable" <+> pprName vn
- <+> "cannot be instantiated with type containing anonymous sizes:"
- indent 2 (ppr tp)
- textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically. This can also be due to the return size being a value parameter. Add type annotation to clarify."
+ arrayElemTypeWith usage bcs' tp
+ when (hasEmptyDims tp) $
+ unifyError usage mempty bcs $
+ "Type variable" <+> pprName vn
+ <+> "cannot be instantiated with type containing anonymous sizes:"
+ indent 2 (ppr tp)
+ textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically. This can also be due to the return size being a value parameter. Add type annotation to clarify."
Just (Equality _) ->
- equalityType usage tp'
+ equalityType usage tp
Just (Overloaded ts old_usage)
| tp `notElem` map (Scalar . Prim) ts ->
- case tp' of
+ case tp of
Scalar (TypeVar _ _ (TypeName [] v) [])
| not $ isRigid v constraints ->
linkVarToTypes usage v ts
@@ -777,15 +794,6 @@
modifyConstraints $ M.insert vn (lvl, Size (Just dim) usage)
-removeUniqueness :: TypeBase dim as -> TypeBase dim as
-removeUniqueness (Scalar (Record ets)) =
- Scalar $ Record $ fmap removeUniqueness ets
-removeUniqueness (Scalar (Arrow als p t1 t2)) =
- Scalar $ Arrow als p (removeUniqueness t1) (removeUniqueness t2)
-removeUniqueness (Scalar (Sum cs)) =
- Scalar $ Sum $ (fmap . fmap) removeUniqueness cs
-removeUniqueness t = t `setUniqueness` Nonunique
-
-- | Assert that this type must be one of the given primitive types.
mustBeOneOf :: MonadUnify m => [PrimType] -> Usage -> StructType -> m ()
mustBeOneOf [req_t] usage t = unify usage (Scalar (Prim req_t)) t
@@ -924,7 +932,7 @@
constraints <- getConstraints
case M.lookup vn constraints of
Just (lvl, NoConstraint _ _) ->
- modifyConstraints $ M.insert vn (lvl, NoConstraint SizeLifted usage)
+ modifyConstraints $ M.insert vn (lvl, NoConstraint Unlifted usage)
Just (_, ParamType l ploc)
| l `elem` [Lifted, SizeLifted] ->
unifyError usage mempty bcs $
@@ -1065,7 +1073,7 @@
| d1 == d2 = return d1
| otherwise = do
tell [(d1, d2)]
- return AnyDim
+ return $ AnyDim undefined
newDimOnMismatch ::
(Monoid as, MonadUnify m) =>
diff --git a/unittests/Futhark/IR/PrimitiveTests.hs b/unittests/Futhark/IR/PrimitiveTests.hs
--- a/unittests/Futhark/IR/PrimitiveTests.hs
+++ b/unittests/Futhark/IR/PrimitiveTests.hs
@@ -57,7 +57,7 @@
[ IntValue <$> arbitrary,
FloatValue <$> arbitrary,
BoolValue <$> arbitrary,
- pure Checked
+ pure UnitValue
]
arbitraryPrimValOfType :: PrimType -> Gen PrimValue
@@ -68,4 +68,4 @@
arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary
arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary
arbitraryPrimValOfType Bool = BoolValue <$> arbitrary
-arbitraryPrimValOfType Cert = return Checked
+arbitraryPrimValOfType Unit = return UnitValue