futhark 0.25.17 → 0.25.18

raw patch · 47 files changed

+266/−144 lines, 47 filesdep ~futhark-manifestPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: futhark-manifest

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• docs/c-api.rst +7/−5
• docs/language-reference.rst +12/−0
• futhark.cabal +1/−1
• prelude/array.fut +10/−0
• rts/c/copy.h +6/−2
• rts/c/server.h +1/−1
• src/Futhark/AD/Rev.hs +3/−0
• src/Futhark/Analysis/AccessPattern.hs +4/−10
• src/Futhark/Analysis/Metrics.hs +1/−0
• src/Futhark/Bench.hs +3/−3
• src/Futhark/CLI/Literate.hs +1/−1
• src/Futhark/CLI/Misc.hs +1/−1
• src/Futhark/CLI/REPL.hs +1/−12
• src/Futhark/CLI/Test.hs +9/−2
• src/Futhark/CodeGen/Backends/GenericC/Code.hs +14/−8
• src/Futhark/CodeGen/ImpGen.hs +11/−9
• src/Futhark/IR/Parse.hs +4/−0
• src/Futhark/IR/Pretty.hs +5/−0
• src/Futhark/IR/Prop/Aliases.hs +1/−0
• src/Futhark/IR/Prop/TypeOf.hs +4/−0
• src/Futhark/IR/Syntax.hs +7/−0
• src/Futhark/IR/Traversals.hs +4/−0
• src/Futhark/IR/TypeCheck.hs +3/−0
• src/Futhark/Internalise/Defunctionalise.hs +2/−0
• src/Futhark/Internalise/Exps.hs +3/−0
• src/Futhark/Internalise/FullNormalise.hs +12/−3
• src/Futhark/Internalise/Monomorphise.hs +2/−0
• src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs +1/−0
• src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs +3/−0
• src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +3/−0
• src/Futhark/Test.hs +40/−59
• src/Language/Futhark/FreeVars.hs +1/−0
• src/Language/Futhark/Interpreter.hs +3/−0
• src/Language/Futhark/Parser/Lexer.x +7/−8
• src/Language/Futhark/Parser/Lexer/Tokens.hs +0/−11
• src/Language/Futhark/Parser/Monad.hs +12/−0
• src/Language/Futhark/Parser/Parser.y +2/−2
• src/Language/Futhark/Pretty.hs +4/−1
• src/Language/Futhark/Prop.hs +2/−0
• src/Language/Futhark/Semantic.hs +4/−1
• src/Language/Futhark/Syntax.hs +7/−0
• src/Language/Futhark/Traversals.hs +3/−0
• src/Language/Futhark/TypeChecker/Consumption.hs +1/−0
• src/Language/Futhark/TypeChecker/Modules.hs +17/−4
• src/Language/Futhark/TypeChecker/Names.hs +2/−0
• src/Language/Futhark/TypeChecker/Terms.hs +4/−0

@@ -5,6 +5,24 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.25.18]++### Added++* New prelude function: `rep`, an implicit form of `replicate`.++* Improved handling of large monomorphic single-dimensional array+  literals (#2160).++### Fixed++* `futhark repl` no longer asks for confirmation on EOF.++* Obscure oversight related to abstract size-lifted types (#2120).++* Accidential exponential-time algorithm in layout optimisation for+  multicore backends (#2151).+ ## [0.25.17]  * Faster device-to-device copies on CUDA.

@@ -400,11 +400,13 @@ .. c:function:: int futhark_new_opaque_t(struct futhark_context *ctx, struct futhark_opaque_t **out, const struct futhark_opaque_t2 *bar, const struct futhark_opaque_t1 *foo);     Construct a record in ``*out`` which has the given values for the-   ``bar`` and ``foo`` fields.  The parameters are the-   fields in alphabetic order.  Tuple fields are named ``vX`` where-   ``X`` is an integer.  The resulting record *aliases* the values-   provided for ``bar`` and ``foo``, but has its own lifetime, and all-   values must be individually freed when they are no longer needed.+   ``bar`` and ``foo`` fields. The parameters are the fields in+   alphabetic order. As a special case, if the record is a tuple+   (i.e., has numeric fields), the parameters are ordered numerically.+   Tuple fields are named ``vX`` where ``X`` is an integer. The+   resulting record *aliases* the values provided for ``bar`` and+   ``foo``, but has its own lifetime, and all values must be+   individually freed when they are no longer needed.  .. c:function:: int futhark_project_opaque_t_bar(struct futhark_context *ctx, struct futhark_opaque_t2 **out, const struct futhark_opaque_t *obj); 

@@ -743,6 +743,14 @@ Create an array containing the indicated elements.  Each element must have the same type and shape. +**Large array optimisation**: as a special case, large one-dimensional+array literal consisting *entirely* of monomorphic constants (i.e.,+numbers must have a type suffix) are handled with specialised+fast-path code by the compiler. To keep compile times manageable, make+sure that all very large array literals (more than about ten thousand+elements) are of this form. This is likely relevant only for generated+code.+ .. _range:  ``x..y...z``@@ -1580,6 +1588,10 @@ then returns a module that exposes only the functionality described by the module type.  This is how internal details of a module can be hidden.++As a slightly ad-hoc limitation, ascription is forbidden when a type+substitution of size-lifted types occurs in a size appearing at the+top level.  ``\(p: mt1): mt2 -> e`` .......................

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.25.17+version:        0.25.18 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to

@@ -128,6 +128,16 @@ def replicate 't (n: i64) (x: t): *[n]t =   map (const x) (iota n) +-- | Construct an array of an inferred length containing the given+-- value.+--+-- **Work:** O(n).+--+-- **Span:** O(1).+#[inline]+def rep 't [n] (x: t): *[n]t =+  replicate n x+ -- | Copy a value.  The result will not alias anything. -- -- **Work:** O(n).

@@ -122,6 +122,10 @@    *num_arrays_out = num_arrays; +  if (r==map_r) {+    return false;+  }+   if (memcmp(&rowmajor_strides[map_r],              &dst_strides[map_r],              sizeof(int64_t)*(r-map_r)) == 0) {@@ -193,11 +197,11 @@     fprintf(ctx->log, "Shape: ");     for (int i = 0; i < r; i++) { fprintf(ctx->log, "[%ld]", (long int)shape[i]); }     fprintf(ctx->log, "\n");-    fprintf(ctx->log, "Dst offset: %ld\n", dst_offset);+    fprintf(ctx->log, "Dst offset: %ld\n", (long int)dst_offset);     fprintf(ctx->log, "Dst strides:");     for (int i = 0; i < r; i++) { fprintf(ctx->log, " %ld", (long int)dst_strides[i]); }     fprintf(ctx->log, "\n");-    fprintf(ctx->log, "Src offset: %ld\n", src_offset);+    fprintf(ctx->log, "Src offset: %ld\n", (long int)src_offset);     fprintf(ctx->log, "Src strides:");     for (int i = 0; i < r; i++) { fprintf(ctx->log, " %ld", (long int)src_strides[i]); }     fprintf(ctx->log, "\n");

@@ -703,7 +703,7 @@    if (num_args != r->num_fields) {     failure();-    printf("%d fields expected byt %d values provided.\n", num_args, r->num_fields);+    printf("%d fields expected but %d values provided.\n", num_args, r->num_fields);     return;   } 

@@ -107,6 +107,9 @@     Assert {} ->       void $ commonBasicOp pat aux e m     --+    ArrayVal {} ->+      void $ commonBasicOp pat aux e m+    --     ArrayLit elems _ -> do       (_pat_v, pat_adj) <- commonBasicOp pat aux e m       t <- lookupType pat_adj

@@ -465,6 +465,7 @@   let ctx_val = case expression of         SubExp se -> varInfoFromSubExp se         Opaque _ se -> varInfoFromSubExp se+        ArrayVal _ _ -> (varInfoFromNames ctx mempty) {variableType = ConstType}         ArrayLit ses _t -> concatVariableInfos mempty ses         UnOp _ se -> varInfoFromSubExp se         BinOp _ lsubexp rsubexp -> concatVariableInfos mempty [lsubexp, rsubexp]@@ -497,14 +498,7 @@     varInfoFromSubExp (Var v) =       case M.lookup v (assignments ctx) of         Just _ -> (varInfoFromNames ctx $ oneName v) {variableType = Variable}-        Nothing ->-          error $-            "Failed to lookup variable \""-              ++ prettyString v-              ++ "\npat: "-              ++ prettyString pats-              ++ "\n\nContext\n"-              ++ show ctx+        Nothing -> (varInfoFromNames ctx mempty) {variableType = Variable} -- Means a global.  analyseMatch :: (Analyse rep) => Context rep -> [VName] -> Body rep -> [Body rep] -> (Context rep, IndexTable rep) analyseMatch ctx pats body parents =@@ -628,8 +622,8 @@     | ParOp Nothing seq_segop <- mc_op = analyseSegOp seq_segop     | ParOp (Just segop) seq_segop <- mc_op = \ctx name -> do         let (ctx', res') = analyseSegOp segop ctx name-        let (ctx'', res'') = analyseSegOp seq_segop ctx name-        (ctx' <> ctx'', unionIndexTables res' res'')+        let (ctx'', res'') = analyseSegOp seq_segop ctx' name+        (ctx'', unionIndexTables res' res'')     | Futhark.IR.MC.OtherOp _ <- mc_op = analyseOtherOp  -- Unfortunately we need these instances, even though they may never appear.

@@ -123,6 +123,7 @@ basicOpMetrics :: BasicOp -> MetricsM () basicOpMetrics (SubExp _) = seen "SubExp" basicOpMetrics (Opaque _ _) = seen "Opaque"+basicOpMetrics ArrayVal {} = seen "ArrayVal" basicOpMetrics ArrayLit {} = seen "ArrayLit" basicOpMetrics BinOp {} = seen "BinOp" basicOpMetrics UnOp {} = seen "UnOp"

@@ -416,9 +416,9 @@       pure $         Left           ( "Reference output generation for "-              ++ program-              ++ " failed:\n"-              ++ unlines (map T.unpack err),+              <> program+              <> " failed:\n"+              <> T.unpack err,             Nothing           )     Right () -> do

@@ -1161,7 +1161,7 @@           unwords compile_options      let onError err = do-          mapM_ (T.hPutStrLn stderr) err+          T.hPutStrLn stderr err           exitFailure      void $

@@ -128,7 +128,7 @@         Just (Right (Left e)) -> do           hPrint stderr e           exitWith $ ExitFailure 2-        Just (Right (Right (tokens, _))) ->+        Just (Right (Right tokens)) ->           mapM_ printToken tokens     _ -> Nothing   where

@@ -89,9 +89,7 @@                 toploop s'           Right _ -> pure () -      finish s = do-        quit <- if fancyTerminal then confirmQuit else pure True-        if quit then pure () else toploop s+      finish _s = pure ()    maybe_init_state <- liftIO $ newFutharkiState 0 noLoadedProg maybe_prog   s <- case maybe_init_state of@@ -108,15 +106,6 @@   Haskeline.runInputT Haskeline.defaultSettings $ toploop s    putStrLn "Leaving 'futhark repl'."--confirmQuit :: Haskeline.InputT IO Bool-confirmQuit = do-  c <- Haskeline.getInputChar "Quit REPL? (y/n) "-  case c of-    Nothing -> pure True -- EOF-    Just 'y' -> pure True-    Just 'n' -> pure False-    _ -> confirmQuit  -- | Representation of breaking at a breakpoint, to allow for -- navigating through the stack frames and such.

@@ -37,6 +37,10 @@  --- Test execution +-- The use of [T.Text] here is somewhat kludgy. We use it to track how+-- many errors have occurred during testing of a single program (which+-- may have multiple entry points). This should really not be done at+-- the monadic level - a test failing should be handled explicitly. type TestM = ExceptT [T.Text] IO  -- Taken from transformers-0.5.5.0.@@ -286,7 +290,8 @@         context "Generating reference outputs" $           -- We probably get the concurrency at the test program level,           -- so force just one data set at a time here.-          ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios+          withExceptT pure $+            ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios        when (mode == Structure) $         mapM_ (testMetrics progs program) structures@@ -393,7 +398,9 @@  compileTestProgram :: [String] -> FutharkExe -> String -> FilePath -> [WarningTest] -> TestM () compileTestProgram extra_options futhark backend program warnings = do-  (_, futerr) <- compileProgram ("--server" : extra_options) futhark backend program+  (_, futerr) <-+    withExceptT pure $+      compileProgram ("--server" : extra_options) futhark backend program   testWarnings warnings futerr  compareResult ::

@@ -22,6 +22,7 @@ import Data.Maybe import Data.Text qualified as T import Futhark.CodeGen.Backends.GenericC.Monad+import Futhark.CodeGen.Backends.GenericC.Pretty (expText, idText, typeText) import Futhark.CodeGen.ImpCode import Futhark.IR.Prop (isBuiltInFunction) import Futhark.MonadFreshNames@@ -58,12 +59,6 @@ compilePrimExp f (UnOpExp Not {} x) = do   x' <- compilePrimExp f x   pure [C.cexp|!$exp:x'|]-compilePrimExp f (UnOpExp (FAbs Float32) x) = do-  x' <- compilePrimExp f x-  pure [C.cexp|(float)fabs($exp:x')|]-compilePrimExp f (UnOpExp (FAbs Float64) x) = do-  x' <- compilePrimExp f x-  pure [C.cexp|fabs($exp:x')|] compilePrimExp f (UnOpExp SSignum {} x) = do   x' <- compilePrimExp f x   pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0)|]@@ -366,8 +361,19 @@   let ct = primTypeToCType t   case vs of     ArrayValues vs' -> do-      let vs'' = [[C.cinit|$exp:v|] | v <- vs']-      earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|]+      -- To handle very large literal arrays (which are inefficient+      -- with language-c-quote, see #2160), we do our own formatting and inject it as a string.+      let array_decl =+            "static "+              <> typeText ct+              <> " "+              <> idText (C.toIdent name_realtype mempty)+              <> "["+              <> prettyText (length vs')+              <> "] = { "+              <> T.intercalate "," (map (expText . flip C.toExp mempty) vs')+              <> "};"+      earlyDecl [C.cedecl|$esc:(T.unpack array_decl)|]     ArrayZeros n ->       earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]   -- Fake a memory block.

@@ -444,7 +444,7 @@      in ( ( stateWarnings s',             Imp.Definitions               types-              (stateConstants s' <> foldMap stateConstants ss)+              (foldMap stateConstants ss <> stateConstants s')               (stateFunctions s')           ),           stateNameSource s'@@ -954,17 +954,19 @@         destslice = skip_slices ++ [DimSlice (tvExp offs_glb) rows 1]     copyDWIM (patElemName pe) destslice (Var y) []     offs_glb <-- tvExp offs_glb + rows+defCompileBasicOp (Pat [pe]) (ArrayVal vs t) = do+  dest_mem <- entryArrayLoc <$> lookupArray (patElemName pe)+  static_array <- newVNameForFun "static_array"+  emit $ Imp.DeclareArray static_array t $ Imp.ArrayValues vs+  let static_src =+        MemLoc static_array [intConst Int64 $ fromIntegral $ length vs] $+          LMAD.iota 0 [fromIntegral $ length vs]+  addVar static_array $ MemVar Nothing $ MemEntry DefaultSpace+  copy t dest_mem static_src defCompileBasicOp (Pat [pe]) (ArrayLit es _)   | Just vs@(v : _) <- mapM isLiteral es = do-      dest_mem <- entryArrayLoc <$> lookupArray (patElemName pe)       let t = primValueType v-      static_array <- newVNameForFun "static_array"-      emit $ Imp.DeclareArray static_array t $ Imp.ArrayValues vs-      let static_src =-            MemLoc static_array [intConst Int64 $ fromIntegral $ length es] $-              LMAD.iota 0 [fromIntegral $ length es]-      addVar static_array $ MemVar Nothing $ MemEntry DefaultSpace-      copy t dest_mem static_src+      defCompileBasicOp (Pat [pe]) (ArrayVal vs t)   | otherwise =       forM_ (zip [0 ..] es) $ \(i, e) ->         copyDWIMFix (patElemName pe) [fromInteger i] e []

@@ -314,6 +314,10 @@           <*> pFlatSlice           <* lexeme "="           <*> pVName,+      try $+        ArrayVal+          <$> brackets (pPrimValue `sepBy` pComma)+          <*> (lexeme ":" *> "[]" *> pPrimType),       ArrayLit         <$> brackets (pSubExp `sepBy` pComma)         <*> (lexeme ":" *> "[]" *> pType),

@@ -198,6 +198,11 @@       <+> colon       <+> "[]"       <> pretty rt+  pretty (ArrayVal vs t) =+    brackets (commasep $ map pretty vs)+      <+> colon+      <+> "[]"+      <> pretty t   pretty (BinOp bop x y) = pretty bop <> parens (pretty x <> comma <+> pretty y)   pretty (CmpOp op x y) = pretty op <> parens (pretty x <> comma <+> pretty y)   pretty (ConvOp conv x) =

@@ -57,6 +57,7 @@ basicOpAliases :: BasicOp -> [Names] basicOpAliases (SubExp se) = [subExpAliases se] basicOpAliases (Opaque _ se) = [subExpAliases se]+basicOpAliases (ArrayVal _ _) = [mempty] basicOpAliases (ArrayLit _ _) = [mempty] basicOpAliases BinOp {} = [mempty] basicOpAliases ConvOp {} = [mempty]

@@ -63,6 +63,10 @@   pure <$> subExpType se basicOpType (Opaque _ se) =   pure <$> subExpType se+basicOpType (ArrayVal vs t) =+  pure [arrayOf (Prim t) (Shape [n]) NoUniqueness]+  where+    n = intConst Int64 $ toInteger $ length vs basicOpType (ArrayLit es rt) =   pure [arrayOf rt (Shape [n]) NoUniqueness]   where

@@ -328,6 +328,13 @@   | -- | Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@.     -- Second arg is the element type of the rows of the array.     ArrayLit [SubExp] Type+  | -- | A one-dimensional array literal that contains only constants.+    -- This is a fast-path for representing very large array literals+    -- that show up in some programs. The key rule for processing this+    -- in compiler passes is that you should never need to look at the+    -- individual elements. Has exactly the same semantics as an+    -- 'ArrayLit'.+    ArrayVal [PrimValue] PrimType   | -- | Unary operation.     UnOp UnOp SubExp   | -- | Binary operation.

@@ -89,6 +89,8 @@   m (Exp trep) mapExpM tv (BasicOp (SubExp se)) =   BasicOp <$> (SubExp <$> mapOnSubExp tv se)+mapExpM _ (BasicOp (ArrayVal vs t)) =+  pure $ BasicOp $ ArrayVal vs t mapExpM tv (BasicOp (ArrayLit els rowt)) =   BasicOp     <$> ( ArrayLit@@ -279,6 +281,8 @@ walkExpM :: (Monad m) => Walker rep m -> Exp rep -> m () walkExpM tv (BasicOp (SubExp se)) =   walkOnSubExp tv se+walkExpM _ (BasicOp ArrayVal {}) =+  pure () walkExpM tv (BasicOp (ArrayLit els rowt)) =   mapM_ (walkOnSubExp tv) els >> walkOnType tv rowt walkExpM tv (BasicOp (BinOp _ x y)) =

@@ -837,6 +837,9 @@   void $ checkSubExp es checkBasicOp (Opaque _ es) =   void $ checkSubExp es+checkBasicOp ArrayVal {} =+  -- We assume this is never changed, so no need to check it.+  pure () checkBasicOp (ArrayLit [] _) =   pure () checkBasicOp (ArrayLit (e : es') t) = do

@@ -507,6 +507,8 @@         _ ->           let tp = Info $ structTypeFromSV sv            in pure (RecordFieldImplicit vn tp loc', (baseName vn, sv))+defuncExp e@(ArrayVal vs t loc) =+  pure (ArrayVal vs t loc, Dynamic $ toParam Observe $ typeOf e) defuncExp (ArrayLit es t@(Info t') loc) = do   es' <- mapM defuncExp' es   pure (ArrayLit es' t loc, Dynamic $ toParam Observe t')

@@ -628,6 +628,9 @@           (baseName name)           (E.Var (E.qualName name) t loc)           loc+internaliseExp desc (E.ArrayVal vs t _) =+  fmap pure . letSubExp desc . I.BasicOp $+    I.ArrayVal (map internalisePrimValue vs) (internalisePrimType t) internaliseExp desc (E.ArrayLit es (Info arr_t) loc)   -- If this is a multidimensional array literal of primitives, we   -- treat it specially by flattening it out followed by a reshape.

@@ -172,9 +172,18 @@       pure $ RecordFieldExplicit n e' floc     f (RecordFieldImplicit v t _) =       f $ RecordFieldExplicit (baseName v) (Var (qualName v) t loc) loc-getOrdering _ (ArrayLit es ty loc) = do-  es' <- mapM (getOrdering False) es-  pure $ ArrayLit es' ty loc+getOrdering _ (ArrayVal vs t loc) =+  pure $ ArrayVal vs t loc+getOrdering _ (ArrayLit es ty loc)+  | Just vs <- mapM isLiteral es,+    Info (Array _ (Shape [_]) (Prim t)) <- ty =+      pure $ ArrayVal vs t loc+  | otherwise = do+      es' <- mapM (getOrdering False) es+      pure $ ArrayLit es' ty loc+  where+    isLiteral (Literal v _) = Just v+    isLiteral _ = Nothing getOrdering _ (Project n e ty loc) = do   e' <- getOrdering False e   pure $ Project n e' ty loc

@@ -638,6 +638,8 @@           (baseName v)           (Var (qualName v) t' loc)           loc+transformExp (ArrayVal vs t loc) =+  pure $ ArrayVal vs t loc transformExp (ArrayLit es t loc) =   ArrayLit <$> mapM transformExp es <*> traverse transformType t <*> pure loc transformExp (AppExp e res) =

@@ -336,6 +336,7 @@ createsNewArrOK (BasicOp Manifest {}) = True createsNewArrOK (BasicOp Concat {}) = True createsNewArrOK (BasicOp ArrayLit {}) = True+createsNewArrOK (BasicOp ArrayVal {}) = True createsNewArrOK (BasicOp Scratch {}) = True createsNewArrOK _ = False 

@@ -93,6 +93,9 @@     isFix _ = False getUseSumFromStm _ _ (Let Pat {} _ (BasicOp Index {})) = Just ([], []) -- incomplete slices getUseSumFromStm _ _ (Let Pat {} _ (BasicOp FlatIndex {})) = Just ([], []) -- incomplete slices+getUseSumFromStm td_env coal_tab (Let (Pat pes) _ (BasicOp ArrayVal {})) =+  let wrts = mapMaybe (getDirAliasedIxfn td_env coal_tab . patElemName) pes+   in Just (wrts, wrts) getUseSumFromStm td_env coal_tab (Let (Pat pes) _ (BasicOp (ArrayLit ses _))) =   let rds = mapMaybe (getDirAliasedIxfn td_env coal_tab) $ mapMaybe seName ses       wrts = mapMaybe (getDirAliasedIxfn td_env coal_tab . patElemName) pes

@@ -482,6 +482,9 @@       -- Whether the rows are primitive constants or arrays, without any scalar       -- variable operands such ArrayLit cannot directly prevent a scalar read.       graphHostOnly e+    BasicOp ArrayVal {} ->+      -- As above.+      graphHostOnly e     BasicOp Update {} ->       graphHostOnly e     BasicOp Concat {} ->

@@ -13,7 +13,6 @@     testRunReferenceOutput,     getExpectedResult,     compileProgram,-    runProgram,     readResults,     ensureReferenceOutput,     determineTuning,@@ -31,7 +30,7 @@ import Control.Exception (catch) import Control.Exception.Base qualified as E import Control.Monad-import Control.Monad.Except (MonadError (..))+import Control.Monad.Except (MonadError (..), runExceptT) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Binary qualified as Bin import Data.ByteString qualified as SBS@@ -344,7 +343,7 @@ -- returns stdout and stderr of the compiler.  Throws an IO exception -- containing stderr if compilation fails. compileProgram ::-  (MonadIO m, MonadError [T.Text] m) =>+  (MonadIO m, MonadError T.Text m) =>   [String] ->   FutharkExe ->   String ->@@ -353,8 +352,8 @@ compileProgram extra_options (FutharkExe futhark) backend program = do   (futcode, stdout, stderr) <- liftIO $ readProcessWithExitCode futhark (backend : options) ""   case futcode of-    ExitFailure 127 -> throwError [progNotFound $ T.pack futhark]-    ExitFailure _ -> throwError [T.decodeUtf8 stderr]+    ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+    ExitFailure _ -> throwError $ T.decodeUtf8 stderr     ExitSuccess -> pure ()   pure (stdout, stderr)   where@@ -362,35 +361,6 @@     options = [program, "-o", binOutputf] ++ extra_options     progNotFound s = s <> ": command not found" --- | @runProgram futhark runner extra_options prog entry input@ runs the--- Futhark program @prog@ (which must have the @.fut@ suffix),--- executing the @entry@ entry point and providing @input@ on stdin.--- The program must have been compiled in advance with--- 'compileProgram'.  If @runner@ is non-null, then it is used as--- "interpreter" for the compiled program (e.g. @python@ when using--- the Python backends).  The @extra_options@ are passed to the--- program.-runProgram ::-  FutharkExe ->-  FilePath ->-  [String] ->-  String ->-  T.Text ->-  Values ->-  IO (ExitCode, SBS.ByteString, SBS.ByteString)-runProgram futhark runner extra_options prog entry input = do-  let progbin = binaryName prog-      dir = takeDirectory prog-      binpath = "." </> progbin-      entry_options = ["-e", T.unpack entry]--      (to_run, to_run_args)-        | null runner = (binpath, entry_options ++ extra_options)-        | otherwise = (runner, binpath : entry_options ++ extra_options)--  input' <- getValuesBS futhark dir input-  liftIO $ readProcessWithExitCode to_run to_run_args $ BS.toStrict input'- -- | Read the given variables from a running server. readResults ::   (MonadIO m, MonadError T.Text m) =>@@ -400,11 +370,33 @@ readResults server =   mapM (either throwError pure <=< liftIO . getValue server) +-- | Call an entry point. Returns server variables storing the result.+callEntry ::+  (MonadIO m, MonadError T.Text m) =>+  FutharkExe ->+  Server ->+  FilePath ->+  EntryName ->+  Values ->+  m [VarName]+callEntry futhark server prog entry input = do+  output_types <- cmdEither $ cmdOutputs server entry+  input_types <- cmdEither $ cmdInputs server entry+  let outs = ["out" <> showText i | i <- [0 .. length output_types - 1]]+      ins = ["in" <> showText i | i <- [0 .. length input_types - 1]]+      ins_and_types = zip ins (map inputType input_types)+  valuesAsVars server ins_and_types futhark dir input+  _ <- cmdEither $ cmdCall server entry outs ins+  cmdMaybe $ cmdFree server ins+  pure outs+  where+    dir = takeDirectory prog+ -- | Ensure that any reference output files exist, or create them (by -- compiling the program with the reference compiler and running it on -- the input) if necessary. ensureReferenceOutput ::-  (MonadIO m, MonadError [T.Text] m) =>+  (MonadIO m, MonadError T.Text m) =>   Maybe Int ->   FutharkExe ->   String ->@@ -415,31 +407,20 @@   missing <- filterM isReferenceMissing $ concatMap entryAndRuns ios    unless (null missing) $ do-    void $ compileProgram [] futhark compiler prog--    res <- liftIO . flip (pmapIO concurrency) missing $ \(entry, tr) -> do-      (code, stdout, stderr) <- runProgram futhark "" ["-b"] prog entry $ runInput tr-      case code of-        ExitFailure e ->-          pure $-            Left-              [ T.pack $-                  "Reference dataset generation failed with exit code "-                    ++ show e-                    ++ " and stderr:\n"-                    ++ map (chr . fromIntegral) (SBS.unpack stderr)-              ]-        ExitSuccess -> do-          let f = file (entry, tr)-          liftIO $ createDirectoryIfMissing True $ takeDirectory f-          SBS.writeFile f stdout-          pure $ Right ()+    void $ compileProgram ["--server"] futhark compiler prog -    case sequence_ res of-      Left err -> throwError err-      Right () -> pure ()+    res <- liftIO . flip (pmapIO concurrency) missing $ \(entry, tr) ->+      withServer server_cfg $ \server -> runExceptT $ do+        outs <- callEntry futhark server prog entry $ runInput tr+        let f = file entry tr+        liftIO $ createDirectoryIfMissing True $ takeDirectory f+        cmdMaybe $ cmdStore server f outs+        cmdMaybe $ cmdFree server outs+    either throwError (const (pure ())) (sequence_ res)   where-    file (entry, tr) =+    server_cfg = futharkServerCfg (dropExtension prog) []++    file entry tr =       takeDirectory prog </> testRunReferenceOutput prog entry tr      entryAndRuns (InputOutputs entry rts) = map (entry,) rts@@ -447,7 +428,7 @@     isReferenceMissing (entry, tr)       | Succeeds (Just SuccessGenerateValues) <- runExpectedResult tr =           liftIO $-            ((<) <$> getModificationTime (file (entry, tr)) <*> getModificationTime prog)+            ((<) <$> getModificationTime (file entry tr) <*> getModificationTime prog)               `catch` (\e -> if isDoesNotExistError e then pure True else E.throw e)       | otherwise =           pure False

@@ -54,6 +54,7 @@     where       freeInExpField (RecordFieldExplicit _ e _) = freeInExp e       freeInExpField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty+  ArrayVal {} -> mempty   ArrayLit es t _ ->     foldMap freeInExp es <> freeInType (unInfo t)   AppExp (Range e me incl _) _ ->

@@ -966,6 +966,9 @@   v' <- eval env v   vs' <- mapM (eval env) vs   pure $ toArray' (valueShape v') (v' : vs')+eval _ (ArrayVal vs _ _) =+  -- Probably will not ever be used.+  pure $ toArray' ShapeLeaf $ map ValuePrim vs eval env (AppExp e (Info (AppRes t retext))) = do   let t' = expandType env $ toStruct t   v <- evalAppExp env e

@@ -196,20 +196,19 @@       let x = action (BS.take (n'-n) s)       x `seq` Right (state', (pos, pos', x)) -scanTokens :: Pos -> BS.ByteString -> Either LexerError ([L Token], Pos)-scanTokens pos str = loop $ initialLexerState pos str+scanTokens :: Pos -> BS.ByteString -> Either LexerError [L Token]+scanTokens pos str = fmap reverse $ loop [] $ initialLexerState pos str   where-   loop s = do+   loop toks s = do      (s', tok) <- getToken s      case tok of        (start, end, EOF) ->-         pure ([], end)-       (start, end, t) -> do-         (rest, endpos) <- loop s'-         pure (L (Loc start end) t : rest, endpos)+         pure toks+       (start, end, t) ->+         loop (L (Loc start end) t:toks) s'  -- | Given a starting position, produce tokens from the given text (or -- a lexer error).  Returns the final position.-scanTokensText :: Pos -> T.Text -> Either LexerError ([L Token], Pos)+scanTokensText :: Pos -> T.Text -> Either LexerError [L Token] scanTokensText pos = scanTokens pos . BS.fromStrict . T.encodeUtf8 }

@@ -16,16 +16,13 @@     binToken,     hexToken,     romToken,-    advance,     readHexRealLit,   ) where  import Data.ByteString.Lazy qualified as BS-import Data.Char (ord) import Data.Either import Data.List (find)-import Data.Loc (Pos (..)) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Read qualified as T@@ -191,14 +188,6 @@ {-# INLINE tokenS #-} tokenS :: (T.Text -> a) -> BS.ByteString -> a tokenS f = f . T.decodeUtf8 . BS.toStrict--advance :: Pos -> BS.ByteString -> Pos-advance orig_pos = BS.foldl' advance' orig_pos . BS.init-  where-    advance' (Pos f !line !col !addr) c-      | c == nl = Pos f (line + 1) 1 (addr + 1)-      | otherwise = Pos f line (col + 1) (addr + 1)-    nl = fromIntegral $ ord '\n'  symbol :: [Name] -> Name -> Token symbol [] q

@@ -17,6 +17,7 @@     mustBe,     primNegate,     applyExp,+    arrayLitExp,     patternExp,     addDocSpec,     addAttrSpec,@@ -110,6 +111,17 @@  arrayFromList :: [a] -> Array Int a arrayFromList l = listArray (0, length l - 1) l++arrayLitExp :: [UncheckedExp] -> SrcLoc -> UncheckedExp+arrayLitExp es loc+  | Just (v : vs) <- mapM isLiteral es,+    all ((primValueType v ==) . primValueType) vs =+      ArrayVal (v : vs) (primValueType v) loc+  | otherwise =+      ArrayLit es NoInfo loc+  where+    isLiteral (Literal v _) = Just v+    isLiteral _ = Nothing  applyExp :: NE.NonEmpty UncheckedExp -> ParserMonad UncheckedExp applyExp all_es@((Constr n [] _ loc1) NE.:| es) =

@@ -605,8 +605,8 @@      | '(' Exp ')'            { Parens $2 (srcspan $1 $>) }      | '(' Exp ',' Exps1 ')'  { TupLit ($2 : $4) (srcspan $1 $>) }      | '('      ')'           { TupLit [] (srcspan $1 $>) }-     | '[' Exps1 ']'          { ArrayLit $2 NoInfo (srcspan $1 $>) }-     | '['       ']'          { ArrayLit [] NoInfo (srcspan $1 $>) }+     | '[' Exps1 ']'          { arrayLitExp $2 (srcspan $1 $>) }+     | '['       ']'          { arrayLitExp [] (srcspan $1 $>) }       | id { let L loc (ID v)  = $1 in Var (QualName [] v) NoInfo (srclocOf loc) } 

@@ -353,6 +353,8 @@   where     fieldArray (RecordFieldExplicit _ e _) = hasArrayLit e     fieldArray RecordFieldImplicit {} = False+prettyExp _ (ArrayVal vs _ _) =+  brackets (commasep $ map pretty vs) prettyExp _ (ArrayLit es t _) =   brackets (commasep $ map pretty es) <> prettyInst t prettyExp _ (StringLit s _) =@@ -631,4 +633,5 @@     precedence Backtick = 9     rprecedence Minus = 10     rprecedence Divide = 10-    rprecedence op = precedence op+    rprecedence PipeLeft = -1+    rprecedence op = precedence op + 1

@@ -463,6 +463,8 @@     record (RecordFieldExplicit name e _) = (name, typeOf e)     record (RecordFieldImplicit name (Info t) _) = (baseName name, t) typeOf (ArrayLit _ (Info t) _) = t+typeOf (ArrayVal vs t loc) =+  Array mempty (Shape [sizeFromInteger (genericLength vs) loc]) (Prim t) typeOf (StringLit vs loc) =   Array     mempty

@@ -125,7 +125,10 @@ -- return type.  The type parameters are in scope in both parameter -- types and the return type.  Non-functional values have only a -- return type.-data BoundV = BoundV [TypeParam] StructType+data BoundV = BoundV+  { boundValTParams :: [TypeParam],+    boundValType :: StructType+  }   deriving (Show)  -- | A mapping from names (which always exist in some namespace) to a

@@ -806,6 +806,12 @@   | -- | Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@.     -- Second arg is the row type of the rows of the array.     ArrayLit [ExpBase f vn] (f StructType) SrcLoc+  | -- | Array value constants, where the elements are known to be+    -- constant primitives. This is a fast-path variant of 'ArrayLit'+    -- that will never be constructed by the parser, but may result+    -- from normalisation later on. Has exactly the same semantics as+    -- an 'ArrayLit'.+    ArrayVal [PrimValue] PrimType SrcLoc   | -- | An attribute applied to the following expression.     Attr (AttrInfo vn) (ExpBase f vn) SrcLoc   | Project Name (ExpBase f vn) (f StructType) SrcLoc@@ -877,6 +883,7 @@   locOf (RecordLit _ pos) = locOf pos   locOf (Project _ _ _ pos) = locOf pos   locOf (ArrayLit _ _ pos) = locOf pos+  locOf (ArrayVal _ _ loc) = locOf loc   locOf (StringLit _ loc) = locOf loc   locOf (Var _ _ loc) = locOf loc   locOf (Ascript _ _ loc) = locOf loc

@@ -146,6 +146,8 @@     TupLit <$> mapM (mapOnExp tv) els <*> pure loc   astMap tv (RecordLit fields loc) =     RecordLit <$> astMap tv fields <*> pure loc+  astMap _ (ArrayVal vs t loc) =+    pure $ ArrayVal vs t loc   astMap tv (ArrayLit els t loc) =     ArrayLit <$> mapM (mapOnExp tv) els <*> traverse (mapOnStructType tv) t <*> pure loc   astMap tv (Ascript e tdecl loc) =@@ -456,6 +458,7 @@ bareExp (TupLit els loc) = TupLit (map bareExp els) loc bareExp (StringLit vs loc) = StringLit vs loc bareExp (RecordLit fields loc) = RecordLit (map bareField fields) loc+bareExp (ArrayVal vs t loc) = ArrayVal vs t loc bareExp (ArrayLit els _ loc) = ArrayLit (map bareExp els) NoInfo loc bareExp (Ascript e te loc) = Ascript (bareExp e) (bareTypeExp te) loc bareExp (Coerce e te _ loc) = Coerce (bareExp e) (bareTypeExp te) NoInfo loc

@@ -954,6 +954,7 @@ checkExp e@FloatLit {} = noAliases e checkExp e@Literal {} = noAliases e checkExp e@StringLit {} = noAliases e+checkExp e@ArrayVal {} = noAliases e checkExp e@ArrayLit {} = noAliases e checkExp e@Negate {} = noAliases e checkExp e@Not {} = noAliases e

@@ -34,7 +34,7 @@ substituteTypesInEnv :: TypeSubs -> Env -> Env substituteTypesInEnv substs env =   env-    { envVtable = M.map (substituteTypesInBoundV substs) $ envVtable env,+    { envVtable = M.map (snd . substituteTypesInBoundV substs) $ envVtable env,       envTypeTable = M.mapWithKey subT $ envTypeTable env,       envModTable = M.map (substituteTypesInMod substs) $ envModTable env     }@@ -44,10 +44,14 @@     subT _ (TypeAbbr l ps (RetType dims t)) =       TypeAbbr l ps $ applySubst substs $ RetType dims t -substituteTypesInBoundV :: TypeSubs -> BoundV -> BoundV+-- Also returns names of new sizes arising from substituting a+-- size-lifted type at the outermost part of the type. This is a+-- somewhat rare case (see #2120). The right solution is to generally+-- fresh (or at least unique) names.+substituteTypesInBoundV :: TypeSubs -> BoundV -> ([VName], BoundV) substituteTypesInBoundV substs (BoundV tps t) =   let RetType dims t' = applySubst substs $ RetType [] t-   in BoundV (tps ++ map (`TypeParamDim` mempty) dims) t'+   in (dims, BoundV (tps <> map (`TypeParamDim` mempty) dims) t')  -- | All names defined anywhere in the 'Env'. allNamesInEnv :: Env -> S.Set VName@@ -346,6 +350,11 @@   Left . TypeError loc mempty $     "Module does not define a value named" <+> pretty name <> "." +topLevelSize :: Loc -> VName -> Either TypeError b+topLevelSize loc name =+  Left . TypeError loc mempty $+    "Type substitution in" <+> dquotes (prettyName name) <+> "results in a top-level size."+ missingMod :: (Pretty a) => Loc -> a -> Either TypeError b missingMod loc name =   Left . TypeError loc mempty $@@ -499,7 +508,11 @@       -- abstract types first.       val_substs <- fmap M.fromList $         forM (M.toList $ envVtable sig) $ \(name, spec_bv) -> do-          let spec_bv' = substituteTypesInBoundV (`M.lookup` abs_subst_to_type) spec_bv+          let (spec_dims, spec_bv') =+                substituteTypesInBoundV (`M.lookup` abs_subst_to_type) spec_bv+              (spec_witnesses, _) = determineSizeWitnesses $ boundValType spec_bv'+          -- The hacky check for #2120.+          when (any (`S.member` spec_witnesses) spec_dims) $ topLevelSize loc name           case findBinding envVtable Term (baseName name) env of             Just (name', bv) -> matchVal loc quals name spec_bv' name' bv             _ -> missingVal loc (baseName name)

@@ -245,6 +245,8 @@   Attr <$> resolveAttrInfo attr <*> resolveExp e <*> pure loc resolveExp (TupLit es loc) =   TupLit <$> mapM resolveExp es <*> pure loc+resolveExp (ArrayVal vs t loc) =+  pure $ ArrayVal vs t loc resolveExp (ArrayLit es NoInfo loc) =   ArrayLit <$> mapM resolveExp es <*> pure NoInfo <*> pure loc resolveExp (Negate e loc) =

@@ -389,6 +389,10 @@               <+> pretty (locStrRel rloc sloc)               <> "."         Nothing -> pure ()+-- No need to type check this, as these are only produced by the+-- parser if the elements are monomorphic and all match.+checkExp (ArrayVal vs t loc) =+  pure $ ArrayVal vs t loc checkExp (ArrayLit all_es _ loc) =   -- Construct the result type and unify all elements with it.  We   -- only create a type variable for empty arrays; otherwise we use