futhark 0.21.6 → 0.21.7

raw patch · 130 files changed

+2128/−1521 lines, 130 filesdep −vector-binary-instancesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: vector-binary-instances

API changes (from Hackage documentation)

Files

• docs/hacking.rst +46/−3
• docs/language-reference.rst +71/−112
• docs/man/futhark.rst +5/−0
• futhark.cabal +7/−5
• prelude/math.fut +6/−6
• prelude/prelude.fut +1/−1
• rts/c/scalar.h +16/−0
• rts/c/scalar_f16.h +8/−0
• rts/python/scalar.py +16/−3
• src/Futhark.hs +145/−0
• src/Futhark/Analysis/CallGraph.hs +3/−3
• src/Futhark/Analysis/LastUse.hs +1/−1
• src/Futhark/Analysis/PrimExp.hs +5/−0
• src/Futhark/Analysis/PrimExp/Parse.hs +6/−8
• src/Futhark/Analysis/Rephrase.hs +3/−3
• src/Futhark/Analysis/SymbolTable.hs +1/−1
• src/Futhark/Analysis/UsageTable.hs +1/−0
• src/Futhark/Builder.hs +2/−2
• src/Futhark/Builder/Class.hs +4/−4
• src/Futhark/CLI/Defs.hs +1/−1
• src/Futhark/CLI/Misc.hs +9/−1
• src/Futhark/CLI/REPL.hs +68/−79
• src/Futhark/CLI/Run.hs +1/−1
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +1/−1
• src/Futhark/CodeGen/Backends/GenericWASM.hs +4/−0
• src/Futhark/CodeGen/Backends/MulticoreC.hs +1/−1
• src/Futhark/CodeGen/Backends/MulticoreWASM.hs +12/−0
• src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +2/−0
• src/Futhark/CodeGen/Backends/SequentialWASM.hs +12/−1
• src/Futhark/CodeGen/Backends/SimpleRep.hs +7/−0
• src/Futhark/CodeGen/ImpCode.hs +49/−7
• src/Futhark/CodeGen/ImpCode/GPU.hs +21/−27
• src/Futhark/CodeGen/ImpCode/Multicore.hs +23/−24
• src/Futhark/CodeGen/ImpCode/OpenCL.hs +3/−9
• src/Futhark/CodeGen/ImpCode/Sequential.hs +2/−12
• src/Futhark/CodeGen/ImpGen.hs +77/−67
• src/Futhark/CodeGen/ImpGen/GPU.hs +5/−5
• src/Futhark/CodeGen/ImpGen/GPU/Base.hs +8/−8
• src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +6/−6
• src/Futhark/CodeGen/ImpGen/GPU/SegMap.hs +1/−1
• src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs +6/−6
• src/Futhark/CodeGen/ImpGen/GPU/SegScan.hs +1/−1
• src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs +1/−1
• src/Futhark/CodeGen/ImpGen/GPU/SegScan/TwoPass.hs +7/−7
• src/Futhark/CodeGen/ImpGen/GPU/ToOpenCL.hs +22/−17
• src/Futhark/CodeGen/ImpGen/Multicore.hs +4/−4
• src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +8/−7
• src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +10/−10
• src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +5/−5
• src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +12/−11
• src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +11/−11
• src/Futhark/Compiler/Config.hs +1/−0
• src/Futhark/Compiler/Program.hs +283/−134
• src/Futhark/Construct.hs +2/−2
• src/Futhark/IR/Aliases.hs +7/−7
• src/Futhark/IR/Mem.hs +2/−2
• src/Futhark/IR/Mem/IxFun.hs +23/−5
• src/Futhark/IR/Parse.hs +8/−3
• src/Futhark/IR/Pretty.hs +5/−4
• src/Futhark/IR/Primitive.hs +35/−1
• src/Futhark/IR/Primitive/Parse.hs +25/−12
• src/Futhark/IR/Prop.hs +2/−2
• src/Futhark/IR/Prop/Aliases.hs +2/−2
• src/Futhark/IR/Prop/Names.hs +2/−2
• src/Futhark/IR/Prop/Patterns.hs +8/−8
• src/Futhark/IR/Prop/Scope.hs +6/−2
• src/Futhark/IR/Prop/TypeOf.hs +2/−1
• src/Futhark/IR/Prop/Types.hs +2/−2
• src/Futhark/IR/SOACS.hs +2/−50
• src/Futhark/IR/SOACS/Simplify.hs +23/−29
• src/Futhark/IR/SegOp.hs +3/−3
• src/Futhark/IR/Syntax.hs +56/−59
• src/Futhark/IR/Syntax/Core.hs +5/−5
• src/Futhark/IR/Traversals.hs +8/−9
• src/Futhark/IR/TypeCheck.hs +11/−9
• src/Futhark/Internalise.hs +35/−0
• src/Futhark/Internalise/AccurateSizes.hs +2/−2
• src/Futhark/Internalise/Bindings.hs +3/−3
• src/Futhark/Internalise/Exps.hs +13/−12
• src/Futhark/Internalise/FreeVars.hs +1/−1
• src/Futhark/Internalise/Lambdas.hs +7/−7
• src/Futhark/Internalise/Monad.hs +1/−1
• src/Futhark/Optimise/CSE.hs +4/−4
• src/Futhark/Optimise/DoubleBuffer.hs +2/−2
• src/Futhark/Optimise/Fusion.hs +19/−19
• src/Futhark/Optimise/Fusion/LoopKernel.hs +4/−4
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +3/−3
• src/Futhark/Optimise/InliningDeadFun.hs +3/−3
• src/Futhark/Optimise/Simplify/Engine.hs +9/−5
• src/Futhark/Optimise/Simplify/Rep.hs +5/−5
• src/Futhark/Optimise/Simplify/Rule.hs +7/−7
• src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +9/−8
• src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs +2/−2
• src/Futhark/Optimise/Simplify/Rules/Index.hs +2/−1
• src/Futhark/Optimise/Simplify/Rules/Simple.hs +10/−1
• src/Futhark/Optimise/TileLoops.hs +3/−3
• src/Futhark/Optimise/Unstream.hs +1/−1
• src/Futhark/Pass/ExpandAllocations.hs +3/−3
• src/Futhark/Pass/ExplicitAllocations.hs +3/−3
• src/Futhark/Pass/ExtractKernels.hs +55/−56
• src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +8/−8
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +11/−10
• src/Futhark/Pass/ExtractKernels/Distribution.hs +9/−9
• src/Futhark/Pass/ExtractKernels/ISRWIM.hs +10/−10
• src/Futhark/Pass/ExtractKernels/Interchange.hs +10/−6
• src/Futhark/Pass/ExtractKernels/Intragroup.hs +21/−21
• src/Futhark/Pass/ExtractKernels/StreamKernel.hs +3/−3
• src/Futhark/Pass/ExtractMulticore.hs +1/−1
• src/Futhark/Pass/KernelBabysitting.hs +2/−1
• src/Futhark/Passes.hs +14/−0
• src/Futhark/Script.hs +1/−1
• src/Futhark/Test/Spec.hs +1/−0
• src/Futhark/Tools.hs +8/−8
• src/Futhark/Transform/FirstOrderTransform.hs +4/−6
• src/Futhark/Transform/Rename.hs +4/−4
• src/Futhark/Transform/Substitute.hs +2/−2
• src/Futhark/Util.hs +28/−7
• src/Language/Futhark/Interpreter.hs +16/−3
• src/Language/Futhark/Parser.hs +1/−5
• src/Language/Futhark/Parser/Monad.hs +292/−0
• src/Language/Futhark/Parser/Parser.y +38/−273
• src/Language/Futhark/Semantic.hs +1/−1
• src/Language/Futhark/Syntax.hs +4/−4
• src/Language/Futhark/TypeChecker.hs +8/−0
• src/Language/Futhark/TypeChecker/Monad.hs +1/−2
• src/Language/Futhark/TypeChecker/Terms/Monad.hs +2/−2
• src/Language/Futhark/TypeChecker/Types.hs +6/−0
• src/Language/Futhark/TypeChecker/Unify.hs +4/−1
• src/futhark.hs +0/−141
• src/main.hs +142/−0

@@ -36,10 +36,16 @@     Guide.    * You may wish to set the environment variable-    ``FUTHARK_COMPILER_DEBUGGING=1``.  Currently this only has the-    effect of making the frontend print internal names, but it may-    control more things in the future.+    ``FUTHARK_COMPILER_DEBUGGING=1``.  This has the following+    effects: +    * The frontend prints internal names.  (This may affect code+      generation in some cases, so turn it off when actually+      generating code.)++    * Tools that talk to server-mode executables will print the+      messages sent back and worth on the standard error stream.+ .. _`stack`: https://docs.haskellstack.org/en/stable/README/ .. _`Profiling`: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html @@ -93,6 +99,43 @@ allows you to tailor your own compilation pipeline using command line options.  It is also useful for seeing what the AST looks like after specific passes.++Running compiler pipelines+--------------------------++You can run the various compiler passes in whatever order you wish.+There are also various shorthands for running entire standard+pipelines:++* ``--gpu``: pipeline used for GPU backends (stopping just+  before adding memory information).++* ``--gpu-mem``: pipeline used for GPU backends, with memory+  information.  This will show the IR that is passed to ImpGen.++* ``--seq``: pipeline used for sequential backends (stopping just+  before adding memory information).++* ``--seq-mem``: pipeline used for sequential backends, with memory+  information.  This will show the IR that is passed to ImpGen.++* ``--mc``: pipeline used for multicore backends (stopping just+  before adding memory information).++* ``--mc-mem``: pipeline used for multicore backends, with memory+  information.  This will show the IR that is passed to ImpGen.++By default, ``futhark dev`` will print the resulting IR.  You can+switch to a different *action* with one of the following options:++* ``--compile-imperative``: generate sequential ImpCode and print it.++* ``--compile-imperative-kernels``: generate GPU ImpCode and print it.++* ``--compile-imperative-multicore``: generate multicore ImpCode and print it.++You must use the appropriate pipeline as well (e.g. ``--gpu-mem`` for+``--compile-imperative-kernels``).  When you are about to have a bad day ------------------------------------

@@ -110,8 +110,8 @@ Futhark type system is entirely structural, and type abbreviations are 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`_).+whose definition has been hidden via the module system (see+:ref:`module-system`).  .. productionlist::    tuple_type: "(" ")" | "(" `type` ("," `type`)+ ")"@@ -216,9 +216,9 @@ Declarations ------------ -A Futhark file or module consists of a sequence of declarations.  Each-declaration is processed in order, and a declaration can only refer to-names bound by preceding declarations.+A Futhark module consists of a sequence of declarations.  Files are+also modules.  Each declaration is processed in order, and a+declaration can only refer to names bound by preceding declarations.  .. productionlist::    dec:   `val_bind` | `type_bind` | `mod_bind` | `mod_type_bind`@@ -227,20 +227,26 @@       : | "local" `dec`       : | "#[" attr "]" dec -The ``open`` declaration brings names defined in another module into-scope (see also `Module System`_).  For the meaning of ``import``, see-`Referring to Other Files`_.  If a declaration is prefixed with-``local``, whatever names it defines will *not* be visible outside the-current module.  In particular ``local open`` is used to bring names-from another module into scope, without making those names available-to users of the module being defined.  In most cases, using module-type ascription is a better idea.+Any names defined by a declaration inside a module are by default+visible to users of that module (see :ref:`module-system`). +* ``open mod_exp`` brings names bound in ``mod_exp`` into the current scope.+  These names will also be visible to users of the module.++* ``local dec`` has the meaning of ``dec``, but any names bound by+  ``dec`` will not be visible outside the module.++* ``import "foo"`` is a shorthand for ``local open import "foo"``,+  where the ``import`` is interpreted as a module expression (see+  :ref:`module-system`).++* ``#[attr] dec`` adds an attribute to a declaration (see :ref:`attributes`).+ Declaring Functions and Values ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  .. productionlist::-   val_bind:   ("def" | "entry" | "let") (`id` | "(" `binop` ")") `type_param`* `pat`+ [":" `type`] "=" `exp`+   val_bind:   ("def" | "entry" | "let") (`id` | "(" `binop` ")") `type_param`* `pat`* [":" `type`] "=" `exp`            : | ("def" | "entry" | "let") `pat` `binop` `pat` [":" `type`] "=" `exp`  **Note:** using ``let`` to define top-level bindings is deprecated.@@ -364,7 +370,7 @@ ~~~~~~~~~~~~~~~~~~  .. productionlist::-   type_bind: "type" ["^" | "~"] `id` `type_param`* "=" `type`+   type_bind: ("type" | "type^" | "type~") `id` `type_param`* "=" `type`    type_param: "[" `id` "]" | "'" `id` | "'~" `id` | "'^" `id`  Type abbreviations function as shorthands for the purpose of@@ -1452,8 +1458,8 @@  .. _module-system: -Module System--------------+Modules+-------  .. productionlist::    mod_bind: "module" `id` `mod_param`* "=" [":" mod_type_exp] "=" `mod_exp`@@ -1469,101 +1475,32 @@ respectively.  Module names exist in the same name space as values, but module types are their own name space. -Named modules are declared as::--  module name = ...--A named module type is defined as::--  module type name = ...--Where a module expression can be the name of another module, an-application of a parametric module, or a sequence of declarations-enclosed in curly braces::--  module Vec3 = {-    type t = ( f32 , f32 , f32 )-    def add(a: t) (b: t): t =-      let (a1, a2, a3) = a in-      let (b1, b2, b3) = b in-      (a1 + b1, a2 + b2 , a3 + b3)-  }--  module AlsoVec3 = Vec3--Functions and types within modules can be accessed using dot-notation::--    type vector = Vec3.t-    def double(v: vector): vector = Vec3.add v v--We can also use ``open Vec3`` to bring the names defined by ``Vec3``-into the current scope.  Multiple modules can be opened simultaneously-by separating their names with spaces.  In case several modules define-the same names, the ones mentioned last take precedence.  The first-argument to ``open`` may be a full module expression.--Named module types are defined as::--  module type ModuleTypeName = ...--A module type expression can be the name of another module type, or a-sequence of *specifications*, or *specs*, enclosed in curly braces.  A-spec can be a *value spec*, indicating the presence of a function or-value, an *abstract type spec*, or a *type abbreviation spec*.  For-example::--  module type Addable = {-    type t                 -- abstract type spec-    type two_ts = (t,t)    -- type abbreviation spec-    val add: t -> t -> t   -- value spec-  }--This module type specifies the presence of an *abstract type* ``t``,-as well as a function operating on values of type ``t``.  We can use-*module type ascription* to restrict a module to what is exposed by-some module type::--  module AbstractVec = Vec3 : Addable--The definition of ``AbstractVec.t`` is now hidden.  In fact, with this-module type, we can neither construct values of type ``AbstractVec.T``-or convert them to anything else, making this a rather useless use of-abstraction.  As a derived form, we can write ``module M: S = e`` to-mean ``module M = e : S``.--In a value spec, sizes in types on the left-hand side of a function-arrow must not be anonymous.  For example, this is forbidden::--  val sum: []t -> t--Instead write::+Module bindings+~~~~~~~~~~~~~~~ -  val sum [n]: [n]t -> t+``module m = mod_exp``+...................... -But this is allowed, because the empty size is not to the left of a-function arrow::+Binds *m* to the module produced by the module expression ``mod_exp``.+Any name x in the module produced by ``mod_exp`` can then be accessed+with ``m.x``. -  val evens [n]: [n]i32 -> []i32+``module m : mod_type_exp = mod_exp``+..................................... -Parametric modules allow us to write definitions that abstract over-modules.  For example::+Shorthand for ``module m = mod_exp : mod_type_exp``. -  module Times = \(M: Addable) -> {-    def times (x: M.t) (k: i32): M.t =-      loop x' = x for i < k do-        M.add x' x-  }+``module m mod_params... = mod_exp``+.................................... -We can instantiate ``Times`` with any module that fulfils the module-type ``Addable`` and get back a module that defines a function-``times``::+Shorthand for ``module m = \mod_params... -> mod_exp``.  This produces+a parametric module. -  module Vec3Times = Times Vec3+``module type mt = mod_type_exp``+................................. -Now ``Vec3Times.times`` is a function of type ``Vec3.t -> int ->-Vec3.t``.  As a derived form, we can write ``module M p = e`` to mean-``module M = \p -> e``.+Binds *mt* to the module type produced by the module type expression+``mod_type_exp``.  Module Expressions ~~~~~~~~~~~~~~~~~~@@ -1624,7 +1561,7 @@ ................  Returns a module that contains the definitions of the file ``"foo"``-relative to the current file.  See :ref:`other-files`.+relative to the current file.  Module Type Expressions ~~~~~~~~~~~~~~~~~~~~~~~@@ -1639,14 +1576,13 @@   .. productionlist::-   spec:   "val" `id` `type_param`* ":" `spec_type`-       : | "val" `binop` `type_param`* ":" `spec_type`-       : | "type" ["^"] `id` `type_param`* "=" `type`-       : | "type" ["^"] `id` `type_param`*+   spec:   "val" `id` `type_param`* ":" `type`+       : | "val" `binop` `type_param`* ":" `type`+       : | ("type" | "type^" | "type~") `id` `type_param`* "=" `type`+       : | ("type" | "type^" | "type~") `id` `type_param`*        : | "module" `id` ":" `mod_type_exp`        : | "include" `mod_type_exp`        : | "#[" attr "]" spec-   spec_type: `type` | `type` "->" `spec_type`  Module types classify modules, with the only (unimportant) difference in expressivity being that modules can contain module types, but@@ -1654,10 +1590,29 @@ module type. They can specify of course that a module contains a *submodule* of a specific module type. +A module type expression can be the name of another module type, or a+sequence of *specifications*, or *specs*, enclosed in curly braces.  A+spec can be a *value spec*, indicating the presence of a function or+value, an *abstract type spec*, or a *type abbreviation spec*.++In a value spec, sizes in types on the left-hand side of a function+arrow must not be anonymous.  For example, this is forbidden::++  val sum: []t -> t++Instead write::++  val sum [n]: [n]t -> t++But this is allowed, because the empty size is not to the left of a+function arrow::++  val evens [n]: [n]i32 -> []i32+ .. _other-files: -Referring to Other Files-------------------------+Referencing Other Files+-----------------------  You can refer to external files in a Futhark file like this:: @@ -1682,6 +1637,10 @@ In fact, a plain ``import "file"`` is equivalent to::    local open import "file"++To re-export names from another file in the current module, use::++  open import "file"  .. _attributes: 

@@ -30,6 +30,11 @@ Check whether a Futhark program type checks.  With ``-w``, no warnings are printed. +futhark check-syntax PROGRAM+----------------------------++Check whether a Futhark program is syntactically correct.+ futhark datacmp FILE_A FILE_B ----------------------------- 

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.21.6+version:        0.21.7 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -18,6 +18,7 @@                 Regarding the internal design of the compiler, the following modules make                 good starting points:                 .+                * "Futhark" contains a basic architectural overview of the compiler.                 * "Futhark.IR.Syntax" explains the                   basic design of the intermediate representation (IR).                 * "Futhark.Construct" explains how to write code that@@ -52,6 +53,7 @@  library   exposed-modules:+      Futhark       Futhark.Actions       Futhark.Analysis.Alias       Futhark.Analysis.CallGraph@@ -282,6 +284,7 @@       Language.Futhark.Core       Language.Futhark.Interpreter       Language.Futhark.Parser+      Language.Futhark.Parser.Monad       Language.Futhark.Prelude       Language.Futhark.Pretty       Language.Futhark.Prop@@ -308,7 +311,7 @@       Paths_futhark   hs-source-dirs:       src-  ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists+  ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages   build-tool-depends:       alex:alex     , happy:happy@@ -356,17 +359,16 @@     , time >=1.6.0.1     , transformers >=0.3     , vector >=0.12-    , vector-binary-instances >=0.2.2.0     , versions >=5.0.0     , zip-archive >=0.3.1.1     , zlib >=0.6.1.2   default-language: Haskell2010  executable futhark-  main-is: src/futhark.hs+  main-is: src/main.hs   other-modules:       Paths_futhark-  ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M"+  ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -Wunused-packages -threaded -rtsopts "-with-rtsopts=-N -qg1 -A16M"   build-depends:       base     , futhark

@@ -240,9 +240,9 @@   def u32 (x: u32) = intrinsics.itob_i32_bool (intrinsics.sign_i32 x)   def u64 (x: u64) = intrinsics.itob_i64_bool (intrinsics.sign_i64 x) -  def f16 (x: f16) = x != 0f16-  def f32 (x: f32) = x != 0f32-  def f64 (x: f64) = x != 0f64+  def f16 (x: f16) = intrinsics.ftob_f16_bool x+  def f32 (x: f32) = intrinsics.ftob_f32_bool x+  def f64 (x: f64) = intrinsics.ftob_f64_bool x    def bool (x: bool) = x }@@ -877,7 +877,7 @@   def f32 (x: f32) = intrinsics.fpconv_f32_f64 x   def f64 (x: f64) = intrinsics.fpconv_f64_f64 x -  def bool (x: bool) = if x then 1f64 else 0f64+  def bool (x: bool) = intrinsics.btof_bool_f64 x    def from_fraction (x: i64) (y: i64) = i64 x / i64 y   def to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x@@ -986,7 +986,7 @@   def f32 (x: f32) = intrinsics.fpconv_f32_f32 x   def f64 (x: f64) = intrinsics.fpconv_f64_f32 x -  def bool (x: bool) = if x then 1f32 else 0f32+  def bool (x: bool) = intrinsics.btof_bool_f32 x    def from_fraction (x: i64) (y: i64) = i64 x / i64 y   def to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x@@ -1099,7 +1099,7 @@   def f32 (x: f32) = intrinsics.fpconv_f32_f16 x   def f64 (x: f64) = intrinsics.fpconv_f64_f16 x -  def bool (x: bool) = if x then 1f16 else 0f16+  def bool (x: bool) = intrinsics.btof_bool_f16 x    def from_fraction (x: i64) (y: i64) = i64 x / i64 y   def to_i64 (x: f16) = intrinsics.fptosi_f16_i64 x

@@ -17,7 +17,7 @@ def t64 (x: f64): i32 = i32.f64 x  -- | Negate a boolean.  `not x` is the same as `!x`.  This function is--- mostly useful for passing to `map+-- mostly useful for passing to `map`. def not (x: bool): bool = !x  -- | Semantically just identity, but serves as an optimisation

@@ -1155,6 +1155,14 @@   } } +static inline bool ftob_f32_bool(float x) {+  return x != 0;+}++static inline float btof_bool_f32(bool x) {+  return x ? 1 : 0;+}+ #ifdef __OPENCL_VERSION__ static inline float futrts_log32(float x) {   return log(x);@@ -1651,6 +1659,14 @@   } else {     return (uint64_t) (int64_t) x;   }+}++static inline bool ftob_f64_bool(double x) {+  return x != 0;+}++static inline double btof_bool_f64(bool x) {+  return x ? 1 : 0; }  static inline int64_t futrts_to_bits64(double x) {

@@ -120,6 +120,14 @@   return (uint64_t) x; } +static inline bool ftob_f16_bool(f16 x) {+  return x != (f16)0;+}++static inline f16 btof_bool_f16(bool x) {+  return x ? 1 : 0;+}+ #ifndef EMULATE_F16  #ifdef __OPENCL_VERSION__

@@ -158,14 +158,26 @@   return np.int8(x)  def btoi_bool_i16(x):-  return np.int8(x)+  return np.int16(x)  def btoi_bool_i32(x):-  return np.int8(x)+  return np.int32(x)  def btoi_bool_i64(x):-  return np.int8(x)+  return np.int64(x) +def ftob_T_bool(x):+  return bool(x)++def btof_bool_f16(x):+  return np.float16(x)++def btof_bool_f32(x):+  return np.float32(x)++def btof_bool_f64(x):+  return np.float64(x)+ def zext_i8_i8(x):   return np.int8(np.uint8(x)) @@ -250,6 +262,7 @@ sext_i8_i32 = sext_i16_i32 = sext_i32_i32 = sext_i64_i32 = sext_T_i32 sext_i8_i64 = sext_i16_i64 = sext_i32_i64 = sext_i64_i64 = sext_T_i64 itob_i8_bool = itob_i16_bool = itob_i32_bool = itob_i64_bool = itob_T_bool+ftob_f16_bool = ftob_f32_bool = ftob_f64_bool = ftob_T_bool  def clz_T(x):   n = np.int32(0)

@@ -0,0 +1,145 @@+-- |+--+-- This module contains no code.  Its purpose is to explain the+-- overall architecture of the code base, with links to the relevant+-- modules and definitions.  It is intended for people who intend to+-- hack on the compiler itself, not for those who just want to use its+-- public API as a library.  Most of what's here discusses the+-- compiler itself, but we'll also provide pointers for where to find+-- the code for the various other tools and subcommands.+--+-- Much of the documentation here is by referencing other modules that+-- contain more information.  Make sure to follow the links.  Also,+-- make sure to click the *source* links to study the actual code.+-- Many of the links are provided not because the exposed module API+-- is particularly interesting, but because their implementation is.+--+-- = Compiler+--+-- At a very high level, the Futhark compiler has a fairly+-- conventional architecture.  After reading and type-checking a+-- program, it is gradually transformed, passing through a variety of+-- different /intermediate representations/ (IRs), where the specifics+-- depend on which code generator is intended.  The final result is+-- then written to one or more files.  We can divide the compiler into+-- roughly three parts: frontend, middle-end [sic], and backend.+--+-- == Frontend+--+-- The frontend of the compiler is concerned with parsing the Futhark+-- source language, type-checking it, and transforming it to the core+-- IR used by the middle-end of the compiler.  The following modules+-- are of particular interest:+--+-- * "Language.Futhark.Syntax" contains the source language AST definition.+--+-- * "Language.Futhark.Parser" contains parsers for the source+--   language and various fragments.+--+-- * "Futhark.Compiler" and "Futhark.Compiler.Program" contains+--   functions for conveniently reading and type-checking an entire+--   Futhark source program, chasing down imports, and so on.+--+-- * "Language.Futhark.TypeChecker" is the type checker itself.+--+-- * /Internalisation/ of the source language to the core IR is in+--   "Futhark.Internalise".+--+-- == Middle-end+--+-- The compiler middle-end is based around /passes/ that are+-- essentially pure functions that accept a program as input and+-- produce a program as output.  A composition of such passes is+-- called a /pipeline/.  The various compiler backends (@futhark+-- opencl@, @futhark multicore@, etc) use different pipelines.  See+-- "Futhark.Pass" and (less importantly) "Futhark.Pipeline".  The+-- actual pipelines we use are in "Futhark.Passes".+--+-- The compiler front-end produces a core IR program that is then+-- processed by a pipeline in the middle-end.  The fundamental+-- structure of this IR is defined in "Futhark.IR.Syntax".  As+-- mentioned in that module, the IR supports multiple+-- /representations/.  The middle-end always starts with the program+-- in the SOACS representation ("Futhark.IR.SOACS"), which closely+-- resembles the kind of free-form nested parallelism that the source+-- language permits.  Depending on the specific compilation pipeline,+-- the program will eventually be transformed to various other+-- representations.  The output of the middle-end is always a core IR+-- program in some representation (probably not the same one that it+-- started with).+--+-- Many passes will involve constructing core IR AST fragments.  See+-- "Futhark.Construct" for advice and guidance on how to do that.+--+-- === Main representations+--+-- * "Futhark.IR.SOACS": the initial core representation of any+--   Futhark program.  This is the representation on which we perform+--   optimisations such as fusion, inlining, and a host of other+--   cleanup.+--+-- * "Futhark.IR.GPU": a representation where parallelism is expressed+--   with flat /segmented operations/, and a few other GPU-specific+--   operations are also supported.  The pass+--   "Futhark.Pass.ExtractKernels" transforms a+--   'Futhark.IR.SOACS.SOACS' program to a 'Futhark.IR.GPU.GPU'+--   program.+--+-- * "Futhark.IR.MC": a representation where parallelism is expressed+--   with flat /segmented operations/, and a few other multicore-specific+--   operations are also supported.  The pass+--   "Futhark.Pass.ExtractMulticore" transforms a+--   'Futhark.IR.SOACS.SOACS' program to a 'Futhark.IR.MC.MC'+--   program.+--+-- * "Futhark.IR.GPUMem": like 'Futhark.IR.GPU.GPU', but with memory+--   information.  See "Futhark.IR.Mem" for information on how we+--   represent memory in the Futhark compiler.  This representation is+--   produced by "Futhark.Pass.ExplicitAllocations.GPU"+--+-- * "Futhark.IR.MCMem": the multicore counterpart to+--   'Futhark.IR.GPUMem.GPUMem'.  Produced by+--   "Futhark.Pass.ExplicitAllocations.MC".+--+-- == Backend+--+-- The backend accepts a program in some core IR representation.+-- Currently this must always be a representation with memory+-- information (e.g. 'Futhark.IR.GPUMem.GPUMem').  It then translates+-- the program to the /imperative/ IR, which we call ImpCode.+--+-- * "Futhark.CodeGen.ImpCode": The main definition of ImpCode, which+--   is an extensible representation like the core IR.+--+-- * "Futhark.CodeGen.ImpCode.GPU": an example of ImpCode+--   extended/specialised to handle GPU operations (but at a high+--   level, before generating actual CUDA/OpenCL kernel code).+--+-- * "Futhark.CodeGen.ImpGen": a translator from core IR to ImpCode.+--   Heavily parameterised so that it can handle the various dialects+--   of both core IR and ImpCode that it must be expected to work+--   with.  In practice, when adding a new backend (or modifying an+--   existing one), you'll be working on more specialised modules such+--   as "Futhark.CodeGen.ImpGen.GPU".+--+-- Ultimately, ImpCode must then be translated to some /real/+-- executable language, which in our case means C or Python.+--+-- * "Futhark.CodeGen.Backends.GenericC": framework for translating+--   ImpCode to C.  Rather convoluted because it is used in a large+--   number of settings.  The module+--   "Futhark.CodeGen.Backends.SequentialC" shows perhaps the simplest+--   use of it.+--+-- * "Futhark.CodeGen.Backends.GenericPython": the generic Python code+--   generator (see "Futhark.CodeGen.Backends.SequentialPython" for a+--   usage example).+--+-- = Command line interface+--+-- The @futhark@ program dispatches to a Haskell-level main function+-- based on its first argument (the subcommand).  Some of these+-- subcommands are implemented as their own modules under the+-- @Futhark.CLI@ hierarchy.  Others, particularly the simplest ones,+-- are bundled together in "Futhark.CLI.Misc".+module Futhark () where

@@ -118,10 +118,10 @@ buildFGStms :: Stms SOACS -> FunCalls buildFGStms = mconcat . map buildFGstm . stmsToList -buildFGBody :: Body -> FunCalls+buildFGBody :: Body SOACS -> FunCalls buildFGBody = buildFGStms . bodyStms -buildFGstm :: Stm -> FunCalls+buildFGstm :: Stm SOACS -> FunCalls buildFGstm (Let (Pat (p : _)) aux (Apply fname _ _ _)) =   FunCalls (M.singleton (patElemName p) (stmAuxAttrs aux, fname)) (S.singleton fname) buildFGstm (Let _ _ (Op op)) = execWriter $ mapSOACM folder op@@ -148,7 +148,7 @@   foldMap noinlineDef (progFuns prog)     <> foldMap onStm (foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog)   where-    onStm :: Stm -> S.Set Name+    onStm :: Stm SOACS -> S.Set Name     onStm (Let _ aux (Apply fname _ _ _))       | "noinline" `inAttrs` stmAuxAttrs aux =         S.singleton fname

@@ -5,7 +5,7 @@ {-# LANGUAGE TypeFamilies #-}  -- | Provides last-use analysis for Futhark programs.-module Futhark.Analysis.LastUse (LastUseMap, analyseGPUMem, analyseSeqMem) where+module Futhark.Analysis.LastUse (LastUseMap, Used, analyseGPUMem, analyseSeqMem) where  import Control.Monad.Reader import Data.Bifunctor (first)

@@ -23,6 +23,7 @@     leafExpTypes,     true,     false,+    fromBool,     constFoldPrimExp,      -- * Construction@@ -586,6 +587,10 @@ true, false :: TPrimExp Bool v true = TPrimExp $ ValueExp $ BoolValue True false = TPrimExp $ ValueExp $ BoolValue False++-- | Conversion from Bool to 'TPrimExp'+fromBool :: Bool -> TPrimExp Bool v+fromBool b = if b then true else false  -- | Boolean negation smart constructor. bNot :: TPrimExp Bool v -> TPrimExp Bool v

@@ -19,33 +19,31 @@ import Futhark.Util.Pretty (prettyText) import Text.Megaparsec -type Parser = Parsec Void T.Text--pBinOp :: Parser BinOp+pBinOp :: Parsec Void T.Text BinOp pBinOp = choice $ map p allBinOps   where     p op = keyword (prettyText op) $> op -pCmpOp :: Parser CmpOp+pCmpOp :: Parsec Void T.Text CmpOp pCmpOp = choice $ map p allCmpOps   where     p op = keyword (prettyText op) $> op -pUnOp :: Parser UnOp+pUnOp :: Parsec Void T.Text UnOp pUnOp = choice $ map p allUnOps   where     p op = keyword (prettyText op) $> op -pConvOp :: Parser ConvOp+pConvOp :: Parsec Void T.Text ConvOp pConvOp = choice $ map p allConvOps   where     p op = keyword (prettyText op) $> op -parens :: Parser a -> Parser a+parens :: Parsec Void T.Text a -> Parsec Void T.Text a parens = between (lexeme "(") (lexeme ")")  -- | Parse a 'PrimExp' given a leaf parser.-pPrimExp :: PrimType -> Parser v -> Parser (PrimExp v)+pPrimExp :: PrimType -> Parsec Void T.Text v -> Parsec Void T.Text (PrimExp v) pPrimExp t pLeaf =   choice     [ flip LeafExp t <$> pLeaf,

@@ -64,12 +64,12 @@ rephrasePat ::   Monad m =>   (from -> m to) ->-  PatT from ->-  m (PatT to)+  Pat from ->+  m (Pat to) rephrasePat = traverse  -- | Rephrase a pattern element.-rephrasePatElem :: Monad m => (from -> m to) -> PatElemT from -> m (PatElemT to)+rephrasePatElem :: Monad m => (from -> m to) -> PatElem from -> m (PatElem to) rephrasePatElem rephraser (PatElem ident from) =   PatElem ident <$> rephraser from 

@@ -366,7 +366,7 @@ defBndEntry ::   (ASTRep rep, IndexOp (Op rep)) =>   SymbolTable rep ->-  PatElem rep ->+  PatElem (LetDec rep) ->   Names ->   Stm rep ->   LetBoundEntry rep

@@ -129,6 +129,7 @@ instance Monoid Usages where   mempty = Usages 0 +-- | A kind of usage. consumedU, inResultU, presentU, sizeU :: Usages consumedU = Usages 1 inResultU = Usages 2

@@ -46,7 +46,7 @@ class ASTRep rep => BuilderOps rep where   mkExpDecB ::     (MonadBuilder m, Rep m ~ rep) =>-    Pat rep ->+    Pat (LetDec rep) ->     Exp rep ->     m (ExpDec rep)   mkBodyB ::@@ -62,7 +62,7 @@    default mkExpDecB ::     (MonadBuilder m, Buildable rep) =>-    Pat rep ->+    Pat (LetDec rep) ->     Exp rep ->     m (ExpDec rep)   mkExpDecB pat e = return $ mkExpDec pat e

@@ -42,8 +42,8 @@   ) =>   Buildable rep   where-  mkExpPat :: [Ident] -> Exp rep -> Pat rep-  mkExpDec :: Pat rep -> Exp rep -> ExpDec rep+  mkExpPat :: [Ident] -> Exp rep -> Pat (LetDec rep)+  mkExpDec :: Pat (LetDec rep) -> Exp rep -> ExpDec rep   mkBody :: Stms rep -> Result -> Body rep   mkLetNames ::     (MonadFreshNames m, HasScope rep m) =>@@ -72,7 +72,7 @@   MonadBuilder m   where   type Rep m :: Data.Kind.Type-  mkExpDecM :: Pat (Rep m) -> Exp (Rep m) -> m (ExpDec (Rep m))+  mkExpDecM :: Pat (LetDec (Rep m)) -> Exp (Rep m) -> m (ExpDec (Rep m))   mkBodyM :: Stms (Rep m) -> Result -> m (Body (Rep m))   mkLetNamesM :: [VName] -> Exp (Rep m) -> m (Stm (Rep m)) @@ -127,7 +127,7 @@ -- | Add a statement with the given pattern and expression. letBind ::   MonadBuilder m =>-  Pat (Rep m) ->+  Pat (LetDec (Rep m)) ->   Exp (Rep m) ->   m () letBind pat e =

@@ -13,7 +13,7 @@ import Language.Futhark  isBuiltin :: String -> Bool-isBuiltin = ("prelude/" `isPrefixOf`)+isBuiltin = ("/prelude/" `isPrefixOf`)  data DefKind = Value | Module | ModuleType | Type 

@@ -5,6 +5,7 @@   ( mainImports,     mainHash,     mainDataget,+    mainCheckSyntax,   ) where @@ -24,7 +25,7 @@ import System.IO  isBuiltin :: String -> Bool-isBuiltin = ("prelude/" `isPrefixOf`)+isBuiltin = ("/prelude/" `isPrefixOf`)  -- | @futhark imports@ mainImports :: String -> [String] -> IO ()@@ -80,3 +81,10 @@     testSpecRuns = testActionRuns . testAction     testActionRuns CompileTimeFailure {} = []     testActionRuns (RunCases ios _ _) = concatMap iosTestRuns ios++-- | @futhark check-syntax@+mainCheckSyntax :: String -> [String] -> IO ()+mainCheckSyntax = mainWithOptions () [] "program" $ \args () ->+  case args of+    [file] -> Just $ void $ readUntypedProgramOrDie file+    _ -> Nothing

@@ -15,19 +15,19 @@ import Data.Char import Data.List (intercalate, intersperse) import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Version import Futhark.Compiler import Futhark.MonadFreshNames-import Futhark.Pipeline-import Futhark.Util (fancyTerminal, toPOSIX)+import Futhark.Util (fancyTerminal) import Futhark.Util.Options import Futhark.Version import Language.Futhark import qualified Language.Futhark.Interpreter as I-import Language.Futhark.Parser hiding (EOF)+import Language.Futhark.Parser import qualified Language.Futhark.Semantic as T import qualified Language.Futhark.TypeChecker as T import NeatInterpolation (text)@@ -81,30 +81,30 @@           Left (Load file) -> do             liftIO $ T.putStrLn $ "Loading " <> T.pack file             maybe_new_state <--              liftIO $ newFutharkiState (futharkiCount s) $ Just file+              liftIO $ newFutharkiState (futharkiCount s) (futharkiProg s) $ Just file             case maybe_new_state of               Right new_state -> toploop new_state               Left err -> do                 liftIO $ putStrLn err                 toploop s'-          Right _ -> return ()+          Right _ -> pure ()        finish s = do         quit <- if fancyTerminal then confirmQuit else pure True-        if quit then return () else toploop s+        if quit then pure () else toploop s -  maybe_init_state <- liftIO $ newFutharkiState 0 maybe_prog+  maybe_init_state <- liftIO $ newFutharkiState 0 noLoadedProg maybe_prog   s <- case maybe_init_state of     Left prog_err -> do-      noprog_init_state <- liftIO $ newFutharkiState 0 Nothing+      noprog_init_state <- liftIO $ newFutharkiState 0 noLoadedProg Nothing       case noprog_init_state of         Left err ->           error $ "Failed to initialise interpreter state: " ++ err         Right s -> do           liftIO $ putStrLn prog_err-          return s {futharkiLoaded = maybe_prog}+          pure s {futharkiLoaded = maybe_prog}     Right s ->-      return s+      pure s   Haskeline.runInputT Haskeline.defaultSettings $ toploop s    putStrLn "Leaving 'futhark repl'."@@ -113,9 +113,9 @@ confirmQuit = do   c <- Haskeline.getInputChar "Quit REPL? (y/n) "   case c of-    Nothing -> return True -- EOF-    Just 'y' -> return True-    Just 'n' -> return False+    Nothing -> pure True -- EOF+    Just 'y' -> pure True+    Just 'n' -> pure False     _ -> confirmQuit  -- | Representation of breaking at a breakpoint, to allow for@@ -128,8 +128,7 @@   }  data FutharkiState = FutharkiState-  { futharkiImports :: Imports,-    futharkiNameSource :: VNameSource,+  { futharkiProg :: LoadedProg,     futharkiCount :: Int,     futharkiEnv :: (T.Env, I.Ctx),     -- | Are we currently stopped at a breakpoint?@@ -141,55 +140,49 @@     futharkiLoaded :: Maybe FilePath   } -newFutharkiState :: Int -> Maybe FilePath -> IO (Either String FutharkiState)-newFutharkiState count maybe_file = runExceptT $ do-  (imports, src, tenv, ienv) <- case maybe_file of+extendEnvs :: LoadedProg -> (T.Env, I.Ctx) -> [String] -> (T.Env, I.Ctx)+extendEnvs prog (tenv, ictx) opens = (tenv', ictx')+  where+    tenv' = T.envWithImports t_imports tenv+    ictx' = I.ctxWithImports i_envs ictx+    t_imports = filter ((`elem` opens) . fst) $ lpImports prog+    i_envs = map snd $ filter ((`elem` opens) . fst) $ M.toList $ I.ctxImports ictx++newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either String FutharkiState)+newFutharkiState count prev_prog maybe_file = runExceptT $ do+  (prog, tenv, ienv) <- case maybe_file of     Nothing -> do       -- Load the builtins through the type checker.-      (_, imports, src) <- badOnLeft show =<< runExceptT (readLibrary [] [])+      (_, prog) <- badOnLeft show =<< runExceptT (reloadProg prev_prog [])       -- Then into the interpreter.       ienv <-         foldM           (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx)           I.initialCtx-          $ map (fmap fileProg) imports+          $ map (fmap fileProg) (lpImports prog) -      -- Then make the prelude available in the type checker.-      (tenv, d, src') <--        badOnLeft pretty . snd $-          T.checkDec imports src T.initialEnv (T.mkInitialImport ".") $-            mkOpen "/prelude/prelude"-      -- Then in the interpreter.-      ienv' <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv d)-      return (imports, src', tenv, ienv')+      let (tenv, ienv') =+            extendEnvs prog (T.initialEnv, ienv) ["/prelude/prelude"]++      pure (prog, tenv, ienv')     Just file -> do-      (ws, imports, src) <--        badOnLeft show-          =<< liftIO-            ( runExceptT (readProgram [] file)-                `catch` \(err :: IOException) ->-                  return (externalErrorS (show err))-            )+      (ws, prog) <- badOnLeft show =<< runExceptT (reloadProg prev_prog [file])       liftIO $ putStrLn $ pretty ws -      let imp = T.mkInitialImport "."-      ienv1 <--        foldM (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $-          map (fmap fileProg) imports-      (tenv1, d1, src') <--        badOnLeft pretty . snd . T.checkDec imports src T.initialEnv imp $-          mkOpen "/prelude/prelude"-      (tenv2, d2, src'') <--        badOnLeft pretty . snd . T.checkDec imports src' tenv1 imp $-          mkOpen $ toPOSIX $ dropExtension file-      ienv2 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv1 d1)-      ienv3 <- badOnLeft show =<< runInterpreter' (I.interpretDec ienv2 d2)-      return (imports, src'', tenv2, ienv3)+      ienv <-+        foldM+          (\ctx -> badOnLeft show <=< runInterpreter' . I.interpretImport ctx)+          I.initialCtx+          $ map (fmap fileProg) (lpImports prog) +      let (tenv, ienv') =+            extendEnvs prog (T.initialEnv, ienv) ["/prelude/prelude", dropExtension file]++      pure (prog, tenv, ienv')+   return     FutharkiState-      { futharkiImports = imports,-        futharkiNameSource = src,+      { futharkiProg = prog,         futharkiCount = count,         futharkiEnv = (tenv, ienv),         futharkiBreaking = Nothing,@@ -199,16 +192,13 @@       }   where     badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a-    badOnLeft _ (Right x) = return x+    badOnLeft _ (Right x) = pure x     badOnLeft p (Left err) = throwError $ p err  getPrompt :: FutharkiM String getPrompt = do   i <- gets futharkiCount-  return $ "[" ++ show i ++ "]> "--mkOpen :: FilePath -> UncheckedDec-mkOpen f = OpenDec (ModImport f NoInfo mempty) mempty+  pure $ "[" ++ show i ++ "]> "  -- The ExceptT part is more of a continuation, really. newtype FutharkiM a = FutharkiM {runFutharkiM :: ExceptT StopReason (StateT FutharkiState (Haskeline.InputT IO)) a}@@ -229,7 +219,7 @@   case T.uncons line of     Nothing       | isJust breaking -> throwError Stop-      | otherwise -> return ()+      | otherwise -> pure ()     Just (':', command) -> do       let (cmdname, rest) = T.break isSpace command           arg = T.dropWhileEnd isSpace $ T.dropWhile isSpace rest@@ -253,36 +243,38 @@     inputLine prompt = do       inp <- FutharkiM $ lift $ lift $ Haskeline.getInputLine prompt       case inp of-        Just s -> return $ T.pack s+        Just s -> pure $ T.pack s         Nothing -> throwError EOF  getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx) getIt = do-  imports <- gets futharkiImports-  src <- gets futharkiNameSource+  imports <- gets $ lpImports . futharkiProg+  src <- gets $ lpNameSource . futharkiProg   (tenv, ienv) <- gets futharkiEnv-  return (imports, src, tenv, ienv)+  pure (imports, src, tenv, ienv)  onDec :: UncheckedDec -> FutharkiM () onDec d = do-  (imports, src, tenv, ienv) <- getIt+  old_imports <- gets $ lpImports . futharkiProg   cur_import <- gets $ T.mkInitialImport . fromMaybe "." . futharkiLoaded+  let mkImport = uncurry $ T.mkImportFrom cur_import+      files = map (T.includeToFilePath . mkImport) $ decImports d -  -- Most of the complexity here concerns the dealing with the fact-  -- that 'import "foo"' is a declaration.  We have to involve a lot-  -- of machinery to load this external code before executing the-  -- declaration itself.-  let basis = Basis imports src ["/prelude/prelude"]-      mkImport = uncurry $ T.mkImportFrom cur_import-  imp_r <- runExceptT $ readImports basis (map mkImport $ decImports d)+  imp_r <- runExceptT $ do+    prog <- lift $ gets futharkiProg+    extendProg prog files    case imp_r of     Left e -> liftIO $ print e-    Right (_, imports', src') ->-      case T.checkDec imports' src' tenv cur_import d of+    Right (_ws, prog) -> do+      env <- gets futharkiEnv+      let (tenv, ienv) = extendEnvs prog env (map fst $ decImports d)+          imports = lpImports prog+          src = lpNameSource prog+      case T.checkDec imports src tenv cur_import d of         (_, Left e) -> liftIO $ putStrLn $ pretty e-        (_, Right (tenv', d', src'')) -> do-          let new_imports = filter ((`notElem` map fst imports) . fst) imports'+        (_, Right (tenv', d', src')) -> do+          let new_imports = filter ((`notElem` map fst old_imports) . fst) imports           int_r <- runInterpreter $ do             let onImport ienv' (s, imp) =                   I.interpretImport ienv' (s, T.fileProg imp)@@ -293,8 +285,7 @@             Right ienv' -> modify $ \s ->               s                 { futharkiEnv = (tenv', ienv'),-                  futharkiImports = imports',-                  futharkiNameSource = src''+                  futharkiProg = prog {lpNameSource = src'}                 }  onExp :: UncheckedExp -> FutharkiM ()@@ -332,7 +323,7 @@ runInterpreter m = runF m (return . Right) intOp   where     intOp (I.ExtOpError err) =-      return $ Left err+      pure $ Left err     intOp (I.ExtOpTrace w v c) = do       liftIO $ putStrLn $ w ++ ": " ++ v       c@@ -384,7 +375,7 @@ runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' m = runF m (return . Right) intOp   where-    intOp (I.ExtOpError err) = return $ Left err+    intOp (I.ExtOpError err) = pure $ Left err     intOp (I.ExtOpTrace w v c) = do       liftIO $ putStrLn $ w ++ ": " ++ v       c@@ -411,9 +402,7 @@   case f prompt e of     Left err -> liftIO $ print err     Right e' -> do-      imports <- gets futharkiImports-      src <- gets futharkiNameSource-      (tenv, _) <- gets futharkiEnv+      (imports, src, tenv, _) <- getIt       case snd $ g imports src tenv e' of         Left err -> liftIO $ putStrLn $ pretty err         Right x -> liftIO $ putStrLn $ h x

@@ -18,7 +18,7 @@ import Futhark.Util.Options import Language.Futhark import qualified Language.Futhark.Interpreter as I-import Language.Futhark.Parser hiding (EOF)+import Language.Futhark.Parser import qualified Language.Futhark.Semantic as T import qualified Language.Futhark.TypeChecker as T import System.Exit

@@ -391,7 +391,7 @@                  ctx->error = cuda_setup(&ctx->cuda, cuda_program, cfg->nvrtc_opts);                   if (ctx->error != NULL) {-                   return NULL;+                   futhark_panic(1, "%s\n", ctx->error);                  }                   typename int32_t no_error = -1;

@@ -7,6 +7,7 @@     GC.asLibrary,     GC.asExecutable,     GC.asServer,+    EntryPointType,     JSEntryPoint (..),     emccExportNames,     javascriptWrapper,@@ -325,6 +326,8 @@     (arraynd_p, arraynd_flat_p, arraynd_dims_p) = (T.pack arraynd, T.pack arraynd_flat, T.pack arraynd_dims)     args = T.pack $ intercalate ", " ["'" ++ ftype ++ "'", show d, heap, fshape, fvalues, ffree] +-- | Javascript code that can be appended to the generated module to+-- run a Futhark server instance on startup. runServer :: T.Text runServer =   [text|@@ -334,5 +337,6 @@      server.run();    }|] +-- | The names exported by the generated module. libraryExports :: T.Text libraryExports = "export {newFutharkContext, FutharkContext, FutharkArray, FutharkOpaque};"

@@ -490,7 +490,7 @@   C.ToIdent a =>   M.Map VName Space ->   String ->-  Code ->+  MCCode ->   a ->   [(VName, (C.Type, ValueType))] ->   [(VName, (C.Type, ValueType))] ->

@@ -25,6 +25,18 @@ import Futhark.IR.MCMem import Futhark.MonadFreshNames +-- | Compile Futhark program to wasm-multicore program (some assembly+-- required).+--+-- The triple that is returned consists of+--+-- * Generated C code (to be passed to Emscripten).+--+-- * JavaScript wrapper code that presents a nicer interface to the+--   Emscripten-produced code (this should be put in a @.class.js@+--   file by itself).+--+-- * Options that should be passed to @emcc@. compileProg ::   MonadFreshNames m =>   T.Text ->

@@ -1,10 +1,12 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Boilerplate for sequential C code. module Futhark.CodeGen.Backends.SequentialC.Boilerplate (generateBoilerplate) where  import qualified Futhark.CodeGen.Backends.GenericC as GC import qualified Language.C.Quote.OpenCL as C +-- | Generate the necessary boilerplate. generateBoilerplate :: GC.CompilerM op s () generateBoilerplate = do   cfg <- GC.publicDef "context_config" GC.InitDecl $ \s ->

@@ -25,7 +25,18 @@ import Futhark.IR.SeqMem import Futhark.MonadFreshNames --- | Compile the program to sequential C with a JavaScript wrapper.+-- | Compile Futhark program to wasm program (some assembly+-- required).+--+-- The triple that is returned consists of+--+-- * Generated C code (to be passed to Emscripten).+--+-- * JavaScript wrapper code that presents a nicer interface to the+--   Emscripten-produced code (this should be put in a @.class.js@+--   file by itself).+--+-- * Options that should be passed to @emcc@. compileProg :: MonadFreshNames m => T.Text -> Prog SeqMem -> m (ImpGen.Warnings, (GC.CParts, T.Text, [String])) compileProg version prog = do   (ws, prog') <- ImpGen.compileProg prog

@@ -230,6 +230,9 @@ cScalarDefs :: T.Text cScalarDefs = scalarH <> scalarF16H +-- | @storageSize pt rank shape@ produces an expression giving size+-- taken when storing this value in the binary value format.  It is+-- assumed that the @shape@ is an array with @rank@ dimensions. storageSize :: PrimType -> Int -> C.Exp -> C.Exp storageSize pt rank shape =   [C.cexp|$int:header_size +@@ -258,6 +261,8 @@     (TypeUnsigned, IntType Int32) -> " u32"     (TypeUnsigned, IntType Int64) -> " u64" +-- | Produce code for storing the header (everything besides the+-- actual payload) for a value of this type. storeValueHeader :: Signedness -> PrimType -> Int -> C.Exp -> C.Exp -> [C.Stm] storeValueHeader sign pt rank shape dest =   [C.cstms|@@ -276,6 +281,8 @@                 memcpy($exp:dest, $exp:shape, $int:rank*sizeof(typename int64_t));                 $exp:dest += $int:rank*sizeof(typename int64_t);|] +-- | Produce code for loading the header (everything besides the+-- actual payload) for a value of this type. loadValueHeader :: Signedness -> PrimType -> Int -> C.Exp -> C.Exp -> [C.Stm] loadValueHeader sign pt rank shape src =   [C.cstms|

@@ -2,13 +2,56 @@ {-# LANGUAGE Strict #-} {-# LANGUAGE TupleSections #-} --- | Imperative intermediate language used as a stepping stone in code generation.+-- | ImpCode is an imperative intermediate language used as a stepping+-- stone in code generation.  The functional core IR+-- ("Futhark.IR.Syntax") gets translated into ImpCode by+-- "Futhark.CodeGen.ImpGen".  Later we then translate ImpCode to, for+-- example, C. ----- This is a generic representation parametrised on an extensible--- arbitrary operation.+-- == Basic design ----- Originally inspired by the paper "Defunctionalizing Push Arrays"--- (FHPC '14).+-- ImpCode distinguishes between /statements/ ('Code'), which may have+-- side effects, and /expressions/ ('Exp') which do not.  Expressions+-- involve only scalars and have a type.  The actual expression+-- definition is in "Futhark.Analysis.PrimExp", specifically+-- 'Futhark.Analysis.PrimExp.PrimExp' and its phantom-typed variant+-- 'Futhark.Analysis.PrimExp.TPrimExp'.+--+-- 'Code' is a generic representation parametrised on an extensible+-- arbitrary operation, represented by the 'Op' constructor.  Specific+-- instantiations of ImpCode, such as+-- "Futhark.CodeGen.ImpCode.Multicore", will pass in a specific kind+-- of operation to express backend-specific functionality (in the case+-- of multicore, this is+-- 'Futhark.CodeGen.ImpCode.Multicore.Multicore').+--+-- == Arrays and memory+--+-- ImpCode does not have arrays. 'DeclareArray' is for declaring+-- constant array literals, not arrays in general.  Instead, ImpCode+-- deals only with memory.  Array operations present in core IR+-- programs are turned into 'Write', v'Read', and 'Copy' operations+-- that use flat indexes and offsets based on the index function of+-- the original array.+--+-- == Scoping+--+-- ImpCode is much simpler than the functional core IR; partly because+-- we hope to do less work on it.  We don't have real optimisation+-- passes on ImpCode.  One result of this simplicity is that ImpCode+-- has a fairly naive view of scoping.  The /only/ things that can+-- bring new names into scope are 'DeclareMem', 'DeclareScalar',+-- 'DeclareArray', 'For', and function parameters.  In particular,+-- 'Op's /cannot/ bind parameters.  The standard workaround is to+-- define 'Op's that retrieve the value of an implicit parameter and+-- assign it to a variable declared with the normal+-- mechanisms. 'Futhark.CodeGen.ImpCode.Multicore.GetLoopBounds' is an+-- example of this pattern.+--+-- == Inspiration+--+-- ImpCode was originally inspired by the paper "Defunctionalizing+-- Push Arrays" (FHPC '14). module Futhark.CodeGen.ImpCode   ( Definitions (..),     Functions (..),@@ -241,8 +284,7 @@   | -- | @Write mem i t space vol v@ writes the value @v@ to     -- @mem@ offset by @i@ elements of type @t@.  The     -- 'Space' argument is the memory space of @mem@-    -- (technically redundant, but convenient).  Note that-    -- /reading/ is done with an 'Exp' ('Read').+    -- (technically redundant, but convenient).     Write VName (Count Elements (TExp Int64)) PrimType Space Volatility Exp   | -- | Set a scalar variable.     SetScalar VName Exp

@@ -5,9 +5,7 @@ -- of a kernel invocation. module Futhark.CodeGen.ImpCode.GPU   ( Program,-    Function,-    FunctionT (Function),-    Code,+    HostCode,     KernelCode,     KernelConst (..),     KernelConstExp,@@ -22,23 +20,19 @@   ) where -import Futhark.CodeGen.ImpCode hiding (Code, Function)-import qualified Futhark.CodeGen.ImpCode as Imp+import Futhark.CodeGen.ImpCode import Futhark.IR.GPU.Sizes import Futhark.IR.Pretty () import Futhark.Util.Pretty  -- | A program that calls kernels.-type Program = Imp.Definitions HostOp---- | A function that calls kernels.-type Function = Imp.Function HostOp+type Program = Definitions HostOp  -- | Host-level code that can call kernels.-type Code = Imp.Code HostOp+type HostCode = Code HostOp  -- | Code inside a kernel.-type KernelCode = Imp.Code KernelOp+type KernelCode = Code KernelOp  -- | A run-time constant related to kernels. newtype KernelConst = SizeConst Name@@ -51,17 +45,17 @@ data HostOp   = CallKernel Kernel   | GetSize VName Name SizeClass-  | CmpSizeLe VName Name SizeClass Imp.Exp+  | CmpSizeLe VName Name SizeClass Exp   | GetSizeMax VName SizeClass   deriving (Show)  -- | A generic kernel containing arbitrary kernel code. data Kernel = Kernel-  { kernelBody :: Imp.Code KernelOp,+  { kernelBody :: Code KernelOp,     -- | The host variables referenced by the kernel.     kernelUses :: [KernelUse],-    kernelNumGroups :: [Imp.Exp],-    kernelGroupSize :: [Imp.Exp],+    kernelNumGroups :: [Exp],+    kernelGroupSize :: [Exp],     -- | A short descriptive and _unique_ name - should be     -- alphanumeric and without spaces.     kernelName :: Name,@@ -156,7 +150,7 @@   | Atomic Space AtomicOp   | Barrier Fence   | MemFence Fence-  | LocalAlloc VName (Count Bytes (Imp.TExp Int64))+  | LocalAlloc VName (Count Bytes (TExp Int64))   | -- | Perform a barrier and also check whether any     -- threads have failed an assertion.  Make sure all     -- threads would reach all 'ErrorSync's if any of them@@ -170,17 +164,17 @@ -- This old value is stored in the first 'VName'.  The second 'VName' -- is the memory block to update.  The 'Exp' is the new value. data AtomicOp-  = AtomicAdd IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicFAdd FloatType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicSMax IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicSMin IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicUMax IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicUMin IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicAnd IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicOr IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicXor IntType VName VName (Count Elements (Imp.TExp Int64)) Exp-  | AtomicCmpXchg PrimType VName VName (Count Elements (Imp.TExp Int64)) Exp Exp-  | AtomicXchg PrimType VName VName (Count Elements (Imp.TExp Int64)) Exp+  = AtomicAdd IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicFAdd FloatType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicSMax IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicSMin IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicUMax IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicUMin IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicAnd IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicOr IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicXor IntType VName VName (Count Elements (TExp Int64)) Exp+  | AtomicCmpXchg PrimType VName VName (Count Elements (TExp Int64)) Exp Exp+  | AtomicXchg PrimType VName VName (Count Elements (TExp Int64)) Exp   deriving (Show)  instance FreeIn AtomicOp where

@@ -3,10 +3,8 @@ -- | Multicore imperative code. module Futhark.CodeGen.ImpCode.Multicore   ( Program,-    Function,-    FunctionT (Function),-    Code,     Multicore (..),+    MCCode,     Scheduling (..),     SchedulerInfo (..),     AtomicOp (..),@@ -15,23 +13,16 @@   ) where -import Futhark.CodeGen.ImpCode hiding (Code, Function)-import qualified Futhark.CodeGen.ImpCode as Imp+import Futhark.CodeGen.ImpCode import Futhark.Util.Pretty --- | An imperative program.-type Program = Imp.Functions Multicore---- | An imperative function.-type Function = Imp.Function Multicore---- | A piece of imperative code, with multicore operations inside.-type Code = Imp.Code Multicore+-- | An imperative multicore program.+type Program = Functions Multicore  -- | A multicore operation. data Multicore   = SegOp String [Param] ParallelTask (Maybe ParallelTask) [Param] SchedulerInfo-  | ParLoop String Code [Param]+  | ParLoop String (Code Multicore) [Param]   | -- | Retrieve inclusive start and exclusive end indexes of the     -- chunk we are supposed to be executing.  Only valid immediately     -- inside a 'ParLoop' construct!@@ -44,17 +35,20 @@     GetNumTasks VName   | Atomic AtomicOp +-- | Multicore code.+type MCCode = Code Multicore+ -- | Atomic operations return the value stored before the update. -- This old value is stored in the first 'VName'.  The second 'VName' -- is the memory block to update.  The 'Exp' is the new value. data AtomicOp-  = AtomicAdd IntType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicSub IntType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicAnd IntType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicOr IntType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicXor IntType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicXchg PrimType VName VName (Count Elements (Imp.TExp Int32)) Exp-  | AtomicCmpXchg PrimType VName VName (Count Elements (Imp.TExp Int32)) VName Exp+  = AtomicAdd IntType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicSub IntType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicAnd IntType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicOr IntType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicXor IntType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicXchg PrimType VName VName (Count Elements (TExp Int32)) Exp+  | AtomicCmpXchg PrimType VName VName (Count Elements (TExp Int32)) VName Exp   deriving (Show)  instance FreeIn AtomicOp where@@ -66,12 +60,17 @@   freeIn' (AtomicCmpXchg _ _ arr i retval x) = freeIn' arr <> freeIn' i <> freeIn' x <> freeIn' retval   freeIn' (AtomicXchg _ _ arr i x) = freeIn' arr <> freeIn' i <> freeIn' x +-- | Information about parallel work that is do be done.  This is+-- passed to the scheduler to help it make scheduling decisions. data SchedulerInfo = SchedulerInfo-  { iterations :: Imp.Exp, -- The number of total iterations for a task-    scheduling :: Scheduling -- The type scheduling for the task+  { -- | The number of total iterations for a task.+    iterations :: Exp,+    -- | The type scheduling for the task.+    scheduling :: Scheduling   } -newtype ParallelTask = ParallelTask Code+-- | A task for a v'SegOp'.+newtype ParallelTask = ParallelTask (Code Multicore)  -- | Whether the Scheduler should schedule the tasks as Dynamic -- or it is restainted to Static

@@ -8,11 +8,9 @@ -- operation that allows one to execute an OpenCL kernel. module Futhark.CodeGen.ImpCode.OpenCL   ( Program (..),-    Function,-    FunctionT (Function),-    Code,     KernelName,     KernelArg (..),+    CLCode,     OpenCL (..),     KernelSafety (..),     numFailureParams,@@ -25,8 +23,7 @@  import qualified Data.Map as M import qualified Data.Text as T-import Futhark.CodeGen.ImpCode hiding (Code, Function)-import qualified Futhark.CodeGen.ImpCode as Imp+import Futhark.CodeGen.ImpCode import Futhark.IR.GPU.Sizes import Futhark.Util.Pretty @@ -52,11 +49,8 @@     failureBacktrace :: String   } --- | A function calling OpenCL kernels.-type Function = Imp.Function OpenCL- -- | A piece of code calling OpenCL.-type Code = Imp.Code OpenCL+type CLCode = Code OpenCL  -- | The name of a kernel. type KernelName = Name

@@ -1,26 +1,16 @@ -- | Sequential imperative code. module Futhark.CodeGen.ImpCode.Sequential   ( Program,-    Function,-    FunctionT (Function),-    Code,     Sequential,     module Futhark.CodeGen.ImpCode,   ) where -import Futhark.CodeGen.ImpCode hiding (Code, Function)-import qualified Futhark.CodeGen.ImpCode as Imp+import Futhark.CodeGen.ImpCode import Futhark.Util.Pretty  -- | An imperative program.-type Program = Imp.Definitions Sequential---- | An imperative function.-type Function = Imp.Function Sequential---- | A piece of imperative code.-type Code = Imp.Code Sequential+type Program = Definitions Sequential  -- | Phantom type for identifying sequential imperative code. data Sequential

@@ -130,6 +130,7 @@ import qualified Data.DList as DL import Data.Either import Data.List (find)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S@@ -155,13 +156,13 @@ import Prelude hiding (quot)  -- | How to compile an t'Op'.-type OpCompiler rep r op = Pat rep -> Op rep -> ImpM rep r op ()+type OpCompiler rep r op = Pat (LetDec rep) -> Op rep -> ImpM rep r op ()  -- | How to compile some 'Stms'. type StmsCompiler rep r op = Names -> Stms rep -> ImpM rep r op () -> ImpM rep r op ()  -- | How to compile an 'Exp'.-type ExpCompiler rep r op = Pat rep -> Exp rep -> ImpM rep r op ()+type ExpCompiler rep r op = Pat (LetDec rep) -> Exp rep -> ImpM rep r op ()  type CopyCompiler rep r op =   PrimType ->@@ -377,7 +378,7 @@    putNameSource $ stateNameSource s''   warnings $ stateWarnings s''-  return (x, stateCode s'')+  pure (x, stateCode s'')  -- | Execute a code generation action, returning the code that was -- emitted.@@ -391,7 +392,7 @@   x <- m   new_code <- gets stateCode   modify $ \s -> s {stateCode = prev_code}-  return (x, new_code)+  pure (x, new_code)  -- | Execute a code generation action, wrapping the generated code -- within a 'Imp.Comment' with the given description.@@ -561,7 +562,7 @@           ++ mkExts epts fparams       mkExts _ _ = [] -  return (inparams, arrayds, mkExts eparams val_params)+  pure (inparams, arrayds, mkExts eparams val_params)   where     isArrayDecl x (ArrayDecl y _ _) = x == y @@ -636,7 +637,7 @@   evs <- case maybe_orig_epts of     Just orig_epts -> compileExternalValues orig_rts orig_epts maybe_params     Nothing -> pure []-  return (evs, catMaybes maybe_params, dests)+  pure (evs, catMaybes maybe_params, dests)  compileFunDef ::   Mem rep inner =>@@ -664,9 +665,9 @@       compileStms (freeIn ses) stms $         forM_ (zip dests ses) $ \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] -      return (outparams, inparams, results, args)+      pure (outparams, inparams, results, args) -compileBody :: Pat rep -> Body rep -> ImpM rep r op ()+compileBody :: Pat (LetDec rep) -> Body rep -> ImpM rep r op () compileBody pat (Body _ stms ses) = do   dests <- destinationFromPat pat   compileStms (freeIn ses) stms $@@ -692,12 +693,12 @@         Prim pt -> do           emit $ Imp.DeclareScalar tmp Imp.Nonvolatile pt           emit $ Imp.SetScalar tmp $ toExp' pt se-          return $ emit $ Imp.SetScalar (paramName p) $ Imp.var tmp pt+          pure $ emit $ Imp.SetScalar (paramName p) $ Imp.var tmp pt         Mem space | Var v <- se -> do           emit $ Imp.DeclareMem tmp space           emit $ Imp.SetMem tmp v space-          return $ emit $ Imp.SetMem (paramName p) tmp space-        _ -> return $ return ()+          pure $ emit $ Imp.SetMem (paramName p) tmp space+        _ -> pure $ pure ()     sequence_ copy_to_merge_params  compileStms :: Names -> Stms rep -> ImpM rep r op () -> ImpM rep r op ()@@ -734,25 +735,25 @@       mapM_ (emit . uncurry Imp.Free) to_free       emit bs_code -      return $ freeIn e_code <> live_after+      pure $ freeIn e_code <> live_after     compileStms' _ [] = do       code <- collect m       emit code-      return $ freeIn code <> alive_after_stms+      pure $ freeIn code <> alive_after_stms      patternAllocs = S.fromList . mapMaybe isMemPatElem . patElems     isMemPatElem pe = case patElemType pe of       Mem space -> Just (patElemName pe, space)       _ -> Nothing -compileExp :: Pat rep -> Exp rep -> ImpM rep r op ()+compileExp :: Pat (LetDec rep) -> Exp rep -> ImpM rep r op () compileExp pat e = do   ec <- asks envExpCompiler   ec pat e  defCompileExp ::   (Mem rep inner) =>-  Pat rep ->+  Pat (LetDec rep) ->   Exp rep ->   ImpM rep r op () defCompileExp pat (If cond tbranch fbranch _) =@@ -766,9 +767,9 @@     compileArg (se, _) = do       t <- subExpType se       case (se, t) of-        (_, Prim pt) -> return $ Just $ Imp.ExpArg $ toExp' pt se-        (Var v, Mem {}) -> return $ Just $ Imp.MemArg v-        _ -> return Nothing+        (_, Prim pt) -> pure $ Just $ Imp.ExpArg $ toExp' pt se+        (Var v, Mem {}) -> pure $ Just $ Imp.MemArg v+        _ -> pure Nothing defCompileExp pat (BasicOp op) = defCompileBasicOp pat op defCompileExp pat (DoLoop merge form body) = do   attrs <- askAttrs@@ -787,7 +788,7 @@             | Prim _ <- paramType p =               copyDWIM (paramName p) [] (Var a) [DimFix $ Imp.le64 i]             | otherwise =-              return ()+              pure ()        bound' <- toExp bound @@ -834,7 +835,7 @@  defCompileBasicOp ::   Mem rep inner =>-  Pat rep ->+  Pat (LetDec rep) ->   BasicOp ->   ImpM rep r op () defCompileBasicOp (Pat [pe]) (SubExp se) =@@ -877,7 +878,7 @@   | Just idxs <- sliceIndices slice =     copyDWIM (patElemName pe) [] (Var src) $ map (DimFix . toInt64Exp) idxs defCompileBasicOp _ Index {} =-  return ()+  pure () defCompileBasicOp (Pat [pe]) (Update safety _ slice se) =   case safety of     Unsafe -> write@@ -902,7 +903,7 @@     copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.le64) is) se []     emit $ foldl (.) id (zipWith Imp.For is ds') copy_elem defCompileBasicOp _ Scratch {} =-  return ()+  pure () defCompileBasicOp (Pat [pe]) (Iota n e s it) = do   e' <- toExp e   s' <- toExp s@@ -917,7 +918,7 @@   copyDWIM (patElemName pe) [] (Var src) [] defCompileBasicOp (Pat [pe]) (Manifest _ src) =   copyDWIM (patElemName pe) [] (Var src) []-defCompileBasicOp (Pat [pe]) (Concat i x ys _) = do+defCompileBasicOp (Pat [pe]) (Concat i (x :| ys) _) = do   offs_glb <- dPrimV "tmp_offs" 0    forM_ (x : ys) $ \y -> do@@ -951,11 +952,11 @@     isLiteral (Constant v) = Just v     isLiteral _ = Nothing defCompileBasicOp _ Rearrange {} =-  return ()+  pure () defCompileBasicOp _ Rotate {} =-  return ()+  pure () defCompileBasicOp _ Reshape {} =-  return ()+  pure () 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@@ -1025,7 +1026,7 @@ dVars ::   Mem rep inner =>   Maybe (Exp rep) ->-  [PatElem rep] ->+  [PatElem (LetDec rep)] ->   ImpM rep r op () dVars e = mapM_ dVar   where@@ -1043,7 +1044,7 @@   emit $ Imp.DeclareScalar name' Imp.Volatile t   addVar name' $ ScalarVar Nothing $ ScalarEntry t   name' <~~ untyped e-  return $ TV name' t+  pure $ TV name' t  dPrim_ :: VName -> PrimType -> ImpM rep r op () dPrim_ name t = do@@ -1057,7 +1058,7 @@ dPrim name t = do   name' <- newVName name   dPrim_ name' t-  return $ TV name' t+  pure $ TV name' t  dPrimV_ :: VName -> Imp.TExp t -> ImpM rep r op () dPrimV_ name e = do@@ -1070,13 +1071,13 @@ dPrimV name e = do   name' <- dPrim name $ primExpType $ untyped e   name' <-- e-  return name'+  pure name'  dPrimVE :: String -> Imp.TExp t -> ImpM rep r op (Imp.TExp t) dPrimVE name e = do   name' <- dPrim name $ primExpType $ untyped e   name' <-- e-  return $ tvExp name'+  pure $ tvExp name'  memBoundToVarEntry ::   Maybe (Exp rep) ->@@ -1120,9 +1121,9 @@     ScalarVar _ entry' ->       emit $ Imp.DeclareScalar name Imp.Nonvolatile $ entryScalarType entry'     ArrayVar _ _ ->-      return ()+      pure ()     AccVar {} ->-      return ()+      pure ()   addVar name entry  dScope ::@@ -1148,11 +1149,11 @@   concat <$> mapM funcallTarget dests   where     funcallTarget (ScalarDestination name) =-      return [name]+      pure [name]     funcallTarget (ArrayDestination _) =-      return []+      pure []     funcallTarget (MemoryDestination name) =-      return [name]+      pure [name]  -- | A typed variable, which we can turn into a typed expression, or -- use as the target for an assignment.  This is used to aid in type@@ -1196,11 +1197,11 @@  instance ToExp SubExp where   toExp (Constant v) =-    return $ Imp.ValueExp v+    pure $ Imp.ValueExp v   toExp (Var v) =     lookupVar v >>= \case       ScalarVar _ (ScalarEntry pt) ->-        return $ Imp.var v pt+        pure $ Imp.var v pt       _ -> error $ "toExp SubExp: SubExp is not a primitive type: " ++ pretty v    toExp' _ (Constant v) = Imp.ValueExp v@@ -1230,7 +1231,7 @@ nameForFun :: String -> ImpM rep r op Name nameForFun s = do   fname <- askFunction-  return $ maybe "" (<> ".") fname <> nameFromString s+  pure $ maybe "" (<> ".") fname <> nameFromString s  askEnv :: ImpM rep r op r askEnv = asks envEnv@@ -1272,27 +1273,27 @@   putVTable $ f old_vtable   a <- m   putVTable old_vtable-  return a+  pure a  lookupVar :: VName -> ImpM rep r op (VarEntry rep) lookupVar name = do   res <- gets $ M.lookup name . stateVTable   case res of-    Just entry -> return entry+    Just entry -> pure entry     _ -> error $ "Unknown variable: " ++ pretty name  lookupArray :: VName -> ImpM rep r op ArrayEntry lookupArray name = do   res <- lookupVar name   case res of-    ArrayVar _ entry -> return entry+    ArrayVar _ entry -> pure entry     _ -> error $ "ImpGen.lookupArray: not an array: " ++ pretty name  lookupMemory :: VName -> ImpM rep r op MemEntry lookupMemory name = do   res <- lookupVar name   case res of-    MemVar _ entry -> return entry+    MemVar _ entry -> pure entry     _ -> error $ "Unknown memory block: " ++ pretty name  lookupArraySpace :: VName -> ImpM rep r op Space@@ -1327,12 +1328,12 @@             )         Just (arrs@(arr : _), Nothing) -> do           space <- lookupArraySpace arr-          return (acc, space, arrs, map toInt64Exp (shapeDims ispace), Nothing)+          pure (acc, space, arrs, map toInt64Exp (shapeDims ispace), Nothing)         Nothing ->           error $ "ImpGen.lookupAcc: unlisted accumulator: " ++ pretty name     _ -> error $ "ImpGen.lookupAcc: not an accumulator: " ++ pretty name -destinationFromPat :: Pat rep -> ImpM rep r op [ValueDestination]+destinationFromPat :: Pat (LetDec rep) -> ImpM rep r op [ValueDestination] destinationFromPat = mapM inspect . patElems   where     inspect pe = do@@ -1340,13 +1341,13 @@       entry <- lookupVar name       case entry of         ArrayVar _ (ArrayEntry MemLoc {} _) ->-          return $ ArrayDestination Nothing+          pure $ ArrayDestination Nothing         MemVar {} ->-          return $ MemoryDestination name+          pure $ MemoryDestination name         ScalarVar {} ->-          return $ ScalarDestination name+          pure $ ScalarDestination name         AccVar {} ->-          return $ ArrayDestination Nothing+          pure $ ArrayDestination Nothing  fullyIndexArray ::   VName ->@@ -1371,14 +1372,23 @@ -- More complicated read/write operations that use index functions.  copy :: CopyCompiler rep r op-copy bt dest src =-  unless-    ( memLocName dest == memLocName src-        && memLocIxFun dest `IxFun.equivalent` memLocIxFun src-    )-    $ do-      cc <- asks envCopyCompiler-      cc bt dest src+copy+  bt+  dst@(MemLoc dst_name _ dst_ixfn@(IxFun.IxFun dst_lmads@(dst_lmad :| _) _ _))+  src@(MemLoc src_name _ src_ixfn@(IxFun.IxFun src_lmads@(src_lmad :| _) _ _)) = do+    -- If we can statically determine that the two index-functions+    -- are equivalent, don't do anything+    unless (dst_name == src_name && dst_ixfn `IxFun.equivalent` src_ixfn) $+      -- It's also possible that we can dynamically determine that the two+      -- index-functions are equivalent.+      sUnless+        ( fromBool (dst_name == src_name && length dst_lmads == 1 && length src_lmads == 1)+            .&&. IxFun.dynamicEqualsLMAD dst_lmad src_lmad+        )+        $ do+          -- If none of the above is true, actually do the copy+          cc <- asks envCopyCompiler+          cc bt dst src  -- | Is this copy really a mapping with transpose? isMapTransposeCopy ::@@ -1434,7 +1444,7 @@   exists <- hasFunction fname   unless exists $ emitFunction fname $ mapTransposeFunction fname bt -  return fname+  pure fname  -- | Use an 'Imp.Copy' if possible, otherwise 'copyElementWise'. defaultCopy :: CopyCompiler rep r op@@ -1646,10 +1656,10 @@               pretty dest_slice             ]     (ArrayDestination Nothing, _) ->-      return () -- Nothing to do; something else set some memory+      pure () -- Nothing to do; something else set some memory       -- somewhere.     (_, AccVar {}) ->-      return () -- Nothing to do; accumulators are phantoms.+      pure () -- 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.@@ -1686,11 +1696,11 @@ copyDWIMFix dest dest_is src src_is =   copyDWIM dest (map DimFix dest_is) src (map DimFix src_is) --- | @compileAlloc pat size space@ allocates @n@ bytes of memory in @space@,--- writing the result to @dest@, which must be a single--- 'MemoryDestination',+-- | @compileAlloc pat size space@ allocates @n@ bytes of memory in+-- @space@, writing the result to @pat@, which must contain a single+-- memory-typed element. compileAlloc ::-  Mem rep inner => Pat rep -> SubExp -> Space -> ImpM rep r op ()+  Mem rep inner => Pat (LetDec rep) -> SubExp -> Space -> ImpM rep r op () compileAlloc (Pat [mem]) e space = do   let e' = Imp.bytes $ toInt64Exp e   allocator <- asks $ M.lookup space . envAllocCompilers@@ -1771,7 +1781,7 @@   name' <- newVName name   emit $ Imp.DeclareMem name' space   addVar name' $ MemVar Nothing $ MemEntry space-  return name'+  pure name'  sAlloc_ :: VName -> Count Bytes (Imp.TExp Int64) -> Space -> ImpM rep r op () sAlloc_ name' size' space = do@@ -1784,13 +1794,13 @@ sAlloc name size space = do   name' <- sDeclareMem name space   sAlloc_ name' size space-  return name'+  pure name'  sArray :: String -> PrimType -> ShapeBase SubExp -> VName -> IxFun -> ImpM rep r op VName sArray name bt shape mem ixfun = do   name' <- newVName name   dArray name' bt shape mem ixfun-  return name'+  pure name'  -- | Declare an array in row-major order in the given memory block. sArrayInMem :: String -> PrimType -> ShapeBase SubExp -> VName -> ImpM rep r op VName

@@ -106,7 +106,7 @@ compileProgCUDA = compileProg $ HostEnv cudaAtomics CUDA mempty  opCompiler ::-  Pat GPUMem ->+  Pat LetDecMem ->   Op GPUMem ->   CallKernelGen () opCompiler dest (Alloc e space) =@@ -158,7 +158,7 @@ sizeClassWithEntryPoint _ size_class = size_class  segOpCompiler ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegOp SegLevel GPUMem ->   CallKernelGen () segOpCompiler pat (SegMap lvl space _ kbody) =@@ -178,7 +178,7 @@ -- otherwise protected by their own multi-versioning branches deeper -- down.  Currently the compiler will not generate multi-versioning -- that makes this a problem, but it might in the future.-checkLocalMemoryReqs :: Imp.Code -> CallKernelGen (Maybe (Imp.TExp Bool))+checkLocalMemoryReqs :: Imp.HostCode -> CallKernelGen (Maybe (Imp.TExp Bool)) checkLocalMemoryReqs code = do   scope <- askScope   let alloc_sizes = map (sum . map alignedSize . localAllocSizes . Imp.kernelBody) $ getGPU code@@ -211,7 +211,7 @@     alignedSize x = x + ((8 - (x `rem` 8)) `rem` 8)  withAcc ::-  Pat GPUMem ->+  Pat LetDecMem ->   [(Shape, [VName], Maybe (Lambda GPUMem, [SubExp]))] ->   Lambda GPUMem ->   CallKernelGen ()@@ -313,7 +313,7 @@ mapTransposeName :: PrimType -> String mapTransposeName bt = "gpu_map_transpose_" ++ pretty bt -mapTransposeFunction :: PrimType -> Imp.Function+mapTransposeFunction :: PrimType -> Imp.Function Imp.HostOp mapTransposeFunction bt =   Imp.Function Nothing [] params transpose_code [] []   where

@@ -107,7 +107,7 @@ -- | The sizes of nested iteration spaces in the kernel. type SegOpSizes = S.Set [SubExp] --- | Find the sizes of nested parallelism in a 'SegOp' body.+-- | Find the sizes of nested parallelism in a t'SegOp' body. segOpSizes :: Stms GPUMem -> SegOpSizes segOpSizes = onStms   where@@ -172,7 +172,7 @@   sOp $ Imp.LocalAlloc mem size  kernelAlloc ::-  Pat GPUMem ->+  Pat LetDecMem ->   SubExp ->   Space ->   InKernelGen ()@@ -189,7 +189,7 @@  splitSpace ::   (ToExp w, ToExp i, ToExp elems_per_thread) =>-  Pat GPUMem ->+  Pat LetDecMem ->   SplitOrdering ->   w ->   i ->@@ -246,8 +246,8 @@  -- | Assign iterations of a for-loop to all threads in the kernel. -- The passed-in function is invoked with the (symbolic) iteration.--- 'threadOperations' will be in effect in the body.  For--- multidimensional loops, use 'groupCoverSpace'.+-- The body must contain thread-level code.  For multidimensional+-- loops, use 'groupCoverSpace'. kernelLoop ::   IntExp t =>   Imp.TExp t ->@@ -506,7 +506,7 @@ -- -- 2. Executes the body of @lam@. ----- 3. Binds the 'SubExp's that are the 'Result' of @lam@ to the+-- 3. Binds the t'SubExp's that are the 'Result' of @lam@ to the -- provided @dest@s, again interpreted as the destination for a -- 'copyDWIM'. applyLambda ::@@ -1942,7 +1942,7 @@  compileGroupResult ::   SegSpace ->-  PatElem GPUMem ->+  PatElem LetDecMem ->   KernelResult ->   InKernelGen () compileGroupResult _ pe (TileReturns _ [(w, per_group_elems)] what) = do@@ -2035,7 +2035,7 @@  compileThreadResult ::   SegSpace ->-  PatElem GPUMem ->+  PatElem LetDecMem ->   KernelResult ->   InKernelGen () compileThreadResult _ _ RegTileReturns {} =

@@ -378,7 +378,7 @@       return (l', do_op')  histKernelGlobalPass ::-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Count NumGroups (Imp.TExp Int64) ->   Count GroupSize (Imp.TExp Int64) ->   SegSpace ->@@ -469,7 +469,7 @@                       do_op (bucket_is ++ is)  histKernelGlobal ::-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -577,7 +577,7 @@ histKernelLocalPass ::   TV Int32 ->   Count NumGroups (Imp.TExp Int64) ->-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Count NumGroups (Imp.TExp Int64) ->   Count GroupSize (Imp.TExp Int64) ->   SegSpace ->@@ -825,7 +825,7 @@ histKernelLocal ::   TV Int32 ->   Count NumGroups (Imp.TExp Int64) ->-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -869,7 +869,7 @@     AtomicLocking _ -> 6  localMemoryCase ::-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Imp.TExp Int32 ->   SegSpace ->   Imp.TExp Int64 ->@@ -1024,7 +1024,7 @@  -- | Generate code for a segmented histogram called from the host. compileSegHist ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->

@@ -17,7 +17,7 @@  -- | Compile 'SegMap' instance code. compileSegMap ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   KernelBody GPUMem ->

@@ -77,7 +77,7 @@ -- | Compile 'SegRed' instance to host-level code with calls to -- various kernels. compileSegRed ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   [SegBinOp GPUMem] ->@@ -96,7 +96,7 @@  -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   [SegBinOp GPUMem] ->@@ -171,7 +171,7 @@       sAllocArrayPerm "segred_tmp" pt full_shape (Space "device") perm  nonsegmentedReduction ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -255,7 +255,7 @@   emit $ Imp.DebugPrint "" Nothing  smallSegmentsReduction ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -364,7 +364,7 @@   emit $ Imp.DebugPrint "" Nothing  largeSegmentsReduction ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -702,7 +702,7 @@  reductionStageTwo ::   KernelConstants ->-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   Imp.TExp Int32 ->   Imp.TExp Int32 ->   [Imp.TExp Int64] ->

@@ -49,7 +49,7 @@ -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. compileSegScan ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   [SegBinOp GPUMem] ->

@@ -209,7 +209,7 @@ -- | Compile 'SegScan' instance to host-level code with calls to a -- single-pass kernel. compileSegScan ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   SegBinOp GPUMem ->

@@ -92,7 +92,7 @@  writeToScanValues ::   [VName] ->-  ([PatElem GPUMem], SegBinOp GPUMem, [KernelResult]) ->+  ([PatElem LetDecMem], SegBinOp GPUMem, [KernelResult]) ->   InKernelGen () writeToScanValues gtids (pes, scan, scan_res)   | shapeRank (segBinOpShape scan) > 0 =@@ -108,7 +108,7 @@  readToScanValues ::   [Imp.TExp Int64] ->-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   SegBinOp GPUMem ->   InKernelGen () readToScanValues is pes scan@@ -123,7 +123,7 @@   Imp.TExp Int64 ->   [Imp.TExp Int64] ->   [Imp.TExp Int64] ->-  [PatElem GPUMem] ->+  [PatElem LetDecMem] ->   SegBinOp GPUMem ->   InKernelGen () readCarries chunk_id chunk_offset dims' vec_is pes scan@@ -146,7 +146,7 @@  -- | Produce partially scanned intervals; one per workgroup. scanStage1 ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   SegSpace ->@@ -317,7 +317,7 @@   return (num_threads, elems_per_group, crossesSegment)  scanStage2 ::-  Pat GPUMem ->+  Pat LetDecMem ->   TV Int32 ->   Imp.TExp Int64 ->   Count NumGroups SubExp ->@@ -394,7 +394,7 @@                   [localArrayIndex constants t]  scanStage3 ::-  Pat GPUMem ->+  Pat LetDecMem ->   Count NumGroups SubExp ->   Count GroupSize SubExp ->   Imp.TExp Int64 ->@@ -481,7 +481,7 @@ -- | Compile 'SegScan' instance to host-level code with calls to -- various kernels. compileSegScan ::-  Pat GPUMem ->+  Pat LetDecMem ->   SegLevel ->   SegSpace ->   [SegBinOp GPUMem] ->

@@ -3,7 +3,7 @@ {-# LANGUAGE TupleSections #-}  -- | This module defines a translation from imperative code with--- kernels to imperative code with OpenCL calls.+-- kernels to imperative code with OpenCL or CUDA calls. module Futhark.CodeGen.ImpGen.GPU.ToOpenCL   ( kernelsToOpenCL,     kernelsToCUDA,@@ -33,8 +33,12 @@ import qualified Language.C.Syntax as C import NeatInterpolation (untrimming) -kernelsToCUDA, kernelsToOpenCL :: ImpGPU.Program -> ImpOpenCL.Program+-- | Generate CUDA host and device code.+kernelsToCUDA :: ImpGPU.Program -> ImpOpenCL.Program kernelsToCUDA = translateGPU TargetCUDA++-- | Generate OpenCL host and device code.+kernelsToOpenCL :: ImpGPU.Program -> ImpOpenCL.Program kernelsToOpenCL = translateGPU TargetOpenCL  -- | Translate a kernels-program to an OpenCL-program.@@ -134,7 +138,7 @@  type AllFunctions = ImpGPU.Functions ImpGPU.HostOp -lookupFunction :: Name -> AllFunctions -> Maybe ImpGPU.Function+lookupFunction :: Name -> AllFunctions -> Maybe (ImpGPU.Function HostOp) lookupFunction fname (ImpGPU.Functions fs) = lookup fname fs  type OnKernelM = ReaderT AllFunctions (State ToOpenCL)@@ -168,14 +172,9 @@  -- Compilation of a device function that is not not invoked from the -- host, but is invoked by (perhaps multiple) kernels.-generateDeviceFun :: Name -> ImpGPU.Function -> OnKernelM ()-generateDeviceFun fname host_func = do-  -- Functions are a priori always considered host-level, so we have-  -- to convert them to device code.  This is where most of our-  -- limitations on device-side functions (no arrays, no parallelism)-  -- comes from.-  let device_func = fmap toDevice host_func-  when (any memParam $ functionInput host_func) bad+generateDeviceFun :: Name -> ImpGPU.Function ImpGPU.KernelOp -> OnKernelM ()+generateDeviceFun fname device_func = do+  when (any memParam $ functionInput device_func) bad    failures <- gets clFailures @@ -199,9 +198,6 @@   -- right clFailures.   void $ ensureDeviceFuns $ functionBody device_func   where-    toDevice :: HostOp -> KernelOp-    toDevice _ = bad-     memParam MemParam {} = True     memParam ScalarParam {} = False @@ -209,7 +205,7 @@  -- Ensure that this device function is available, but don't regenerate -- it if it already exists.-ensureDeviceFun :: Name -> ImpGPU.Function -> OnKernelM ()+ensureDeviceFun :: Name -> ImpGPU.Function ImpGPU.KernelOp -> OnKernelM () ensureDeviceFun fname host_func = do   exists <- gets $ M.member fname . clDevFuns   unless exists $ generateDeviceFun fname host_func@@ -221,10 +217,19 @@     forM (S.toList called) $ \fname -> do       def <- asks $ lookupFunction fname       case def of-        Just func -> do-          ensureDeviceFun fname func+        Just host_func -> do+          -- Functions are a priori always considered host-level, so we have+          -- to convert them to device code.  This is where most of our+          -- limitations on device-side functions (no arrays, no parallelism)+          -- comes from.+          let device_func = fmap toDevice host_func+          ensureDeviceFun fname device_func           return $ Just fname         Nothing -> return Nothing+  where+    bad = compilerLimitationS "Cannot generate GPU functions that contain parallelism."+    toDevice :: HostOp -> KernelOp+    toDevice _ = bad  onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL onKernel target kernel = do

@@ -83,7 +83,7 @@                 error $ "Missing locks for " ++ pretty acc  withAcc ::-  Pat MCMem ->+  Pat LetDecMem ->   [(Shape, [VName], Maybe (Lambda MCMem, [SubExp]))] ->   Lambda MCMem ->   MulticoreGen ()@@ -116,7 +116,7 @@   defCompileExp dest e  compileMCOp ::-  Pat MCMem ->+  Pat LetDecMem ->   MCOp MCMem () ->   ImpM MCMem HostEnv Imp.Multicore () compileMCOp _ (OtherOp ()) = pure ()@@ -151,10 +151,10 @@       scheduling_info (decideScheduling' op seq_code)  compileSegOp ::-  Pat MCMem ->+  Pat LetDecMem ->   SegOp () MCMem ->   TV Int32 ->-  ImpM MCMem HostEnv Imp.Multicore Imp.Code+  ImpM MCMem HostEnv Imp.Multicore Imp.MCCode compileSegOp pat (SegHist _ space histops _ kbody) ntasks =   compileSegHist pat space histops kbody ntasks compileSegOp pat (SegScan _ space scans _ kbody) ntasks =

@@ -13,6 +13,7 @@     renameHistOpLambda,     atomicUpdateLocking,     AtomicUpdate (..),+    DoAtomicUpdate,     Locking (..),     getSpace,     getLoopBounds,@@ -103,7 +104,7 @@  -- When the SegRed's return value is a scalar -- we perform a call by value-result in the segop function-getReturnParams :: Pat MCMem -> SegOp () MCMem -> MulticoreGen [Imp.Param]+getReturnParams :: Pat LetDecMem -> SegOp () MCMem -> MulticoreGen [Imp.Param] getReturnParams pat SegRed {} =   -- It's a good idea to make sure any prim values are initialised, as   -- we will load them (redundantly) in the task code, and@@ -123,7 +124,7 @@  compileThreadResult ::   SegSpace ->-  PatElem MCMem ->+  PatElem LetDecMem ->   KernelResult ->   MulticoreGen () compileThreadResult space pe (Returns _ _ what) = do@@ -156,7 +157,7 @@       let full_shape = Shape [num_threads] <> shape <> arrayShape t       sAllocArray s (elemType t) full_shape DefaultSpace -isLoadBalanced :: Imp.Code -> Bool+isLoadBalanced :: Imp.MCCode -> Bool isLoadBalanced (a Imp.:>>: b) = isLoadBalanced a && isLoadBalanced b isLoadBalanced (Imp.For _ _ a) = isLoadBalanced a isLoadBalanced (Imp.If _ a b) = isLoadBalanced a && isLoadBalanced b@@ -168,7 +169,7 @@ segBinOpComm' :: [SegBinOp rep] -> Commutativity segBinOpComm' = mconcat . map segBinOpComm -decideScheduling' :: SegOp () rep -> Imp.Code -> Imp.Scheduling+decideScheduling' :: SegOp () rep -> Imp.MCCode -> Imp.Scheduling decideScheduling' SegHist {} _ = Imp.Static decideScheduling' SegScan {} _ = Imp.Static decideScheduling' (SegRed _ _ reds _ _) code =@@ -177,16 +178,16 @@     Noncommutative -> Imp.Static decideScheduling' SegMap {} code = decideScheduling code -decideScheduling :: Imp.Code -> Imp.Scheduling+decideScheduling :: Imp.MCCode -> Imp.Scheduling decideScheduling code =   if isLoadBalanced code     then Imp.Static     else Imp.Dynamic  -- | Try to extract invariant allocations.  If we assume that the--- given 'Imp.Code' is the body of a 'SegOp', then it is always safe+-- given 'Imp.MCCode' is the body of a 'SegOp', then it is always safe -- to move the immediate allocations to the prebody.-extractAllocations :: Imp.Code -> (Imp.Code, Imp.Code)+extractAllocations :: Imp.MCCode -> (Imp.MCCode, Imp.MCCode) extractAllocations segop_code = f segop_code   where     declared = Imp.declaredIn segop_code

@@ -16,12 +16,12 @@ import Prelude hiding (quot, rem)  compileSegHist ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   KernelBody MCMem ->   TV Int32 ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegHist pat space histops kbody nsubtasks   | [_] <- unSegSpace space =     nonsegmentedHist pat space histops kbody nsubtasks@@ -37,12 +37,12 @@ histSize = product . map toInt64Exp . shapeDims . histShape  nonsegmentedHist ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   KernelBody MCMem ->   TV Int32 ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode nonsegmentedHist pat space histops kbody num_histos = do   let ns = map snd $ unSegSpace space       ns_64 = map toInt64Exp ns@@ -91,7 +91,7 @@       return $ f l'  atomicHistogram ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   KernelBody MCMem ->@@ -161,7 +161,7 @@ -- across the histogram indicies. -- This is expected to be fast if len(histDest) is small subHistogram ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   TV Int32 ->@@ -287,11 +287,11 @@ -- parallelize over the segments, -- where each segment is updated sequentially. segmentedHist ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode segmentedHist pat space histops kbody = do   emit $ Imp.DebugPrint "Segmented segHist" Nothing   collect $ do@@ -300,11 +300,11 @@     emit $ Imp.Op $ Imp.ParLoop "segmented_hist" body free_params  compileSegHistBody ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [HistOp MCMem] ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegHistBody pat space histops kbody = collect $ do   let (is, ns) = unzip $ unSegSpace space       ns_64 = map toInt64Exp ns

@@ -13,7 +13,7 @@  writeResult ::   [VName] ->-  PatElemT dec ->+  PatElem dec ->   KernelResult ->   MulticoreGen () writeResult is pe (Returns _ _ se) =@@ -29,10 +29,10 @@   error $ "writeResult: cannot handle " ++ pretty res  compileSegMapBody ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegMapBody pat space (KernelBody _ kstms kres) = collect $ do   let (is, ns) = unzip $ unSegSpace space       ns' = map toInt64Exp ns@@ -45,10 +45,10 @@       zipWithM_ (writeResult is) (patElems pat) kres  compileSegMap ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegMap pat space kbody = collect $ do   body <- compileSegMapBody pat space kbody   free_params <- freeParams body

@@ -1,6 +1,7 @@ module Futhark.CodeGen.ImpGen.Multicore.SegRed   ( compileSegRed,     compileSegRed',+    DoSegBody,   ) where @@ -16,12 +17,12 @@  -- | Generate code for a SegRed construct compileSegRed ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->   TV Int32 ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegRed pat space reds kbody nsubtasks =   compileSegRed' pat space reds nsubtasks $ \red_cont ->     compileStms mempty (kernelBodyStms kbody) $ do@@ -35,12 +36,12 @@  -- | Like 'compileSegRed', but where the body is a monadic action. compileSegRed' ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   TV Int32 ->   DoSegBody ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegRed' pat space reds nsubtasks kbody   | [_] <- unSegSpace space =     nonsegmentedReduction pat space reds nsubtasks kbody@@ -72,12 +73,12 @@ nextParams slug = drop (length (slugNeutral slug)) $ slugParams slug  nonsegmentedReduction ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   TV Int32 ->   DoSegBody ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode nonsegmentedReduction pat space reds nsubtasks kbody = collect $ do   thread_res_arrs <- groupResultArrays "reduce_stage_1_tid_res_arr" (tvSize nsubtasks) reds   let slugs1 = zipWith SegBinOpSlug reds thread_res_arrs@@ -163,7 +164,7 @@   emit $ Imp.Op $ Imp.ParLoop "segred_stage_1" fbody free_params  reductionStage2 ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   Imp.TExp Int32 ->   [SegBinOpSlug] ->@@ -200,11 +201,11 @@ -- Maybe we should select the work of the inner loop -- based on n_segments and dimensions etc. segmentedReduction ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   DoSegBody ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode segmentedReduction pat space reds kbody =   collect $ do     body <- compileSegRedBody pat space reds kbody@@ -212,11 +213,11 @@     emit $ Imp.Op $ Imp.ParLoop "segmented_segred" body free_params  compileSegRedBody ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   DoSegBody ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegRedBody pat space reds kbody = do   let (is, ns) = unzip $ unSegSpace space       ns_64 = map toInt64Exp ns

@@ -14,12 +14,12 @@  -- Compile a SegScan construct compileSegScan ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->   TV Int32 ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegScan pat space reds kbody nsubtasks   | [_] <- unSegSpace space =     nonsegmentedScan pat space reds kbody nsubtasks@@ -45,12 +45,12 @@       sAllocArray s pt full_shape DefaultSpace  nonsegmentedScan ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->   TV Int32 ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode nonsegmentedScan pat space scan_ops kbody nsubtasks = do   emit $ Imp.DebugPrint "nonsegmented segScan" Nothing   collect $ do@@ -64,7 +64,7 @@       scanStage3 pat space scan_ops3 kbody  scanStage1 ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->@@ -129,7 +129,7 @@   emit $ Imp.Op $ Imp.ParLoop "scan_stage_1" body free_params  scanStage2 ::-  Pat MCMem ->+  Pat LetDecMem ->   TV Int32 ->   SegSpace ->   [SegBinOp MCMem] ->@@ -187,7 +187,7 @@ -- Stage 3 : Finally each thread partially scans a chunk of the input --           reading its corresponding carry-in scanStage3 ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->@@ -252,11 +252,11 @@ -- parallelize over the segments and each segment is -- scanned sequentially. segmentedScan ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode segmentedScan pat space scan_ops kbody = do   emit $ Imp.DebugPrint "segmented segScan" Nothing   collect $ do@@ -265,11 +265,11 @@     emit $ Imp.Op $ Imp.ParLoop "seg_scan" body free_params  compileSegScanBody ::-  Pat MCMem ->+  Pat LetDecMem ->   SegSpace ->   [SegBinOp MCMem] ->   KernelBody MCMem ->-  MulticoreGen Imp.Code+  MulticoreGen Imp.MCCode compileSegScanBody pat space scan_ops kbody = collect $ do   let (is, ns) = unzip $ unSegSpace space       ns_64 = map toInt64Exp ns

@@ -1,3 +1,4 @@+-- | Configuration of compiler behaviour that is universal to all backends. module Futhark.Compiler.Config   ( FutharkConfig (..),     newFutharkConfig,

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  -- | Low-level compilation parts.  Look at "Futhark.Compiler" for a@@ -6,142 +7,227 @@ module Futhark.Compiler.Program   ( readLibrary,     readUntypedLibrary,-    readImports,     Imports,     FileModule (..),     E.Warnings,-    Basis (..),-    emptyBasis,+    LoadedProg (lpNameSource),+    noLoadedProg,+    lpImports,+    reloadProg,+    extendProg,   ) where +import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+  ( MVar,+    modifyMVar,+    newEmptyMVar,+    newMVar,+    putMVar,+    readMVar,+  ) import Control.Monad import Control.Monad.Except-import Control.Monad.State-import Data.List (intercalate, isPrefixOf)-import Data.Maybe+import Control.Monad.State (execStateT, gets, modify)+import Data.Bifunctor (first)+import Data.List (intercalate, isPrefixOf, sort)+import qualified Data.Map as M+import Data.Maybe (mapMaybe) import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.Clock (UTCTime) import Futhark.Error import Futhark.FreshNames-import Futhark.Util (readFileSafely)-import Futhark.Util.Pretty (line, ppr, (</>))+import Futhark.Util (interactWithFileSafely, nubOrd, startupTime)+import Futhark.Util.Pretty (line, ppr, text, (</>)) import qualified Language.Futhark as E import Language.Futhark.Parser import Language.Futhark.Prelude import Language.Futhark.Semantic import qualified Language.Futhark.TypeChecker as E import Language.Futhark.Warnings+import System.Directory (getModificationTime) import System.FilePath (normalise) import qualified System.FilePath.Posix as Posix -newtype ReaderState = ReaderState-  {alreadyRead :: [(ImportName, E.UncheckedProg)]}+data LoadedFile fm = LoadedFile+  { lfPath :: FilePath,+    lfImportName :: ImportName,+    lfMod :: fm,+    -- | Modification time of the underlying file.+    lfModTime :: UTCTime+  }+  deriving (Eq, Ord, Show) --- | A little monad for parsing a Futhark program.-type ReaderM m = StateT ReaderState m+newtype UncheckedImport = UncheckedImport+  { unChecked ::+      Either CompilerError (LoadedFile E.UncheckedProg, [(ImportName, MVar UncheckedImport)])+  } -runReaderM ::-  (MonadError CompilerError m) =>-  ReaderM m a ->-  m [(ImportName, E.UncheckedProg)]-runReaderM m = reverse . alreadyRead <$> execStateT m (ReaderState mempty)+-- | If mapped to Nothing, treat it as present.  This is used when+-- reloading programs.+type ReaderState = MVar (M.Map ImportName (Maybe (MVar UncheckedImport))) -readImportFile ::+newState :: [ImportName] -> IO ReaderState+newState known = newMVar $ M.fromList $ zip known $ repeat Nothing++orderedImports ::   (MonadError CompilerError m, MonadIO m) =>-  ImportName ->-  ReaderM m (T.Text, FilePath)+  [(ImportName, MVar UncheckedImport)] ->+  m [(ImportName, LoadedFile E.UncheckedProg)]+orderedImports = fmap reverse . flip execStateT [] . mapM_ (spelunk [])+  where+    spelunk steps (include, mvar)+      | include `elem` steps =+        externalErrorS $+          "Import cycle: "+            ++ intercalate+              " -> "+              (map includeToString $ reverse $ include : steps)+      | otherwise = do+        prev <- gets $ lookup include+        case prev of+          Just _ -> pure ()+          Nothing -> do+            (file, more_imports) <-+              either throwError pure . unChecked =<< liftIO (readMVar mvar)+            mapM_ (spelunk (include : steps)) more_imports+            modify ((include, file) :)++newImportMVar :: IO UncheckedImport -> IO (Maybe (MVar UncheckedImport))+newImportMVar m = do+  mvar <- newEmptyMVar+  void $ forkIO $ putMVar mvar =<< m+  pure $ Just mvar++contentsAndModTime :: FilePath -> IO (Maybe (Either String (T.Text, UTCTime)))+contentsAndModTime filepath =+  interactWithFileSafely $+    (,) <$> T.readFile filepath <*> getModificationTime filepath++readImportFile :: ImportName -> IO (Either CompilerError (LoadedFile T.Text)) readImportFile include = do   -- First we try to find a file of the given name in the search path,   -- then we look at the builtin library if we have to.  For the   -- builtins, we don't use the search path.   let filepath = includeToFilePath include-  r <- liftIO $ readFileSafely filepath+  r <- contentsAndModTime filepath   case (r, lookup prelude_str prelude) of-    (Just (Right s), _) -> return (s, filepath)-    (Just (Left e), _) -> externalErrorS e-    (Nothing, Just t) -> return (t, prelude_str)-    (Nothing, Nothing) -> externalErrorS not_found+    (Just (Right (s, mod_time)), _) ->+      pure $ Right $ loaded filepath s mod_time+    (Just (Left e), _) -> pure $ Left $ ExternalError $ text e+    (Nothing, Just s) ->+      pure $ Right $ loaded prelude_str s startupTime+    (Nothing, Nothing) -> pure $ Left $ ExternalError $ text not_found   where     prelude_str = "/" Posix.</> includeToString include Posix.<.> "fut" +    loaded path s mod_time =+      LoadedFile+        { lfImportName = include,+          lfPath = path,+          lfMod = s,+          lfModTime = mod_time+        }+     not_found =       "Error at " ++ E.locStr (E.srclocOf include)         ++ ": could not find import '"         ++ includeToString include         ++ "'." -readImport ::-  (MonadError CompilerError m, MonadIO m) =>-  [ImportName] ->-  ImportName ->-  ReaderM m ()-readImport steps include-  | include `elem` steps =-    externalErrorS $-      "Import cycle: "-        ++ intercalate-          " -> "-          (map includeToString $ reverse $ include : steps)-  | otherwise = do-    already_done <- gets $ isJust . lookup include . alreadyRead+handleFile ::+  ReaderState -> LoadedFile T.Text -> IO UncheckedImport+handleFile state_mvar (LoadedFile file_name import_name file_contents mod_time) = do+  case parseFuthark file_name file_contents of+    Left err -> pure $ UncheckedImport $ Left $ ExternalError $ text $ show err+    Right prog -> do+      let imports = map (uncurry (mkImportFrom import_name)) $ E.progImports prog+      mvars <-+        mapMaybe sequenceA . zip imports+          <$> mapM (readImport state_mvar) imports+      let file =+            LoadedFile+              { lfPath = file_name,+                lfImportName = import_name,+                lfModTime = mod_time,+                lfMod = prog+              }+      pure $ UncheckedImport $ Right (file, mvars) -    unless already_done $-      uncurry (handleFile steps include) =<< readImportFile include+readImport :: ReaderState -> ImportName -> IO (Maybe (MVar UncheckedImport))+readImport state_mvar include =+  modifyMVar state_mvar $ \state ->+    case M.lookup include state of+      Just x -> pure (state, x)+      Nothing -> do+        prog_mvar <- newImportMVar $ do+          readImportFile include >>= \case+            Left e -> pure $ UncheckedImport $ Left e+            Right file -> handleFile state_mvar file+        pure (M.insert include prog_mvar state, prog_mvar) -handleFile ::+readUntypedLibraryExceptKnown ::   (MonadIO m, MonadError CompilerError m) =>   [ImportName] ->-  ImportName ->-  T.Text ->-  FilePath ->-  ReaderM m ()-handleFile steps import_name file_contents file_name = do-  prog <- case parseFuthark file_name file_contents of-    Left err -> externalErrorS $ show err-    Right prog -> return prog--  let steps' = import_name : steps-  mapM_ (readImport steps' . uncurry (mkImportFrom import_name)) $-    E.progImports prog--  modify $ \s ->-    s {alreadyRead = (import_name, prog) : alreadyRead s}---- | Pre-typechecked imports, including a starting point for the name source.-data Basis = Basis-  { basisImports :: Imports,-    basisNameSource :: VNameSource,-    -- | Files that should be implicitly opened.-    basisRoots :: [String]-  }+  [FilePath] ->+  m [LoadedFile E.UncheckedProg]+readUntypedLibraryExceptKnown known fps = do+  state_mvar <- liftIO $ newState known+  let prelude_import = mkInitialImport "/prelude/prelude"+  prelude_mvar <- liftIO $ readImport state_mvar prelude_import+  fps_mvars <- liftIO (mapM (onFile state_mvar) fps)+  let unknown_mvars = onlyUnknown ((prelude_import, prelude_mvar) : fps_mvars)+  map snd <$> orderedImports unknown_mvars+  where+    onlyUnknown = mapMaybe sequenceA+    onFile state_mvar fp =+      modifyMVar state_mvar $ \state -> do+        case M.lookup include state of+          Just prog_mvar -> pure (state, (include, prog_mvar))+          Nothing -> do+            prog_mvar <- newImportMVar $ do+              r <- contentsAndModTime fp+              case r of+                Just (Right (fs, mod_time)) -> do+                  handleFile state_mvar $+                    LoadedFile+                      { lfImportName = include,+                        lfMod = fs,+                        lfModTime = mod_time,+                        lfPath = fp+                      }+                Just (Left e) ->+                  pure $ UncheckedImport $ Left $ ExternalError $ text $ show e+                Nothing ->+                  pure $ UncheckedImport $ Left $ ExternalError $ text $ fp <> ": file not found."+            pure (M.insert include prog_mvar state, (include, prog_mvar))+      where+        include = mkInitialImport fp_name+        (fp_name, _) = Posix.splitExtension fp --- | A basis that contains no imports, and has a properly initialised--- name source.-emptyBasis :: Basis-emptyBasis =-  Basis-    { basisImports = mempty,-      basisNameSource = src,-      basisRoots = mempty-    }+asImports :: [LoadedFile (VNameSource, FileModule)] -> Imports+asImports = map f   where-    src = newNameSource $ E.maxIntrinsicTag + 1+    f lf = (includeToString (lfImportName lf), snd $ lfMod lf) -typeCheckProgram ::+typeCheckProg ::   MonadError CompilerError m =>-  Basis ->-  [(ImportName, E.UncheckedProg)] ->-  m (E.Warnings, Imports, VNameSource)-typeCheckProgram basis =-  foldM f (mempty, basisImports basis, basisNameSource basis)+  [LoadedFile (VNameSource, FileModule)] ->+  VNameSource ->+  [LoadedFile E.UncheckedProg] ->+  m (E.Warnings, [LoadedFile (VNameSource, FileModule)], VNameSource)+typeCheckProg orig_imports orig_src =+  foldM f (mempty, orig_imports, orig_src)   where     roots = ["/prelude/prelude"] -    f (ws, imports, src) (import_name, prog) = do+    f (ws, imports, src) (LoadedFile path import_name prog mod_time) = do       let prog'             | "/prelude" `isPrefixOf` includeToFilePath import_name = prog             | otherwise = prependRoots roots prog-      case E.checkProg imports src import_name prog' of+      case E.checkProg (asImports imports) src import_name prog' of         (prog_ws, Left err) -> do           let ws' = ws <> prog_ws           externalError $@@ -151,49 +237,123 @@         (prog_ws, Right (m, src')) ->           pure             ( ws <> prog_ws,-              imports ++ [(includeToString import_name, m)],+              imports ++ [LoadedFile path import_name (src, m) mod_time],               src'             )  setEntryPoints ::   [E.Name] ->   [FilePath] ->-  [(ImportName, E.UncheckedProg)] ->-  [(ImportName, E.UncheckedProg)]-setEntryPoints extra_eps fps = map onProg+  [LoadedFile E.UncheckedProg] ->+  [LoadedFile E.UncheckedProg]+setEntryPoints extra_eps fps = map onFile   where     fps' = map normalise fps-    onProg (name, prog)-      | includeToFilePath name `elem` fps' =-        (name, prog {E.progDecs = map onDec (E.progDecs prog)})+    onFile lf+      | includeToFilePath (lfImportName lf) `elem` fps' =+        lf {lfMod = prog {E.progDecs = map onDec (E.progDecs prog)}}       | otherwise =-        (name, prog)+        lf+      where+        prog = lfMod lf      onDec (E.ValDec vb)       | E.valBindName vb `elem` extra_eps =         E.ValDec vb {E.valBindEntryPoint = Just E.NoInfo}     onDec dec = dec --- | Read (and parse) all source files (including the builtin prelude)--- corresponding to a set of root files.-readUntypedLibrary ::-  (MonadIO m, MonadError CompilerError m) =>-  [FilePath] ->-  m [(ImportName, E.UncheckedProg)]-readUntypedLibrary fps = runReaderM $ do-  readImport [] (mkInitialImport "/prelude/prelude")-  mapM_ onFile fps+prependRoots :: [FilePath] -> E.UncheckedProg -> E.UncheckedProg+prependRoots roots (E.Prog doc ds) =+  E.Prog doc $ map mkImport roots ++ ds   where-    onFile fp = do-      r <- liftIO $ readFileSafely fp-      case r of-        Just (Right fs) ->-          handleFile [] (mkInitialImport fp_name) fs fp-        Just (Left e) -> externalErrorS e-        Nothing -> externalErrorS $ fp ++ ": file not found."-      where-        (fp_name, _) = Posix.splitExtension fp+    mkImport fp =+      -- We do not use ImportDec here, because we do not want the+      -- type checker to issue a warning about a redundant import.+      E.LocalDec (E.OpenDec (E.ModImport fp E.NoInfo mempty) mempty) mempty +-- | A loaded, type-checked program.  This can be used to extract+-- information about the program, but also to speed up subsequent+-- reloads.+data LoadedProg = LoadedProg+  { lpRoots :: [FilePath],+    -- | The 'VNameSource' is the name source just *before* the module+    -- was type checked.+    lpFiles :: [LoadedFile (VNameSource, FileModule)],+    -- | Final name source.+    lpNameSource :: VNameSource+  }++-- | The 'Imports' of a 'LoadedProg', as expected by e.g. type+-- checking functions.+lpImports :: LoadedProg -> Imports+lpImports = map f . lpFiles+  where+    f lf = (includeToString (lfImportName lf), snd $ lfMod lf)++unchangedImports ::+  MonadIO m =>+  VNameSource ->+  [LoadedFile (VNameSource, FileModule)] ->+  m ([LoadedFile (VNameSource, FileModule)], VNameSource)+unchangedImports src [] = pure ([], src)+unchangedImports src (f : fs)+  | "/prelude" `isPrefixOf` includeToFilePath (lfImportName f) =+    first (f :) <$> unchangedImports src fs+  | otherwise = do+    changed <-+      maybe True (either (const True) (> lfModTime f))+        <$> liftIO (interactWithFileSafely (getModificationTime $ lfPath f))+    if changed+      then pure ([], fst $ lfMod f)+      else first (f :) <$> unchangedImports src fs++-- | A "loaded program" containing no actual files.  Use this as a+-- starting point for 'reloadProg'+noLoadedProg :: LoadedProg+noLoadedProg =+  LoadedProg+    { lpRoots = [],+      lpFiles = mempty,+      lpNameSource = newNameSource $ E.maxIntrinsicTag + 1+    }++-- | Find out how many of the old imports can be used.  Here we are+-- forced to be overly conservative, because our type checker+-- enforces a linear ordering.+usableLoadedProg :: MonadIO m => LoadedProg -> [FilePath] -> m LoadedProg+usableLoadedProg (LoadedProg roots imports src) new_roots+  | sort roots == sort new_roots = do+    (imports', src') <- unchangedImports src imports+    pure $ LoadedProg [] imports' src'+  | otherwise =+    pure noLoadedProg++-- | Extend a loaded program with (possibly new) files.+extendProg ::+  (MonadError CompilerError m, MonadIO m) =>+  LoadedProg ->+  [FilePath] ->+  m (E.Warnings, LoadedProg)+extendProg lp new_roots = do+  new_imports_untyped <-+    readUntypedLibraryExceptKnown (map lfImportName $ lpFiles lp) new_roots+  (ws, imports, src') <-+    typeCheckProg (lpFiles lp) (lpNameSource lp) new_imports_untyped+  pure (ws, LoadedProg (nubOrd (lpRoots lp ++ new_roots)) imports src')++-- | Load some new files, reusing as much of the previously loaded+-- program as possible.  This does not *extend* the currently loaded+-- program the way 'extendProg' does it, so it is always correct (if+-- less efficient) to pass 'noLoadedProg'.+reloadProg ::+  (MonadError CompilerError m, MonadIO m) =>+  LoadedProg ->+  [FilePath] ->+  m (E.Warnings, LoadedProg)+reloadProg lp new_roots = do+  lp' <- usableLoadedProg lp new_roots+  extendProg lp' new_roots+ -- | Read and type-check some Futhark files. readLibrary ::   (MonadError CompilerError m, MonadIO m) =>@@ -204,30 +364,19 @@   [FilePath] ->   m (E.Warnings, Imports, VNameSource) readLibrary extra_eps fps =-  typeCheckProgram emptyBasis . setEntryPoints (E.defaultEntryPoint : extra_eps) fps-    =<< readUntypedLibrary fps---- | Read and type-check Futhark imports (no @.fut@ extension; may--- refer to baked-in prelude).  This is an exotic operation that--- probably only makes sense in an interactive environment.-readImports ::-  (MonadError CompilerError m, MonadIO m) =>-  Basis ->-  [ImportName] ->-  m-    ( E.Warnings,-      Imports,-      VNameSource-    )-readImports basis imps = do-  files <- runReaderM $ mapM (readImport []) imps-  typeCheckProgram basis files+  fmap frob+    . typeCheckProg mempty (lpNameSource noLoadedProg)+    . setEntryPoints (E.defaultEntryPoint : extra_eps) fps+    =<< readUntypedLibraryExceptKnown [] fps+  where+    frob (x, y, z) = (x, asImports y, z) -prependRoots :: [FilePath] -> E.UncheckedProg -> E.UncheckedProg-prependRoots roots (E.Prog doc ds) =-  E.Prog doc $ map mkImport roots ++ ds+-- | Read (and parse) all source files (including the builtin prelude)+-- corresponding to a set of root files.+readUntypedLibrary ::+  (MonadIO m, MonadError CompilerError m) =>+  [FilePath] ->+  m [(ImportName, E.UncheckedProg)]+readUntypedLibrary = fmap (map f) . readUntypedLibraryExceptKnown []   where-    mkImport fp =-      -- We do not use ImportDec here, because we do not want the-      -- type checker to issue a warning about a redundant import.-      E.LocalDec (E.OpenDec (E.ModImport fp E.NoInfo mempty) mempty) mempty+    f lf = (lfImportName lf, lfMod lf)

@@ -445,7 +445,7 @@         lambdaBody = body       } --- | Easily construct a 'Lambda' within a 'MonadBuilder'.+-- | Easily construct a t'Lambda' within a 'MonadBuilder'. mkLambda ::   MonadBuilder m =>   [LParam (Rep m)] ->@@ -547,7 +547,7 @@ -- | Instantiate all existential parts dimensions of the given -- type, using a monadic action to create the necessary t'SubExp's. -- You should call this function within some monad that allows you to--- collect the actions performed (say, 'Writer').+-- collect the actions performed (say, 'State'). instantiateShapes ::   Monad m =>   (Int -> m SubExp) ->

@@ -224,15 +224,15 @@ removeLambdaAliases = runIdentity . rephraseLambda removeAliases  removePatAliases ::-  PatT (AliasDec, a) ->-  PatT a+  Pat (AliasDec, a) ->+  Pat a removePatAliases = runIdentity . rephrasePat (return . snd)  addAliasesToPat ::   (ASTRep rep, CanBeAliased (Op rep), Typed dec) =>-  PatT dec ->+  Pat dec ->   Exp (Aliases rep) ->-  PatT (VarAliases, dec)+  Pat (VarAliases, dec) addAliasesToPat pat e =   Pat $ mkPatAliases pat e @@ -247,9 +247,9 @@  mkPatAliases ::   (Aliased rep, Typed dec) =>-  PatT dec ->+  Pat dec ->   Exp rep ->-  [PatElemT (VarAliases, dec)]+  [PatElem (VarAliases, dec)] mkPatAliases pat e =   let als = expAliases e ++ repeat mempty    in -- In case the pattern has@@ -331,7 +331,7 @@  mkAliasedLetStm ::   (ASTRep rep, CanBeAliased (Op rep)) =>-  Pat rep ->+  Pat (LetDec rep) ->   StmAux (ExpDec rep) ->   Exp (Aliases rep) ->   Stm (Aliases rep)

@@ -767,7 +767,7 @@  matchPatToExp ::   (Mem rep inner, LetDec rep ~ LetDecMem, TC.Checkable rep) =>-  Pat (Aliases rep) ->+  Pat (LetDec (Aliases rep)) ->   Exp (Aliases rep) ->   TC.TypeM rep () matchPatToExp pat e = do@@ -901,7 +901,7 @@             ++ ")"  bodyReturnsFromPat ::-  PatT (MemBound NoUniqueness) -> [(VName, BodyReturns)]+  Pat (MemBound NoUniqueness) -> [(VName, BodyReturns)] bodyReturnsFromPat pat =   map asReturns $ patElems pat   where

@@ -29,6 +29,7 @@     existentialize,     closeEnough,     equivalent,+    dynamicEqualsLMAD,   ) where @@ -43,11 +44,6 @@ import qualified Data.Map.Strict as M import Data.Maybe (isJust) import Futhark.Analysis.PrimExp-  ( IntExp,-    PrimExp (..),-    TPrimExp (..),-    primExpType,-  ) import Futhark.Analysis.PrimExp.Convert (substituteInPrimExp) import qualified Futhark.Analysis.PrimExp.Generalize as PEG import Futhark.IR.Prop@@ -1067,3 +1063,25 @@         == map ldStride (lmadDims lmad2)         && map ldRotate (lmadDims lmad1)         == map ldRotate (lmadDims lmad2)++-- | Dynamically determine if two 'LMADDim' are equal.+--+-- True if the dynamic values of their constituents are equal.+dynamicEqualsLMADDim :: Eq num => LMADDim (TPrimExp t num) -> LMADDim (TPrimExp t num) -> TPrimExp Bool num+dynamicEqualsLMADDim dim1 dim2 =+  ldStride dim1 .==. ldStride dim2+    .&&. ldRotate dim1 .==. ldRotate dim2+    .&&. ldShape dim1 .==. ldShape dim2+    .&&. fromBool (ldPerm dim1 == ldPerm dim2)+    .&&. fromBool (ldMon dim1 == ldMon dim2)++-- | Dynamically determine if two 'LMAD' are equal.+--+-- True if offset and constituent 'LMADDim' are equal.+dynamicEqualsLMAD :: Eq num => LMAD (TPrimExp t num) -> LMAD (TPrimExp t num) -> TPrimExp Bool num+dynamicEqualsLMAD lmad1 lmad2 =+  lmadOffset lmad1 .==. lmadOffset lmad2+    .&&. foldr+      ((.&&.) . uncurry dynamicEqualsLMADDim)+      true+      (zip (lmadDims lmad1) (lmadDims lmad2))

@@ -17,6 +17,7 @@ import Data.Char (isAlpha) import Data.Functor import Data.List (zipWith5)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Set as S import qualified Data.Text as T@@ -283,7 +284,9 @@         d <- "@" *> L.decimal         parens $ do           w <- pSubExp <* pComma-          Concat d <$> pVName <*> many (pComma *> pVName) <*> pure w,+          x <- pVName+          ys <- many (pComma *> pVName)+          return $ Concat d (x :| ys) w,       pIota,       try $         flip Update@@ -312,6 +315,8 @@       pConvOp "sitofp" SIToFP pIntType pFloatType,       pConvOp "itob" (const . IToB) pIntType (keyword "bool"),       pConvOp "btoi" (const BToI) (keyword "bool") pIntType,+      pConvOp "ftob" (const . FToB) pFloatType (keyword "bool"),+      pConvOp "btof" (const BToF) (keyword "bool") pFloatType,       --       pIndex,       pFlatIndex,@@ -381,11 +386,11 @@ pLParams :: PR rep -> Parser [LParam rep] pLParams pr = braces $ pLParam pr `sepBy` pComma -pPatElem :: PR rep -> Parser (PatElem rep)+pPatElem :: PR rep -> Parser (PatElem (LetDec rep)) pPatElem pr =   (PatElem <$> pVName <*> (pColon *> pLetDec pr)) <?> "pattern element" -pPat :: PR rep -> Parser (Pat rep)+pPat :: PR rep -> Parser (Pat (LetDec rep)) pPat pr = Pat <$> braces (pPatElem pr `sepBy` pComma)  pResult :: Parser Result

@@ -18,6 +18,7 @@ where  import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Futhark.IR.Syntax import Futhark.Util.Pretty@@ -134,10 +135,10 @@ instance Pretty Attrs where   ppr = spread . attrAnnots -instance Pretty (PatElemT dec) => Pretty (PatT dec) where+instance Pretty t => Pretty (Pat t) where   ppr (Pat xs) = braces $ commastack $ map ppr xs -instance Pretty t => Pretty (PatElemT t) where+instance Pretty t => Pretty (PatElem t) where   ppr (PatElem name t) = ppr name <+> colon <+> align (ppr t)  instance Pretty t => Pretty (Param t) where@@ -217,8 +218,8 @@     text "rearrange" <> apply [apply (map ppr perm), ppr e]   ppr (Rotate es e) =     text "rotate" <> apply [apply (map ppr es), ppr e]-  ppr (Concat i x ys w) =-    text "concat" <> text "@" <> ppr i <> apply (ppr w : ppr x : map ppr ys)+  ppr (Concat i (x :| xs) w) =+    text "concat" <> text "@" <> ppr i <> apply (ppr w : ppr x : map ppr xs)   ppr (Copy e) = text "copy" <> parens (ppr e)   ppr (Manifest perm e) = text "manifest" <> apply [apply (map ppr perm), ppr e]   ppr (Assert e msg (loc, _)) =

@@ -102,6 +102,7 @@     intByteSize,     floatByteSize,     commutativeBinOp,+    associativeBinOp,      -- * Prettyprinting     convOpFun,@@ -564,6 +565,12 @@   | -- | Convert a boolean to an integer.  True is converted     -- to 1 and False to 0.     BToI IntType+  | -- | Convert a float to a boolean value.  Zero becomes false;+    -- | anything else is true.+    FToB FloatType+  | -- | Convert a boolean to a float.  True is converted+    -- to 1 and False to 0.+    BToF FloatType   deriving (Eq, Ord, Show)  -- | A list of all unary operators for all types.@@ -640,7 +647,9 @@       UIToFP <$> allIntTypes <*> allFloatTypes,       SIToFP <$> allIntTypes <*> allFloatTypes,       IToB <$> allIntTypes,-      BToI <$> allIntTypes+      BToI <$> allIntTypes,+      FToB <$> allFloatTypes,+      BToF <$> allFloatTypes     ]  -- | Apply an 'UnOp' to an operand.  Returns 'Nothing' if the@@ -906,6 +915,8 @@ doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0 :: Int+doConvOp (FToB _) (FloatValue v) = Just $ BoolValue $ floatToDouble v /= 0+doConvOp (BToF to) (BoolValue v) = Just $ FloatValue $ floatValue to $ if v then 1 else 0 :: Double doConvOp _ _ = Nothing  -- | Turn the conversion the other way around.  Note that most@@ -921,6 +932,8 @@ flipConvOp (SIToFP from to) = FPToSI to from flipConvOp (IToB from) = BToI from flipConvOp (BToI to) = IToB to+flipConvOp (FToB from) = BToF from+flipConvOp (BToF to) = FToB 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@@ -1133,6 +1146,8 @@ convOpType (SIToFP from to) = (IntType from, FloatType to) convOpType (IToB from) = (IntType from, Bool) convOpType (BToI to) = (Bool, IntType to)+convOpType (FToB from) = (FloatType from, Bool)+convOpType (BToF to) = (Bool, FloatType to)  halfToWord :: Half -> Word16 halfToWord (Half (CUShort x)) = x@@ -1679,6 +1694,23 @@ commutativeBinOp FMin {} = True commutativeBinOp _ = False +-- | True if the given binary operator is associative.+associativeBinOp :: BinOp -> Bool+associativeBinOp Add {} = True+associativeBinOp Mul {} = True+associativeBinOp And {} = True+associativeBinOp Or {} = True+associativeBinOp Xor {} = True+associativeBinOp LogOr {} = True+associativeBinOp LogAnd {} = True+associativeBinOp SMax {} = True+associativeBinOp SMin {} = True+associativeBinOp UMax {} = True+associativeBinOp UMin {} = True+associativeBinOp FMax {} = True+associativeBinOp FMin {} = True+associativeBinOp _ = False+ -- Prettyprinting instances  instance Pretty BinOp where@@ -1763,6 +1795,8 @@ convOpFun SIToFP {} = "sitofp" convOpFun IToB {} = "itob" convOpFun BToI {} = "btoi"+convOpFun FToB {} = "ftob"+convOpFun BToF {} = "btof"  taggedI :: String -> IntType -> Doc taggedI s Int8 = text $ s ++ "8"

@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Parsers for primitive values and types.  Mostly useful for+-- "Futhark.IR.Parse", but can perhaps come in handy elsewhere too. module Futhark.IR.Primitive.Parse   ( pPrimValue,     pPrimType,@@ -24,27 +26,34 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -type Parser = Parsec Void T.Text-+-- | Is this character a valid member of an identifier? constituent :: Char -> Bool constituent c = isAlphaNum c || (c `elem` ("_/'+-=!&^.<>*|" :: String)) -whitespace :: Parser ()+-- | Consume whitespace (including skipping line comments).+whitespace :: Parsec Void T.Text () whitespace = L.space space1 (L.skipLineComment "--") empty -lexeme :: Parser a -> Parser a+-- | Consume whitespace after the provided parser, if it succeeds.+lexeme :: Parsec Void T.Text a -> Parsec Void T.Text a lexeme = try . L.lexeme whitespace -keyword :: T.Text -> Parser ()+-- | @keyword k@ parses @k@, which must not be immediately followed by+-- a 'constituent' character.  This ensures that @iff@ is not seen as+-- the @if@ keyword followed by @f@.  Sometimes called the "maximum+-- munch" rule.+keyword :: T.Text -> Parsec Void T.Text () keyword s = lexeme $ chunk s *> notFollowedBy (satisfy constituent) -pIntValue :: Parser IntValue+-- | Parse an integer value.+pIntValue :: Parsec Void T.Text IntValue pIntValue = try $ do   x <- L.signed (pure ()) L.decimal   t <- pIntType   pure $ intValue t (x :: Integer) -pFloatValue :: Parser FloatValue+-- | Parse a floating-point value.+pFloatValue :: Parsec Void T.Text FloatValue pFloatValue =   choice     [ pNum,@@ -64,7 +73,8 @@       t <- pFloatType       pure $ floatValue t (x :: Double) -pBoolValue :: Parser Bool+-- | Parse a boolean value.+pBoolValue :: Parsec Void T.Text Bool pBoolValue =   choice     [ keyword "true" $> True,@@ -72,7 +82,7 @@     ]  -- | Defined in this module for convenience.-pPrimValue :: Parser PrimValue+pPrimValue :: Parsec Void T.Text PrimValue pPrimValue =   choice     [ FloatValue <$> pFloatValue,@@ -82,17 +92,20 @@     ]     <?> "primitive value" -pFloatType :: Parser FloatType+-- | Parse a floating-point type.+pFloatType :: Parsec Void T.Text FloatType pFloatType = choice $ map p allFloatTypes   where     p t = keyword (prettyText t) $> t -pIntType :: Parser IntType+-- | Parse an integer type.+pIntType :: Parsec Void T.Text IntType pIntType = choice $ map p allIntTypes   where     p t = keyword (prettyText t) $> t -pPrimType :: Parser PrimType+-- | Parse a primitive type.+pPrimType :: Parsec Void T.Text PrimType pPrimType =   choice [p Bool, p Unit, FloatType <$> pFloatType, IntType <$> pIntType]   where

@@ -233,11 +233,11 @@   -- 'expExtTypesFromPat'.   expTypesFromPat ::     (HasScope rep m, Monad m) =>-    Pat rep ->+    Pat (LetDec rep) ->     m [BranchType rep]  -- | Construct the type of an expression that would match the pattern.-expExtTypesFromPat :: Typed dec => PatT dec -> [ExtType]+expExtTypesFromPat :: Typed dec => Pat dec -> [ExtType] expExtTypesFromPat pat =   existentialiseExtTypes (patNames pat) $     staticShapes $ map patElemType $ patElems pat

@@ -193,7 +193,7 @@ consumedByLambda = consumedInBody . lambdaBody  -- | The aliases of each pattern element (including the context).-patAliases :: AliasesOf dec => PatT dec -> [Names]+patAliases :: AliasesOf dec => Pat dec -> [Names] patAliases = map (aliasesOf . patElemDec) . patElems  -- | Something that contains alias information.@@ -204,7 +204,7 @@ instance AliasesOf Names where   aliasesOf = id -instance AliasesOf dec => AliasesOf (PatElemT dec) where+instance AliasesOf dec => AliasesOf (PatElem dec) where   aliasesOf = aliasesOf . patElemDec  -- | Also includes the name itself.

@@ -337,7 +337,7 @@ instance FreeIn dec => FreeIn (Param dec) where   freeIn' (Param attrs _ dec) = freeIn' attrs <> freeIn' dec -instance FreeIn dec => FreeIn (PatElemT dec) where+instance FreeIn dec => FreeIn (PatElem dec) where   freeIn' (PatElem _ dec) = freeIn' dec  instance FreeIn (LParamInfo rep) => FreeIn (LoopForm rep) where@@ -362,7 +362,7 @@ instance FreeIn SubExpRes where   freeIn' (SubExpRes cs se) = freeIn' cs <> freeIn' se -instance FreeIn dec => FreeIn (PatT dec) where+instance FreeIn dec => FreeIn (Pat dec) where   freeIn' (Pat xs) =     fvBind bound_here $ freeIn' xs     where

@@ -39,35 +39,35 @@ paramIdent param = Ident (paramName param) (typeOf param)  -- | An 'Ident' corresponding to a pattern element.-patElemIdent :: Typed dec => PatElemT dec -> Ident+patElemIdent :: Typed dec => PatElem dec -> Ident patElemIdent pelem = Ident (patElemName pelem) (typeOf pelem)  -- | The type of a name bound by a t'PatElem'.-patElemType :: Typed dec => PatElemT dec -> Type+patElemType :: Typed dec => PatElem dec -> Type patElemType = typeOf  -- | Set the rep of a t'PatElem'.-setPatElemDec :: PatElemT oldattr -> newattr -> PatElemT newattr+setPatElemDec :: PatElem oldattr -> newattr -> PatElem newattr setPatElemDec pe x = fmap (const x) pe  -- | Return a list of the 'Ident's bound by the t'Pat'.-patIdents :: Typed dec => PatT dec -> [Ident]+patIdents :: Typed dec => Pat dec -> [Ident] patIdents = map patElemIdent . patElems  -- | Return a list of the 'Name's bound by the t'Pat'.-patNames :: PatT dec -> [VName]+patNames :: Pat dec -> [VName] patNames = map patElemName . patElems  -- | Return a list of the typess bound by the pattern.-patTypes :: Typed dec => PatT dec -> [Type]+patTypes :: Typed dec => Pat dec -> [Type] patTypes = map identType . patIdents  -- | Return the number of names bound by the pattern.-patSize :: PatT dec -> Int+patSize :: Pat dec -> Int patSize (Pat xs) = length xs  -- | Create a pattern using 'Type' as the attribute.-basicPat :: [Ident] -> PatT Type+basicPat :: [Ident] -> Pat Type basicPat values =   Pat $ map patElem values   where

@@ -16,6 +16,10 @@ -- from variable names to 'NameInfo's.  Convenience facilities are -- also provided to communicate that some monad or applicative functor -- maintains type information.+--+-- A simple example of a monad that maintains such as environment is+-- 'Reader'.  Indeed, 'HasScope' and 'LocalScope' instances for this+-- monad are already defined. module Futhark.IR.Prop.Scope   ( HasScope (..),     NameInfo (..),@@ -178,12 +182,12 @@     M.insert i (IndexName it) $ scopeOfLParams (map fst xs)  -- | The scope of a pattern.-scopeOfPat :: LetDec rep ~ dec => PatT dec -> Scope rep+scopeOfPat :: LetDec rep ~ dec => Pat dec -> Scope rep scopeOfPat =   mconcat . map scopeOfPatElem . patElems  -- | The scope of a pattern element.-scopeOfPatElem :: LetDec rep ~ dec => PatElemT dec -> Scope rep+scopeOfPatElem :: LetDec rep ~ dec => PatElem dec -> Scope rep scopeOfPatElem (PatElem name dec) = M.singleton name $ LetName dec  -- | The scope of some lambda parameters.

@@ -35,6 +35,7 @@   ) where +import Data.List.NonEmpty (NonEmpty (..)) import Futhark.IR.Prop.Constants import Futhark.IR.Prop.Reshape import Futhark.IR.Prop.Scope@@ -115,7 +116,7 @@     result t = [rearrangeType perm t] basicOpType (Rotate _ e) =   pure <$> lookupType e-basicOpType (Concat i x _ ressize) =+basicOpType (Concat i (x :| _) ressize) =   result <$> lookupType x   where     result xt = [setDimSize i xt ressize]

@@ -554,7 +554,7 @@ instance Typed dec => Typed (Param dec) where   typeOf = typeOf . paramDec -instance Typed dec => Typed (PatElemT dec) where+instance Typed dec => Typed (PatElem dec) where   typeOf = typeOf . patElemDec  instance Typed b => Typed (a, b) where@@ -594,7 +594,7 @@ instance SetType b => SetType (a, b) where   setType (a, b) t = (a, setType b t) -instance SetType dec => SetType (PatElemT dec) where+instance SetType dec => SetType (PatElem dec) where   setType (PatElem name dec) t =     PatElem name $ setType dec t 

@@ -5,27 +5,12 @@ module Futhark.IR.SOACS   ( SOACS, -    -- * Syntax types-    Body,-    Stm,-    Pat,-    Exp,-    Lambda,-    FParam,-    LParam,-    RetType,-    PatElem,-     -- * Module re-exports     module Futhark.IR.Prop,     module Futhark.IR.Traversals,     module Futhark.IR.Pretty,     module Futhark.IR.Syntax,     module Futhark.IR.SOACS.SOAC,-    AST.LambdaT (Lambda),-    AST.BodyT (Body),-    AST.PatT (Pat),-    AST.PatElemT (PatElem),   ) where @@ -34,25 +19,10 @@ import Futhark.IR.Pretty import Futhark.IR.Prop import Futhark.IR.SOACS.SOAC-import Futhark.IR.Syntax hiding-  ( Body,-    Exp,-    FParam,-    LParam,-    Lambda,-    Pat,-    PatElem,-    RetType,-    Stm,-  )-import qualified Futhark.IR.Syntax as AST+import Futhark.IR.Syntax import Futhark.IR.Traversals import qualified Futhark.IR.TypeCheck as TC --- This module could be written much nicer if Haskell had functors--- like Standard ML.  Instead, we have to abuse the namespace/module--- system.- -- | The rep for the basic representation. data SOACS @@ -62,31 +32,13 @@ instance ASTRep SOACS where   expTypesFromPat = return . expExtTypesFromPat -type Exp = AST.Exp SOACS--type Body = AST.Body SOACS--type Stm = AST.Stm SOACS--type Pat = AST.Pat SOACS--type Lambda = AST.Lambda SOACS--type FParam = AST.FParam SOACS--type LParam = AST.LParam SOACS--type RetType = AST.RetType SOACS--type PatElem = AST.PatElem SOACS- instance TC.CheckableOp SOACS where   checkOp = typeCheckSOAC  instance TC.Checkable SOACS  instance Buildable SOACS where-  mkBody = AST.Body ()+  mkBody = Body ()   mkExpPat merge _ = basicPat merge   mkExpDec _ _ = ()   mkLetNames = simpleMkLetNames

@@ -30,13 +30,13 @@ import Data.Either import Data.Foldable import Data.List (partition, transpose, unzip6, zip6)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S import Futhark.Analysis.DataDependencies import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT-import qualified Futhark.IR as AST import Futhark.IR.Prop.Aliases import Futhark.IR.SOACS import Futhark.MonadFreshNames@@ -67,24 +67,18 @@   Simplify.simplifyFun simpleSOACS soacRules Engine.noExtraHoistBlockers  simplifyLambda ::-  (HasScope SOACS m, MonadFreshNames m) =>-  Lambda ->-  m Lambda+  (HasScope SOACS m, MonadFreshNames m) => Lambda SOACS -> m (Lambda SOACS) simplifyLambda =   Simplify.simplifyLambda simpleSOACS soacRules Engine.noExtraHoistBlockers  simplifyStms ::-  (HasScope SOACS m, MonadFreshNames m) =>-  Stms SOACS ->-  m (Stms SOACS)+  (HasScope SOACS m, MonadFreshNames m) => Stms SOACS -> m (Stms SOACS) simplifyStms stms = do   scope <- askScope   Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers scope stms  simplifyConsts ::-  MonadFreshNames m =>-  Stms SOACS ->-  m (Stms SOACS)+  MonadFreshNames m => Stms SOACS -> m (Stms SOACS) simplifyConsts =   Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers mempty @@ -155,9 +149,9 @@  fixLambdaParams ::   (MonadBuilder m, Buildable (Rep m), BuilderOps (Rep m)) =>-  AST.Lambda (Rep m) ->+  Lambda (Rep m) ->   [Maybe SubExp] ->-  m (AST.Lambda (Rep m))+  m (Lambda (Rep m)) fixLambdaParams lam fixes = do   body <- runBodyBuilder $     localScope (scopeOfLParams $ lambdaParams lam) $ do@@ -176,7 +170,7 @@     maybeFix p (Just x) = letBindNames [paramName p] $ BasicOp $ SubExp x     maybeFix _ Nothing = return () -removeLambdaResults :: [Bool] -> AST.Lambda rep -> AST.Lambda rep+removeLambdaResults :: [Bool] -> Lambda rep -> Lambda rep removeLambdaResults keep lam =   lam     { lambdaBody = lam_body',@@ -363,11 +357,11 @@ removeReplicateInput ::   Aliased rep =>   ST.SymbolTable rep ->-  AST.Lambda rep ->+  Lambda rep ->   [VName] ->   Maybe-    ( [([VName], Certs, AST.Exp rep)],-      AST.Lambda rep,+    ( [([VName], Certs, Exp rep)],+      Lambda rep,       [VName]     ) removeReplicateInput vtable fun arrs@@ -472,11 +466,11 @@           | otherwise = DimNew w     certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $       Reshape (redim : newshape) arr-  | Just (_, cs, _, BasicOp (Concat d arr arrs dw), ps, outer_arr : outer_arrs) <-+  | Just (_, cs, _, BasicOp (Concat d (arr :| arrs) dw), ps, outer_arr : outer_arrs) <-       isMapWithOp pat e,     (arr : arrs) == map paramName ps =     Simplify . certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $-      Concat (d + 1) outer_arr outer_arrs dw+      Concat (d + 1) (outer_arr :| outer_arrs) dw   | Just       (map_pe, cs, _, BasicOp (Rearrange perm rearrange_arr), [p], [arr]) <-       isMapWithOp pat e,@@ -493,13 +487,13 @@ mapOpToOp _ _ _ _ = Skip  isMapWithOp ::-  PatT dec ->+  Pat dec ->   SOAC (Wise SOACS) ->   Maybe-    ( PatElemT dec,+    ( PatElem dec,       Certs,       SubExp,-      AST.Exp (Wise SOACS),+      Exp (Wise SOACS),       [Param Type],       [VName]     )@@ -597,7 +591,7 @@     mix = concat . transpose     incWrites r (w, n, a) = (w, n * r, a) -- ToDO: is it (n*r) or (n+r-1)??     isConcat v = case ST.lookupExp v vtable of-      Just (BasicOp (Concat 0 x ys _), cs) -> do+      Just (BasicOp (Concat 0 (x :| ys) _), cs) -> do         x_w <- sizeOf x         y_ws <- mapM sizeOf ys         guard $ all (x_w ==) y_ws@@ -696,7 +690,7 @@ arrayOpCerts (ArrayCopy cs _) = cs arrayOpCerts (ArrayVar cs _) = cs -isArrayOp :: Certs -> AST.Exp rep -> Maybe ArrayOp+isArrayOp :: Certs -> Exp rep -> Maybe ArrayOp isArrayOp cs (BasicOp (Index arr slice)) =   Just $ ArrayIndexing cs arr slice isArrayOp cs (BasicOp (Rearrange perm arr)) =@@ -708,7 +702,7 @@ isArrayOp _ _ =   Nothing -fromArrayOp :: ArrayOp -> (Certs, AST.Exp rep)+fromArrayOp :: ArrayOp -> (Certs, Exp rep) 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)@@ -718,8 +712,8 @@ arrayOps ::   forall rep.   (Buildable rep, HasSOAC rep) =>-  AST.Body rep ->-  S.Set (AST.Pat rep, ArrayOp)+  Body rep ->+  S.Set (Pat (LetDec rep), ArrayOp) arrayOps = mconcat . map onStm . stmsToList . bodyStms   where     onStm (Let pat aux e) =@@ -746,9 +740,9 @@ replaceArrayOps ::   forall rep.   (Buildable rep, BuilderOps rep, HasSOAC rep) =>-  M.Map (AST.Pat rep, ArrayOp) ArrayOp ->-  AST.Body rep ->-  AST.Body rep+  M.Map (Pat (LetDec rep), ArrayOp) ArrayOp ->+  Body rep ->+  Body rep replaceArrayOps substs (Body _ stms res) =   mkBody (fmap onStm stms) res   where

@@ -151,7 +151,7 @@     lambdaReturnType $ histOp op  -- | Split reduction results returned by a 'KernelBody' into those--- that correspond to indexes for the 'HistOps', and those that+-- that correspond to indexes for the 'HistOp's, and those that -- correspond to value. splitHistResults :: [HistOp rep] -> [SubExp] -> [([SubExp], [SubExp])] splitHistResults ops res =@@ -1327,7 +1327,7 @@ topDownSegOp ::   (HasSegOp rep, BuilderOps rep, Buildable rep) =>   ST.SymbolTable rep ->-  Pat rep ->+  Pat (LetDec rep) ->   StmAux (ExpDec rep) ->   SegOp (SegOpLevel rep) rep ->   Rule rep@@ -1433,7 +1433,7 @@ bottomUpSegOp ::   (HasSegOp rep, BuilderOps rep) =>   (ST.SymbolTable rep, UT.UsageTable) ->-  Pat rep ->+  Pat (LetDec rep) ->   StmAux (ExpDec rep) ->   SegOp (SegOpLevel rep) rep ->   Rule rep

@@ -14,11 +14,11 @@ -- The core language type system is much more restricted than the core -- language.  This is a theme that repeats often.  The only types that -- are supported in the core language are various primitive types--- t'PrimType' which can be combined in arrays (ignore v'Mem' for--- now).  Types are represented as t'TypeBase', which is parameterised--- by the shape of the array and whether we keep uniqueness--- information.  The t'Type' alias, which is the most commonly used,--- uses t'Shape' and t'NoUniqueness'.+-- t'PrimType' which can be combined in arrays (ignore v'Mem' and+-- v'Acc' for now).  Types are represented as t'TypeBase', which is+-- parameterised by the shape of the array and whether we keep+-- uniqueness information.  The t'Type' alias, which is the most+-- commonly used, uses t'Shape' and t'NoUniqueness'. -- -- This means that the records, tuples, and sum types of the source -- language are represented merely as collections of primitives and@@ -56,7 +56,7 @@ -- the values of the variables indicated by the result. -- -- A statement ('Stm') consists of a t'Pat' alongside an--- expression 'ExpT'.  A pattern is a sequence of name/type pairs.+-- expression 'Exp'.  A pattern is a sequence of name/type pairs. -- -- For example, the source language expression @let z = x + y - 1 in -- z@ would in the core language be represented (in prettyprinted@@ -70,9 +70,9 @@ -- -- == Representations ----- Most AST types ('Stm', 'ExpT', t'Prog', etc) are parameterised by a+-- Most AST types ('Stm', 'Exp', t'Prog', etc) are parameterised by a -- type parameter @rep@.  The representation specifies how to fill out--- various polymorphic parts of the AST.  For example, 'ExpT' has a+-- various polymorphic parts of the AST.  For example, 'Exp' has a -- constructor v'Op' whose payload depends on @rep@, via the use of a -- type family called t'Op' (a kind of type-level function) which is -- applied to the @rep@.  The SOACS representation@@ -80,7 +80,7 @@ -- that @Op SOACS@ is a SOAC, while the Kernels representation -- ("Futhark.IR.Kernels") defines @Op Kernels@ as some kind of kernel -- construct.  Similarly, various other decorations (e.g. what--- information we store in a t'PatElemT') are also type families.+-- information we store in a t'PatElem') are also type families. -- -- The full list of possible decorations is defined as part of the -- type class 'RepTypes' (although other type families are also@@ -91,6 +91,11 @@ -- the different forms of decorations that we desire (it would easily -- become a type with a dozen type parameters). --+-- Some AST elements (such as 'Pat') do not take a @rep@ type+-- parameter, but instead immediately the single type of decoration+-- that they contain.  We only use the more complicated machinery when+-- needed.+-- -- Defining a new representation (or /rep/) thus requires you to -- define an empty datatype and implement a handful of type class -- instances for it.  See the source of "Futhark.IR.Seq"@@ -113,17 +118,14 @@     -- * Abstract syntax tree     Ident (..),     SubExp (..),-    PatElem,-    PatElemT (..),-    PatT (..),-    Pat,+    PatElem (..),+    Pat (..),     StmAux (..),     Stm (..),     Stms,     SubExpRes (..),     Result,-    BodyT (..),-    Body,+    Body (..),     BasicOp (..),     UnOp (..),     BinOp (..),@@ -133,14 +135,12 @@     DimChange (..),     ShapeChange,     WithAccInput,-    ExpT (..),-    Exp,+    Exp (..),     LoopForm (..),     IfDec (..),     IfSort (..),     Safety (..),-    LambdaT (..),-    Lambda,+    Lambda (..),      -- * Definitions     Param (..),@@ -166,6 +166,7 @@  import Control.Category import Data.Foldable+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Sequence as Seq import Data.String import Data.Traversable (fmapDefault, foldMapDefault)@@ -175,32 +176,26 @@ import Language.Futhark.Core import Prelude hiding (id, (.)) --- | A type alias for namespace control.-type PatElem rep = PatElemT (LetDec rep)- -- | A pattern is conceptually just a list of names and their types.-newtype PatT dec = Pat {patElems :: [PatElemT dec]}+newtype Pat dec = Pat {patElems :: [PatElem dec]}   deriving (Ord, Show, Eq) -instance Semigroup (PatT dec) where+instance Semigroup (Pat dec) where   Pat xs <> Pat ys = Pat (xs <> ys) -instance Monoid (PatT dec) where+instance Monoid (Pat dec) where   mempty = Pat mempty -instance Functor PatT where+instance Functor Pat where   fmap = fmapDefault -instance Foldable PatT where+instance Foldable Pat where   foldMap = foldMapDefault -instance Traversable PatT where+instance Traversable Pat where   traverse f (Pat xs) =     Pat <$> traverse (traverse f) xs --- | A type alias for namespace control.-type Pat rep = PatT (LetDec rep)- -- | Auxilliary Information associated with a statement. data StmAux dec = StmAux   { stmAuxCerts :: !Certs,@@ -216,7 +211,7 @@ -- | A local variable binding. data Stm rep = Let   { -- | Pat.-    stmPat :: Pat rep,+    stmPat :: Pat (LetDec rep),     -- | Auxiliary information statement.     stmAux :: StmAux (ExpDec rep),     -- | Expression.@@ -278,20 +273,17 @@  -- | A body consists of a number of bindings, terminating in a result -- (essentially a tuple literal).-data BodyT rep = Body+data Body rep = Body   { bodyDec :: BodyDec rep,     bodyStms :: Stms rep,     bodyResult :: Result   } -deriving instance RepTypes rep => Ord (BodyT rep)--deriving instance RepTypes rep => Show (BodyT rep)+deriving instance RepTypes rep => Ord (Body rep) -deriving instance RepTypes rep => Eq (BodyT rep)+deriving instance RepTypes rep => Show (Body rep) --- | Type alias for namespace reasons.-type Body = BodyT+deriving instance RepTypes rep => Eq (Body rep)  -- | The new dimension in a 'Reshape'-like operation.  This allows us to -- disambiguate "real" reshapes, that change the actual shape of the@@ -371,8 +363,19 @@     Update Safety VName (Slice SubExp) SubExp   | FlatIndex VName (FlatSlice SubExp)   | FlatUpdate VName (FlatSlice SubExp) VName-  | -- | @concat@0([1],[2, 3, 4]) = [1, 2, 3, 4]@.-    Concat Int VName [VName] SubExp+  | -- | @+    -- concat(0, [1] :| [[2, 3, 4], [5, 6]], 6) = [1, 2, 3, 4, 5, 6]@.+    -- @+    --+    -- Concatenates the non-empty list of 'VName' resulting in an+    -- array of length t'SubExp'. The 'Int' argument is used to+    -- specify the dimension along which the arrays are+    -- concatenated. For instance:+    --+    -- @+    -- concat(1, [[1,2], [3, 4]] :| [[[5,6]], [[7, 8]]], 4) = [[1, 2, 5, 6], [3, 4, 7, 8]]+    -- @+    Concat Int (NonEmpty VName) SubExp   | -- | Copy the given array.  The result will not alias anything.     Copy VName   | -- | Manifest an array with dimensions represented in the given@@ -416,13 +419,13 @@ -- | The root Futhark expression type.  The v'Op' constructor contains -- a rep-specific operation.  Do-loops, branches and function calls -- are special.  Everything else is a simple t'BasicOp'.-data ExpT rep+data Exp rep   = -- | A simple (non-recursive) operation.     BasicOp BasicOp   | Apply Name [(SubExp, Diet)] [RetType rep] (Safety, SrcLoc, [SrcLoc])-  | If SubExp (BodyT rep) (BodyT rep) (IfDec (BranchType rep))+  | If SubExp (Body rep) (Body rep) (IfDec (BranchType rep))   | -- | @loop {a} = {v} (for i < n|while b) do b@.-    DoLoop [(FParam rep, SubExp)] (LoopForm rep) (BodyT rep)+    DoLoop [(FParam rep, SubExp)] (LoopForm rep) (Body rep)   | -- | 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@@ -433,11 +436,11 @@     WithAcc [WithAccInput rep] (Lambda rep)   | Op (Op rep) -deriving instance RepTypes rep => Eq (ExpT rep)+deriving instance RepTypes rep => Eq (Exp rep) -deriving instance RepTypes rep => Show (ExpT rep)+deriving instance RepTypes rep => Show (Exp rep) -deriving instance RepTypes rep => Ord (ExpT rep)+deriving instance RepTypes rep => Ord (Exp rep)  -- | For-loop or while-loop? data LoopForm rep@@ -476,24 +479,18 @@     IfEquiv   deriving (Eq, Show, Ord) --- | A type alias for namespace control.-type Exp = ExpT- -- | Anonymous function for use in a SOAC.-data LambdaT rep = Lambda+data Lambda rep = Lambda   { lambdaParams :: [LParam rep],-    lambdaBody :: BodyT rep,+    lambdaBody :: Body rep,     lambdaReturnType :: [Type]   } -deriving instance RepTypes rep => Eq (LambdaT rep)--deriving instance RepTypes rep => Show (LambdaT rep)+deriving instance RepTypes rep => Eq (Lambda rep) -deriving instance RepTypes rep => Ord (LambdaT rep)+deriving instance RepTypes rep => Show (Lambda rep) --- | Type alias for namespacing reasons.-type Lambda = LambdaT+deriving instance RepTypes rep => Ord (Lambda rep)  -- | A function and loop parameter. type FParam rep = Param (FParamInfo rep)@@ -510,7 +507,7 @@     funDefName :: Name,     funDefRetType :: [RetType rep],     funDefParams :: [FParam rep],-    funDefBody :: BodyT rep+    funDefBody :: Body rep   }  deriving instance RepTypes rep => Eq (FunDef rep)

@@ -60,7 +60,7 @@     unitSlice,     fixSlice,     sliceSlice,-    PatElemT (..),+    PatElem (..),      -- * Flat (LMAD) slices     FlatSlice (..),@@ -456,7 +456,7 @@ -- | An element of a pattern - consisting of a name and an addditional -- parametric decoration.  This decoration is what is expected to -- contain the type of the resulting variable.-data PatElemT dec = PatElem+data PatElem dec = PatElem   { -- | The name being bound.     patElemName :: VName,     -- | Pat element decoration.@@ -464,13 +464,13 @@   }   deriving (Ord, Show, Eq) -instance Functor PatElemT where+instance Functor PatElem where   fmap = fmapDefault -instance Foldable PatElemT where+instance Foldable PatElem where   foldMap = foldMapDefault -instance Traversable PatElemT where+instance Traversable PatElem where   traverse f (PatElem name dec) =     PatElem name <$> f dec 

@@ -44,6 +44,7 @@ import Control.Monad.Identity import Data.Bitraversable import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..)) import Futhark.IR.Prop.Scope import Futhark.IR.Prop.Types (mapOnType) import Futhark.IR.Syntax@@ -146,13 +147,11 @@   BasicOp <$> (Rearrange perm <$> mapOnVName tv e) mapExpM tv (BasicOp (Rotate es e)) =   BasicOp <$> (Rotate <$> mapM (mapOnSubExp tv) es <*> mapOnVName tv e)-mapExpM tv (BasicOp (Concat i x ys size)) =-  BasicOp-    <$> ( Concat i-            <$> mapOnVName tv x-            <*> mapM (mapOnVName tv) ys-            <*> mapOnSubExp tv size-        )+mapExpM tv (BasicOp (Concat i (x :| ys) size)) = do+  x' <- mapOnVName tv x+  ys' <- mapM (mapOnVName tv) ys+  size' <- mapOnSubExp tv size+  return $ BasicOp $ Concat i (x' :| ys') size' mapExpM tv (BasicOp (Copy e)) =   BasicOp <$> (Copy <$> mapOnVName tv e) mapExpM tv (BasicOp (Manifest perm e)) =@@ -319,7 +318,7 @@   walkOnVName tv e walkExpM tv (BasicOp (Rotate es e)) =   mapM_ (walkOnSubExp tv) es >> walkOnVName tv e-walkExpM tv (BasicOp (Concat _ x ys size)) =+walkExpM tv (BasicOp (Concat _ (x :| ys) size)) =   walkOnVName tv x >> mapM_ (walkOnVName tv) ys >> walkOnSubExp tv size walkExpM tv (BasicOp (Copy e)) =   walkOnVName tv e@@ -354,7 +353,7 @@ -- given op for some representation. type OpStmsTraverser m op rep = (Scope rep -> Stms rep -> m (Stms rep)) -> op -> m op --- | This representatin supports an 'OpStmsTraverser' for its 'Op'.+-- | This representation supports an 'OpStmsTraverser' for its t'Op'. -- This is used for some simplification rules. class TraverseOpStms rep where   -- | Transform every sub-'Stms' of this op.

@@ -21,7 +21,6 @@     TypeM,     bad,     context,-    message,     Checkable (..),     CheckableOp (..),     lookupVar,@@ -42,14 +41,12 @@     matchExtPat,     matchExtBranchType,     argType,-    argAliases,     noArgAliases,     checkArg,     checkSOACArrayArgs,     checkLambda,     checkBody,     consume,-    consumeOnlyParams,     binding,     alternative,   )@@ -60,6 +57,7 @@ import Control.Parallel.Strategies import Data.Bifunctor (second) import Data.List (find, intercalate, isPrefixOf, sort)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S@@ -78,7 +76,7 @@   | DupDefinitionError Name   | DupParamError Name VName   | DupPatError VName-  | InvalidPatError (Pat (Aliases rep)) [ExtType] (Maybe String)+  | InvalidPatError (Pat (LetDec (Aliases rep))) [ExtType] (Maybe String)   | UnknownVariableError VName   | UnknownFunctionError Name   | ParameterMismatch (Maybe Name) [Type] [Type]@@ -316,6 +314,7 @@ runTypeM env (TypeM m) =   second stateCons <$> runStateT (runReaderT m env) (TState mempty mempty) +-- | Signal a type error. bad :: ErrorCase rep -> TypeM rep a bad e = do   messages <- asks envContext@@ -393,6 +392,9 @@ checkConsumption (ConsumptionError e) = bad $ TypeError e checkConsumption (Consumption os) = return os +-- | Type check two mutually control flow branches.  Think @if@.  This+-- interacts with consumption checking, as it is OK for an array to be+-- consumed in both branches. alternative :: TypeM rep a -> TypeM rep b -> TypeM rep (a, b) alternative m1 m2 = do   (x, os1) <- collectOccurences m1@@ -907,7 +909,7 @@           ++ " dimensions of "           ++ show rank           ++ "-dimensional array."-checkBasicOp (Concat i arr1exp arr2exps ressize) = do+checkBasicOp (Concat i (arr1exp :| arr2exps) ressize) = do   arr1t <- checkArrIdent arr1exp   arr2ts <- mapM checkArrIdent arr2exps   let success =@@ -1230,7 +1232,7 @@  checkPatElem ::   Checkable rep =>-  PatElemT (LetDec rep) ->+  PatElem (LetDec rep) ->   TypeM rep () checkPatElem (PatElem name dec) =   context ("When checking pattern element " ++ pretty name) $@@ -1287,7 +1289,7 @@  matchExtPat ::   Checkable rep =>-  Pat (Aliases rep) ->+  Pat (LetDec (Aliases rep)) ->   [ExtType] ->   TypeM rep () matchExtPat pat ts =@@ -1490,7 +1492,7 @@   checkLParamDec :: VName -> LParamInfo rep -> TypeM rep ()   checkLetBoundDec :: VName -> LetDec rep -> TypeM rep ()   checkRetType :: [RetType rep] -> TypeM rep ()-  matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()+  matchPat :: Pat (LetDec (Aliases rep)) -> Exp (Aliases rep) -> TypeM rep ()   primFParam :: VName -> PrimType -> TypeM rep (FParam (Aliases rep))   matchReturnType :: [RetType rep] -> Result -> TypeM rep ()   matchBranchType :: [BranchType rep] -> Body (Aliases rep) -> TypeM rep ()@@ -1514,7 +1516,7 @@   default checkRetType :: RetType rep ~ DeclExtType => [RetType rep] -> TypeM rep ()   checkRetType = mapM_ $ checkExtType . declExtTypeOf -  default matchPat :: Pat (Aliases rep) -> Exp (Aliases rep) -> TypeM rep ()+  default matchPat :: Pat (LetDec (Aliases rep)) -> Exp (Aliases rep) -> TypeM rep ()   matchPat pat = matchExtPat pat <=< expExtType    default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))

@@ -5,6 +5,41 @@ -- -- This module implements a transformation from source to core -- Futhark.+--+-- The source and core language is similar in spirit, but the core+-- language is much more regular (and mostly much simpler) in order to+-- make it easier to write program transformations.+--+-- * "Language.Futhark.Syntax" contains the source language definition.+--+-- * "Futhark.IR.Syntax" contains the core IR definition.+--+-- Specifically, internalisation generates the SOACS dialect of the+-- core IR ("Futhark.IR.SOACS").  This is then initially used by the+-- compiler middle-end.  The main differences between the source and+-- core IR are as follows:+--+-- * The core IR has no modules.  These are removed in+--   "Futhark.Internalise.Defunctorise".+--+-- * The core IR is monomorphic.  Polymorphic functions are monomorphised in+--   "Futhark.Internalise.Monomorphise"+--+-- * The core IR is first-order. "Futhark.Internalise.Defunctionalise"+--   removes higher-order functions.+--+-- * The core IR is in [ANF](https://en.wikipedia.org/wiki/A-normal_form).+--+-- * The core IR does not have arrays of tuples (or tuples or records+--   at all, really).  Arrays of tuples are turned into multiple+--   arrays.  For example, a source language transposition of an array+--   of pairs becomes a core IR that contains two transpositions of+--   two distinct arrays.  The guts of this transformation is in+--   "Futhark.Internalise.Exps".+--+-- * For the above reason, SOACs also accept multiple input arrays.+--   The available primitive operations are also somewhat different+--   than in the source language.  See 'Futhark.IR.SOACS.SOAC.SOAC'. module Futhark.Internalise (internaliseProg) where  import qualified Data.Text as T

@@ -20,7 +20,7 @@  shapeMapping ::   (HasScope SOACS m, Monad m) =>-  [FParam] ->+  [FParam SOACS] ->   [Type] ->   m (M.Map VName SubExp) shapeMapping all_params value_arg_types =@@ -42,7 +42,7 @@     match (Var v, se) = Just (v, se)     match _ = Nothing -argShapes :: [VName] -> [FParam] -> [Type] -> InternaliseM [SubExp]+argShapes :: [VName] -> [FParam SOACS] -> [Type] -> InternaliseM [SubExp] argShapes shapes all_params valargts = do   mapping <- shapeMapping all_params valargts   let addShape name =

@@ -36,7 +36,7 @@ bindingFParams ::   [E.TypeParam] ->   [E.Pat] ->-  ([I.FParam] -> [[I.FParam]] -> InternaliseM a) ->+  ([I.FParam I.SOACS] -> [[I.FParam I.SOACS]] -> InternaliseM a) ->   InternaliseM a bindingFParams tparams params m = do   flattened_params <- mapM flattenPat params@@ -65,7 +65,7 @@   [E.TypeParam] ->   E.Pat ->   [I.Type] ->-  ([I.FParam] -> [I.FParam] -> InternaliseM a) ->+  ([I.FParam I.SOACS] -> [I.FParam I.SOACS] -> InternaliseM a) ->   InternaliseM a bindingLoopParams tparams pat ts m = do   pat_idents <- flattenPat pat@@ -81,7 +81,7 @@ bindingLambdaParams ::   [E.Pat] ->   [I.Type] ->-  ([I.LParam] -> InternaliseM a) ->+  ([I.LParam I.SOACS] -> InternaliseM a) ->   InternaliseM a bindingLambdaParams params ts m = do   params_idents <- concat <$> mapM flattenPat params

@@ -10,6 +10,7 @@  import Control.Monad.Reader import Data.List (find, intercalate, intersperse, transpose)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -128,7 +129,7 @@  entryPoint ::   Name ->-  [(E.EntryParam, [I.FParam])] ->+  [(E.EntryParam, [I.FParam SOACS])] ->   ( E.EntryType,     [[I.TypeBase ExtShape Uniqueness]]   ) ->@@ -187,20 +188,20 @@        in (d + 1, te')     withoutDims te = (0 :: Int, te) -internaliseBody :: String -> E.Exp -> InternaliseM Body+internaliseBody :: String -> E.Exp -> InternaliseM (Body SOACS) internaliseBody desc e =   buildBody_ $ subExpsRes <$> internaliseExp (desc <> "_res") e  bodyFromStms ::   InternaliseM (Result, a) ->-  InternaliseM (Body, a)+  InternaliseM (Body SOACS, a) bodyFromStms m = do   ((res, a), stms) <- collectStms m   (,a) <$> mkBodyM stms res  -- | Only returns those pattern names that are not used in the pattern -- itself (the "non-existential" part, you could say).-letValExp :: String -> I.Exp -> InternaliseM [VName]+letValExp :: String -> I.Exp SOACS -> InternaliseM [VName] letValExp name e = do   e_t <- expExtType e   names <- replicateM (length e_t) $ newVName name@@ -208,11 +209,11 @@   let ctx = shapeContext e_t   pure $ map fst $ filter ((`S.notMember` ctx) . snd) $ zip names [0 ..] -letValExp' :: String -> I.Exp -> InternaliseM [SubExp]+letValExp' :: String -> I.Exp SOACS -> InternaliseM [SubExp] letValExp' _ (BasicOp (SubExp se)) = pure [se] letValExp' name ses = map I.Var <$> letValExp name ses -eValBody :: [InternaliseM I.Exp] -> InternaliseM I.Body+eValBody :: [InternaliseM (I.Exp SOACS)] -> InternaliseM (I.Body SOACS) eValBody es = buildBody_ $ do   es' <- sequence es   varsRes . concat <$> mapM (letValExp "x") es'@@ -919,7 +920,7 @@           ses''         ) -generateCaseIf :: [I.SubExp] -> Case -> I.Body -> InternaliseM I.Exp+generateCaseIf :: [I.SubExp] -> Case -> I.Body SOACS -> InternaliseM (I.Exp SOACS) generateCaseIf ses (CasePat p eCase _) bFail = do   (cond, pertinent) <- generateCond p ses   eCase' <- internalisePat' [] p pertinent eCase (internaliseBody "case")@@ -1115,7 +1116,7 @@ internaliseScanOrReduce ::   String ->   String ->-  (SubExp -> I.Lambda -> [SubExp] -> [VName] -> InternaliseM (SOAC SOACS)) ->+  (SubExp -> I.Lambda SOACS -> [SubExp] -> [VName] -> InternaliseM (SOAC SOACS)) ->   (E.Exp, E.Exp, E.Exp, SrcLoc) ->   InternaliseM [SubExp] internaliseScanOrReduce desc what f (lam, ne, arr, loc) = do@@ -1526,7 +1527,7 @@  -- 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 SOACS -> InternaliseM [ExtType] bodyExtType (Body _ stms res) =   existentialiseExtTypes (M.keys stmsscope) . staticShapes     <$> extendedScope (traverse subExpResType res) stmsscope@@ -1786,7 +1787,7 @@           =<< mapM (fmap (arraysSize 0) . mapM lookupType) [ys]        let conc xarr yarr =-            I.BasicOp $ I.Concat 0 xarr [yarr] ressize+            I.BasicOp $ I.Concat 0 (xarr :| [yarr]) ressize       letSubExps desc $ zipWith conc xs ys     handleRest [TupLit [offset, e] _] "rotate" = Just $ \desc -> do       offset' <- internaliseExp1 "rotation_offset" offset@@ -2084,7 +2085,7 @@   return $ if check then I.Safe else I.Unsafe  -- Implement partitioning using maps, scans and writes.-partitionWithSOACS :: Int -> I.Lambda -> [I.VName] -> InternaliseM ([I.SubExp], [I.SubExp])+partitionWithSOACS :: Int -> I.Lambda SOACS -> [I.VName] -> InternaliseM ([I.SubExp], [I.SubExp]) partitionWithSOACS k lam arrs = do   arr_ts <- mapM lookupType arrs   let w = arraysSize 0 arr_ts@@ -2178,7 +2179,7 @@       [SubExp] ->       SubExp ->       Int ->-      [I.LParam] ->+      [I.LParam SOACS] ->       InternaliseM SubExp     mkOffsetLambdaBody _ _ _ [] =       return $ constant (-1 :: Int64)