futhark 0.19.1 → 0.19.2

raw patch · 58 files changed

+1823/−1625 lines, 58 filesdep +hashabledep −sexp-grammarPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable

Dependencies removed: sexp-grammar

API changes (from Hackage documentation)

Files

• docs/binary-data-format.rst +9/−5
• docs/man/futhark-bench.rst +14/−14
• docs/man/futhark-literate.rst +51/−50
• docs/man/futhark-test.rst +2/−2
• docs/man/futhark.rst +6/−0
• futhark.cabal +5/−3
• rts/c/atomics.h +4/−0
• rts/python/server.py +3/−2
• src/Futhark/Actions.hs +12/−27
• src/Futhark/Analysis/PrimExp.hs +2/−23
• src/Futhark/Analysis/PrimExp/Parse.hs +55/−0
• src/Futhark/CLI/Dev.hs +39/−34
• src/Futhark/CLI/Literate.hs +267/−178
• src/Futhark/CLI/Misc.hs +14/−0
• src/Futhark/CodeGen/Backends/SimpleRep.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +6/−1
• src/Futhark/CodeGen/ImpGen/Multicore/Base.hs +1/−11
• src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +1/−1
• src/Futhark/Compiler.hs +25/−4
• src/Futhark/Compiler/Program.hs +22/−12
• src/Futhark/Construct.hs +0/−11
• src/Futhark/IR/Aliases.hs +3/−34
• src/Futhark/IR/Decorations.hs +1/−10
• src/Futhark/IR/Kernels/Kernel.hs +20/−56
• src/Futhark/IR/Kernels/Sizes.hs +9/−26
• src/Futhark/IR/MC/Op.hs +1/−14
• src/Futhark/IR/Mem.hs +9/−91
• src/Futhark/IR/Mem/IxFun.hs +16/−57
• src/Futhark/IR/Parse.hs +927/−0
• src/Futhark/IR/Pretty.hs +65/−86
• src/Futhark/IR/Primitive.hs +12/−186
• src/Futhark/IR/Primitive/Parse.hs +95/−0
• src/Futhark/IR/Prop.hs +1/−8
• src/Futhark/IR/Prop/Names.hs +1/−9
• src/Futhark/IR/SOACS/SOAC.hs +7/−84
• src/Futhark/IR/SegOp.hs +31/−124
• src/Futhark/IR/Syntax.hs +10/−200
• src/Futhark/IR/Syntax/Core.hs +15/−126
• src/Futhark/Internalise/LiftLambdas.hs +6/−1
• src/Futhark/Internalise/Monomorphise.hs +1/−2
• src/Futhark/Optimise/BlkRegTiling.hs +1/−1
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +1/−1
• src/Futhark/Optimise/Simplify/Lore.hs +6/−27
• src/Futhark/Optimise/TileLoops/Shared.hs +1/−1
• src/Futhark/Pass/ExtractKernels.hs +1/−1
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +2/−2
• src/Futhark/Pass/ExtractKernels/Intragroup.hs +1/−1
• src/Futhark/Pass/ExtractMulticore.hs +1/−1
• src/Futhark/Script.hs +16/−4
• src/Futhark/Test.hs +0/−1
• src/Futhark/Test/Values.hs +0/−6
• src/Futhark/Util.hs +7/−11
• src/Language/Futhark/Core.hs +4/−44
• src/Language/Futhark/Prop.hs +0/−5
• src/Language/Futhark/TypeChecker/Terms.hs +10/−11
• src/futhark.hs +1/−0
• unittests/Futhark/IR/PrimitiveTests.hs +1/−14

@@ -39,7 +39,7 @@  The general format has this header:: -  b <version> <num_dims> <type>+  b <version> <num_dims> <type> <values...>  Where ``version`` is a byte containing the version of the binary format used for encoding (currently 2), ``num_dims`` is the number of dimensions in the array as@@ -50,11 +50,12 @@    b <version> 0 <type> <value> -To encode an array we must encode the number of dimensions ``n`` as a single-byte, each dimension ``dim_i`` as an unsigned 64-bit little endian integer, and-finally all the values in their binary little endian representation::+To encode an array, we encode the number of dimensions ``n`` as a+single byte, each dimension ``dim_i`` as an unsigned 64-bit little+endian integer, and finally all the values in row-major order in their+binary little endian representation:: -  b <version> <n> <type> <dim_1> <dim_2> ... <dim_n> <values>+  b <version> <n> <type> <dim_1> <dim_2> ... <dim_n> <values...>   Type Values@@ -77,3 +78,6 @@  Note that unsigned and signed integers have the same byte-level representation.++Values of type ``bool`` are encoded with a byte each.  The results are+undefined if this byte is not either 0 or 1.

@@ -134,20 +134,20 @@ The following program benchmarks how quickly we can sum arrays of different sizes:: -  -- How quickly can we reduce arrays?-  ---  -- ==-  -- nobench input { 0 }-  -- output { 0 }-  -- input { 100 }-  -- output { 4950 }-  -- compiled input { 100000 }-  -- output { 704982704 }-  -- compiled input { 100000000 }-  -- output { 887459712 }--  let main(n: i32): i32 =-    reduce (+) 0 (iota n)+ -- How quickly can we reduce arrays?+ --+ -- ==+ -- nobench input { 0i64 }+ -- output { 0i64 }+ -- input { 100i64 }+ -- output { 4950i64 }+ -- compiled input { 10000i64 }+ -- output { 49995000i64 }+ -- compiled input { 1000000i64 }+ -- output { 499999500000i64 }+ + let main(n: i64): i64 =+   reduce (+) 0 (iota n)  SEE ALSO ========

@@ -34,10 +34,56 @@ Image directives and builtin functions Shells out to ``convert`` (from ImageMagick).  Video generation uses ``fmpeg``. -Directives+OPTIONS+=======++--backend=name++  The backend used when compiling Futhark programs (without leading+  ``futhark``, e.g. just ``opencl``).  Defaults to ``c``.++--futhark=program++  The program used to perform operations (eg. compilation).  Defaults+  to the binary running ``futhark literate`` itself.++--output=FILE++  Override the default output file.  The image directory will be set+  to the provided ``FILE`` with its extension stripped and ``-img/``+  appended.++--pass-option=opt++  Pass an option to benchmark programs that are being run.  For+  example, we might want to run OpenCL programs on a specific device::++    futhark literate prog.fut --backend=opencl --pass-option=-dHawaii++--pass-compiler-option=opt++  Pass an extra option to the compiler when compiling the programs.++--skip-compilation++  Do not run the compiler, and instead assume that the program has+  already been compiled.  Use with caution.++--stop-on-error++  Terminate immediately without producing an output file if a+  directive fails.  Otherwise a file will still be produced, and+  failing directives will be followed by an error message.++-v, --verbose++  Print verbose information on stderr about directives as they are+  executing.++DIRECTIVES ========== -A directive is a way to embed the results the running the program.+A directive is a way to show the result of running a funtion. Depending on the directive, this can be as simple as printing the textual representation of the result, or as complex as running an external plotting program and referencing a generated image.@@ -104,7 +150,8 @@   The two arrays must have the same length and are interpreted as   ``x`` and ``y`` values, respectively. -  The expression may also be a record, where each field will be+  The expression may also be a record expression (*not* merely the+  name of a Futhark variable of record type), where each field will be   plotted separately and must have the type mentioned above.  * ``> :gnuplot e; script...``@@ -119,7 +166,7 @@   Use ``set term png size width,height`` to change the size to   ``width`` by ``height`` pixels. -FutharkScript+FUTHARKSCRIPT =============  Only an extremely limited subset of Futhark is supported:@@ -140,52 +187,6 @@  * ``$loadimg "file"`` reads an image from the given file and returns   it as a row-major ``[][]u32`` array with each pixel encoded as ARGB.--OPTIONS-=======----backend=name--  The backend used when compiling Futhark programs (without leading-  ``futhark``, e.g. just ``opencl``).  Defaults to ``c``.----futhark=program--  The program used to perform operations (eg. compilation).  Defaults-  to the binary running ``futhark literate`` itself.----output=FILE--  Override the default output file.  The image directory will be set-  to the provided ``FILE`` with its extension stripped and ``-img/``-  appended.----pass-option=opt--  Pass an option to benchmark programs that are being run.  For-  example, we might want to run OpenCL programs on a specific device::--    futhark literate prog.fut --backend=opencl --pass-option=-dHawaii----pass-compiler-option=opt--  Pass an extra option to the compiler when compiling the programs.----skip-compilation--  Do not run the compiler, and instead assume that the program has-  already been compiled.  Use with caution.----stop-on-error--  Terminate immediately without producing an output file if a-  directive fails.  Otherwise a file will still be produced, and-  failing directives will be followed by an error message.---v, --verbose--  Print verbose information on stderr about directives as they are-  executing.  SAFETY ======

@@ -194,7 +194,7 @@   -- input { [4,3,2,1] 1i64 }   -- output { 3 }   -- input { [4,3,2,1] 5i64 }-  -- error: Assertion.*failed+  -- error: Error*    let main (a: []i32) (i: i64): i32 =     a[i]@@ -202,7 +202,7 @@ The following program contains two entry points, both of which are tested:: -  let add(x: i32, y: i32): i32 = x + y+  let add (x: i32) (y: i32): i32 = x + y    -- Test the add1 function.   -- ==

@@ -54,6 +54,12 @@ intended for use in developing the Futhark compiler, not for programmers writing in Futhark. +futhark hash PROGRAM+--------------------++Print a hexadecimal hash of the program AST, including all imports.+Supposed to be invariant to whitespace changes.+ futhark imports PROGRAM ----------------------- 

@@ -1,7 +1,7 @@ cabal-version: 2.4 -- Run 'cabal2nix . >futhark.nix' after adding deps. name:           futhark-version:        0.19.1+version:        0.19.2 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -61,6 +61,7 @@       Futhark.Analysis.Metrics       Futhark.Analysis.Metrics.Type       Futhark.Analysis.PrimExp+      Futhark.Analysis.PrimExp.Parse       Futhark.Analysis.PrimExp.Convert       Futhark.Analysis.PrimExp.Generalize       Futhark.Analysis.PrimExp.Simplify@@ -147,6 +148,7 @@       Futhark.IR       Futhark.IR.Aliases       Futhark.IR.Decorations+      Futhark.IR.Parse       Futhark.IR.Kernels       Futhark.IR.Kernels.Kernel       Futhark.IR.Kernels.Simplify@@ -160,6 +162,7 @@       Futhark.IR.Mem.Simplify       Futhark.IR.Pretty       Futhark.IR.Primitive+      Futhark.IR.Primitive.Parse       Futhark.IR.Prop       Futhark.IR.Prop.Aliases       Futhark.IR.Prop.Constants@@ -310,6 +313,7 @@     , filepath >=1.4.1.1     , free >=4.12.4     , gitrev >=1.2.0+    , hashable     , haskeline     , language-c-quote >=0.12     , mainland-pretty >=0.6.1@@ -322,7 +326,6 @@     , process >=1.4.3.0     , process-extras >=0.7.2     , regex-tdfa >=1.2-    , sexp-grammar >= 2.2.1     , srcloc >=0.4     , template-haskell >=2.11.1     , temporary@@ -379,7 +382,6 @@     , megaparsec     , mtl     , parser-combinators-    , sexp-grammar     , tasty     , tasty-hunit     , tasty-quickcheck

@@ -246,6 +246,8 @@ #endif } +#ifdef FUTHARK_F64_ENABLED+ inline double atomic_fadd_f64_global(volatile __global double *p, double x) { #if defined(FUTHARK_CUDA) && __CUDA_ARCH__ >= 600   return atomicAdd((double*)p, x);@@ -277,6 +279,8 @@   return old.f; #endif }++#endif  inline int64_t atomic_smax_i64_global(volatile __global int64_t *p, int64_t x) { #ifdef FUTHARK_CUDA

@@ -54,9 +54,10 @@         entry = self._get_entry_point(self._get_arg(args, 0))         num_ins = len(entry[0])         num_outs = len(entry[1])+        exp_len = 1 + num_outs + num_ins -        if len(args) != 1 + num_outs + num_ins:-            raise self.Failure('Invalid argument count, expected %d')+        if len(args) != exp_len:+            raise self.Failure('Invalid argument count, expected %d' % exp_len)          out_vnames = args[1:num_outs+1] 

@@ -4,6 +4,7 @@ -- something with the result of the pipeline. module Futhark.Actions   ( printAction,+    printAliasesAction,     impCodeGenAction,     kernelImpCodeGenAction,     multicoreImpCodeGenAction,@@ -12,13 +13,11 @@     compileOpenCLAction,     compileCUDAAction,     compileMulticoreAction,-    sexpAction,   ) where  import Control.Monad import Control.Monad.IO.Class-import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.Maybe (fromMaybe) import Futhark.Analysis.Alias import Futhark.Analysis.Metrics@@ -36,17 +35,25 @@ import Futhark.IR.Prop.Aliases import Futhark.IR.SeqMem (SeqMem) import Futhark.Util (runProgramWithExitCode, unixEnvironment)-import Language.SexpGrammar as Sexp import System.Exit import System.FilePath import qualified System.Info --- | Print the result to stdout, with alias annotations.-printAction :: (ASTLore lore, CanBeAliased (Op lore)) => Action lore+-- | Print the result to stdout.+printAction :: ASTLore lore => Action lore printAction =   Action     { actionName = "Prettyprint",       actionDescription = "Prettyprint the resulting internal representation on standard output.",+      actionProcedure = liftIO . putStrLn . pretty+    }++-- | Print the result to stdout, alias annotations.+printAliasesAction :: (ASTLore lore, CanBeAliased (Op lore)) => Action lore+printAliasesAction =+  Action+    { actionName = "Prettyprint",+      actionDescription = "Prettyprint the resulting internal representation on standard output.",       actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis     } @@ -85,28 +92,6 @@       actionDescription = "Translate program into imperative multicore IL and write it on standard output.",       actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenMulticore.compileProg     }---- | Print metrics about AST node counts to stdout.-sexpAction :: ASTLore lore => Action lore-sexpAction =-  Action-    { actionName = "Print sexps",-      actionDescription = "Print sexps on the final IR.",-      actionProcedure = liftIO . helper-    }-  where-    helper :: ASTLore lore => Prog lore -> IO ()-    helper prog =-      case encodePretty prog of-        Right prog' -> do-          ByteString.putStrLn prog'-          let prog'' = decode prog'-          unless (prog'' == Right prog) $-            error $-              "S-exp not isomorph!\n"-                ++ either show pretty prog''-        Left s ->-          error $ "Couldn't encode program: " ++ s  cmdCC :: String cmdCC = fromMaybe "cc" $ lookup "CC" unixEnvironment

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -62,15 +61,11 @@ import Control.Monad import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Text as T import Data.Traversable import Futhark.IR.Primitive import Futhark.IR.Prop.Names import Futhark.Util.IntegralExp import Futhark.Util.Pretty-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | A primitive expression parametrised over the representation of@@ -87,20 +82,7 @@   | UnOpExp UnOp (PrimExp v)   | ConvOpExp ConvOp (PrimExp v)   | FunExp String [PrimExp v] PrimType-  deriving (Eq, Ord, Show, Generic)--instance SexpIso v => SexpIso (PrimExp v) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "leaf") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "value") >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "bin-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "cmp-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el (Sexp.sym "un-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el (Sexp.sym "conv-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                  With-                    (. Sexp.list (Sexp.el (Sexp.sym "fun") >>> Sexp.el (iso T.unpack T.pack . sexpIso) >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-                    End+  deriving (Eq, Ord, Show)  instance Functor PrimExp where   fmap = fmapDefault@@ -131,10 +113,7 @@ -- construction.  Does not guarantee that the underlying expression is -- actually type correct. newtype TPrimExp t v = TPrimExp {untyped :: PrimExp v}-  deriving (Eq, Ord, Show, Generic)--instance SexpIso v => SexpIso (TPrimExp t v) where-  sexpIso = with $ \e -> sexpIso >>> e+  deriving (Eq, Ord, Show)  instance Functor (TPrimExp t) where   fmap = fmapDefault

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Futhark.Analysis.PrimExp.Parse+  ( pPrimExp,+    pPrimValue,++    -- * Module reexport+    module Futhark.Analysis.PrimExp,+  )+where++import Data.Functor+import qualified Data.Text as T+import Data.Void+import Futhark.Analysis.PrimExp+import Futhark.IR.Primitive.Parse+import Futhark.Util.Pretty (prettyText)+import Text.Megaparsec++type Parser = Parsec Void T.Text++pBinOp :: Parser BinOp+pBinOp = choice $ map p allBinOps+  where+    p op = keyword (prettyText op) $> op++pCmpOp :: Parser CmpOp+pCmpOp = choice $ map p allCmpOps+  where+    p op = keyword (prettyText op) $> op++pUnOp :: Parser UnOp+pUnOp = choice $ map p allUnOps+  where+    p op = keyword (prettyText op) $> op++pConvOp :: Parser ConvOp+pConvOp = choice $ map p allConvOps+  where+    p op = keyword (prettyText op) $> op++parens :: Parser a -> Parser a+parens = between (lexeme "(") (lexeme ")")++pPrimExp :: Parser (v, PrimType) -> Parser (PrimExp v)+pPrimExp pLeaf =+  choice+    [ uncurry LeafExp <$> pLeaf,+      ValueExp <$> pPrimValue,+      BinOpExp <$> pBinOp <*> pPrimExp pLeaf <*> pPrimExp pLeaf,+      CmpOpExp <$> pCmpOp <*> pPrimExp pLeaf <*> pPrimExp pLeaf,+      ConvOpExp <$> pConvOp <*> pPrimExp pLeaf,+      UnOpExp <$> pUnOp <*> pPrimExp pLeaf,+      parens $ pPrimExp pLeaf+    ]

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}  -- | Futhark Compiler Driver module Futhark.CLI.Dev (main) where@@ -8,9 +7,9 @@ import Control.Category (id) import Control.Monad import Control.Monad.State-import qualified Data.ByteString.Lazy as ByteString import Data.List (intersperse) import Data.Maybe+import qualified Data.Text as T import qualified Data.Text.IO as T import Futhark.Actions import Futhark.Analysis.Metrics (OpMetrics)@@ -20,6 +19,7 @@ import qualified Futhark.IR.KernelsMem as KernelsMem import qualified Futhark.IR.MC as MC import qualified Futhark.IR.MCMem as MCMem+import Futhark.IR.Parse import Futhark.IR.Prop.Aliases (CanBeAliased) import qualified Futhark.IR.SOACS as SOACS import qualified Futhark.IR.Seq as Seq@@ -52,7 +52,6 @@ import qualified Futhark.Util.Pretty as PP import Language.Futhark.Core (nameFromString) import Language.Futhark.Parser (parseFuthark)-import qualified Language.SexpGrammar as Sexp import System.Exit import System.FilePath import System.IO@@ -445,19 +444,19 @@       "p"       ["print"]       (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction printAction})-      "Prettyprint the resulting internal representation on standard output (default action).",+      "Print the resulting IR (default action).",     Option+      []+      ["print-aliases"]+      (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction printAliasesAction})+      "Print the resulting IR with aliases.",+    Option       "m"       ["metrics"]       (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction metricsAction})       "Print AST metrics of the resulting internal representation on standard output.",     Option       []-      ["sexp"]-      (NoArg $ Right $ \opts -> opts {futharkAction = PolyAction sexpAction})-      "Print the resulting IR as S-expressions to standard output.",-    Option-      []       ["defunctorise"]       (NoArg $ Right $ \opts -> opts {futharkPipeline = Defunctorise})       "Partially evaluate all module constructs and print the residual program.",@@ -631,31 +630,37 @@                   >>= Monomorphise.transformProg                   >>= LiftLambdas.transformProg                   >>= Defunctionalise.transformProg-        Pipeline {} ->-          case splitExtensions file of-            (base, ".fut") -> do-              prog <- runPipelineOnProgram (futharkConfig config) id file-              runPolyPasses config base (SOACS prog)-            (base, ".sexp") -> do-              input <- liftIO $ ByteString.readFile file-              prog <- case Sexp.decode @(Prog SOACS.SOACS) input of-                Right prog' -> return $ SOACS prog'-                Left _ ->-                  case Sexp.decode @(Prog Kernels.Kernels) input of-                    Right prog' -> return $ Kernels prog'-                    Left _ ->-                      case Sexp.decode @(Prog Seq.Seq) input of-                        Right prog' -> return $ Seq prog'-                        Left _ ->-                          case Sexp.decode @(Prog KernelsMem.KernelsMem) input of-                            Right prog' -> return $ KernelsMem prog'-                            Left _ ->-                              case Sexp.decode @(Prog SeqMem.SeqMem) input of-                                Right prog' -> return $ SeqMem prog'-                                Left e -> externalErrorS $ "Couldn't parse sexp input: " ++ show e-              runPolyPasses config base prog-            (_, ext) ->-              externalErrorS $ unwords ["Unsupported extension", show ext, ". Supported extensions: sexp, fut"]+        Pipeline {} -> do+          let (base, ext) = splitExtension file++              readCore parse construct = do+                input <- liftIO $ T.readFile file+                case parse file input of+                  Left err -> externalErrorS $ T.unpack err+                  Right prog -> runPolyPasses config base $ construct prog++              handlers =+                [ ( ".fut",+                    do+                      prog <- runPipelineOnProgram (futharkConfig config) id file+                      runPolyPasses config base (SOACS prog)+                  ),+                  (".fut_soacs", readCore parseSOACS SOACS),+                  (".fut_kernels", readCore parseKernels Kernels),+                  (".fut_kernels_mem", readCore parseKernelsMem KernelsMem),+                  (".fut_mc", readCore parseMC MC),+                  (".fut_mc_mem", readCore parseMCMem MCMem)+                ]+          case lookup ext handlers of+            Just handler -> handler+            Nothing ->+              externalErrorS $+                unwords+                  [ "Unsupported extension",+                    show ext,+                    ". Supported extensions:",+                    unwords $ map fst handlers+                  ]  runPolyPasses :: Config -> FilePath -> UntypedPassState -> FutharkM () runPolyPasses config base initial_prog = do

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}  -- | @futhark literate@@@ -6,12 +7,14 @@  import qualified Codec.BMP as BMP import Control.Monad.Except-import Data.Bifunctor (bimap, first, second)+import Control.Monad.State hiding (State)+import Data.Bifunctor (first, second) import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Char import Data.Functor+import Data.Hashable (hash) import Data.Int (Int64) import Data.List (foldl', transpose) import qualified Data.Map as M@@ -28,21 +31,28 @@ import Futhark.Server import Futhark.Test import Futhark.Test.Values-import Futhark.Util (nubOrd, runProgramWithExitCode)+import Futhark.Util+  ( directoryContents,+    hashIntText,+    nubOrd,+    runProgramWithExitCode,+  ) import Futhark.Util.Options import Futhark.Util.Pretty (prettyText, prettyTextOneLine) import qualified Futhark.Util.Pretty as PP import System.Directory-  ( createDirectoryIfMissing,-    removeFile,+  ( copyFile,+    createDirectoryIfMissing,+    doesFileExist,     removePathForcibly,   ) import System.Environment (getExecutablePath) import System.Exit import System.FilePath import System.IO+import System.IO.Error (isDoesNotExistError) import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)-import Text.Megaparsec hiding (failure, token)+import Text.Megaparsec hiding (State, failure, token) import Text.Megaparsec.Char import Text.Printf @@ -255,18 +265,44 @@     Right script ->       pure script -type ScriptM = ExceptT T.Text IO+-- | The collection of file paths (all inside the image directory)+-- produced during directive execution.+type Files = S.Set FilePath +newtype State = State {stateFiles :: Files}++newtype ScriptM a = ScriptM (ExceptT T.Text (StateT State IO) a)+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadError T.Text,+      MonadFail,+      MonadIO,+      MonadState State+    )++runScriptM :: ScriptM a -> IO (Either T.Text a, Files)+runScriptM (ScriptM m) = second stateFiles <$> runStateT (runExceptT m) s+  where+    s = State mempty+ withTempFile :: (FilePath -> ScriptM a) -> ScriptM a withTempFile f =   join . liftIO . withSystemTempFile "futhark-literate" $ \tmpf tmpf_h -> do     hClose tmpf_h-    either throwError pure <$> runExceptT (f tmpf)+    (res, files) <- runScriptM (f tmpf)+    pure $ do+      modify $ \s -> s {stateFiles = files <> stateFiles s}+      either throwError pure res  withTempDir :: (FilePath -> ScriptM a) -> ScriptM a withTempDir f =-  join . liftIO . withSystemTempDirectory "futhark-literate" $ \dir ->-    either throwError pure <$> runExceptT (f dir)+  join . liftIO . withSystemTempDirectory "futhark-literate" $ \dir -> do+    (res, files) <- runScriptM (f dir)+    pure $ do+      modify $ \s -> s {stateFiles = files <> stateFiles s}+      either throwError pure res  greyFloatToImg ::   (RealFrac a, SVec.Storable a) =>@@ -309,7 +345,12 @@ valueToBMPs :: Value -> Maybe [LBS.ByteString] valueToBMPs = mapM valueToBMP . valueElems -system :: FilePath -> [String] -> T.Text -> ScriptM T.Text+system ::+  (MonadIO m, MonadError T.Text m) =>+  FilePath ->+  [String] ->+  T.Text ->+  m T.Text system prog options input = do   res <- liftIO $ runProgramWithExitCode prog options $ T.encodeUtf8 input   case res of@@ -326,13 +367,6 @@   where     prog' = "'" <> T.pack prog <> "'" -bmpToPNG :: FilePath -> ScriptM FilePath-bmpToPNG bmp = do-  void $ system "convert" [bmp, png] mempty-  pure png-  where-    png = bmp `replaceExtension` "png"- formatDataForGnuplot :: [Value] -> T.Text formatDataForGnuplot = T.unlines . map line . transpose . map valueElems   where@@ -420,97 +454,147 @@ literateBuiltin f _ =   throwError $ "Unknown builtin function $" <> prettyText f -processDirective :: FilePath -> ScriptServer -> Int -> Directive -> ScriptM T.Text-processDirective imgdir server i (DirectiveBrief d) =-  processDirective imgdir server i d-processDirective imgdir server i (DirectiveCovert d) =-  processDirective imgdir server i d-processDirective _ server _ (DirectiveRes e) = do-  vs <- evalExpToGround literateBuiltin server e+data Options = Options+  { scriptBackend :: String,+    scriptFuthark :: Maybe FilePath,+    scriptExtraOptions :: [String],+    scriptCompilerOptions :: [String],+    scriptSkipCompilation :: Bool,+    scriptOutput :: Maybe FilePath,+    scriptVerbose :: Int,+    scriptStopOnError :: Bool+  }++initialOptions :: Options+initialOptions =+  Options+    { scriptBackend = "c",+      scriptFuthark = Nothing,+      scriptExtraOptions = [],+      scriptCompilerOptions = [],+      scriptSkipCompilation = False,+      scriptOutput = Nothing,+      scriptVerbose = 0,+      scriptStopOnError = False+    }++data Env = Env+  { envImgDir :: FilePath,+    envOpts :: Options,+    envServer :: ScriptServer,+    envHash :: Int+  }++newFile :: Env -> FilePath -> (FilePath -> ScriptM ()) -> ScriptM FilePath+newFile env template m = do+  let fname =+        envImgDir env+          </> T.unpack (hashIntText (envHash env)) <> "-" <> template+  exists <- liftIO $ doesFileExist fname+  liftIO $ createDirectoryIfMissing True $ envImgDir env+  when (exists && scriptVerbose (envOpts env) > 0) $+    liftIO $ T.hPutStrLn stderr $ "Using existing file: " <> T.pack fname+  unless exists $ m fname+  modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s}+  pure fname++processDirective :: Env -> Directive -> ScriptM T.Text+processDirective env (DirectiveBrief d) =+  processDirective env d+processDirective env (DirectiveCovert d) =+  processDirective env d+processDirective env (DirectiveRes e) = do+  v <- either nope pure =<< evalExpToGround literateBuiltin (envServer env) e   pure $     T.unlines       [ "",         "```",-        prettyText vs,+        prettyText v,         "```",         ""       ]+  where+    nope t =+      throwError $ "Cannot show value of type " <> prettyText t ---processDirective imgdir server i (DirectiveImg e) = do-  vs <- evalExpToGround literateBuiltin server e-  case vs of-    ValueAtom v+processDirective env (DirectiveImg e) = do+  maybe_v <- evalExpToGround literateBuiltin (envServer env) e+  case maybe_v of+    Right (ValueAtom v)       | Just bmp <- valueToBMP v -> do-        let bmpfile = imgdir </> "img" <> show i <.> ".bmp"-        liftIO $ createDirectoryIfMissing True imgdir-        liftIO $ LBS.writeFile bmpfile bmp-        pngfile <- bmpToPNG bmpfile-        liftIO $ removeFile bmpfile+        pngfile <- withTempDir $ \dir -> do+          let bmpfile = dir </> "img.bmp"+          liftIO $ LBS.writeFile bmpfile bmp+          newFile env "img.png" $ \pngfile ->+            void $ system "convert" [bmpfile, pngfile] mempty         pure $ imgBlock pngfile-    _ ->+    Right v ->+      nope $ fmap valueType v+    Left t ->+      nope t+  where+    nope t =       throwError $-        "Cannot create image from value of type "-          <> prettyText (fmap valueType vs)+        "Cannot create image from value of type " <> prettyText t ---processDirective imgdir server i (DirectivePlot e size) = do-  v <- evalExpToGround literateBuiltin server e-  case v of-    _-      | Just vs <- plottable2d v ->-        plotWith [(Nothing, vs)]-    ValueRecord m-      | Just m' <- traverse plottable2d m ->-        plotWith $ map (first Just) $ M.toList m'-    _ ->-      throwError $-        "Cannot plot value of type " <> prettyText (fmap valueType v)+processDirective env (DirectivePlot e size) = do+  maybe_v <- evalExpToGround literateBuiltin (envServer env) e+  case maybe_v of+    Right v+      | Just vs <- plottable2d v -> do+        pngfile <- newFile env "plot.png" $ plotWith [(Nothing, vs)]+        pure $ imgBlock pngfile+    Right (ValueRecord m)+      | Just m' <- traverse plottable2d m -> do+        pngfile <- newFile env "plot.png" $ plotWith $ map (first Just) $ M.toList m'+        pure $ imgBlock pngfile+    Right v ->+      throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v)+    Left t ->+      throwError $ "Cannot plot opaque value of type " <> prettyText t   where     plottable2d v = do       [x, y] <- plottable v       Just [x, y] -    pngfile = imgdir </> "plot" <> show i <.> ".png"-     tag (Nothing, xys) j = ("data" <> T.pack (show (j :: Int)), xys)     tag (Just f, xys) _ = (f, xys) -    plotWith xys = withGnuplotData [] (zipWith tag xys [0 ..]) $ \fs sets -> do-      liftIO $ createDirectoryIfMissing True imgdir-      let size' = T.pack $-            case size of-              Nothing -> "500,500"-              Just (w, h) -> show w ++ "," ++ show h-          plotCmd f title =-            let title' = case title of-                  Nothing -> "notitle"-                  Just x -> "title '" <> x <> "'"-             in f <> " " <> title' <> " with lines"-          cmds = T.intercalate ", " (zipWith plotCmd fs (map fst xys))-          script =-            T.unlines-              [ "set terminal png size " <> size' <> " enhanced",-                "set output '" <> T.pack pngfile <> "'",-                "set key outside",-                T.unlines sets,-                "plot " <> cmds-              ]-      void $ system "gnuplot" [] script-      pure $ imgBlock pngfile+    plotWith xys pngfile =+      withGnuplotData [] (zipWith tag xys [0 ..]) $ \fs sets -> do+        let size' = T.pack $+              case size of+                Nothing -> "500,500"+                Just (w, h) -> show w ++ "," ++ show h+            plotCmd f title =+              let title' = case title of+                    Nothing -> "notitle"+                    Just x -> "title '" <> x <> "'"+               in f <> " " <> title' <> " with lines"+            cmds = T.intercalate ", " (zipWith plotCmd fs (map fst xys))+            script =+              T.unlines+                [ "set terminal png size " <> size' <> " enhanced",+                  "set output '" <> T.pack pngfile <> "'",+                  "set key outside",+                  T.unlines sets,+                  "plot " <> cmds+                ]+        void $ system "gnuplot" [] script ---processDirective imgdir server i (DirectiveGnuplot e script) = do-  vs <- evalExpToGround literateBuiltin server e-  case vs of-    ValueRecord m-      | Just m' <- traverse plottable m ->-        plotWith $ M.toList m'-    _ ->-      throwError $-        "Cannot plot value of type " <> prettyText (fmap valueType vs)+processDirective env (DirectiveGnuplot e script) = do+  maybe_v <- evalExpToGround literateBuiltin (envServer env) e+  case maybe_v of+    Right (ValueRecord m)+      | Just m' <- traverse plottable m -> do+        pngfile <- newFile env "plot.png" $ plotWith $ M.toList m'+        pure $ imgBlock pngfile+    Right v ->+      throwError $ "Cannot plot value of type " <> prettyText (fmap valueType v)+    Left t ->+      throwError $ "Cannot plot opaque value of type " <> prettyText t   where-    pngfile = imgdir </> "plot" <> show i <.> ".png"--    plotWith xys = withGnuplotData [] xys $ \_ sets -> do-      liftIO $ createDirectoryIfMissing True imgdir+    plotWith xys pngfile = withGnuplotData [] xys $ \_ sets -> do       let script' =             T.unlines               [ "set terminal png enhanced",@@ -519,61 +603,55 @@                 script               ]       void $ system "gnuplot" [] script'-      pure $ imgBlock pngfile ---processDirective imgdir server i (DirectiveVideo e params) = do+processDirective env (DirectiveVideo e params) = do   when (format `notElem` ["webm", "gif"]) $     throwError $ "Unknown video format: " <> format -  v <- evalExp literateBuiltin server e+  v <- evalExp literateBuiltin (envServer env) e   let nope =         throwError $           "Cannot produce video from value of type " <> prettyText (fmap scriptValueType v)-  case v of-    ValueAtom SValue {} -> do-      ValueAtom arr <- getExpValue server v-      case valueToBMPs arr of-        Nothing -> nope-        Just bmps ->-          withTempDir $ \dir -> do-            zipWithM_ (writeBMPFile dir) [0 ..] bmps-            bmpsToVideo dir-    ValueTuple [stepfun, initial, num_frames]-      | ValueAtom (SFun stepfun' _ [_, _] closure) <- stepfun,-        ValueAtom (SValue _ _) <- initial,-        ValueAtom (SValue "i64" _) <- num_frames -> do-        Just (ValueAtom num_frames') <--          mapM getValue <$> getExpValue server num_frames-        withTempDir $ \dir -> do-          let num_frames_int = fromIntegral (num_frames' :: Int64)-          renderFrames dir (stepfun', map ValueAtom closure) initial num_frames_int-          bmpsToVideo dir-    _ ->-      nope -  when (videoFormat params == Just "gif") $ do-    void $ system "ffmpeg" ["-i", webmfile, giffile] mempty-    liftIO $ removeFile webmfile+  videofile <- newFile env ("video" <.> T.unpack format) $ \videofile ->+    case v of+      ValueAtom SValue {} -> do+        ValueAtom arr <- getExpValue (envServer env) v+        case valueToBMPs arr of+          Nothing -> nope+          Just bmps ->+            withTempDir $ \dir -> do+              zipWithM_ (writeBMPFile dir) [0 ..] bmps+              onWebM videofile =<< bmpsToVideo dir+      ValueTuple [stepfun, initial, num_frames]+        | ValueAtom (SFun stepfun' _ [_, _] closure) <- stepfun,+          ValueAtom (SValue _ _) <- initial,+          ValueAtom (SValue "i64" _) <- num_frames -> do+          Just (ValueAtom num_frames') <-+            mapM getValue <$> getExpValue (envServer env) num_frames+          withTempDir $ \dir -> do+            let num_frames_int = fromIntegral (num_frames' :: Int64)+            renderFrames dir (stepfun', map ValueAtom closure) initial num_frames_int+            onWebM videofile =<< bmpsToVideo dir+      _ ->+        nope    pure $ videoBlock params videofile   where     framerate = fromMaybe 30 $ videoFPS params     format = fromMaybe "webm" $ videoFormat params-    webmfile = imgdir </> "video" <> show i <.> "webm"-    giffile = imgdir </> "video" <> show i <.> "gif"     bmpfile dir j = dir </> printf "frame%010d.bmp" (j :: Int)-    videofile = imgdir </> "video" <> show i <.> T.unpack format      renderFrames dir (stepfun, closure) initial num_frames =       foldM_ frame initial [0 .. num_frames -1]       where         frame old_state j = do           v <--            evalExp literateBuiltin server+            evalExp literateBuiltin (envServer env)               . Call (FuncFut stepfun)               . map valueToExp               $ closure ++ [old_state]-          freeValue server old_state+          freeValue (envServer env) old_state            let nope =                 throwError $@@ -582,8 +660,8 @@            case v of             ValueTuple [arr_v@(ValueAtom SValue {}), new_state] -> do-              ValueAtom arr <- getExpValue server arr_v-              freeValue server arr_v+              ValueAtom arr <- getExpValue (envServer env) arr_v+              freeValue (envServer env) arr_v               case valueToBMP arr of                 Nothing -> nope                 Just bmp -> do@@ -591,8 +669,10 @@                   pure new_state             _ -> nope +    writeBMPFile dir j bmp =+      liftIO $ LBS.writeFile (bmpfile dir j) bmp+     bmpsToVideo dir = do-      liftIO $ createDirectoryIfMissing True imgdir       void $         system           "ffmpeg"@@ -607,49 +687,29 @@             "yuv420p",             "-b:v",             "2M",-            webmfile+            dir </> "video.webm"           ]           mempty+      pure $ dir </> "video.webm" -    writeBMPFile dir j bmp =-      liftIO $ LBS.writeFile (bmpfile dir j) bmp+    onWebM videofile webmfile+      | format == "gif" =+        void $ system "ffmpeg" ["-i", webmfile, videofile] mempty+      | otherwise =+        liftIO $ copyFile webmfile videofile  -- Did this script block succeed or fail? data Failure = Failure | Success   deriving (Eq, Ord, Show) -data Options = Options-  { scriptBackend :: String,-    scriptFuthark :: Maybe FilePath,-    scriptExtraOptions :: [String],-    scriptCompilerOptions :: [String],-    scriptSkipCompilation :: Bool,-    scriptOutput :: Maybe FilePath,-    scriptVerbose :: Int,-    scriptStopOnError :: Bool-  }--initialOptions :: Options-initialOptions =-  Options-    { scriptBackend = "c",-      scriptFuthark = Nothing,-      scriptExtraOptions = [],-      scriptCompilerOptions = [],-      scriptSkipCompilation = False,-      scriptOutput = Nothing,-      scriptVerbose = 0,-      scriptStopOnError = False-    }--processBlock :: Options -> FilePath -> ScriptServer -> Int -> Block -> IO (Failure, T.Text)-processBlock _ _ _ _ (BlockCode code)-  | T.null code = pure (Success, "\n")-  | otherwise = pure (Success, "\n```futhark\n" <> code <> "```\n\n")-processBlock _ _ _ _ (BlockComment text) =-  pure (Success, text)-processBlock opts imgdir server i (BlockDirective directive) = do-  when (scriptVerbose opts > 0) $+processBlock :: Env -> Block -> IO (Failure, T.Text, Files)+processBlock _ (BlockCode code)+  | T.null code = pure (Success, "\n", mempty)+  | otherwise = pure (Success, "\n```futhark\n" <> code <> "```\n\n", mempty)+processBlock _ (BlockComment text) =+  pure (Success, text, mempty)+processBlock env (BlockDirective directive) = do+  when (scriptVerbose (envOpts env) > 0) $     T.hPutStrLn stderr . prettyText $       "Processing " <> PP.align (PP.ppr directive) <> "..."   let prompt = case directive of@@ -658,25 +718,44 @@           "```\n" <> prettyText (pprDirective False directive) <> "\n```\n"         _ ->           "```\n" <> prettyText (pprDirective True directive) <> "\n```\n"-  r <- runExceptT $ processDirective imgdir server i directive-  second (prompt <>) <$> case r of-    Left err -> failed err-    Right t -> pure (Success, t)+      env' = env {envHash = hash (envHash env, prettyText directive)}+  (r, files) <- runScriptM $ processDirective env' directive+  case r of+    Left err -> failed prompt err files+    Right t -> pure (Success, prompt <> t, files)   where-    failed err = do+    failed prompt err files = do       let message = prettyTextOneLine directive <> " failed:\n" <> err <> "\n"       liftIO $ T.hPutStr stderr message-      when (scriptStopOnError opts) exitFailure+      when (scriptStopOnError (envOpts env)) exitFailure       pure         ( Failure,-          T.unlines ["**FAILED**", "```", err, "```"]+          T.unlines [prompt, "**FAILED**", "```", err, "```"],+          files         ) -processScript :: Options -> FilePath -> ScriptServer -> [Block] -> IO (Failure, T.Text)-processScript opts imgdir server script =-  bimap (foldl' min Success) mconcat . unzip-    <$> zipWithM (processBlock opts imgdir server) [0 ..] script+-- Delete all files in the given directory that are not contained in+-- 'files'.+cleanupImgDir :: Env -> Files -> IO ()+cleanupImgDir env keep_files =+  mapM_ toRemove . filter (not . (`S.member` keep_files))+    =<< (directoryContents (envImgDir env) `catchError` onError)+  where+    onError e+      | isDoesNotExistError e = pure []+      | otherwise = throwError e+    toRemove f = do+      when (scriptVerbose (envOpts env) > 0) $+        T.hPutStrLn stderr $ "Deleting unused file: " <> T.pack f+      removePathForcibly f +processScript :: Env -> [Block] -> IO (Failure, T.Text)+processScript env script = do+  (failures, outputs, files) <-+    unzip3 <$> mapM (processBlock env) script+  cleanupImgDir env $ mconcat files+  pure (foldl' min Success failures, mconcat outputs)+ commandLineOptions :: [FunOptDescr Options] commandLineOptions =   [ Option@@ -756,24 +835,34 @@                 ++ scriptCompilerOptions opts         when (scriptVerbose opts > 0) $           T.hPutStrLn stderr $ "Compiling " <> T.pack prog <> "..."-        cres <--          runExceptT $++        let onError err = do+              mapM_ (T.hPutStrLn stderr) err+              exitFailure+        void $+          either onError pure <=< runExceptT $             compileProgram compile_options (FutharkExe futhark) (scriptBackend opts) prog-        case cres of-          Left err -> do-            mapM_ (T.hPutStrLn stderr) err++      let onError err = do+            T.hPutStrLn stderr err             exitFailure-          Right _ ->-            pure ()+      proghash <-+        either onError (pure . hash) <=< runExceptT $+          system futhark ["hash", prog] mempty        let mdfile = fromMaybe (prog `replaceExtension` "md") $ scriptOutput opts           imgdir = dropExtension mdfile <> "-img"           run_options = scriptExtraOptions opts -      removePathForcibly imgdir-       withScriptServer ("." </> dropExtension prog) run_options $ \server -> do-        (failure, md) <- processScript opts imgdir server script-        when (failure == Failure) exitFailure+        let env =+              Env+                { envServer = server,+                  envOpts = opts,+                  envHash = proghash,+                  envImgDir = imgdir+                }+        (failure, md) <- processScript env script         T.writeFile mdfile md+        when (failure == Failure) exitFailure     _ -> Nothing

@@ -3,6 +3,7 @@ -- | Various small subcommands that are too simple to deserve their own file. module Futhark.CLI.Misc   ( mainImports,+    mainHash,     mainDataget,   ) where@@ -10,10 +11,14 @@ import Control.Monad.State import qualified Data.ByteString.Lazy as BS import Data.Function (on)+import Data.Hashable (hash) import Data.List (isInfixOf, isPrefixOf, nubBy)+import qualified Data.Text.IO as T import Futhark.Compiler import Futhark.Test+import Futhark.Util (hashIntText) import Futhark.Util.Options+import Futhark.Util.Pretty (prettyText) import System.Environment (getExecutablePath) import System.Exit import System.FilePath@@ -31,6 +36,15 @@             map (++ ".fut") $               filter (\f -> not ("prelude/" `isPrefixOf` f)) $                 map fst prog_imports+    _ -> Nothing++-- | @futhark hash@+mainHash :: String -> [String] -> IO ()+mainHash = mainWithOptions () [] "program" $ \args () ->+  case args of+    [file] -> Just $ do+      prog <- readUntypedProgramOrDie file+      liftIO $ T.putStrLn $ hashIntText $ hash $ prettyText prog     _ -> Nothing  -- | @futhark dataget@

@@ -911,7 +911,7 @@       return p.t;     } -    static inline double fsignum32(double x) {+    static inline float fsignum32(float x) {       return $id:(funName' "isnan32")(x) ? x : ((x > 0) - (x < 0));     } |]

@@ -1735,7 +1735,7 @@   offset <- sExt64 . kernelGlobalThreadId . kernelConstants <$> askEnv   n <- toInt64Exp . arraySize 0 <$> lookupType what   copyDWIM (patElemName pe) [DimSlice offset n $ toInt64Exp stride] (Var what) []-compileThreadResult _ pe (WriteReturns rws _arr dests) = do+compileThreadResult _ pe (WriteReturns (Shape rws) _arr dests) = do   constants <- kernelConstants <$> askEnv   let rws' = map toInt64Exp rws   forM_ dests $ \(slice, e) -> do

@@ -414,7 +414,11 @@     [C.cedecl|$esc:("#endif")|],     [C.cedecl|$esc:("#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable")|]   ]-    ++ [[C.cedecl|$esc:("#pragma OPENCL EXTENSION cl_khr_fp64 : enable")|] | uses_float64]+    ++ concat+      [ [C.cunit|$esc:("#pragma OPENCL EXTENSION cl_khr_fp64 : enable")+                 $esc:("#define FUTHARK_F64_ENABLED")|]+        | uses_float64+      ]     ++ [C.cunit| /* Some OpenCL programs dislike empty progams, or programs with no kernels.  * Declare a dummy kernel to ensure they remain our friends. */@@ -472,6 +476,7 @@     cudafy =       [CUDAC.cunit| $esc:("#define FUTHARK_CUDA")+$esc:("#define FUTHARK_F64_ENABLED")  typedef char int8_t; typedef short int16_t;

@@ -1,6 +1,5 @@ module Futhark.CodeGen.ImpGen.Multicore.Base-  ( compileKBody,-    extractAllocations,+  ( extractAllocations,     compileThreadResult,     HostEnv (..),     AtomicBinOp,@@ -94,15 +93,6 @@   forM segbinops $ \(SegBinOp comm lam ne shape) -> do     lam' <- renameLambda lam     return $ SegBinOp comm lam' ne shape--compileKBody ::-  KernelBody MCMem ->-  ([(SubExp, [Imp.Exp])] -> ImpM MCMem () Imp.Multicore ()) ->-  ImpM MCMem () Imp.Multicore ()-compileKBody kbody red_cont =-  compileStms (freeIn $ kernelBodyResult kbody) (kernelBodyStms kbody) $ do-    let red_res = kernelBodyResult kbody-    red_cont $ zip (map kernelResultSubExp red_res) $ repeat []  compileThreadResult ::   SegSpace ->

@@ -18,7 +18,7 @@   MulticoreGen () writeResult is pe (Returns _ se) =   copyDWIMFix (patElemName pe) (map Imp.vi64 is) se []-writeResult _ pe (WriteReturns rws _ idx_vals) = do+writeResult _ pe (WriteReturns (Shape rws) _ idx_vals) = do   let (iss, vs) = unzip idx_vals       rws' = map toInt64Exp rws   forM_ (zip iss vs) $ \(slice, v) -> do

@@ -13,11 +13,14 @@     module Futhark.Compiler.Program,     readProgram,     readProgramOrDie,+    readUntypedProgram,+    readUntypedProgramOrDie,   ) where  import Control.Monad import Control.Monad.Except+import Data.Bifunctor (first) import qualified Data.Text.IO as T import qualified Futhark.Analysis.Alias as Alias import Futhark.Compiler.Program@@ -29,6 +32,8 @@ import qualified Futhark.TypeCheck as I import Futhark.Util.Log import Futhark.Util.Pretty (ppr, prettyText)+import qualified Language.Futhark as E+import Language.Futhark.Semantic (includeToString) import Language.Futhark.Warnings import System.Exit (ExitCode (..), exitWith) import System.IO@@ -162,15 +167,31 @@   m (Warnings, Imports, VNameSource) readProgram extra_eps = readLibrary extra_eps . pure --- | Not verbose, and terminates process on error.-readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)-readProgramOrDie file = liftIO $ do-  res <- runFutharkM (readProgram mempty file) NotVerbose+-- | Read and parse (but do not type-check) a Futhark program,+-- including all imports.+readUntypedProgram ::+  (MonadError CompilerError m, MonadIO m) =>+  FilePath ->+  m [(String, E.UncheckedProg)]+readUntypedProgram =+  fmap (map (first includeToString)) . readUntypedLibrary . pure++orDie :: MonadIO m => FutharkM a -> m a+orDie m = liftIO $ do+  res <- runFutharkM m NotVerbose   case res of     Left err -> do       dumpError newFutharkConfig err       exitWith $ ExitFailure 2     Right res' -> return res'++-- | Not verbose, and terminates process on error.+readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)+readProgramOrDie file = orDie $ readProgram mempty file++-- | Not verbose, and terminates process on error.+readUntypedProgramOrDie :: MonadIO m => FilePath -> m [(String, E.UncheckedProg)]+readUntypedProgramOrDie file = orDie $ readUntypedProgram file  -- | Run an operation that produces warnings, and handle them -- appropriately, yielding the non-warning return value.  "Proper

@@ -6,6 +6,7 @@ -- more high-level API. module Futhark.Compiler.Program   ( readLibrary,+    readUntypedLibrary,     readImports,     Imports,     FileModule (..),@@ -183,19 +184,15 @@         E.ValDec vb {E.valBindEntryPoint = Just E.NoInfo}     onDec dec = dec --- | Read and type-check some Futhark files.-readLibrary ::-  (MonadError CompilerError m, MonadIO m) =>-  -- | Extra functions that should be marked as entry points; only-  -- applies to the immediate files, not any imports imported.-  [E.Name] ->-  -- | The files to read.+-- | 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 (E.Warnings, Imports, VNameSource)-readLibrary extra_eps fps =-  typeCheckProgram emptyBasis . setEntryPoints extra_eps fps <=< runReaderM $ do-    readImport [] (mkInitialImport "/prelude/prelude")-    mapM_ onFile fps+  m [(ImportName, E.UncheckedProg)]+readUntypedLibrary fps = runReaderM $ do+  readImport [] (mkInitialImport "/prelude/prelude")+  mapM_ onFile fps   where     onFile fp = do       r <- liftIO $ readFileSafely fp@@ -206,6 +203,19 @@         Nothing -> externalErrorS $ fp ++ ": file not found."       where         (fp_name, _) = Posix.splitExtension fp++-- | Read and type-check some Futhark files.+readLibrary ::+  (MonadError CompilerError m, MonadIO m) =>+  -- | Extra functions that should be marked as entry points; only+  -- applies to the immediate files, not any imports imported.+  [E.Name] ->+  -- | The files to read.+  [FilePath] ->+  m (E.Warnings, Imports, VNameSource)+readLibrary extra_eps fps =+  typeCheckProgram emptyBasis . setEntryPoints 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

@@ -66,7 +66,6 @@     eConvOp,     eSignum,     eCopy,-    eAssert,     eBody,     eLambda,     eRoundToMultipleOf,@@ -276,16 +275,6 @@   m (Exp (Lore m)) ->   m (Exp (Lore m)) eCopy e = BasicOp . Copy <$> (letExp "copy_arg" =<< e)--eAssert ::-  MonadBinder m =>-  m (Exp (Lore m)) ->-  ErrorMsg SubExp ->-  SrcLoc ->-  m (Exp (Lore m))-eAssert e msg loc = do-  e' <- letSubExp "assert_arg" =<< e-  return $ BasicOp $ Assert e' msg (loc, mempty)  eBody ::   (MonadBinder m) =>

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -60,20 +59,14 @@ import Futhark.Transform.Rename import Futhark.Transform.Substitute import qualified Futhark.Util.Pretty as PP-import GHC.Generics-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic  -- | The lore for the basic representation. data Aliases lore --- | A wrapper around 'AliasDec to get around the fact that we need an+-- | A wrapper around 'AliasDec' to get around the fact that we need an -- 'Ord' instance, which 'AliasDec does not have. newtype AliasDec = AliasDec {unAliases :: Names}-  deriving (Show, Generic)--instance SexpIso AliasDec where-  sexpIso = with $ \vname -> sexpIso >>> vname+  deriving (Show)  instance Semigroup AliasDec where   x <> y = AliasDec $ unAliases x <> unAliases y@@ -97,7 +90,7 @@   freeIn' = const mempty  instance PP.Pretty AliasDec where-  ppr = PP.commasep . map PP.ppr . namesToList . unAliases+  ppr = PP.braces . PP.commasep . map PP.ppr . namesToList . unAliases  -- | The aliases of the let-bound variable. type VarAliases = AliasDec@@ -143,20 +136,6 @@   bodyAliases = map unAliases . fst . fst . bodyDec   consumedInBody = unAliases . snd . fst . bodyDec -instance-  PrettyAnnot (PatElemT dec) =>-  PrettyAnnot (PatElemT (VarAliases, dec))-  where-  ppAnnot (PatElem name (AliasDec als, dec)) =-    let alias_comment = PP.oneLine <$> aliasComment name als-     in case (alias_comment, ppAnnot (PatElem name dec)) of-          (_, Nothing) ->-            alias_comment-          (Just alias_comment', Just inner_comment) ->-            Just $ alias_comment' PP.</> inner_comment-          (Nothing, Just inner_comment) ->-            Just inner_comment- instance (ASTLore lore, CanBeAliased (Op lore)) => PrettyLore (Aliases lore) where   ppExpLore (consumed, inner) e =     maybeComment $@@ -190,16 +169,6 @@ maybeComment :: [PP.Doc] -> Maybe PP.Doc maybeComment [] = Nothing maybeComment cs = Just $ PP.folddoc (PP.</>) cs--aliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc-aliasComment name als =-  case namesToList als of-    [] -> Nothing-    als' ->-      Just $-        PP.oneLine $-          PP.text "-- " <> PP.ppr name <> PP.text " aliases "-            <> PP.commasep (map PP.ppr als')  resultAliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc resultAliasComment name als =

@@ -13,7 +13,6 @@ import Futhark.IR.Prop.Types import Futhark.IR.RetType import Futhark.IR.Syntax.Core-import Language.SexpGrammar (SexpIso)  -- | A collection of type families, along with constraints specifying -- that the types they map to should satisfy some minimal@@ -48,15 +47,7 @@     Typed (FParamInfo l),     Typed (LParamInfo l),     Typed (LetDec l),-    DeclTyped (FParamInfo l),-    SexpIso (LetDec l),-    SexpIso (ExpDec l),-    SexpIso (BodyDec l),-    SexpIso (FParamInfo l),-    SexpIso (LParamInfo l),-    SexpIso (RetType l),-    SexpIso (BranchType l),-    SexpIso (Op l)+    DeclTyped (FParamInfo l)   ) =>   Decorations l   where

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -25,7 +24,6 @@   ) where -import Control.Category import Futhark.Analysis.Metrics import qualified Futhark.Analysis.SymbolTable as ST import Futhark.IR@@ -44,12 +42,8 @@     ppr,     text,     (<+>),-    (</>),   ) import qualified Futhark.Util.Pretty as PP-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | At which level the *body* of a t'SegOp' executes.@@ -64,32 +58,23 @@         segGroupSize :: Count GroupSize SubExp,         segVirt :: SegVirt       }-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SegLevel where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "thread") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "group") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance PP.Pretty SegLevel where   ppr lvl =-    lvl'-      </> PP.parens-        ( text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi-            <+> text "groupsize="-            <> ppr (segGroupSize lvl)-            <> case segVirt lvl of-              SegNoVirt -> mempty-              SegNoVirtFull -> PP.semi <+> text "full"-              SegVirt -> PP.semi <+> text "virtualise"-        )+    PP.parens+      ( lvl' <> PP.semi+          <+> text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi+          <+> text "groupsize=" <> ppr (segGroupSize lvl) <> virt+      )     where       lvl' = case lvl of-        SegThread {} -> "_thread"-        SegGroup {} -> "_group"+        SegThread {} -> "thread"+        SegGroup {} -> "group"+      virt = case segVirt lvl of+        SegNoVirt -> mempty+        SegNoVirtFull -> PP.semi <+> text "full"+        SegVirt -> PP.semi <+> text "virtualise"  instance Engine.Simplifiable SegLevel where   simplify (SegThread num_groups group_size virt) =@@ -157,18 +142,7 @@     -- The @Name@ is a size name.  Note that @w@ is an i64 to avoid     -- overflow issues.     CalcNumGroups SubExp Name SubExp-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SizeOp where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "split-space") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "get-size") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "get-size-max") >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "cmp-size-le") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With-                (. Sexp.list (Sexp.el (Sexp.sym "calc-num-groups") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-                End+  deriving (Eq, Ord, Show)  instance Substitute SizeOp where   substituteNames subst (SplitSpace o w i elems_per_thread) =@@ -222,19 +196,18 @@   freeIn' _ = mempty  instance PP.Pretty SizeOp where-  ppr (SplitSpace o w i elems_per_thread) =-    text "splitSpace" <> suff+  ppr (SplitSpace SplitContiguous w i elems_per_thread) =+    text "split_space"       <> parens (commasep [ppr w, ppr i, ppr elems_per_thread])-    where-      suff = case o of-        SplitContiguous -> mempty-        SplitStrided stride -> text "Strided" <> parens (ppr stride)+  ppr (SplitSpace (SplitStrided stride) w i elems_per_thread) =+    text "split_space_strided"+      <> parens (commasep [ppr stride, ppr w, ppr i, ppr elems_per_thread])   ppr (GetSize name size_class) =     text "get_size" <> parens (commasep [ppr name, ppr size_class])   ppr (GetSizeMax size_class) =     text "get_size_max" <> parens (commasep [ppr size_class])   ppr (CmpSizeLe name size_class x) =-    text "get_size" <> parens (commasep [ppr name, ppr size_class])+    text "cmp_size" <> parens (commasep [ppr name, ppr size_class])       <+> text "<="       <+> ppr x   ppr (CalcNumGroups w max_num_groups group_size) =@@ -266,16 +239,7 @@     SegOp (SegOp SegLevel lore)   | SizeOp SizeOp   | OtherOp op-  deriving (Eq, Ord, Show, Generic)--instance (SexpIso op, Decorations lore) => SexpIso (HostOp lore op) where-  sexpIso =-    match $-      With (. sexpIso) $-        With (. sexpIso) $-          With-            (. sexpIso)-            End+  deriving (Eq, Ord, Show)  instance (ASTLore lore, Substitute op) => Substitute (HostOp lore op) where   substituteNames substs (SegOp op) =

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-}@@ -23,10 +22,7 @@ import Futhark.Transform.Substitute import Futhark.Util.IntegralExp (IntegralExp) import Futhark.Util.Pretty-import GHC.Generics (Generic) import Language.Futhark.Core (Name)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | An indication of which comparisons have been performed to get to@@ -47,32 +43,22 @@     SizeLocalMemory   | -- | A bespoke size with a default.     SizeBespoke Name Int64-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SizeClass where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "threshold") >>> Sexp.el sexpIso >>> props (Sexp.optKey "default" (iso fromIntegral fromIntegral . Sexp.int)))) $-        With (. Sexp.sym "group") $-          With (. Sexp.sym "num-groups") $-            With (. Sexp.sym "tile") $-              With (. Sexp.sym "reg-tile") $-                With (. Sexp.sym "local-memory") $-                  With-                    (. Sexp.list (Sexp.el (Sexp.sym "bespoke") >>> Sexp.el sexpIso >>> Sexp.el (iso fromIntegral fromIntegral . Sexp.int)))-                    End+  deriving (Eq, Ord, Show)  instance Pretty SizeClass where-  ppr (SizeThreshold path _) = text $ "threshold (" ++ unwords (map pStep path) ++ ")"+  ppr (SizeThreshold path def) =+    "threshold(" <> ppr (map pStep path) <> def' <> ")"     where-      pStep (v, True) = pretty v-      pStep (v, False) = '!' : pretty v+      pStep (v, True) = ppr v+      pStep (v, False) = "!" <> ppr v+      def' = maybe mempty ((", " <>) . ppr) def   ppr SizeGroup = text "group_size"   ppr SizeNumGroups = text "num_groups"   ppr SizeTile = text "tile_size"   ppr SizeRegTile = text "reg_tile_size"   ppr SizeLocalMemory = text "local_memory"-  ppr (SizeBespoke k _) = ppr k+  ppr (SizeBespoke k def) =+    text "bespoke" <> parens (ppr k <> comma <+> ppr def)  -- | The default value for the size.  If 'Nothing', that means the backend gets to decide. sizeDefault :: SizeClass -> Maybe Int64@@ -82,10 +68,7 @@  -- | A wrapper supporting a phantom type for indicating what we are counting. newtype Count u e = Count {unCount :: e}-  deriving (Eq, Ord, Show, Num, IntegralExp, FreeIn, Pretty, Substitute, Generic)--instance SexpIso e => SexpIso (Count u e) where-  sexpIso = with $ \count -> sexpIso >>> count+  deriving (Eq, Ord, Show, Num, IntegralExp, FreeIn, Pretty, Substitute)  instance Functor (Count u) where   fmap = fmapDefault

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}@@ -16,7 +15,6 @@   ) where -import Control.Category import Data.Bifunctor (first) import Futhark.Analysis.Metrics import qualified Futhark.Analysis.SymbolTable as ST@@ -37,9 +35,6 @@     (<+>),     (</>),   )-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | An operation for the multicore representation.  Feel free to@@ -54,15 +49,7 @@       (SegOp () lore)   | -- | Something else (in practice often a SOAC).     OtherOp op-  deriving (Eq, Ord, Show, Generic)--instance (Decorations lore, SexpIso op) => SexpIso (MCOp lore op) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance (ASTLore lore, Substitute op) => Substitute (MCOp lore op) where   substituteNames substs (ParOp par_op op) =

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -134,11 +133,8 @@ import Futhark.Transform.Substitute import qualified Futhark.TypeCheck as TC import Futhark.Util-import Futhark.Util.Pretty (indent, ppr, text, (</>))+import Futhark.Util.Pretty (indent, ppr, text, (<+>), (</>)) import qualified Futhark.Util.Pretty as PP-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  type LetDecMem = MemInfo SubExp NoUniqueness MemBind@@ -179,15 +175,7 @@     -- expression, but what are you gonna do...     Alloc SubExp Space   | Inner inner-  deriving (Eq, Ord, Show, Generic)--instance SexpIso inner => SexpIso (MemOp inner) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "alloc") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "inner") >>> Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance AllocOp (MemOp inner) where   allocOp = Alloc@@ -268,16 +256,7 @@     -- byte offsets, multiply the offset with the size of the array     -- element type.     MemArray PrimType (ShapeBase d) u ret-  deriving (Eq, Show, Ord, Generic) --- XXX Ord?--instance (SexpIso d, SexpIso u, SexpIso ret) => SexpIso (MemInfo d u ret) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "prim") >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "mem") >>> Sexp.el sexpIso)) $-          With-            (. Sexp.list (Sexp.el (Sexp.sym "array") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-            End+  deriving (Eq, Show, Ord) --- XXX Ord?  type MemBound u = MemInfo SubExp u MemBind @@ -371,28 +350,14 @@   ppr (MemMem DefaultSpace) = PP.text "mem"   ppr (MemMem s) = PP.text "mem" <> PP.ppr s   ppr (MemArray bt shape u ret) =-    PP.ppr (Array bt shape u) <> PP.text "@" <> PP.ppr ret--instance PP.Pretty (Param (MemInfo SubExp Uniqueness ret)) where-  ppr = PP.ppr . fmap declTypeOf--instance PP.Pretty (Param (MemInfo SubExp NoUniqueness ret)) where-  ppr = PP.ppr . fmap typeOf--instance PP.Pretty (PatElemT (MemInfo SubExp NoUniqueness ret)) where-  ppr = PP.ppr . fmap typeOf+    PP.ppr (Array bt shape u) <+> PP.text "@" <+> PP.ppr ret  -- | Memory information for an array bound somewhere in the program. data MemBind   = -- | Located in this memory block with this index     -- function.     ArrayIn VName IxFun-  deriving (Show, Generic)--instance SexpIso MemBind where-  sexpIso = with $ \membind ->-    Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso)-      >>> membind+  deriving (Show)  instance Eq MemBind where   _ == _ = True@@ -409,7 +374,7 @@  instance PP.Pretty MemBind where   ppr (ArrayIn mem ixfun) =-    PP.text "@" <> PP.ppr mem <> PP.text "->" PP.</> PP.ppr ixfun+    PP.ppr mem <+> "->" PP.</> PP.ppr ixfun  instance FreeIn MemBind where   freeIn' (ArrayIn mem ixfun) = freeIn' mem <> freeIn' ixfun@@ -423,29 +388,7 @@   | -- | The operation returns a new (existential) memory     -- block.     ReturnsNewBlock Space Int ExtIxFun-  deriving (Show, Generic)--instance SexpIso MemReturn where-  sexpIso =-    match $-      With-        ( .-            Sexp.list-              ( Sexp.el (Sexp.sym "returns-in-block")-                  >>> Sexp.el sexpIso-                  >>> Sexp.el sexpIso-              )-        )-        $ With-          ( .-              Sexp.list-                ( Sexp.el (Sexp.sym "returns-new-block")-                    >>> Sexp.el sexpIso-                    >>> Sexp.el sexpIso-                    >>> Sexp.el sexpIso-                )-          )-          End+  deriving (Show)  instance Eq MemReturn where   _ == _ = True@@ -501,9 +444,9 @@  instance PP.Pretty MemReturn where   ppr (ReturnsInBlock v ixfun) =-    PP.parens $ PP.text (pretty v) <> PP.text "->" PP.</> PP.ppr ixfun+    PP.parens $ ppr v <+> "->" PP.</> PP.ppr ixfun   ppr (ReturnsNewBlock space i ixfun) =-    PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" PP.</> PP.ppr ixfun+    "?" <> ppr i <> PP.ppr space <+> "->" PP.</> PP.ppr ixfun  instance FreeIn MemReturn where   freeIn' (ReturnsInBlock v ixfun) = freeIn' v <> freeIn' ixfun@@ -1000,31 +943,6 @@                     existentialiseIxFun (map patElemName ctx) ixfun                 _ -> ReturnsInBlock mem $ existentialiseIxFun [] ixfun       )--instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (PatElemT (MemInfo SubExp u r)) where-  ppAnnot = bindeeAnnot patElemName patElemDec--instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (Param (MemInfo SubExp u r)) where-  ppAnnot = bindeeAnnot paramName paramDec--bindeeAnnot ::-  (PP.Pretty u, PP.Pretty r) =>-  (a -> VName) ->-  (a -> MemInfo SubExp u r) ->-  a ->-  Maybe PP.Doc-bindeeAnnot bindeeName bindeeLore bindee =-  case bindeeLore bindee of-    dec@MemArray {} ->-      Just $-        PP.stack $-          map (("-- " <>) . PP.text) $-            lines $-              pretty (PP.ppr (bindeeName bindee) PP.<+> ":" PP.<+> PP.ppr dec)-    MemMem {} ->-      Nothing-    MemPrim _ ->-      Nothing  extReturns :: [ExtType] -> [ExpReturns] extReturns ts =

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -6,6 +5,9 @@ -- linear-memory accessor descriptors; see Zhu, Hoeflinger and David work. module Futhark.IR.Mem.IxFun   ( IxFun (..),+    LMAD (..),+    LMADDim (..),+    Monotonicity (..),     index,     iota,     iotaOffset,@@ -59,9 +61,6 @@ import Futhark.Transform.Substitute import Futhark.Util.IntegralExp import Futhark.Util.Pretty-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, mod, (.))  type Shape num = [num]@@ -75,16 +74,7 @@   | Dec   | -- | monotonously increasing, decreasing or unknown     Unknown-  deriving (Show, Eq, Generic)--instance SexpIso Monotonicity where-  sexpIso =-    match $-      With (. Sexp.sym "inc") $-        With (. Sexp.sym "dec") $-          With-            (. Sexp.sym "unknown")-            End+  deriving (Show, Eq)  data LMADDim num = LMADDim   { ldStride :: num,@@ -93,19 +83,7 @@     ldPerm :: Int,     ldMon :: Monotonicity   }-  deriving (Show, Eq, Generic)--instance SexpIso num => SexpIso (LMADDim num) where-  sexpIso = with $ \lmaddim ->-    Sexp.list-      ( Sexp.el (Sexp.sym "dim")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> lmaddim+  deriving (Show, Eq)  -- | LMAD's representation consists of a general offset and for each dimension a -- stride, rotate factor, number of elements (or shape), permutation, and@@ -137,16 +115,7 @@   { lmadOffset :: num,     lmadDims :: [LMADDim num]   }-  deriving (Show, Eq, Generic)--instance SexpIso num => SexpIso (LMAD num) where-  sexpIso = with $ \lmad ->-    Sexp.list-      ( Sexp.el (Sexp.sym "lmad")-          >>> Sexp.el sexpIso-          >>> Sexp.rest sexpIso-      )-      >>> lmad+  deriving (Show, Eq)  -- | An index function is a mapping from a multidimensional array -- index space (the domain) to a one-dimensional memory index space.@@ -162,17 +131,7 @@     -- | ignoring permutations, is the index function contiguous?     ixfunContig :: Bool   }-  deriving (Show, Eq, Generic)--instance SexpIso num => SexpIso (IxFun num) where-  sexpIso = with $ \ixfun ->-    Sexp.list-      ( Sexp.el (Sexp.sym "ixfun")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> ixfun+  deriving (Show, Eq)  instance Pretty Monotonicity where   ppr = text . show@@ -181,12 +140,12 @@   ppr (LMAD offset dims) =     braces $       semisep-        [ text "offset: " <> oneLine (ppr offset),-          text "strides: " <> p ldStride,-          text "rotates: " <> p ldRotate,-          text "shape: " <> p ldShape,-          text "permutation: " <> p ldPerm,-          text "monotonicity: " <> p ldMon+        [ "offset: " <> oneLine (ppr offset),+          "strides: " <> p ldStride,+          "rotates: " <> p ldRotate,+          "shape: " <> p ldShape,+          "permutation: " <> p ldPerm,+          "monotonicity: " <> p ldMon         ]     where       p f = oneLine $ brackets $ commasep $ map (ppr . f) dims@@ -195,9 +154,9 @@   ppr (IxFun lmads oshp cg) =     braces $       semisep-        [ text "base: " <> brackets (commasep $ map ppr oshp),-          text "contiguous: " <> text (show cg),-          text "LMADs: " <> brackets (commasep $ NE.toList $ NE.map ppr lmads)+        [ "base: " <> brackets (commasep $ map ppr oshp),+          "contiguous: " <> if cg then "true" else "false",+          "LMADs: " <> brackets (commasep $ NE.toList $ NE.map ppr lmads)         ]  instance Substitute num => Substitute (LMAD num) where

@@ -0,0 +1,927 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Parser for the Futhark core language.+module Futhark.IR.Parse+  ( parseSOACS,+    parseKernels,+    parseKernelsMem,+    parseMC,+    parseMCMem,+  )+where++import Data.Char (isAlpha)+import Data.Functor+import Data.List (zipWith5)+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Void+import Futhark.Analysis.PrimExp.Parse+import Futhark.IR+import Futhark.IR.Kernels (Kernels)+import qualified Futhark.IR.Kernels.Kernel as Kernel+import Futhark.IR.KernelsMem (KernelsMem)+import Futhark.IR.MC (MC)+import qualified Futhark.IR.MC.Op as MC+import Futhark.IR.MCMem (MCMem)+import Futhark.IR.Mem+import qualified Futhark.IR.Mem.IxFun as IxFun+import Futhark.IR.Primitive.Parse+import Futhark.IR.SOACS (SOACS)+import qualified Futhark.IR.SOACS.SOAC as SOAC+import qualified Futhark.IR.SegOp as SegOp+import Futhark.Util.Pretty (prettyText)+import Text.Megaparsec+import Text.Megaparsec.Char hiding (space)+import qualified Text.Megaparsec.Char.Lexer as L++type Parser = Parsec Void T.Text++pStringLiteral :: Parser String+pStringLiteral = char '"' >> manyTill L.charLiteral (char '"')++pName :: Parser Name+pName =+  lexeme . fmap nameFromString $+    (:) <$> satisfy isAlpha <*> many (satisfy constituent)++pVName :: Parser VName+pVName = lexeme $ do+  (s, tag) <-+    satisfy constituent `manyTill_` try pTag+      <?> "variable name"+  pure $ VName (nameFromString s) tag+  where+    pTag =+      "_" *> L.decimal <* notFollowedBy (satisfy constituent)++pBool :: Parser Bool+pBool = choice [keyword "true" $> True, keyword "false" $> False]++pInt :: Parser Int+pInt = lexeme L.decimal++pInt64 :: Parser Int64+pInt64 = lexeme L.decimal++braces, brackets, parens :: Parser a -> Parser a+braces = between (lexeme "{") (lexeme "}")+brackets = between (lexeme "[") (lexeme "]")+parens = between (lexeme "(") (lexeme ")")++pComma, pColon, pSemi, pEqual, pSlash, pAsterisk, pArrow :: Parser ()+pComma = void $ lexeme ","+pColon = void $ lexeme ":"+pSemi = void $ lexeme ";"+pEqual = void $ lexeme "="+pSlash = void $ lexeme "/"+pAsterisk = void $ lexeme "*"+pArrow = void $ lexeme "->"++pNonArray :: Parser (TypeBase shape u)+pNonArray = Prim <$> pPrimType++pTypeBase ::+  ArrayShape shape =>+  Parser shape ->+  Parser u ->+  Parser (TypeBase shape u)+pTypeBase ps pu = do+  u <- pu+  shape <- ps+  arrayOf <$> pNonArray <*> pure shape <*> pure u++pShape :: Parser Shape+pShape = Shape <$> many (brackets pSubExp)++pExt :: Parser a -> Parser (Ext a)+pExt p =+  choice+    [ lexeme $ "?" $> Ext <*> L.decimal,+      Free <$> p+    ]++pExtSize :: Parser ExtSize+pExtSize = pExt pSubExp++pExtShape :: Parser ExtShape+pExtShape = Shape <$> many (brackets pExtSize)++pType :: Parser Type+pType = pTypeBase pShape (pure NoUniqueness)++pTypes :: Parser [Type]+pTypes = braces $ pType `sepBy` pComma++pExtType :: Parser ExtType+pExtType = pTypeBase pExtShape (pure NoUniqueness)++pUniqueness :: Parser Uniqueness+pUniqueness = choice [pAsterisk $> Unique, pure Nonunique]++pDeclBase ::+  Parser (TypeBase shape NoUniqueness) ->+  Parser (TypeBase shape Uniqueness)+pDeclBase p = flip toDecl <$> pUniqueness <*> p++pDeclType :: Parser DeclType+pDeclType = pDeclBase pType++pDeclExtType :: Parser DeclExtType+pDeclExtType = pDeclBase pExtType++pSubExp :: Parser SubExp+pSubExp = Var <$> pVName <|> Constant <$> pPrimValue++pPatternLike :: Parser a -> Parser ([a], [a])+pPatternLike p = braces $ do+  xs <- p `sepBy` pComma+  choice+    [ pSemi *> ((xs,) <$> (p `sepBy` pComma)),+      pure (mempty, xs)+    ]++pConvOp ::+  T.Text -> (t1 -> t2 -> ConvOp) -> Parser t1 -> Parser t2 -> Parser BasicOp+pConvOp s op t1 t2 =+  keyword s $> op' <*> t1 <*> pSubExp <*> (keyword "to" *> t2)+  where+    op' f se t = ConvOp (op f t) se++pBinOp :: Parser BasicOp+pBinOp = choice (map p allBinOps) <?> "binary op"+  where+    p bop =+      keyword (prettyText bop)+        *> parens (BinOp bop <$> pSubExp <* pComma <*> pSubExp)++pCmpOp :: Parser BasicOp+pCmpOp = choice (map p allCmpOps) <?> "comparison op"+  where+    p op =+      keyword (prettyText op)+        *> parens (CmpOp op <$> pSubExp <* pComma <*> pSubExp)++pUnOp :: Parser BasicOp+pUnOp = choice (map p allUnOps) <?> "unary op"+  where+    p bop = keyword (prettyText bop) $> UnOp bop <*> pSubExp++pDimIndex :: Parser (DimIndex SubExp)+pDimIndex =+  choice+    [ try $+        DimSlice <$> pSubExp <* lexeme ":+"+          <*> pSubExp <* lexeme "*"+          <*> pSubExp,+      DimFix <$> pSubExp+    ]++pSlice :: Parser (Slice SubExp)+pSlice = brackets $ pDimIndex `sepBy` pComma++pIndex :: Parser BasicOp+pIndex = try $ Index <$> pVName <*> pSlice++pErrorMsgPart :: Parser (ErrorMsgPart SubExp)+pErrorMsgPart =+  choice+    [ ErrorString <$> pStringLiteral,+      flip ($) <$> (pSubExp <* pColon)+        <*> choice+          [ keyword "i32" $> ErrorInt32,+            keyword "i64" $> ErrorInt64+          ]+    ]++pErrorMsg :: Parser (ErrorMsg SubExp)+pErrorMsg = ErrorMsg <$> braces (pErrorMsgPart `sepBy` pComma)++pSrcLoc :: Parser SrcLoc+pSrcLoc = pStringLiteral $> mempty -- FIXME++pErrorLoc :: Parser (SrcLoc, [SrcLoc])+pErrorLoc = (,mempty) <$> pSrcLoc++pShapeChange :: Parser (ShapeChange SubExp)+pShapeChange = parens $ pDimChange `sepBy` pComma+  where+    pDimChange =+      choice+        [ "~" $> DimCoercion <*> pSubExp,+          DimNew <$> pSubExp+        ]++pIota :: Parser BasicOp+pIota =+  choice $ map p allIntTypes+  where+    p t =+      keyword ("iota" <> prettyText (primBitSize (IntType t)))+        *> parens+          ( Iota+              <$> pSubExp <* pComma+              <*> pSubExp <* pComma+              <*> pSubExp+              <*> pure t+          )++pBasicOp :: Parser BasicOp+pBasicOp =+  choice+    [ keyword "opaque" $> Opaque <*> parens pSubExp,+      keyword "copy" $> Copy <*> parens pVName,+      keyword "assert"+        *> parens+          ( Assert <$> pSubExp <* pComma+              <*> pErrorMsg <* pComma+              <*> pErrorLoc+          ),+      keyword "rotate"+        *> parens+          (Rotate <$> parens (pSubExp `sepBy` pComma) <* pComma <*> pVName),+      keyword "replicate"+        *> parens (Replicate <$> pShape <* pComma <*> pSubExp),+      keyword "reshape"+        *> parens (Reshape <$> pShapeChange <* pComma <*> pVName),+      keyword "scratch"+        *> parens (Scratch <$> pPrimType <*> many (pComma *> pSubExp)),+      keyword "rearrange"+        *> parens+          (Rearrange <$> parens (pInt `sepBy` pComma) <* pComma <*> pVName),+      keyword "manifest"+        *> parens+          (Manifest <$> parens (pInt `sepBy` pComma) <* pComma <*> pVName),+      keyword "concat" *> do+        d <- "@" *> L.decimal+        parens $ do+          w <- pSubExp <* pComma+          Concat d <$> pVName <*> many (pComma *> pVName) <*> pure w,+      pIota,+      try $+        Update+          <$> pVName <* keyword "with"+          <*> pSlice <* lexeme "="+          <*> pSubExp,+      ArrayLit+        <$> brackets (pSubExp `sepBy` pComma)+        <*> (lexeme ":" *> "[]" *> pType),+      --+      pConvOp "sext" SExt pIntType pIntType,+      pConvOp "zext" ZExt pIntType pIntType,+      pConvOp "fpconv" FPConv pFloatType pFloatType,+      pConvOp "fptoui" FPToUI pFloatType pIntType,+      pConvOp "fptosi" FPToSI pFloatType pIntType,+      pConvOp "uitofp" UIToFP pIntType pFloatType,+      pConvOp "sitofp" SIToFP pIntType pFloatType,+      pConvOp "itob" (const . IToB) pIntType (keyword "bool"),+      pConvOp "btoi" (const BToI) (keyword "bool") pIntType,+      --+      pIndex,+      pBinOp,+      pCmpOp,+      pUnOp,+      SubExp <$> pSubExp+    ]++pAttr :: Parser Attr+pAttr = do+  v <- pName+  choice+    [ AttrComp v <$> parens (pAttr `sepBy` pComma),+      pure $ AttrAtom v+    ]++pAttrs :: Parser Attrs+pAttrs = Attrs . S.fromList <$> many pAttr'+  where+    pAttr' = lexeme "#[" *> pAttr <* lexeme "]"++pComm :: Parser Commutativity+pComm =+  choice+    [ keyword "commutative" $> Commutative,+      pure Noncommutative+    ]++-- | This record contains parser for all the representation-specific+-- bits.  Essentially a manually passed-around type class dictionary,+-- because ambiguities make it impossible to write this with actual+-- type classes.+data PR lore = PR+  { pRetType :: Parser (RetType lore),+    pBranchType :: Parser (BranchType lore),+    pFParamInfo :: Parser (FParamInfo lore),+    pLParamInfo :: Parser (LParamInfo lore),+    pLetDec :: Parser (LetDec lore),+    pOp :: Parser (Op lore),+    pBodyDec :: BodyDec lore,+    pExpDec :: ExpDec lore+  }++pRetTypes :: PR lore -> Parser [RetType lore]+pRetTypes pr = braces $ pRetType pr `sepBy` pComma++pBranchTypes :: PR lore -> Parser [BranchType lore]+pBranchTypes pr = braces $ pBranchType pr `sepBy` pComma++pParam :: Parser t -> Parser (Param t)+pParam p = Param <$> pVName <*> (pColon *> p)++pFParam :: PR lore -> Parser (FParam lore)+pFParam = pParam . pFParamInfo++pFParams :: PR lore -> Parser [FParam lore]+pFParams pr = parens $ pFParam pr `sepBy` pComma++pLParam :: PR lore -> Parser (LParam lore)+pLParam = pParam . pLParamInfo++pLParams :: PR lore -> Parser [LParam lore]+pLParams pr = braces $ pLParam pr `sepBy` pComma++pPatElem :: PR lore -> Parser (PatElem lore)+pPatElem pr =+  (PatElem <$> pVName <*> (pColon *> pLetDec pr)) <?> "pattern element"++pPattern :: PR lore -> Parser (Pattern lore)+pPattern pr = uncurry Pattern <$> pPatternLike (pPatElem pr)++pIf :: PR lore -> Parser (Exp lore)+pIf pr =+  keyword "if" $> f <*> pSort <*> pSubExp+    <*> (keyword "then" *> pBranchBody)+    <*> (keyword "else" *> pBranchBody)+    <*> (lexeme ":" *> pBranchTypes pr)+  where+    pSort =+      choice+        [ lexeme "<fallback>" $> IfFallback,+          lexeme "<equiv>" $> IfEquiv,+          pure IfNormal+        ]+    f sort cond tbranch fbranch t =+      If cond tbranch fbranch $ IfDec t sort+    pBranchBody =+      choice+        [ try $ braces $ Body (pBodyDec pr) mempty <$> pSubExp `sepBy` pComma,+          braces (pBody pr)+        ]++pApply :: PR lore -> Parser (Exp lore)+pApply pr =+  keyword "apply"+    $> Apply+    <*> pName+    <*> parens (pArg `sepBy` pComma) <* pColon+    <*> pRetTypes pr+    <*> pure (Safe, mempty, mempty)+  where+    pArg =+      choice+        [ lexeme "*" $> (,Consume) <*> pSubExp,+          (,Observe) <$> pSubExp+        ]++pLoop :: PR lore -> Parser (Exp lore)+pLoop pr =+  keyword "loop" $> uncurry DoLoop+    <*> pLoopParams+    <*> pLoopForm <* keyword "do"+    <*> braces (pBody pr)+  where+    pLoopParams = do+      (ctx, val) <- pPatternLike (pFParam pr)+      void $ lexeme "="+      (ctx_init, val_init) <-+        splitAt (length ctx) <$> braces (pSubExp `sepBy` pComma)+      pure (zip ctx ctx_init, zip val val_init)++    pLoopForm =+      choice+        [ keyword "for" $> ForLoop+            <*> pVName <* lexeme ":"+            <*> pIntType <* lexeme "<"+            <*> pSubExp+            <*> many ((,) <$> pLParam pr <* keyword "in" <*> pVName),+          keyword "while" $> WhileLoop <*> pVName+        ]++pLambda :: PR lore -> Parser (Lambda lore)+pLambda pr =+  choice+    [ lexeme "\\"+        $> lam+        <*> pLParams pr <* pColon+        <*> pTypes <* pArrow+        <*> pBody pr,+      keyword "nilFn" $> Lambda mempty (Body (pBodyDec pr) mempty []) []+    ]+  where+    lam params ret body = Lambda params body ret++pReduce :: PR lore -> Parser (SOAC.Reduce lore)+pReduce pr =+  SOAC.Reduce+    <$> pComm+    <*> pLambda pr <* pComma+    <*> braces (pSubExp `sepBy` pComma)++pScan :: PR lore -> Parser (SOAC.Scan lore)+pScan pr =+  SOAC.Scan+    <$> pLambda pr <* pComma+    <*> braces (pSubExp `sepBy` pComma)++pExp :: PR lore -> Parser (Exp lore)+pExp pr =+  choice+    [ pIf pr,+      pApply pr,+      pLoop pr,+      Op <$> pOp pr,+      BasicOp <$> pBasicOp+    ]++pStm :: PR lore -> Parser (Stm lore)+pStm pr =+  keyword "let" $> Let <*> pPattern pr <* pEqual <*> pStmAux <*> pExp pr+  where+    pStmAux = flip StmAux <$> pAttrs <*> pCerts <*> pure (pExpDec pr)+    pCerts =+      choice+        [ lexeme "#" *> braces (Certificates <$> pVName `sepBy` pComma)+            <?> "certificates",+          pure mempty+        ]++pStms :: PR lore -> Parser (Stms lore)+pStms pr = stmsFromList <$> many (pStm pr)++pBody :: PR lore -> Parser (Body lore)+pBody pr =+  choice+    [ Body (pBodyDec pr) <$> pStms pr <* keyword "in" <*> pResult,+      Body (pBodyDec pr) mempty <$> pResult+    ]+  where+    pResult = braces $ pSubExp `sepBy` pComma++pEntry :: Parser EntryPoint+pEntry = parens $ (,) <$> pEntryPointTypes <* pComma <*> pEntryPointTypes+  where+    pEntryPointTypes = braces (pEntryPointType `sepBy` pComma)+    pEntryPointType =+      choice+        [ "direct" $> TypeDirect,+          "unsigned" $> TypeUnsigned,+          "opaque" *> parens (TypeOpaque <$> pStringLiteral <* pComma <*> pInt)+        ]++pFunDef :: PR lore -> Parser (FunDef lore)+pFunDef pr = do+  attrs <- pAttrs+  entry <-+    choice+      [ keyword "entry" $> Just <*> pEntry,+        keyword "fun" $> Nothing+      ]+  fname <- pName+  fparams <- pFParams pr <* pColon+  ret <- pRetTypes pr+  FunDef entry attrs fname ret fparams+    <$> (pEqual *> braces (pBody pr))++pProg :: PR lore -> Parser (Prog lore)+pProg pr = Prog <$> pStms pr <*> many (pFunDef pr)++pSOAC :: PR lore -> Parser (SOAC.SOAC lore)+pSOAC pr =+  choice+    [ keyword "map" *> pScrema pMapForm,+      keyword "redomap" *> pScrema pRedomapForm,+      keyword "scanomap" *> pScrema pScanomapForm,+      keyword "screma" *> pScrema pScremaForm,+      pScatter,+      pHist,+      pStream+    ]+  where+    pScrema p =+      parens $+        SOAC.Screma+          <$> pSubExp <* pComma+          <*> p <* pComma+          <*> (pVName `sepBy` pComma)+    pScremaForm =+      SOAC.ScremaForm+        <$> braces (pScan pr `sepBy` pComma) <* pComma+        <*> braces (pReduce pr `sepBy` pComma) <* pComma+        <*> pLambda pr+    pRedomapForm =+      SOAC.ScremaForm mempty+        <$> braces (pReduce pr `sepBy` pComma) <* pComma+        <*> pLambda pr+    pScanomapForm =+      SOAC.ScremaForm+        <$> braces (pScan pr `sepBy` pComma) <* pComma+        <*> pure mempty+        <*> pLambda pr+    pMapForm =+      SOAC.ScremaForm mempty mempty <$> pLambda pr+    pScatter =+      keyword "scatter"+        *> parens+          ( SOAC.Scatter <$> pSubExp <* pComma+              <*> pLambda pr <* pComma+              <*> braces (pVName `sepBy` pComma)+              <*> many (pComma *> pDest)+          )+      where+        pDest =+          parens $ (,,) <$> pShape <* pComma <*> pInt <* pComma <*> pVName+    pHist =+      keyword "hist"+        *> parens+          ( SOAC.Hist+              <$> pSubExp <* pComma+              <*> braces (pHistOp `sepBy` pComma) <* pComma+              <*> pLambda pr+              <*> many (pComma *> pVName)+          )+      where+        pHistOp =+          SOAC.HistOp+            <$> pSubExp <* pComma+            <*> pSubExp <* pComma+            <*> braces (pVName `sepBy` pComma) <* pComma+            <*> braces (pSubExp `sepBy` pComma) <* pComma+            <*> pLambda pr+    pStream =+      choice+        [ keyword "streamParComm" *> pStreamPar SOAC.InOrder Commutative,+          keyword "streamPar" *> pStreamPar SOAC.InOrder Noncommutative,+          keyword "streamParPerComm" *> pStreamPar SOAC.Disorder Commutative,+          keyword "streamParPer" *> pStreamPar SOAC.Disorder Noncommutative,+          keyword "streamSeq" *> pStreamSeq+        ]+    pStreamPar order comm =+      parens $+        SOAC.Stream+          <$> pSubExp <* pComma+          <*> pParForm order comm <* pComma+          <*> pLambda pr <* pComma+          <*> braces (pSubExp `sepBy` pComma)+          <*> many (pComma *> pVName)+    pParForm order comm =+      SOAC.Parallel order comm <$> pLambda pr+    pStreamSeq =+      parens $+        SOAC.Stream+          <$> pSubExp <* pComma+          <*> pure SOAC.Sequential+          <*> pLambda pr <* pComma+          <*> braces (pSubExp `sepBy` pComma)+          <*> many (pComma *> pVName)++pSizeClass :: Parser Kernel.SizeClass+pSizeClass =+  choice+    [ keyword "group_size" $> Kernel.SizeGroup,+      keyword "num_groups" $> Kernel.SizeNumGroups,+      keyword "num_groups" $> Kernel.SizeNumGroups,+      keyword "tile_size" $> Kernel.SizeTile,+      keyword "reg_tile_size" $> Kernel.SizeRegTile,+      keyword "local_memory" $> Kernel.SizeLocalMemory,+      keyword "threshold"+        *> parens+          ( Kernel.SizeThreshold+              <$> pKernelPath+              <*> optional (pComma *> pInt64)+          ),+      keyword "bespoke"+        *> parens (Kernel.SizeBespoke <$> pName <* pComma <*> pInt64)+    ]+  where+    pKernelPath =+      brackets $ pStep `sepBy` pComma+    pStep =+      choice+        [ lexeme "!" $> (,) <*> pName <*> pure False,+          (,) <$> pName <*> pure True+        ]++pSizeOp :: Parser Kernel.SizeOp+pSizeOp =+  choice+    [ keyword "get_size"+        *> parens (Kernel.GetSize <$> pName <* pComma <*> pSizeClass),+      keyword "get_size_max"+        *> parens (Kernel.GetSizeMax <$> pSizeClass),+      keyword "cmp_size"+        *> ( parens (Kernel.CmpSizeLe <$> pName <* pComma <*> pSizeClass)+               <*> (lexeme "<=" *> pSubExp)+           ),+      keyword "calc_num_groups"+        *> parens+          ( Kernel.CalcNumGroups+              <$> pSubExp <* pComma <*> pName <* pComma <*> pSubExp+          ),+      keyword "split_space"+        *> parens+          ( Kernel.SplitSpace Kernel.SplitContiguous+              <$> pSubExp <* pComma+              <*> pSubExp <* pComma+              <*> pSubExp+          ),+      keyword "split_space_strided"+        *> parens+          ( Kernel.SplitSpace+              <$> (Kernel.SplitStrided <$> pSubExp) <* pComma+              <*> pSubExp <* pComma+              <*> pSubExp <* pComma+              <*> pSubExp+          )+    ]++pSegSpace :: Parser SegOp.SegSpace+pSegSpace =+  flip SegOp.SegSpace+    <$> parens (pDim `sepBy` pComma)+    <*> parens (lexeme "~" *> pVName)+  where+    pDim = (,) <$> pVName <* lexeme "<" <*> pSubExp++pKernelResult :: Parser SegOp.KernelResult+pKernelResult =+  choice+    [ keyword "returns" $> SegOp.Returns+        <*> choice+          [ keyword "(manifest)" $> SegOp.ResultNoSimplify,+            keyword "(private)" $> SegOp.ResultPrivate,+            pure SegOp.ResultMaySimplify+          ]+        <*> pSubExp,+      try $+        flip SegOp.WriteReturns+          <$> pVName <* pColon+          <*> pShape <* keyword "with"+          <*> parens (pWrite `sepBy` pComma),+      try "tile"+        *> parens (SegOp.TileReturns <$> (pTile `sepBy` pComma)) <*> pVName,+      try "blkreg_tile"+        *> parens (SegOp.RegTileReturns <$> (pRegTile `sepBy` pComma)) <*> pVName,+      keyword "concat"+        *> parens+          ( SegOp.ConcatReturns SegOp.SplitContiguous+              <$> pSubExp <* pComma+              <*> pSubExp+          )+        <*> pVName,+      keyword "concat_strided"+        *> parens+          ( SegOp.ConcatReturns+              <$> (SegOp.SplitStrided <$> pSubExp) <* pComma+              <*> pSubExp <* pComma+              <*> pSubExp+          )+        <*> pVName+    ]+  where+    pTile = (,) <$> pSubExp <* pSlash <*> pSubExp+    pRegTile = do+      dim <- pSubExp <* pSlash+      parens $ do+        blk_tile <- pSubExp <* pAsterisk+        reg_tile <- pSubExp+        pure (dim, blk_tile, reg_tile)+    pWrite = (,) <$> pSlice <* pEqual <*> pSubExp++pKernelBody :: PR lore -> Parser (SegOp.KernelBody lore)+pKernelBody pr =+  SegOp.KernelBody (pBodyDec pr)+    <$> pStms pr <* keyword "return"+    <*> braces (pKernelResult `sepBy` pComma)++pSegOp :: PR lore -> Parser lvl -> Parser (SegOp.SegOp lvl lore)+pSegOp pr pLvl =+  choice+    [ keyword "segmap" *> pSegMap,+      keyword "segred" *> pSegRed,+      keyword "segscan" *> pSegScan,+      keyword "seghist" *> pSegHist+    ]+  where+    pSegMap =+      SegOp.SegMap+        <$> pLvl+        <*> pSegSpace <* pColon+        <*> pTypes+        <*> braces (pKernelBody pr)+    pSegOp' f p =+      f <$> pLvl+        <*> pSegSpace+        <*> parens (p `sepBy` pComma) <* pColon+        <*> pTypes+        <*> braces (pKernelBody pr)+    pSegBinOp = do+      nes <- braces (pSubExp `sepBy` pComma) <* pComma+      shape <- pShape <* pComma+      comm <- pComm+      lam <- pLambda pr+      pure $ SegOp.SegBinOp comm lam nes shape+    pHistOp =+      SegOp.HistOp+        <$> pSubExp <* pComma+        <*> pSubExp <* pComma+        <*> braces (pVName `sepBy` pComma) <* pComma+        <*> braces (pSubExp `sepBy` pComma) <* pComma+        <*> pShape <* pComma+        <*> pLambda pr+    pSegRed = pSegOp' SegOp.SegRed pSegBinOp+    pSegScan = pSegOp' SegOp.SegScan pSegBinOp+    pSegHist = pSegOp' SegOp.SegHist pHistOp++pSegLevel :: Parser Kernel.SegLevel+pSegLevel =+  parens $+    choice+      [ keyword "thread" $> Kernel.SegThread,+        keyword "group" $> Kernel.SegGroup+      ]+      <*> (pSemi *> lexeme "#groups=" $> Kernel.Count <*> pSubExp)+      <*> (pSemi *> lexeme "groupsize=" $> Kernel.Count <*> pSubExp)+      <*> choice+        [ pSemi+            *> choice+              [ keyword "full" $> SegOp.SegNoVirtFull,+                keyword "virtualise" $> SegOp.SegVirt+              ],+          pure SegOp.SegNoVirt+        ]++pHostOp :: PR lore -> Parser op -> Parser (Kernel.HostOp lore op)+pHostOp pr pOther =+  choice+    [ Kernel.SegOp <$> pSegOp pr pSegLevel,+      Kernel.SizeOp <$> pSizeOp,+      Kernel.OtherOp <$> pOther+    ]++pMCOp :: PR lore -> Parser op -> Parser (MC.MCOp lore op)+pMCOp pr pOther =+  choice+    [ MC.ParOp . Just+        <$> (keyword "par" *> braces pMCSegOp)+        <*> (keyword "seq" *> braces pMCSegOp),+      MC.ParOp Nothing <$> pMCSegOp,+      MC.OtherOp <$> pOther+    ]+  where+    pMCSegOp = pSegOp pr (void $ lexeme "()")++pIxFunBase :: Parser a -> Parser (IxFun.IxFun a)+pIxFunBase pNum =+  braces $ do+    base <- pLab "base" $ brackets (pNum `sepBy` pComma) <* pSemi+    ct <- pLab "contiguous" $ pBool <* pSemi+    lmads <- pLab "LMADs" $ brackets (pLMAD `sepBy1` pComma)+    pure $ IxFun.IxFun (NE.fromList lmads) base ct+  where+    pLab s m = keyword s *> pColon *> m+    pMon =+      choice+        [ "Inc" $> IxFun.Inc,+          "Dec" $> IxFun.Dec,+          "Unknown" $> IxFun.Unknown+        ]+    pLMAD = braces $ do+      offset <- pLab "offset" pNum <* pSemi+      strides <- pLab "strides" $ brackets (pNum `sepBy` pComma) <* pSemi+      rotates <- pLab "rotates" $ brackets (pNum `sepBy` pComma) <* pSemi+      shape <- pLab "shape" $ brackets (pNum `sepBy` pComma) <* pSemi+      perm <- pLab "permutation" $ brackets (pInt `sepBy` pComma) <* pSemi+      mon <- pLab "monotonicity" $ brackets (pMon `sepBy` pComma)+      pure $ IxFun.LMAD offset $ zipWith5 IxFun.LMADDim strides rotates shape perm mon++pPrimExpLeaf :: Parser (VName, PrimType)+pPrimExpLeaf = (,int64) <$> pVName++pExtPrimExpLeaf :: Parser (Ext VName, PrimType)+pExtPrimExpLeaf = (,int64) <$> pExt pVName++pIxFun :: Parser IxFun+pIxFun = pIxFunBase $ isInt64 <$> pPrimExp pPrimExpLeaf++pExtIxFun :: Parser ExtIxFun+pExtIxFun = pIxFunBase $ isInt64 <$> pPrimExp pExtPrimExpLeaf++pMemInfo :: Parser d -> Parser u -> Parser ret -> Parser (MemInfo d u ret)+pMemInfo pd pu pret =+  choice+    [ MemPrim <$> pPrimType,+      keyword "mem" $> MemMem <*> choice [pSpace, pure DefaultSpace],+      pArray+    ]+  where+    pArray = do+      u <- pu+      shape <- Shape <$> many (brackets pd)+      pt <- pPrimType+      MemArray pt shape u <$> (lexeme "@" *> pret)++pSpace :: Parser Space+pSpace =+  lexeme "@"+    *> choice+      [ Space . nameToString <$> pName,+        ScalarSpace <$> (shapeDims <$> pShape) <*> pPrimType+      ]++pMemBind :: Parser MemBind+pMemBind = ArrayIn <$> pVName <* lexeme "->" <*> pIxFun++pMemReturn :: Parser MemReturn+pMemReturn =+  choice+    [ parens $ ReturnsInBlock <$> pVName <* lexeme "->" <*> pExtIxFun,+      do+        i <- "?" *> pInt+        space <- choice [pSpace, pure DefaultSpace] <* lexeme "->"+        ReturnsNewBlock space i <$> pExtIxFun+    ]++pRetTypeMem :: Parser RetTypeMem+pRetTypeMem = pMemInfo pExtSize pUniqueness pMemReturn++pBranchTypeMem :: Parser BranchTypeMem+pBranchTypeMem = pMemInfo pExtSize (pure NoUniqueness) pMemReturn++pFParamMem :: Parser FParamMem+pFParamMem = pMemInfo pSubExp pUniqueness pMemBind++pLParamMem :: Parser LParamMem+pLParamMem = pMemInfo pSubExp (pure NoUniqueness) pMemBind++pLetDecMem :: Parser LetDecMem+pLetDecMem = pMemInfo pSubExp (pure NoUniqueness) pMemBind++pMemOp :: Parser inner -> Parser (MemOp inner)+pMemOp pInner =+  choice+    [ keyword "alloc"+        *> parens+          (Alloc <$> pSubExp <*> choice [pComma *> pSpace, pure DefaultSpace]),+      Inner <$> pInner+    ]++prSOACS :: PR SOACS+prSOACS =+  PR pDeclExtType pExtType pDeclType pType pType (pSOAC prSOACS) () ()++prKernels :: PR Kernels+prKernels =+  PR pDeclExtType pExtType pDeclType pType pType op () ()+  where+    op = pHostOp prKernels (pSOAC prKernels)++prKernelsMem :: PR KernelsMem+prKernelsMem =+  PR pRetTypeMem pBranchTypeMem pFParamMem pLParamMem pLetDecMem op () ()+  where+    op = pMemOp $ pHostOp prKernelsMem empty++prMC :: PR MC+prMC =+  PR pDeclExtType pExtType pDeclType pType pType op () ()+  where+    op = pMCOp prMC (pSOAC prMC)++prMCMem :: PR MCMem+prMCMem =+  PR pRetTypeMem pBranchTypeMem pFParamMem pLParamMem pLetDecMem op () ()+  where+    op = pMemOp $ pMCOp prMCMem empty++parseLore :: PR lore -> FilePath -> T.Text -> Either T.Text (Prog lore)+parseLore pr fname s =+  either (Left . T.pack . errorBundlePretty) Right $+    parse (whitespace *> pProg pr <* eof) fname s++parseSOACS :: FilePath -> T.Text -> Either T.Text (Prog SOACS)+parseSOACS = parseLore prSOACS++parseKernels :: FilePath -> T.Text -> Either T.Text (Prog Kernels)+parseKernels = parseLore prKernels++parseKernelsMem :: FilePath -> T.Text -> Either T.Text (Prog KernelsMem)+parseKernelsMem = parseLore prKernelsMem++parseMC :: FilePath -> T.Text -> Either T.Text (Prog MC)+parseMC = parseLore prMC++parseMCMem :: FilePath -> T.Text -> Either T.Text (Prog MCMem)+parseMCMem = parseLore prMCMem

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,7 +11,6 @@ module Futhark.IR.Pretty   ( prettyTuple,     pretty,-    PrettyAnnot (..),     PrettyLore (..),     ppTuple',   )@@ -18,34 +18,17 @@  import Data.Foldable (toList) import Data.Maybe-import Futhark.IR.Prop.Patterns import Futhark.IR.Syntax import Futhark.Util.Pretty --- | Class for values that may have some prettyprinted annotation.-class PrettyAnnot a where-  ppAnnot :: a -> Maybe Doc--instance PrettyAnnot (PatElemT (TypeBase shape u)) where-  ppAnnot = const Nothing--instance PrettyAnnot (Param (TypeBase shape u)) where-  ppAnnot = const Nothing--instance PrettyAnnot () where-  ppAnnot = const Nothing- -- | The class of lores whose annotations can be prettyprinted. class   ( Decorations lore,     Pretty (RetType lore),     Pretty (BranchType lore),-    Pretty (Param (FParamInfo lore)),-    Pretty (Param (LParamInfo lore)),-    Pretty (PatElemT (LetDec lore)),-    PrettyAnnot (PatElem lore),-    PrettyAnnot (FParam lore),-    PrettyAnnot (LParam lore),+    Pretty (FParamInfo lore),+    Pretty (LParamInfo lore),+    Pretty (LetDec lore),     Pretty (Op lore)   ) =>   PrettyLore lore@@ -143,31 +126,20 @@ instance Pretty (PatElemT dec) => Pretty (PatternT dec) where   ppr pat = ppPattern (patternContextElements pat) (patternValueElements pat) -instance Pretty (PatElemT b) => Pretty (PatElemT (a, b)) where-  ppr = ppr . fmap snd--instance Pretty (PatElemT Type) where-  ppr (PatElem name t) = ppr name <+> colon <+> ppr t--instance Pretty (Param b) => Pretty (Param (a, b)) where-  ppr = ppr . fmap snd--instance Pretty (Param DeclType) where-  ppr (Param name t) = ppr name <+> colon <+> ppr t+instance Pretty t => Pretty (PatElemT t) where+  ppr (PatElem name t) = ppr name <+> colon <+> align (ppr t) -instance Pretty (Param Type) where-  ppr (Param name t) = ppr name <+> colon <+> ppr t+instance Pretty t => Pretty (Param t) where+  ppr (Param name t) = ppr name <+> colon <+> align (ppr t)  instance PrettyLore lore => Pretty (Stm lore) where   ppr bnd@(Let pat aux e) =-    stmannot $-      align $-        hang 2 $-          text "let" <+> align (ppr pat)-            <+> case (linebreak, ppExpLore (stmAuxDec aux) e) of-              (True, Nothing) -> equals </> ppr e-              (_, Just ann) -> equals </> (ann </> ppr e)-              (False, Nothing) -> equals <+/> ppr e+    align . hang 2 $+      text "let" <+> align (ppr pat)+        <+> case (linebreak, stmannot) of+          (True, []) -> equals </> ppr e+          (False, []) -> equals <+/> ppr e+          (_, ann) -> equals </> (stack ann </> ppr e)     where       linebreak = case e of         DoLoop {} -> True@@ -179,11 +151,11 @@         _ -> False        stmannot =-        case stmAttrAnnots bnd-          <> stmCertAnnots bnd-          <> mapMaybe ppAnnot (patternElements $ stmPattern bnd) of-          [] -> id-          annots -> (align (stack annots) </>)+        concat+          [ maybeToList (ppExpLore (stmAuxDec aux) e),+            stmAttrAnnots bnd,+            stmCertAnnots bnd+          ]  instance Pretty BasicOp where   ppr (SubExp se) = ppr se@@ -252,10 +224,13 @@         | null $ bodyStms b = ppr b         | otherwise = nestedBlock "{" "}" $ ppr b   ppr (BasicOp op) = ppr op-  ppr (Apply fname args _ (safety, _, _)) =+  ppr (Apply fname args ret (safety, _, _)) =     text "apply"-      <+> text (nameToString fname) <> safety'-        <> apply (map (align . pprArg) args)+      <+> text (nameToString fname)+      <> safety'+      <> apply (map (align . pprArg) args)+      </> colon+      <+> braces (commasep $ map ppr ret)     where       pprArg (arg, Consume) = text "*" <> ppr arg       pprArg (arg, _) = ppr arg@@ -264,32 +239,30 @@         Safe -> mempty   ppr (Op op) = ppr op   ppr (DoLoop ctx val form loopbody) =-    annot (mapMaybe ppAnnot (ctxparams ++ valparams)) $-      text "loop" <+> ppPattern ctxparams valparams-        <+> equals-        <+> ppTuple' (ctxinit ++ valinit)-        </> ( case form of-                ForLoop i it bound [] ->-                  text "for"-                    <+> align-                      ( ppr i <> text ":" <> ppr it-                          <+> text "<"-                          <+> align (ppr bound)-                      )-                ForLoop i it bound loop_vars ->-                  annot (mapMaybe (ppAnnot . fst) loop_vars) $-                    text "for"-                      <+> align-                        ( ppr i <> text ":" <> ppr it-                            <+> text "<"-                            <+> align (ppr bound)-                            </> stack (map pprLoopVar loop_vars)-                        )-                WhileLoop cond ->-                  text "while" <+> ppr cond-            )-        <+> text "do"-        <+> nestedBlock "{" "}" (ppr loopbody)+    text "loop" <+> ppPattern ctxparams valparams+      <+> equals+      <+> ppTuple' (ctxinit ++ valinit)+      </> ( case form of+              ForLoop i it bound [] ->+                text "for"+                  <+> align+                    ( ppr i <> text ":" <> ppr it+                        <+> text "<"+                        <+> align (ppr bound)+                    )+              ForLoop i it bound loop_vars ->+                text "for"+                  <+> align+                    ( ppr i <> text ":" <> ppr it+                        <+> text "<"+                        <+> align (ppr bound)+                        </> stack (map pprLoopVar loop_vars)+                    )+              WhileLoop cond ->+                text "while" <+> ppr cond+          )+      <+> text "do"+      <+> nestedBlock "{" "}" (ppr loopbody)     where       (ctxparams, ctxinit) = unzip ctx       (valparams, valinit) = unzip val@@ -298,23 +271,29 @@ instance PrettyLore lore => Pretty (Lambda lore) where   ppr (Lambda [] _ []) = text "nilFn"   ppr (Lambda params body rettype) =-    annot (mapMaybe ppAnnot params) $-      text "fn" <+> ppTuple' rettype-        <+/> align (parens (commasep (map ppr params)))-        <+> text "=>" </> indent 2 (ppr body)+    text "\\" <> ppTuple' params+      <+/> colon <+> ppTuple' rettype <+> text "->"+      </> indent 2 (ppr body) +instance Pretty EntryPointType where+  ppr TypeDirect = "direct"+  ppr TypeUnsigned = "unsigned"+  ppr (TypeOpaque desc n) = "opaque" <> apply [ppr (show desc), ppr n]+ instance PrettyLore lore => Pretty (FunDef lore) where   ppr (FunDef entry attrs name rettype fparams body) =-    annot (mapMaybe ppAnnot fparams <> attrAnnots attrs) $-      text fun <+> ppTuple' rettype-        <+/> text (nameToString name)+    annot (attrAnnots attrs) $+      fun <+> text (nameToString name)         <+> apply (map ppr fparams)+        </> indent 2 (colon <+> align (ppTuple' rettype))         <+> equals         <+> nestedBlock "{" "}" (ppr body)     where-      fun-        | isJust entry = "entry"-        | otherwise = "fun"+      fun = case entry of+        Nothing -> "fun"+        Just (p_entry, ret_entry) ->+          "entry"+            <> nestedBlock "(" ")" (ppTuple' p_entry <> comma </> ppTuple' ret_entry)  instance PrettyLore lore => Pretty (Prog lore) where   ppr (Prog consts funs) =

@@ -1,8 +1,6 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}  -- | Definitions of primitive types, the values that inhabit these -- types, and operations on these values.  A primitive value can also@@ -116,7 +114,6 @@ import Data.Fixed (mod') -- Weird location. import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Map as M-import qualified Data.Text as T import Data.Word import Futhark.Util   ( ceilDouble,@@ -131,10 +128,6 @@     tgammaf,   ) import Futhark.Util.Pretty-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic-import Text.Read (readMaybe) import Prelude hiding (id, (.))  -- | An integer type, ordered by size.  Note that signedness is not a@@ -145,17 +138,7 @@   | Int16   | Int32   | Int64-  deriving (Eq, Ord, Show, Enum, Bounded, Generic)--instance SexpIso IntType where-  sexpIso =-    match $-      With (sym "i8" >>>) $-        With (sym "i16" >>>) $-          With (sym "i32" >>>) $-            With-              (sym "i64" >>>)-              End+  deriving (Eq, Ord, Show, Enum, Bounded)  instance Pretty IntType where   ppr Int8 = text "i8"@@ -171,15 +154,7 @@ data FloatType   = Float32   | Float64-  deriving (Eq, Ord, Show, Enum, Bounded, Generic)--instance SexpIso FloatType where-  sexpIso =-    match $-      With (sym "f32" >>>) $-        With-          (sym "f64" >>>)-          End+  deriving (Eq, Ord, Show, Enum, Bounded)  instance Pretty FloatType where   ppr Float32 = text "f32"@@ -195,17 +170,7 @@   | FloatType FloatType   | Bool   | Cert-  deriving (Eq, Ord, Show, Generic)--instance SexpIso PrimType where-  sexpIso =-    match $-      With (. sexpIso) $-        With (. sexpIso) $-          With (sym "bool" >>>) $-            With-              (sym "cert" >>>)-              End+  deriving (Eq, Ord, Show)  instance Enum PrimType where   toEnum 0 = IntType Int8@@ -243,35 +208,13 @@     ++ map FloatType allFloatTypes     ++ [Bool, Cert] -numberIso :: (Read a, Pretty a) => T.Text -> Grammar p (T.Text :- t) (a :- t)-numberIso postfix = partialOsi (fromS postfix) (toS postfix)-  where-    toS t s = prettyText s <> t--    fromS t s-      | t `T.isSuffixOf` s,-        Just v <- readMaybe $ T.unpack $ T.dropEnd (T.length t) s =-        Right v-      | otherwise =-        Left $ expected $ "Couldn't parse " <> t- -- | An integer value. data IntValue   = Int8Value !Int8   | Int16Value !Int16   | Int32Value !Int32   | Int64Value !Int64-  deriving (Eq, Ord, Show, Generic)--instance SexpIso IntValue where-  sexpIso =-    match $-      With (. numberIso "i8" . Sexp.symbol) $-        With (. numberIso "i16" . Sexp.symbol) $-          With (. numberIso "i32" . Sexp.symbol) $-            With-              (. numberIso "i64" . Sexp.symbol)-              End+  deriving (Eq, Ord, Show)  instance Pretty IntValue where   ppr (Int8Value v) = text $ show v ++ "i8"@@ -304,7 +247,7 @@ data FloatValue   = Float32Value !Float   | Float64Value !Double-  deriving (Show, Generic)+  deriving (Show)  instance Eq FloatValue where   Float32Value x == Float32Value y = isNaN x && isNaN y || x == y@@ -327,14 +270,6 @@   (>) = flip (<)   (>=) = flip (<=) -instance SexpIso FloatValue where-  sexpIso =-    match $-      With (. numberIso "f32" . Sexp.symbol) $-        With-          (. numberIso "f64" . Sexp.symbol)-          End- instance Pretty FloatValue where   ppr (Float32Value v)     | isInfinite v, v >= 0 = text "f32.inf"@@ -364,17 +299,7 @@   | BoolValue !Bool   | -- | The only value of type @cert@.     Checked-  deriving (Eq, Ord, Show, Generic)--instance SexpIso PrimValue where-  sexpIso =-    match $-      With (. sexpIso) $-        With (. sexpIso) $-          With (. sexpIso) $-            With-              (sym "checked" >>>)-              End+  deriving (Eq, Ord, Show)  instance Pretty PrimValue where   ppr (IntValue v) = ppr v@@ -421,20 +346,7 @@     USignum IntType   | -- | Floating-point sign function.     FSignum FloatType-  deriving (Eq, Ord, Show, Generic)--instance SexpIso UnOp where-  sexpIso =-    match $-      With (. Sexp.sym "not") $-        With (. Sexp.list (Sexp.el (Sexp.sym "complement") >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "abs") >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "fabs") >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el (Sexp.sym "ssignum") >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el (Sexp.sym "usignum") >>> Sexp.el sexpIso)) $-                  With-                    (. Sexp.list (Sexp.el (Sexp.sym "fsignum") >>> Sexp.el sexpIso))-                    End+  deriving (Eq, Ord, Show)  -- | What to do in case of arithmetic overflow.  Futhark's semantics -- are that overflow does wraparound, but for generated code (like@@ -445,15 +357,7 @@ -- Note that all values of this type are considered equal for 'Eq' and -- 'Ord'. data Overflow = OverflowWrap | OverflowUndef-  deriving (Show, Generic)--instance SexpIso Overflow where-  sexpIso =-    match $-      With (. Sexp.sym "wrap") $-        With-          (. Sexp.sym "undef")-          End+  deriving (Show)  instance Eq Overflow where   _ == _ = True@@ -477,15 +381,7 @@ -- result will only be used when it is non-zero (so it doesn't matter -- what result is provided with a zero divisor, as long as the program -- keeps running).-data Safety = Unsafe | Safe deriving (Eq, Ord, Show, Generic)--instance SexpIso Safety where-  sexpIso =-    match $-      With (. Sexp.sym "unsafe") $-        With-          (. Sexp.sym "safe")-          End+data Safety = Unsafe | Safe deriving (Eq, Ord, Show)  -- | Binary operators.  These correspond closely to the binary operators in -- LLVM.  Most are parametrised by their expected input and output@@ -565,7 +461,7 @@     LogAnd   | -- | Boolean or - not short-circuiting.     LogOr-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show)  -- | Comparison operators are like 'BinOp's, but they always return a -- boolean value.  The somewhat ugly constructor names are straight@@ -594,7 +490,7 @@     CmpLlt   | -- | Boolean less than or equal.     CmpLle-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show)  -- | Conversion operators try to generalise the @from t0 x to t1@ -- instructions from LLVM.@@ -627,7 +523,7 @@   | -- | Convert a boolean to an integer.  True is converted     -- to 1 and False to 0.     BToI IntType-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show)  -- | A list of all unary operators for all types. allUnOps :: [UnOp]@@ -1537,76 +1433,6 @@ commutativeBinOp FMax {} = True commutativeBinOp FMin {} = True commutativeBinOp _ = False---- SexpIso instances--instance SexpIso BinOp where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "add") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "fadd") >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "sub") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "fsub") >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el (Sexp.sym "mul") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el (Sexp.sym "fmul") >>> Sexp.el sexpIso)) $-                  With (. Sexp.list (Sexp.el (Sexp.sym "udiv") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                    With (. Sexp.list (Sexp.el (Sexp.sym "udivup") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                      With (. Sexp.list (Sexp.el (Sexp.sym "sdiv") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                        With (. Sexp.list (Sexp.el (Sexp.sym "sdivup") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                          With (. Sexp.list (Sexp.el (Sexp.sym "fdiv") >>> Sexp.el sexpIso)) $-                            With (. Sexp.list (Sexp.el (Sexp.sym "fmod") >>> Sexp.el sexpIso)) $-                              With (. Sexp.list (Sexp.el (Sexp.sym "umod") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                With (. Sexp.list (Sexp.el (Sexp.sym "smod") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                  With (. Sexp.list (Sexp.el (Sexp.sym "squot") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                    With (. Sexp.list (Sexp.el (Sexp.sym "srem") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                      With (. Sexp.list (Sexp.el (Sexp.sym "smin") >>> Sexp.el sexpIso)) $-                                        With (. Sexp.list (Sexp.el (Sexp.sym "umin") >>> Sexp.el sexpIso)) $-                                          With (. Sexp.list (Sexp.el (Sexp.sym "fmin") >>> Sexp.el sexpIso)) $-                                            With (. Sexp.list (Sexp.el (Sexp.sym "smax") >>> Sexp.el sexpIso)) $-                                              With (. Sexp.list (Sexp.el (Sexp.sym "umax") >>> Sexp.el sexpIso)) $-                                                With (. Sexp.list (Sexp.el (Sexp.sym "fmap") >>> Sexp.el sexpIso)) $-                                                  With (. Sexp.list (Sexp.el (Sexp.sym "shl") >>> Sexp.el sexpIso)) $-                                                    With (. Sexp.list (Sexp.el (Sexp.sym "lshr") >>> Sexp.el sexpIso)) $-                                                      With (. Sexp.list (Sexp.el (Sexp.sym "ashr") >>> Sexp.el sexpIso)) $-                                                        With (. Sexp.list (Sexp.el (Sexp.sym "and") >>> Sexp.el sexpIso)) $-                                                          With (. Sexp.list (Sexp.el (Sexp.sym "or") >>> Sexp.el sexpIso)) $-                                                            With (. Sexp.list (Sexp.el (Sexp.sym "xor") >>> Sexp.el sexpIso)) $-                                                              With (. Sexp.list (Sexp.el (Sexp.sym "pow") >>> Sexp.el sexpIso)) $-                                                                With (. Sexp.list (Sexp.el (Sexp.sym "fpow") >>> Sexp.el sexpIso)) $-                                                                  With (. Sexp.sym "logand") $-                                                                    With-                                                                      (. Sexp.sym "logor")-                                                                      End--instance SexpIso CmpOp where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "eq") >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "ult") >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "ule") >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "slt") >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el (Sexp.sym "sle") >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el (Sexp.sym "lt") >>> Sexp.el sexpIso)) $-                  With (. Sexp.list (Sexp.el (Sexp.sym "le") >>> Sexp.el sexpIso)) $-                    With (. Sexp.sym "llt") $-                      With-                        (. Sexp.sym "lle")-                        End--instance SexpIso ConvOp where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "zext") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "sext") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "fpconv") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "fptoui") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el (Sexp.sym "fptosi") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el (Sexp.sym "uitofp") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                  With (. Sexp.list (Sexp.el (Sexp.sym "sitofp") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                    With (. Sexp.list (Sexp.el (Sexp.sym "itob") >>> Sexp.el sexpIso)) $-                      With-                        (. Sexp.list (Sexp.el (Sexp.sym "btoi") >>> Sexp.el sexpIso))-                        End  -- Prettyprinting instances 

@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++module Futhark.IR.Primitive.Parse+  ( pPrimValue,+    pPrimType,+    pFloatType,+    pIntType,++    -- * Building blocks+    constituent,+    lexeme,+    keyword,+    whitespace,+  )+where++import Data.Char (isAlphaNum)+import Data.Functor+import qualified Data.Text as T+import Data.Void+import Futhark.IR.Primitive+import Futhark.Util.Pretty hiding (empty)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++type Parser = Parsec Void T.Text++constituent :: Char -> Bool+constituent c = isAlphaNum c || (c `elem` ("_/'+-=!&^.<>*|" :: String))++whitespace :: Parser ()+whitespace = L.space space1 (L.skipLineComment "--") empty++lexeme :: Parser a -> Parser a+lexeme = try . L.lexeme whitespace++keyword :: T.Text -> Parser ()+keyword s = lexeme $ chunk s *> notFollowedBy (satisfy constituent)++pIntValue :: Parser IntValue+pIntValue = try $ do+  x <- L.signed (pure ()) L.decimal+  t <- pIntType+  pure $ intValue t (x :: Integer)++pFloatValue :: Parser FloatValue+pFloatValue =+  choice+    [ pNum,+      keyword "f32.nan" $> Float32Value (0 / 0),+      keyword "f32.inf" $> Float32Value (1 / 0),+      keyword "-f32.inf" $> Float32Value (-1 / 0),+      keyword "f64.nan" $> Float64Value (0 / 0),+      keyword "f64.inf" $> Float64Value (1 / 0),+      keyword "-f64.inf" $> Float64Value (-1 / 0)+    ]+  where+    pNum = try $ do+      x <- L.signed (pure ()) L.float+      t <- pFloatType+      pure $ floatValue t (x :: Double)++pBoolValue :: Parser Bool+pBoolValue =+  choice+    [ keyword "true" $> True,+      keyword "false" $> False+    ]++-- | Defined in this module for convenience.+pPrimValue :: Parser PrimValue+pPrimValue =+  choice+    [ FloatValue <$> pFloatValue,+      IntValue <$> pIntValue,+      BoolValue <$> pBoolValue+    ]+    <?> "primitive value"++pFloatType :: Parser FloatType+pFloatType = choice $ map p allFloatTypes+  where+    p t = keyword (prettyText t) $> t++pIntType :: Parser IntType+pIntType = choice $ map p allIntTypes+  where+    p t = keyword (prettyText t) $> t++pPrimType :: Parser PrimType+pPrimType =+  choice [p Bool, p Cert, FloatType <$> pFloatType, IntType <$> pIntType]+  where+    p t = keyword (prettyText t) $> t

@@ -28,7 +28,6 @@     safeExp,     subExpVars,     subExpVar,-    shapeVars,     commutativeLambda,     entryPointSize,     defAux,@@ -59,7 +58,6 @@ import Futhark.Transform.Rename (Rename, Renameable) import Futhark.Transform.Substitute (Substitutable, Substitute) import Futhark.Util.Pretty-import Language.SexpGrammar as Sexp  -- | @isBuiltInFunction k@ is 'True' if @k@ is an element of 'builtInFunctions'. isBuiltInFunction :: Name -> Bool@@ -145,11 +143,6 @@ subExpVar (Var v) = Just v subExpVar Constant {} = Nothing --- | Return the variable dimension sizes.  May contain--- duplicates.-shapeVars :: Shape -> [VName]-shapeVars = subExpVars . shapeDims- -- | Does the given lambda represent a known commutative function? -- Based on pattern matching and checking whether the lambda -- represents a known arithmetic operator; don't expect anything@@ -197,7 +190,7 @@ -- | A handy shorthand for properties that we usually want to things -- we stuff into ASTs. type ASTConstraints a =-  (Eq a, Ord a, Show a, Rename a, Substitute a, FreeIn a, Pretty a, SexpIso a)+  (Eq a, Ord a, Show a, Rename a, Substitute a, FreeIn a, Pretty a)  -- | A type class for operations. class (ASTConstraints op, TypedOp op) => IsOp op where

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}@@ -52,19 +51,12 @@ import Futhark.IR.Syntax import Futhark.IR.Traversals import Futhark.Util.Pretty-import GHC.Generics-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | A set of names.  Note that the 'Ord' instance is a dummy that -- treats everything as 'EQ' if '==', and otherwise 'LT'. newtype Names = Names (IM.IntMap VName)-  deriving (Eq, Show, Generic)--instance SexpIso Names where-  sexpIso = with $ \names ->-    (iso IM.fromList IM.toList . sexpIso) >>> names+  deriving (Eq, Show)  -- | Retrieve the data structure underlying the names representation. namesIntMap :: Names -> IM.IntMap VName

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -70,9 +69,6 @@ import Futhark.Util (chunks, maybeNth) import Futhark.Util.Pretty (Doc, Pretty, comma, commasep, parens, ppr, text, (<+>), (</>)) import qualified Futhark.Util.Pretty as PP-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | A second-order array combinator (SOAC).@@ -108,17 +104,7 @@   | -- | A combination of scan, reduction, and map.  The first     -- t'SubExp' is the size of the input arrays.     Screma SubExp (ScremaForm lore) [VName]-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (SOAC lore) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "stream") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "scatter") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "hist") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With-              (. Sexp.list (Sexp.el (Sexp.sym "screma") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-              End+  deriving (Eq, Ord, Show)  -- | Information about computing a single histogram. data HistOp lore = HistOp@@ -130,55 +116,20 @@     histNeutral :: [SubExp],     histOp :: Lambda lore   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (HistOp lore) where-  sexpIso = with $ \histop ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> histop+  deriving (Eq, Ord, Show)  -- | Is the stream chunk required to correspond to a contiguous -- subsequence of the original input ('InOrder') or not?  'Disorder' -- streams can be more efficient, but not all algorithms work with -- this. data StreamOrd = InOrder | Disorder-  deriving (Eq, Ord, Show, Generic)--instance SexpIso StreamOrd where-  sexpIso =-    match $-      With (. Sexp.sym "in-order") $-        With-          (. Sexp.sym "disorder")-          End+  deriving (Eq, Ord, Show)  -- | What kind of stream is this? data StreamForm lore   = Parallel StreamOrd Commutativity (Lambda lore)   | Sequential-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (StreamForm lore) where-  sexpIso =-    match $-      With-        ( .-            Sexp.list-              ( Sexp.el (Sexp.sym "parallel")-                  >>> Sexp.el sexpIso-                  >>> Sexp.el sexpIso-                  >>> Sexp.el sexpIso-              )-        )-        $ With-          (. Sexp.list (Sexp.el (Sexp.sym "sequential")))-          End+  deriving (Eq, Ord, Show)  -- | The essential parts of a 'Screma' factored out (everything -- except the input arrays).@@ -187,16 +138,7 @@       [Scan lore]       [Reduce lore]       (Lambda lore)-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (ScremaForm lore) where-  sexpIso = with $ \scremaform ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> scremaform+  deriving (Eq, Ord, Show)  singleBinOp :: Bindable lore => [Lambda lore] -> Lambda lore singleBinOp lams =@@ -217,16 +159,7 @@   { scanLambda :: Lambda lore,     scanNeutral :: [SubExp]   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (Scan lore) where-  sexpIso = with $ \scan ->-    Sexp.list-      ( Sexp.el (Sexp.sym "scan")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> scan+  deriving (Eq, Ord, Show)  -- | How many reduction results are produced by these 'Scan's? scanResults :: [Scan lore] -> Int@@ -245,17 +178,7 @@     redLambda :: Lambda lore,     redNeutral :: [SubExp]   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (Reduce lore) where-  sexpIso = with $ \red ->-    Sexp.list-      ( Sexp.el (Sexp.sym "reduce")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> red+  deriving (Eq, Ord, Show)  -- | How many reduction results are produced by these 'Reduce's? redResults :: [Reduce lore] -> Int

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -96,24 +95,13 @@     (</>),   ) import qualified Futhark.Util.Pretty as PP-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp hiding (expected)-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | How an array is split into chunks. data SplitOrdering   = SplitContiguous   | SplitStrided SubExp-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SplitOrdering where-  sexpIso =-    match $-      With (. Sexp.sym "contiguous") $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "strided") >>> Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance FreeIn SplitOrdering where   freeIn' SplitContiguous = mempty@@ -145,19 +133,7 @@     histShape :: Shape,     histOp :: Lambda lore   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (HistOp lore) where-  sexpIso = with $ \histop ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> histop+  deriving (Eq, Ord, Show)  -- | The type of a histogram produced by a 'HistOp'.  This can be -- different from the type of the 'histDest's in case we are@@ -182,17 +158,7 @@     -- code.     segBinOpShape :: Shape   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (SegBinOp lore) where-  sexpIso = with $ \segbinop ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> segbinop+  deriving (Eq, Ord, Show)  -- | How many reduction results are produced by these 'SegBinOp's? segBinOpResults :: [SegBinOp lore] -> Int@@ -209,17 +175,7 @@     kernelBodyStms :: Stms lore,     kernelBodyResult :: [KernelResult]   }-  deriving (Generic) -instance Decorations lore => SexpIso (KernelBody lore) where-  sexpIso = with $ \kernelbody ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> kernelbody- deriving instance Decorations lore => Ord (KernelBody lore)  deriving instance Decorations lore => Show (KernelBody lore)@@ -240,16 +196,7 @@     -- same physical thread later on, and can thus be     -- kept in registers.     ResultPrivate-  deriving (Eq, Show, Ord, Generic)--instance SexpIso ResultManifest where-  sexpIso =-    match $-      With (. Sexp.sym "no-simplify") $-        With (. Sexp.sym "may-simplify") $-          With-            (. Sexp.sym "private")-            End+  deriving (Eq, Show, Ord)  -- | A 'KernelBody' does not return an ordinary 'Result'.  Instead, it -- returns a list of these.@@ -259,7 +206,7 @@     -- result-per-group depends on where the 'SegOp' occurs.     Returns ResultManifest SubExp   | WriteReturns-      [SubExp] -- Size of array.  Must match number of dims.+      Shape -- Size of array.  Must match number of dims.       VName -- Which array       [(Slice SubExp, SubExp)]   | -- Arbitrary number of index/value pairs.@@ -281,18 +228,7 @@         )       ]       VName -- Tile returned by this worker/group.-  deriving (Eq, Show, Ord, Generic)--instance SexpIso KernelResult where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "returns") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "write-returns") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "concat-returns") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "tile-returns") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With-                (. Sexp.list (Sexp.el (Sexp.sym "reg-tile-returns") >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-                End+  deriving (Eq, Show, Ord)  -- | Get the root t'SubExp' corresponding values for a 'KernelResult'. kernelResultSubExp :: KernelResult -> SubExp@@ -412,13 +348,13 @@   where     checkKernelResult (Returns _ what) t =       TC.require [t] what-    checkKernelResult (WriteReturns rws arr res) t = do-      mapM_ (TC.require [Prim int64]) rws+    checkKernelResult (WriteReturns shape arr res) t = do+      mapM_ (TC.require [Prim int64]) $ shapeDims shape       arr_t <- lookupType arr       forM_ res $ \(slice, e) -> do         mapM_ (traverse $ TC.require [Prim int64]) slice         TC.require [t] e-        unless (arr_t == t `arrayOfShape` Shape rws) $+        unless (arr_t == t `arrayOfShape` shape) $           TC.bad $             TC.TypeError $               "WriteReturns returning "@@ -426,7 +362,7 @@                 ++ " of type "                 ++ pretty t                 ++ ", shape="-                ++ pretty rws+                ++ pretty shape                 ++ ", but destination array has type "                 ++ pretty arr_t       TC.consume =<< TC.lookupAliases arr@@ -478,19 +414,18 @@     text "returns (private)" <+> ppr what   ppr (Returns ResultMaySimplify what) =     text "returns" <+> ppr what-  ppr (WriteReturns rws arr res) =-    ppr arr <+> text "with" <+> PP.apply (map ppRes res)+  ppr (WriteReturns shape arr res) =+    ppr arr <+> PP.colon <+> ppr shape+      </> text "with" <+> PP.apply (map ppRes res)     where-      ppRes (is, e) =-        PP.brackets (PP.commasep $ zipWith f is rws) <+> text "<-" <+> ppr e-      f i rw = ppr i <+> text "<" <+> ppr rw-  ppr (ConcatReturns o w per_thread_elems v) =-    text "concat" <> suff+      ppRes (slice, e) =+        PP.brackets (commasep (map ppr slice)) <+> text "=" <+> ppr e+  ppr (ConcatReturns SplitContiguous w per_thread_elems v) =+    text "concat"       <> parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v-    where-      suff = case o of-        SplitContiguous -> mempty-        SplitStrided stride -> text "Strided" <> parens (ppr stride)+  ppr (ConcatReturns (SplitStrided stride) w per_thread_elems v) =+    text "concat_strided"+      <> parens (commasep [ppr stride, ppr w, ppr per_thread_elems]) <+> ppr v   ppr (TileReturns dims v) =     "tile" <> parens (commasep $ map onDim dims) <+> ppr v     where@@ -515,16 +450,7 @@     -- that all physical threads participate in the work.  This can     -- save some checks in code generation.     SegNoVirtFull-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SegVirt where-  sexpIso =-    match $-      With (. Sexp.sym "virt") $-        With (. Sexp.sym "no-virt") $-          With-            (. Sexp.sym "no-virt-ful")-            End+  deriving (Eq, Ord, Show)  -- | Index space of a 'SegOp'. data SegSpace = SegSpace@@ -534,15 +460,7 @@     segFlat :: VName,     unSegSpace :: [(VName, SubExp)]   }-  deriving (Eq, Ord, Show, Generic)--instance SexpIso SegSpace where-  sexpIso = with $ \segspace ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> segspace+  deriving (Eq, Ord, Show)  -- | The sizes spanned by the indexes of the 'SegSpace'. segSpaceDims :: SegSpace -> [SubExp]@@ -575,17 +493,7 @@     SegRed lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore)   | SegScan lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore)   | SegHist lvl SegSpace [HistOp lore] [Type] (KernelBody lore)-  deriving (Eq, Ord, Show, Generic)--instance (SexpIso lvl, Decorations lore) => SexpIso (SegOp lvl lore) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "segmap") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "segred") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "segscan") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With-              (. Sexp.list (Sexp.el (Sexp.sym "seghist") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-              End+  deriving (Eq, Ord, Show)  -- | The level of a 'SegOp'. segLevel :: SegOp lvl lore -> lvl@@ -602,8 +510,8 @@ segSpace (SegHist _ lvl _ _ _) = lvl  segResultShape :: SegSpace -> Type -> KernelResult -> Type-segResultShape _ t (WriteReturns rws _ _) =-  t `arrayOfShape` Shape rws+segResultShape _ t (WriteReturns shape _ _) =+  t `arrayOfShape` shape segResultShape space t (Returns _ _) =   foldr (flip arrayOfRow) t $ segSpaceDims space segResultShape _ t (ConcatReturns _ w _ _) =@@ -955,24 +863,23 @@       <+> PP.nestedBlock "{" "}" (ppr body)   ppr (SegRed lvl space reds ts body) =     text "segred" <> ppr lvl-      </> PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr reds))       </> PP.align (ppr space)-      <+> PP.colon+      </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr reds)+      </> PP.colon       <+> ppTuple' ts       <+> PP.nestedBlock "{" "}" (ppr body)   ppr (SegScan lvl space scans ts body) =     text "segscan" <> ppr lvl-      </> PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr scans))       </> PP.align (ppr space)-      <+> PP.colon+      </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr scans)+      </> PP.colon       <+> ppTuple' ts       <+> PP.nestedBlock "{" "}" (ppr body)   ppr (SegHist lvl space ops ts body) =     text "seghist" <> ppr lvl-      </> ppr lvl-      </> PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops))       </> PP.align (ppr space)-      <+> PP.colon+      </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops)+      </> PP.colon       <+> ppTuple' ts       <+> PP.nestedBlock "{" "}" (ppr body)     where

@@ -1,8 +1,6 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} {-# LANGUAGE Trustworthy #-}@@ -173,29 +171,17 @@ import qualified Data.Sequence as Seq import qualified Data.Set as S import Data.String-import qualified Data.Text as T import Data.Traversable (fmapDefault, foldMapDefault) import Futhark.IR.Decorations import Futhark.IR.Syntax.Core-import GHC.Generics (Generic) import Language.Futhark.Core-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | A single attribute. data Attr   = AttrAtom Name   | AttrComp Name [Attr]-  deriving (Ord, Show, Eq, Generic)--instance SexpIso Attr where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "atom") >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "comp") >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-          End+  deriving (Ord, Show, Eq)  instance IsString Attr where   fromString = AttrAtom . fromString@@ -203,10 +189,7 @@ -- | Every statement is associated with a set of attributes, which can -- have various effects throughout the compiler. newtype Attrs = Attrs {unAttrs :: S.Set Attr}-  deriving (Ord, Show, Eq, Monoid, Semigroup, Generic)--instance SexpIso Attrs where-  sexpIso = with $ \attrs -> sexpIso >>> attrs+  deriving (Ord, Show, Eq, Monoid, Semigroup)  -- | Construct 'Attrs' from a single 'Attr'. oneAttr :: Attr -> Attrs@@ -230,15 +213,7 @@     -- | "real" values     patternValueElements :: [PatElemT dec]   }-  deriving (Ord, Show, Eq, Generic)--instance SexpIso dec => SexpIso (PatternT dec) where-  sexpIso = with $ \vname ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> vname+  deriving (Ord, Show, Eq)  instance Semigroup (PatternT dec) where   Pattern cs1 vs1 <> Pattern cs2 vs2 = Pattern (cs1 ++ cs2) (vs1 ++ vs2)@@ -265,17 +240,7 @@     stmAuxAttrs :: Attrs,     stmAuxDec :: dec   }-  deriving (Ord, Show, Eq, Generic)--instance SexpIso dec => SexpIso (StmAux dec) where-  sexpIso = with $ \vname ->-    Sexp.list-      ( Sexp.el (Sexp.sym "aux")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> vname+  deriving (Ord, Show, Eq)  instance Semigroup dec => Semigroup (StmAux dec) where   StmAux cs1 attrs1 dec1 <> StmAux cs2 attrs2 dec2 =@@ -290,18 +255,7 @@     -- | Expression.     stmExp :: Exp lore   }-  deriving (Generic) -instance Decorations lore => SexpIso (Stm lore) where-  sexpIso = with $ \stm ->-    Sexp.list-      ( Sexp.el (Sexp.sym "let")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> stm- deriving instance Decorations lore => Ord (Stm lore)  deriving instance Decorations lore => Show (Stm lore)@@ -311,9 +265,6 @@ -- | A sequence of statements. type Stms lore = Seq.Seq (Stm lore) -instance Decorations lore => SexpIso (Stms lore) where-  sexpIso = iso stmsFromList stmsToList . sexpIso- -- | A single statement. oneStm :: Stm lore -> Stms lore oneStm = Seq.singleton@@ -342,17 +293,7 @@     bodyStms :: Stms lore,     bodyResult :: Result   }-  deriving (Generic) -instance Decorations lore => SexpIso (BodyT lore) where-  sexpIso = with $ \stm ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> stm- deriving instance Decorations lore => Ord (BodyT lore)  deriving instance Decorations lore => Show (BodyT lore)@@ -373,15 +314,7 @@   | -- | The new dimension is not necessarily numerically     -- equal to the old one.     DimNew d-  deriving (Ord, Show, Generic)--instance SexpIso d => SexpIso (DimChange d) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "coercion") >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "new") >>> Sexp.el sexpIso))-          End+  deriving (Ord, Show)  instance Eq d => Eq (DimChange d) where   DimCoercion x == DimNew y = x == y@@ -466,40 +399,7 @@     -- subexpressions specify how much each dimension is rotated.  The     -- length of this list must be equal to the rank of the array.     Rotate [SubExp] VName-  deriving (Eq, Ord, Show, Generic)--instance SexpIso BasicOp where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el sexpIso)) $-        With (. Sexp.list (Sexp.el (Sexp.sym "opaque") >>> Sexp.el sexpIso)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "array") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With (. Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                With (. Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                  With (. Sexp.list (Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                    With (. Sexp.list (Sexp.el (Sexp.sym "assert") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el assertHelper)) $-                      With (. Sexp.list (Sexp.el (Sexp.sym "index") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                        With (. Sexp.list (Sexp.el (Sexp.sym "update") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                          With (. Sexp.list (Sexp.el (Sexp.sym "concat") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                            With (. Sexp.list (Sexp.el (Sexp.sym "copy") >>> Sexp.el sexpIso)) $-                              With (. Sexp.list (Sexp.el (Sexp.sym "manifest") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                With (. Sexp.list (Sexp.el (Sexp.sym "iota") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                  With (. Sexp.list (Sexp.el (Sexp.sym "replicate") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                    With (. Sexp.list (Sexp.el (Sexp.sym "scratch") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                      With (. Sexp.list (Sexp.el (Sexp.sym "reshape") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                        With (. Sexp.list (Sexp.el (Sexp.sym "rearrange") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-                                          With-                                            (. Sexp.list (Sexp.el (Sexp.sym "rotate") >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-                                            End-    where-      assertHelper =-        with $ \tuple ->-          Sexp.list-            ( Sexp.el (iso (const mempty) (T.pack . show) . Sexp.symbol)-                >>> Sexp.rest (iso (const mempty) (T.pack . show) . Sexp.symbol)-            )-            >>> tuple+  deriving (Eq, Ord, Show)  -- | The root Futhark expression type.  The v'Op' constructor contains -- a lore-specific operation.  Do-loops, branches and function calls@@ -513,28 +413,7 @@     -- parameters are divided into context and value part.     DoLoop [(FParam lore, SubExp)] [(FParam lore, SubExp)] (LoopForm lore) (BodyT lore)   | Op (Op lore)-  deriving (Generic) -instance Decorations lore => SexpIso (ExpT lore) where-  sexpIso =-    match $-      With (. sexpIso) $-        With (. Sexp.list (Sexp.el (Sexp.sym "apply") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el applyHelper)) $-          With (. Sexp.list (Sexp.el (Sexp.sym "if") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-            With (. Sexp.list (Sexp.el (Sexp.sym "loop") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-              With-                (. sexpIso)-                End-    where-      applyHelper =-        with $ \triple ->-          Sexp.list-            ( Sexp.el sexpIso-                >>> Sexp.el (iso (const mempty) (T.pack . show) . Sexp.symbol)-                >>> Sexp.rest (iso (const mempty) (T.pack . show) . Sexp.symbol)-            )-            >>> triple- deriving instance Decorations lore => Eq (ExpT lore)  deriving instance Decorations lore => Show (ExpT lore)@@ -545,16 +424,7 @@ data LoopForm lore   = ForLoop VName IntType SubExp [(LParam lore, VName)]   | WhileLoop VName-  deriving (Generic) -instance Decorations lore => SexpIso (LoopForm lore) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "for") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "while") >>> Sexp.el sexpIso))-          End- deriving instance Decorations lore => Eq (LoopForm lore)  deriving instance Decorations lore => Show (LoopForm lore)@@ -566,15 +436,7 @@   { ifReturns :: [rt],     ifSort :: IfSort   }-  deriving (Eq, Show, Ord, Generic)--instance SexpIso rt => SexpIso (IfDec rt) where-  sexpIso = with $ \stm ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> stm+  deriving (Eq, Show, Ord)  -- | What kind of branch is this?  This has no semantic meaning, but -- provides hints to simplifications.@@ -593,16 +455,7 @@     -- have problems (e.g. contain things we cannot generate     -- code for).     IfEquiv-  deriving (Eq, Show, Ord, Generic)--instance SexpIso IfSort where-  sexpIso =-    match $-      With (sym "normal" >>>) $-        With (sym "fallback" >>>) $-          With-            (sym "equiv" >>>)-            End+  deriving (Eq, Show, Ord)  -- | A type alias for namespace control. type Exp = ExpT@@ -613,18 +466,7 @@     lambdaBody :: BodyT lore,     lambdaReturnType :: [Type]   }-  deriving (Generic) -instance Decorations lore => SexpIso (LambdaT lore) where-  sexpIso = with $ \lambdat ->-    Sexp.list-      ( Sexp.el (Sexp.sym "lambda")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> lambdat- deriving instance Decorations lore => Eq (LambdaT lore)  deriving instance Decorations lore => Show (LambdaT lore)@@ -651,21 +493,7 @@     funDefParams :: [FParam lore],     funDefBody :: BodyT lore   }-  deriving (Generic) -instance Decorations lore => SexpIso (FunDef lore) where-  sexpIso = with $ \fundef ->-    Sexp.list-      ( Sexp.el (Sexp.sym "fundef")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> fundef- deriving instance Decorations lore => Eq (FunDef lore)  deriving instance Decorations lore => Show (FunDef lore)@@ -689,16 +517,7 @@     TypeOpaque String Int   | -- | Maps directly.     TypeDirect-  deriving (Eq, Show, Ord, Generic)--instance SexpIso EntryPointType where-  sexpIso =-    match $-      With (. Sexp.sym "unsigned") $-        With (. Sexp.list (Sexp.el (Sexp.sym "opaque") >>> Sexp.el (iso T.unpack T.pack . sexpIso) >>> Sexp.el sexpIso)) $-          With-            (. Sexp.sym "direct")-            End+  deriving (Eq, Show, Ord)  -- | An entire Futhark program. data Prog lore = Prog@@ -711,13 +530,4 @@     -- checked).     progFuns :: [FunDef lore]   }-  deriving (Eq, Ord, Show, Generic)--instance Decorations lore => SexpIso (Prog lore) where-  sexpIso = with $ \prog ->-    Sexp.list-      ( Sexp.el (Sexp.sym "prog")-          >>> Sexp.el sexpIso-          >>> Sexp.rest sexpIso-      )-      >>> prog+  deriving (Eq, Ord, Show)

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -63,22 +62,15 @@ import qualified Data.Map.Strict as M import Data.Maybe import Data.String-import qualified Data.Text as T import Data.Traversable (fmapDefault, foldMapDefault) import Futhark.IR.Primitive-import GHC.Generics import Language.Futhark.Core-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic import Prelude hiding (id, (.))  -- | The size of an array type as a list of its dimension sizes, with -- the type of sizes being parametric. newtype ShapeBase d = Shape {shapeDims :: [d]}-  deriving (Eq, Ord, Show, Generic)--instance SexpIso d => SexpIso (ShapeBase d) where-  sexpIso = with $ \vname -> sexpIso >>> vname+  deriving (Eq, Ord, Show)  instance Functor ShapeBase where   fmap = fmapDefault@@ -103,15 +95,7 @@ data Ext a   = Ext Int   | Free a-  deriving (Eq, Ord, Show, Generic)--instance SexpIso a => SexpIso (Ext a) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "ext") >>> Sexp.el sexpIso)) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "free") >>> Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance Functor Ext where   fmap = fmapDefault@@ -133,15 +117,7 @@ -- | The size of an array type as merely the number of dimensions, -- with no further information. newtype Rank = Rank Int-  deriving (Show, Eq, Ord, Generic)--instance SexpIso Rank where-  sexpIso = with $ \rank ->-    Sexp.list-      ( Sexp.el (Sexp.sym "rank")-          >>> Sexp.el sexpIso-      )-      >>> rank+  deriving (Show, Eq, Ord)  -- | A class encompassing types containing array shape information. class (Monoid a, Eq a, Ord a) => ArrayShape a where@@ -206,26 +182,14 @@     -- array of some primitive type.  Used for private memory     -- on GPUs.     ScalarSpace [SubExp] PrimType-  deriving (Show, Eq, Ord, Generic)--instance SexpIso Space where-  sexpIso =-    match $-      With (Sexp.sym "default" >>>) $-        With (. Sexp.list (Sexp.el (sym "space") >>> Sexp.el (iso T.unpack T.pack . sexpIso))) $-          With-            (. Sexp.list (Sexp.el (sym "scalar-space") >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-            End+  deriving (Show, Eq, Ord)  -- | A string representing a specific non-default memory space. type SpaceId = String  -- | A fancier name for @()@ - encodes no uniqueness information. data NoUniqueness = NoUniqueness-  deriving (Eq, Ord, Show, Generic)--instance SexpIso NoUniqueness where-  sexpIso = with (. sym "no-uniqueness")+  deriving (Eq, Ord, Show)  -- | A Futhark type is either an array or an element type.  When -- comparing types for equality with '==', shapes must match.@@ -233,7 +197,7 @@   = Prim PrimType   | Array PrimType shape u   | Mem Space-  deriving (Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord)  instance Bitraversable TypeBase where   bitraverse f g (Array t shape u) = Array t <$> f shape <*> g u@@ -246,15 +210,6 @@ instance Bifoldable TypeBase where   bifoldMap = bifoldMapDefault -instance (SexpIso shape, SexpIso u) => SexpIso (TypeBase shape u) where-  sexpIso =-    match $-      With (. sexpIso) $-        With (. Sexp.list (Sexp.el (sym "array") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $-          With-            (. Sexp.list (Sexp.el (sym "mem") >>> Sexp.el sexpIso))-            End- -- | A type with shape information, used for describing the type of -- variables. type Type = TypeBase Shape NoUniqueness@@ -286,16 +241,7 @@     -- alias, because the parameter does not carry     -- aliases.     ObservePrim-  deriving (Eq, Ord, Show, Generic)--instance SexpIso Diet where-  sexpIso =-    match $-      With (Sexp.sym "consume" >>>) $-        With (Sexp.sym "observe" >>>) $-          With-            (Sexp.sym "observe-prim" >>>)-            End+  deriving (Eq, Ord, Show)  -- | An identifier consists of its name and the type of the value -- bound to the identifier.@@ -303,16 +249,7 @@   { identName :: VName,     identType :: Type   }-  deriving (Show, Generic)--instance SexpIso Ident where-  sexpIso = with $ \vname ->-    Sexp.list-      ( Sexp.el (Sexp.sym "ident")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> vname+  deriving (Show)  instance Eq Ident where   x == y = identName x == identName y@@ -322,10 +259,7 @@  -- | A list of names used for certificates in some expressions. newtype Certificates = Certificates {unCertificates :: [VName]}-  deriving (Eq, Ord, Show, Generic)--instance SexpIso Certificates where-  sexpIso = with $ \certificates -> sexpIso >>> certificates+  deriving (Eq, Ord, Show)  instance Semigroup Certificates where   Certificates x <> Certificates y = Certificates (x <> y)@@ -339,15 +273,7 @@ data SubExp   = Constant PrimValue   | Var VName-  deriving (Show, Eq, Ord, Generic)--instance SexpIso SubExp where-  sexpIso =-    match $-      With (. sexpIso) $-        With-          (. sexpIso)-          End+  deriving (Show, Eq, Ord)  -- | A function or lambda parameter. data Param dec = Param@@ -356,16 +282,7 @@     -- | Function parameter decoration.     paramDec :: dec   }-  deriving (Ord, Show, Eq, Generic)--instance SexpIso dec => SexpIso (Param dec) where-  sexpIso = with $ \vname ->-    Sexp.list-      ( Sexp.el (Sexp.sym "param")-          >>> Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> vname+  deriving (Ord, Show, Eq)  instance Foldable Param where   foldMap = foldMapDefault@@ -382,15 +299,7 @@     DimFix d   | -- | @DimSlice start_offset num_elems stride@.     DimSlice d d d-  deriving (Eq, Ord, Show, Generic)--instance SexpIso d => SexpIso (DimIndex d) where-  sexpIso =-    match $-      With (. sexpIso) $-        With-          (. Sexp.list (Sexp.el (Sexp.sym "slice") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso))-          End+  deriving (Eq, Ord, Show)  instance Functor DimIndex where   fmap f (DimFix i) = DimFix $ f i@@ -459,15 +368,7 @@     -- | Pattern element decoration.     patElemDec :: dec   }-  deriving (Ord, Show, Eq, Generic)--instance SexpIso dec => SexpIso (PatElemT dec) where-  sexpIso = with $ \pe ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> pe+  deriving (Ord, Show, Eq)  instance Functor PatElemT where   fmap = fmapDefault@@ -482,10 +383,7 @@ -- | An error message is a list of error parts, which are concatenated -- to form the final message. newtype ErrorMsg a = ErrorMsg [ErrorMsgPart a]-  deriving (Eq, Ord, Show, Generic)--instance SexpIso a => SexpIso (ErrorMsg a) where-  sexpIso = with $ \errormsg -> sexpIso >>> errormsg+  deriving (Eq, Ord, Show)  instance IsString (ErrorMsg a) where   fromString = ErrorMsg . pure . fromString@@ -498,16 +396,7 @@     ErrorInt32 a   | -- | A bigger run-time integer value.     ErrorInt64 a-  deriving (Eq, Ord, Show, Generic)--instance SexpIso a => SexpIso (ErrorMsgPart a) where-  sexpIso =-    match $-      With (. Sexp.list (Sexp.el (Sexp.sym "error-string") . Sexp.el (iso T.unpack T.pack . sexpIso))) $-        With (. Sexp.list (Sexp.el (Sexp.sym "error-int32") . Sexp.el sexpIso)) $-          With-            (. Sexp.list (Sexp.el (Sexp.sym "error-int64") . Sexp.el sexpIso))-            End+  deriving (Eq, Ord, Show)  instance IsString (ErrorMsgPart a) where   fromString = ErrorString

@@ -9,6 +9,7 @@  import Control.Monad.Reader import Control.Monad.State+import Data.Bifunctor import Data.Foldable import Data.List (partition) import qualified Data.Map.Strict as M@@ -76,6 +77,8 @@           S.fromList ext         Match _ _ (_, Info ext) _ ->           S.fromList ext+        DoLoop _ _ _ _ _ (Info (_, ext)) _ ->+          S.fromList ext         _ ->           mempty @@ -110,7 +113,9 @@       isSize (v, _) = v `S.member` sizes_in_types       (free_dims, free_nondims) = partition isSize free -      free_params = map mkParam $ free_dims ++ free_nondims+      free_params =+        map (mkParam . second (`setUniqueness` Nonunique)) $+          free_dims ++ free_nondims    addValBind $     ValBind

@@ -412,8 +412,7 @@   fname' <- transformFName loc fname $ toStruct t   e1' <- transformExp e1   e2' <- transformExp e2-  if orderZero (typeOf e1')-    && orderZero (typeOf e2')+  if orderZero (typeOf e1') && orderZero (typeOf e2')     then return $ applyOp fname' e1' e2'     else do       -- We have to flip the arguments to the function, because

@@ -848,7 +848,7 @@                         --y_tp  <- subExpType y_elm                         return (y_elm, y_ind) -                      let ret = WriteReturns [rz] loc_Y_nm [([DimFix res_i], res_v)]+                      let ret = WriteReturns (Shape [rz]) loc_Y_nm [([DimFix res_i], res_v)]                       let body = KernelBody () stms [ret]                        res_nms <-

@@ -143,7 +143,7 @@                   map (pe64 . Var) gtids            let res_dims = arrayDims $ snd bindee_dec-              ret' = WriteReturns res_dims src [(map DimFix slice', se)]+              ret' = WriteReturns (Shape res_dims) src [(map DimFix slice', se)]            return             ( PatElem bindee_nm bindee_dec,

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -44,19 +43,14 @@ import Futhark.IR.Prop.Aliases import Futhark.Transform.Rename import Futhark.Transform.Substitute-import GHC.Generics (Generic)-import Language.SexpGrammar as Sexp hiding (cons)-import Language.SexpGrammar.Generic+import Futhark.Util.Pretty import Prelude hiding (id, (.))  data Wise lore  -- | The wisdom of the let-bound variable. newtype VarWisdom = VarWisdom {varWisdomAliases :: VarAliases}-  deriving (Eq, Ord, Show, Generic)--instance SexpIso VarWisdom where-  sexpIso = with $ \varwisdom -> sexpIso >>> varwisdom+  deriving (Eq, Ord, Show)  instance Rename VarWisdom where   rename = substituteRename@@ -73,15 +67,7 @@   { _expWisdomConsumed :: ConsumedInExp,     expWisdomFree :: AliasDec   }-  deriving (Eq, Ord, Show, Generic)--instance SexpIso ExpWisdom where-  sexpIso = with $ \expwisdom ->-    Sexp.list-      ( Sexp.el sexpIso-          >>> Sexp.el sexpIso-      )-      >>> expwisdom+  deriving (Eq, Ord, Show)  instance FreeIn ExpWisdom where   freeIn' = mempty@@ -104,14 +90,7 @@     bodyWisdomConsumed :: ConsumedInExp,     bodyWisdomFree :: AliasDec   }-  deriving (Eq, Ord, Show, Generic)--instance SexpIso BodyWisdom where-  sexpIso = with $ \bodywisdom ->-    Sexp.list-      ( Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso-      )-      >>> bodywisdom+  deriving (Eq, Ord, Show)  instance Rename BodyWisdom where   rename = substituteRename@@ -157,8 +136,8 @@   expTypesFromPattern =     withoutWisdom . expTypesFromPattern . removePatternWisdom -instance PrettyAnnot (PatElemT dec) => PrettyAnnot (PatElemT (VarWisdom, dec)) where-  ppAnnot = ppAnnot . fmap snd+instance Pretty VarWisdom where+  ppr _ = ppr ()  instance (PrettyLore lore, CanBeWise (Op lore)) => PrettyLore (Wise lore) where   ppExpLore (_, dec) = ppExpLore dec . removeExpWisdom

@@ -90,7 +90,7 @@     t_v <- subExpType res_v     return (t_v, res_v, res_i) -  let ret = WriteReturns [arr_size] updt_arr [([DimFix res_i], res_v)]+  let ret = WriteReturns (Shape [arr_size]) updt_arr [([DimFix res_i], res_v)]   let body = KernelBody () stms [ret]    letTupExp desc <=< renameExp $ Op $ SegOp $ SegMap lvl segspace [t_v] body

@@ -570,7 +570,7 @@           zip (chunks (concat $ zipWith (\ws n -> replicate n $ length ws) as_ws as_ns) i_res) v_res             & chunks as_ns             & zip3 as_ws as_vs-        return $ WriteReturns (shapeDims a_w) a [(map DimFix is, v) | (is, v) <- is_vs]+        return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs]       body = KernelBody () kstms krets       inputs = do         (p, p_a) <- zip (lambdaParams lam') ivs

@@ -825,7 +825,7 @@      inPlaceReturn ispace (aw, inp, is_vs) =       WriteReturns-        (init ws ++ aw)+        (Shape (init ws ++ aw))         (kernelInputArray inp)         [(map DimFix $ map Var (init gtids) ++ is, v) | (is, v) <- is_vs]       where@@ -864,7 +864,7 @@     v_t <- subExpType v'     return       ( v_t,-        WriteReturns (arrayDims arr_t) arr' [(map DimFix write_is, v')]+        WriteReturns (arrayShape arr_t) arr' [(map DimFix write_is, v')]       )    mk_lvl <- mkSegLevel

@@ -284,7 +284,7 @@               zip (chunks (concat $ zipWith (\ws n -> replicate n $ length ws) dests_ws dests_ns) i_res) v_res                 & chunks dests_ns                 & zip3 dests_ws dests_vs-            return $ WriteReturns (shapeDims a_w) a [(map DimFix is, v) | (is, v) <- is_vs]+            return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs]           inputs = do             (p, p_a) <- zip (lambdaParams lam') ivs             return $ KernelInput (paramName p) (paramType p) p_a [Var write_i]

@@ -327,7 +327,7 @@           zip (chunks (concat $ zipWith (\ws n -> replicate n $ length ws) dests_ws dests_ns) i_res) v_res             & chunks dests_ns             & zip3 dests_ws dests_vs-        return $ WriteReturns (shapeDims a_w) a [(map DimFix is, v) | (is, v) <- is_vs]+        return $ WriteReturns a_w a [(map DimFix is, v) | (is, v) <- is_vs]       kbody = KernelBody () kstms kres   return $     oneStm $

@@ -125,7 +125,7 @@       StringLit . T.pack <$> lexeme sep ("\"" *> manyTill charLiteral "\"")     ]   where-    pField = (,) <$> parseEntryName <*> (pEquals *> parseExp sep)+    pField = (,) <$> lexeme sep parseEntryName <*> (pEquals *> parseExp sep)     pEquals = lexeme sep "="     pComma = lexeme sep ","     mkTuple [v] = v@@ -164,6 +164,7 @@           s <- LBS.readFile tmpf           case V.readValues s of             Just [val] -> pure $ Right val+            Just [] -> pure $ Left "Cannot read opaque value from Futhark server."             _ -> pure $ Left "Invalid data file produced by Futhark server."  writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> V.Value -> m ()@@ -378,10 +379,21 @@       throwError $ "Function " <> fname <> " not fully applied."     toGround (SValue _ v) = pure v --- | Like 'evalExp', but requires all values to be non-functional.+-- | Like 'evalExp', but requires all values to be non-functional.  If+-- the value has a bad type, return that type instead.  Other+-- evaluation problems (e.g. type failures) raise errors. evalExpToGround ::-  (MonadError T.Text m, MonadIO m) => EvalBuiltin m -> ScriptServer -> Exp -> m V.CompoundValue-evalExpToGround builtin server e = getExpValue server =<< evalExp builtin server e+  (MonadError T.Text m, MonadIO m) =>+  EvalBuiltin m ->+  ScriptServer ->+  Exp ->+  m (Either (V.Compound ScriptValueType) V.CompoundValue)+evalExpToGround builtin server e = do+  v <- evalExp builtin server e+  -- This assumes that the only error that can occur during+  -- getExpValue is trying to read an opaque.+  (Right <$> getExpValue server v)+    `catchError` const (pure $ Left $ fmap scriptValueType v)  -- | The set of Futhark variables that are referenced by the -- expression - these will have to be entry points in the Futhark

@@ -16,7 +16,6 @@     getValuesBS,     withValuesFile,     compareValues,-    compareValues1,     checkResult,     testRunReferenceOutput,     getExpectedResult,

@@ -29,7 +29,6 @@      -- * Comparing Values     compareValues,-    compareValues1,     Mismatch,      -- * Converting values@@ -58,7 +57,6 @@ import qualified Data.Vector.Unboxed.Mutable as UMVec import Futhark.IR.Primitive (PrimValue) import Futhark.IR.Prop.Constants (IsValue (..))-import Futhark.Util (maybeHead) import Futhark.Util.Loc (Pos (..)) import Futhark.Util.Pretty import qualified Futhark.Util.Pretty as PP@@ -626,10 +624,6 @@   where     n = length got     m = length expected---- | As 'compareValues', but only reports one mismatch.-compareValues1 :: [Value] -> [Value] -> Maybe Mismatch-compareValues1 got expected = maybeHead $ compareValues got expected  compareValue :: Int -> Value -> Value -> [Mismatch] compareValue i got_v expected_v

@@ -23,8 +23,8 @@     splitFromEnd,     splitAt3,     focusNth,+    hashIntText,     unixEnvironment,-    isEnvVarSet,     isEnvVarAtLeast,     fancyTerminal,     runProgramWithExitCode,@@ -70,6 +70,7 @@ import System.IO (hIsTerminalDevice, stdout) import System.IO.Unsafe import System.Process.ByteString+import Text.Printf import Text.Read (readMaybe)  -- | Like 'nub', but without the quadratic runtime.@@ -156,21 +157,16 @@   | (bef, x : aft) <- genericSplitAt i xs = Just (bef, x, aft)   | otherwise = Nothing +-- | Convert the given integer (implied to be a hash digest) to a+-- hexadecimal non-negative number.+hashIntText :: Int -> T.Text+hashIntText x = T.pack $ printf "%x" (fromIntegral x :: Word)+ {-# NOINLINE unixEnvironment #-}  -- | The Unix environment when the Futhark compiler started. unixEnvironment :: [(String, String)] unixEnvironment = unsafePerformIO getEnvironment---- | Is an environment variable set to 0 or 1?  If 0, return False; if--- 1, True; otherwise default.-isEnvVarSet :: String -> Bool -> Bool-isEnvVarSet name default_val = fromMaybe default_val $ do-  val <- lookup name unixEnvironment-  case val of-    "0" -> return False-    "1" -> return True-    _ -> Nothing  -- | True if the environment variable, viewed as an integer, has at -- least this numeric value.  Returns False if variable is unset or

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-}@@ -55,10 +54,6 @@ import Data.Word (Word16, Word32, Word64, Word8) import Futhark.Util.Loc import Futhark.Util.Pretty-import GHC.Generics-import Language.SexpGrammar as Sexp-import Language.SexpGrammar.Generic-import Text.Read import Prelude hiding (id, (.))  -- | The uniqueness attribute of a type.  This essentially indicates@@ -69,15 +64,7 @@     Nonunique   | -- | No references outside current function.     Unique-  deriving (Eq, Ord, Show, Generic)--instance SexpIso Uniqueness where-  sexpIso =-    match $-      With (. Sexp.sym "nonunique") $-        With-          (. Sexp.sym "unique")-          End+  deriving (Eq, Ord, Show)  instance Semigroup Uniqueness where   (<>) = min@@ -94,15 +81,7 @@ data Commutativity   = Noncommutative   | Commutative-  deriving (Eq, Ord, Show, Generic)--instance SexpIso Commutativity where-  sexpIso =-    match $-      With (. Sexp.sym "noncommutative") $-        With-          (. Sexp.sym "commutative")-          End+  deriving (Eq, Ord, Show)  instance Semigroup Commutativity where   (<>) = min@@ -118,10 +97,7 @@ -- compiler.  'String's, being lists of characters, are very slow, -- while 'T.Text's are based on byte-arrays. newtype Name = Name T.Text-  deriving (Show, Eq, Ord, IsString, Semigroup, Generic)--instance SexpIso Name where-  sexpIso = with (. symbol)+  deriving (Show, Eq, Ord, IsString, Semigroup)  instance Pretty Name where   ppr = text . nameToString@@ -202,23 +178,7 @@ -- | A name tagged with some integer.  Only the integer is used in -- comparisons, no matter the type of @vn@. data VName = VName !Name !Int-  deriving (Show, Generic)--instance SexpIso VName where-  sexpIso = with $ \vname ->-    Sexp.symbol-      >>> flipped-        ( pair-            >>> partialIso-              (\(nm, i) -> T.pack $ nameToString nm ++ "_" ++ show i)-              ( \s ->-                  let (nm, i) = T.breakOnEnd "_" s-                   in case readMaybe $ T.unpack i of-                        Just i' -> Right (nameFromString $ T.unpack $ T.init nm, i')-                        Nothing -> Left $ expected "Couldn't parse int of vname"-              )-        )-      >>> vname+  deriving (Show)  -- | Return the tag contained in the 'VName'. baseTag :: VName -> Int

@@ -66,7 +66,6 @@     addAliases,     setUniqueness,     noSizes,-    addSizes,     anySizes,     traverseDims,     DimPos (..),@@ -162,10 +161,6 @@ -- | Change the shape of a type to be just the rank. noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as noSizes = first $ const ()---- | Add size annotations that are all 'AnyDim'.-addSizes :: TypeBase () as -> TypeBase (DimDecl vn) as-addSizes = first $ const AnyDim  -- | Change all size annotations to be 'AnyDim'. anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as

@@ -2368,8 +2368,6 @@       contravariantArg tp dp && contravariantArg tr dr     contravariantArg _ _ =       True-consumeArg loc (Scalar (Arrow _ _ _ t2)) (FuncDiet _ pd) =-  consumeArg loc t2 pd consumeArg loc at Consume = return [consumption (aliases at) loc] consumeArg loc at _ = return [observation (aliases at) loc] @@ -2414,6 +2412,15 @@       onExp known (Var v (Info t) loc)         | Just bad <- checkCausality (pquote (ppr v)) known t loc =           bad+      onExp known (ProjectSection _ (Info t) loc)+        | Just bad <- checkCausality "projection section" known t loc =+          bad+      onExp known (OpSectionRight _ (Info t) _ _ _ loc)+        | Just bad <- checkCausality "operator section" known t loc =+          bad+      onExp known (OpSectionLeft _ (Info t) _ _ _ loc)+        | Just bad <- checkCausality "operator section" known t loc =+          bad       onExp known (ArrayLit [] (Info t) loc)         | Just bad <- checkCausality "empty array" known t loc =           bad@@ -2432,15 +2439,7 @@         return e       onExp         known-        e@( BinOp-              (f, floc)-              ft-              (x, Info (_, xp))-              (y, Info (_, yp))-              _-              (Info ext)-              _-            ) = do+        e@(BinOp (f, floc) ft (x, Info (_, xp)) (y, Info (_, yp)) _ (Info ext) _) = do           args_known <-             lift $               execStateT (sequencePoint known x y $ catMaybes [xp, yp]) mempty

@@ -63,6 +63,7 @@       ("pkg", (Pkg.main, "Manage local packages.")),       ("check", (Check.main, "Type check a program.")),       ("imports", (Misc.mainImports, "Print all non-builtin imported Futhark files.")),+      ("hash", (Misc.mainHash, "Print hash of program AST.")),       ("autotune", (Autotune.main, "Autotune threshold parameters.")),       ("query", (Query.main, "Query semantic information about program.")),       ("literate", (Literate.main, "Process a literate Futhark program."))

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Futhark.IR.PrimitiveTests@@ -10,14 +9,13 @@  import Control.Applicative import Futhark.IR.Primitive-import Language.SexpGrammar import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit import Prelude  tests :: TestTree-tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType, doUnOpTests]+tests = testGroup "PrimitiveTests" [propPrimValuesHaveRightType]  propPrimValuesHaveRightType :: TestTree propPrimValuesHaveRightType =@@ -26,17 +24,6 @@     [ testCase (show t ++ " has blank of right type") $         primValueType (blankPrimValue t) @?= t       | t <- [minBound .. maxBound]-    ]--doUnOpTests :: TestTree-doUnOpTests =-  testGroup-    "doUnOp"-    [ testCase "not" $-        let unop = decode @UnOp "(complement i32)"-            val = decode @PrimValue "42i32"-            res = doUnOp <$> unop <*> val-         in res @?= Right (Just (IntValue (Int32Value (-43))))     ]  instance Arbitrary IntType where