futhark 0.19.4 → 0.19.5
raw patch · 107 files changed
+4358/−2708 lines, 107 filesdep ~versions
Dependency ranges changed: versions
Files
- docs/c-api.rst +9/−5
- docs/installation.rst +27/−0
- docs/language-reference.rst +37/−4
- docs/man/futhark-literate.rst +14/−8
- docs/server-protocol.rst +2/−2
- docs/usage.rst +38/−12
- futhark.cabal +2/−2
- prelude/math.fut +10/−0
- rts/c/cuda.h +2/−1
- rts/python/scalar.py +6/−0
- rts/python/values.py +5/−6
- src/Futhark/Analysis/Metrics.hs +3/−0
- src/Futhark/Analysis/PrimExp/Convert.hs +20/−0
- src/Futhark/Analysis/SymbolTable.hs +6/−0
- src/Futhark/Analysis/UsageTable.hs +11/−12
- src/Futhark/CLI/Autotune.hs +17/−9
- src/Futhark/CLI/Bench.hs +18/−17
- src/Futhark/CLI/Literate.hs +9/−1
- src/Futhark/CLI/Test.hs +1/−6
- src/Futhark/CodeGen/Backends/CCUDA.hs +2/−1
- src/Futhark/CodeGen/Backends/COpenCL.hs +1/−5
- src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +13/−0
- src/Futhark/CodeGen/Backends/GenericC.hs +13/−11
- src/Futhark/CodeGen/Backends/GenericC/CLI.hs +1/−1
- src/Futhark/CodeGen/Backends/GenericPython.hs +8/−9
- src/Futhark/CodeGen/Backends/SimpleRep.hs +15/−3
- src/Futhark/CodeGen/ImpCode.hs +1/−7
- src/Futhark/CodeGen/ImpGen.hs +124/−5
- src/Futhark/CodeGen/ImpGen/Kernels.hs +30/−5
- src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +49/−8
- src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +1/−1
- src/Futhark/CodeGen/ImpGen/Multicore.hs +70/−2
- src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +26/−13
- src/Futhark/Construct.hs +46/−10
- src/Futhark/Doc/Generator.hs +1/−1
- src/Futhark/IR/Mem.hs +70/−11
- src/Futhark/IR/Mem/IxFun.hs +8/−29
- src/Futhark/IR/Mem/Simplify.hs +2/−3
- src/Futhark/IR/Parse.hs +49/−4
- src/Futhark/IR/Pretty.hs +25/−8
- src/Futhark/IR/Primitive.hs +47/−13
- src/Futhark/IR/Primitive/Parse.hs +3/−2
- src/Futhark/IR/Prop.hs +1/−0
- src/Futhark/IR/Prop/Aliases.hs +28/−3
- src/Futhark/IR/Prop/Names.hs +30/−4
- src/Futhark/IR/Prop/TypeOf.hs +11/−1
- src/Futhark/IR/Prop/Types.hs +50/−21
- src/Futhark/IR/SOACS/SOAC.hs +3/−2
- src/Futhark/IR/SOACS/Simplify.hs +11/−0
- src/Futhark/IR/SegOp.hs +9/−3
- src/Futhark/IR/Syntax.hs +11/−0
- src/Futhark/IR/Syntax/Core.hs +11/−2
- src/Futhark/IR/Traversals.hs +46/−2
- src/Futhark/Internalise.hs +319/−273
- src/Futhark/Internalise/AccurateSizes.hs +28/−27
- src/Futhark/Internalise/Bindings.hs +20/−12
- src/Futhark/Internalise/Defunctionalise.hs +52/−49
- src/Futhark/Internalise/FreeVars.hs +12/−12
- src/Futhark/Internalise/Lambdas.hs +20/−27
- src/Futhark/Internalise/LiftLambdas.hs +7/−19
- src/Futhark/Internalise/Monomorphise.hs +180/−168
- src/Futhark/Internalise/TypesValues.hs +39/−17
- src/Futhark/Optimise/Fusion.hs +3/−4
- src/Futhark/Optimise/Fusion/LoopKernel.hs +1/−1
- src/Futhark/Optimise/InliningDeadFun.hs +1/−1
- src/Futhark/Optimise/Simplify.hs +4/−1
- src/Futhark/Optimise/Simplify/Engine.hs +28/−11
- src/Futhark/Optimise/Simplify/Rules.hs +118/−15
- src/Futhark/Optimise/Simplify/Rules/Loop.hs +5/−6
- src/Futhark/Optimise/Simplify/Rules/Simple.hs +1/−1
- src/Futhark/Optimise/Sink.hs +5/−6
- src/Futhark/Pass/ExpandAllocations.hs +149/−111
- src/Futhark/Pass/ExplicitAllocations.hs +147/−75
- src/Futhark/Pass/ExplicitAllocations/SegOp.hs +15/−14
- src/Futhark/Pass/ExtractKernels.hs +119/−64
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +10/−5
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +30/−29
- src/Futhark/Pass/ExtractKernels/Interchange.hs +105/−1
- src/Futhark/Pass/ExtractKernels/Intragroup.hs +24/−12
- src/Futhark/Pass/ExtractMulticore.hs +12/−2
- src/Futhark/Pass/KernelBabysitting.hs +4/−2
- src/Futhark/Pkg/Types.hs +4/−4
- src/Futhark/Script.hs +1/−4
- src/Futhark/Test/Values.hs +4/−4
- src/Futhark/Test/Values/Parser.hs +1/−1
- src/Futhark/Transform/FirstOrderTransform.hs +179/−125
- src/Futhark/Transform/Rename.hs +10/−8
- src/Futhark/Transform/Substitute.hs +12/−2
- src/Futhark/TypeCheck.hs +185/−89
- src/Futhark/Util.hs +6/−0
- src/Futhark/Util/Pretty.hs +5/−0
- src/Language/Futhark.hs +4/−0
- src/Language/Futhark/Interpreter.hs +207/−157
- src/Language/Futhark/Parser/Lexer.x +4/−4
- src/Language/Futhark/Parser/Parser.y +39/−29
- src/Language/Futhark/Pretty.hs +77/−76
- src/Language/Futhark/Prop.hs +293/−235
- src/Language/Futhark/Query.hs +13/−9
- src/Language/Futhark/Syntax.hs +134/−111
- src/Language/Futhark/Traversals.hs +103/−110
- src/Language/Futhark/TypeChecker.hs +3/−3
- src/Language/Futhark/TypeChecker/Match.hs +1/−1
- src/Language/Futhark/TypeChecker/Modules.hs +31/−48
- src/Language/Futhark/TypeChecker/Terms.hs +391/−272
- src/Language/Futhark/TypeChecker/Types.hs +70/−114
- src/Language/Futhark/TypeChecker/Unify.hs +68/−60
- unittests/Futhark/IR/PrimitiveTests.hs +2/−2
docs/c-api.rst view
@@ -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:
docs/installation.rst view
@@ -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+<https://nixos.org/>`_, 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
docs/language-reference.rst view
@@ -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:
docs/man/futhark-literate.rst view
@@ -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
docs/server-protocol.rst view
@@ -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 --------
docs/usage.rst view
@@ -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 ^^^^^^^^^^^^
futhark.cabal view
@@ -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
prelude/math.fut view
@@ -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
rts/c/cuda.h view
@@ -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);
rts/python/scalar.py view
@@ -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))
rts/python/values.py view
@@ -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)
src/Futhark/Analysis/Metrics.hs view
@@ -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 ()
src/Futhark/Analysis/PrimExp/Convert.hs view
@@ -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 ::
src/Futhark/Analysis/SymbolTable.hs view
@@ -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
src/Futhark/Analysis/UsageTable.hs view
@@ -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
src/Futhark/CLI/Autotune.hs view
@@ -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)
src/Futhark/CLI/Bench.hs view
@@ -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
src/Futhark/CLI/Literate.hs view
@@ -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
src/Futhark/CLI/Test.hs view
@@ -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 =
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -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;|]
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -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;|]
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -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]
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -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 <-
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -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 =
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -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
src/Futhark/CodeGen/Backends/SimpleRep.hs view
@@ -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"
src/Futhark/CodeGen/ImpCode.hs view
@@ -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
src/Futhark/CodeGen/ImpGen.hs view
@@ -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.
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -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)
src/Futhark/CodeGen/ImpGen/Kernels/Base.hs view
@@ -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 $
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -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
src/Futhark/CodeGen/ImpGen/Multicore.hs view
@@ -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 ->
src/Futhark/CodeGen/ImpGen/Multicore/Base.hs view
@@ -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
src/Futhark/Construct.hs view
@@ -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.
src/Futhark/Doc/Generator.hs view
@@ -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)
src/Futhark/IR/Mem.hs view
@@ -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
src/Futhark/IR/Mem/IxFun.hs view
@@ -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,
src/Futhark/IR/Mem/Simplify.hs view
@@ -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
src/Futhark/IR/Parse.hs view
@@ -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 =
src/Futhark/IR/Pretty.hs view
@@ -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
src/Futhark/IR/Primitive.hs view
@@ -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
src/Futhark/IR/Primitive/Parse.hs view
@@ -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
src/Futhark/IR/Prop.hs view
@@ -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
src/Futhark/IR/Prop/Aliases.hs view
@@ -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
src/Futhark/IR/Prop/Names.hs view
@@ -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
src/Futhark/IR/Prop/TypeOf.hs view
@@ -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.
src/Futhark/IR/Prop/Types.hs view
@@ -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
src/Futhark/IR/SOACS/SOAC.hs view
@@ -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
src/Futhark/IR/SOACS/Simplify.hs view
@@ -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
src/Futhark/IR/SegOp.hs view
@@ -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
src/Futhark/IR/Syntax.hs view
@@ -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)
src/Futhark/IR/Syntax/Core.hs view
@@ -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
src/Futhark/IR/Traversals.hs view
@@ -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
src/Futhark/Internalise.hs view
@@ -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
src/Futhark/Internalise/AccurateSizes.hs view
@@ -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 ->
src/Futhark/Internalise/Bindings.hs view
@@ -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) =
src/Futhark/Internalise/Defunctionalise.hs view
@@ -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
src/Futhark/Internalise/FreeVars.hs view
@@ -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)
src/Futhark/Internalise/Lambdas.hs view
@@ -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 ->
src/Futhark/Internalise/LiftLambdas.hs view
@@ -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'
src/Futhark/Internalise/Monomorphise.hs view
@@ -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}
src/Futhark/Internalise/TypesValues.hs view
@@ -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] ->
src/Futhark/Optimise/Fusion.hs view
@@ -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
src/Futhark/Optimise/Fusion/LoopKernel.hs view
@@ -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,
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -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 $
src/Futhark/Optimise/Simplify.hs view
@@ -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')
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -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]
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -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
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -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'
src/Futhark/Optimise/Simplify/Rules/Simple.hs view
@@ -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
src/Futhark/Optimise/Sink.hs view
@@ -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 =
src/Futhark/Pass/ExpandAllocations.hs view
@@ -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
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -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
src/Futhark/Pass/ExplicitAllocations/SegOp.hs view
@@ -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)
src/Futhark/Pass/ExtractKernels.hs view
@@ -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 ->
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -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
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -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') ->
src/Futhark/Pass/ExtractKernels/Interchange.hs view
@@ -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')
src/Futhark/Pass/ExtractKernels/Intragroup.hs view
@@ -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,
src/Futhark/Pass/ExtractMulticore.hs view
@@ -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
src/Futhark/Pass/KernelBabysitting.hs view
@@ -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
src/Futhark/Pkg/Types.hs view
@@ -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).
src/Futhark/Script.hs view
@@ -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) =
src/Futhark/Test/Values.hs view
@@ -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
src/Futhark/Test/Values/Parser.hs view
@@ -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",
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -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)
src/Futhark/Transform/Rename.hs view
@@ -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) =
src/Futhark/Transform/Substitute.hs view
@@ -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
src/Futhark/TypeCheck.hs view
@@ -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 "<anonymous>" 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 ()
src/Futhark/Util.hs view
@@ -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
src/Futhark/Util/Pretty.hs view
@@ -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
src/Language/Futhark.hs view
@@ -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
src/Language/Futhark/Interpreter.hs view
@@ -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 "#<fun>"+ pprPrec _ ValueAcc {} = text "#<acc>" 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
src/Language/Futhark/Parser/Lexer.x view
@@ -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
src/Language/Futhark/Parser/Parser.y view
@@ -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
src/Language/Futhark/Pretty.hs view
@@ -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
src/Language/Futhark/Prop.hs view
@@ -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.
src/Language/Futhark/Query.hs view
@@ -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
src/Language/Futhark/Syntax.hs view
@@ -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
src/Language/Futhark/Traversals.hs view
@@ -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
src/Language/Futhark/TypeChecker.hs view
@@ -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
src/Language/Futhark/TypeChecker/Match.hs view
@@ -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
src/Language/Futhark/TypeChecker/Modules.hs view
@@ -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)
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -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})
src/Language/Futhark/TypeChecker/Types.hs view
@@ -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)
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -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) =>
unittests/Futhark/IR/PrimitiveTests.hs view
@@ -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