futhark 0.25.7 → 0.25.8

raw patch · 18 files changed

+284/−130 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/error-index.rst +25/−0
• docs/glossary.rst +20/−0
• docs/man/futhark-literate.rst +3/−0
• docs/man/futhark-profile.rst +12/−0
• docs/man/futhark-test.rst +4/−4
• futhark.cabal +1/−1
• src/Futhark/Analysis/DataDependencies.hs +12/−2
• src/Futhark/Bench.hs +1/−1
• src/Futhark/CLI/Literate.hs +4/−4
• src/Futhark/CLI/Profile.hs +85/−30
• src/Futhark/IR/SOACS/SOAC.hs +6/−5
• src/Futhark/IR/SegOp.hs +1/−2
• src/Futhark/Internalise/Monad.hs +9/−2
• src/Futhark/Profile.hs +8/−3
• src/Futhark/Script.hs +23/−9
• src/Language/Futhark/Parser/Parser.y +44/−63
• src/Language/Futhark/TypeChecker/Match.hs +4/−4
• src/Language/Futhark/TypeChecker/Terms.hs +22/−0

@@ -841,6 +841,31 @@  :ref:`See here <assert>` for details on how to use ``assert``. +.. _refutable-pattern:++"Refutable pattern not allowed here"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This occurs when you try to use a :term:`refutable pattern` in a+``let`` binding or function parameter. A refutable pattern is a+pattern that is not guaranteed to match a well-typed value. For+example, this expression tries to bind an arbitrary tuple value ``x``+a pattern that requires the first element is ``2``:++.. code-block:: futhark++   let (2, y) = x in 0++What should happen at run-time if ``x`` is not 2? Refutable patterns+are only allowed in ``match`` expressions, where the failure to match+can be handled.  For example:++.. code-block:: futhark++   match x+   case (2, y) ->  0+   case _ -> ... -- do something else+ .. _record-type-not-known:  "Full type of *x* is not known at this point"

@@ -159,6 +159,12 @@       Not :term:`variant`. +   Irrefutable pattern++     A :term:`pattern` that will always match a value of its type. For+     example, ``(x,y)`` is a pattern that will match any tuple. See+     also :term:`refutable pattern`.+    Irregular       Something that is not regular.  Usually used as shorthand for@@ -290,10 +296,24 @@      fully exploit the parallelism of the program, although      :term:`nested data parallelism` muddles the picture. +   Pattern++     A syntactical construct for decomposing a value into its+     consituent parts. Patterns are used in function parameters,+     ``let``-bindings, and ``match``. See :ref:`patterns`.+    Recursion       A function that calls itself.  Currently not supported in      Futhark.++   Refutable pattern++     A :term:`pattern` that does does not match all possible values.+     For example, the pattern ``(1,x)`` matches only tuples where the+     first element is ``1``. These may not be used in ``let``+     expressions or in function parameters. See also+     :term:`irrefutable pattern`.     Regular nested data parallelism 

@@ -270,6 +270,9 @@   of values is returned, which should be destructured before use. For example:   ``let (a, b) = $loaddata "foo.in" in bar a b``. +* ``$loadbytes "file"`` reads the contents of the given file as an+  array of type ``[]u8``.+ * ``$loadaudio "file"`` reads audio from the given file and returns it as a   ``[][]f64``, where each row corresponds to a channel of the original   soundfile. Most common audio-formats are supported, including mp3, ogg, wav,

@@ -53,6 +53,10 @@   the GPU backends, the cost centres are kernel executions and memory   copies. +* ``foo.timeline``: a list of all recorded profiling events, in the+  order in which they occurred, along with their runtime and other+  available information+ Technicalities -------------- @@ -62,6 +66,14 @@ runtime measurement reported by ``futhark bench``.  However, enabling profiling may still affect performance, as it changes the behaviour of the run time system.++Raw reports+-----------++Alternatively, the JSON can also contain a raw profiling report as+produced by the C API function ``futhark_context_report()``. A+directory is still created, but it will only contain a single set of+files, and it will not contain a log.  EXAMPLES ========

@@ -62,10 +62,10 @@ If ``input`` is preceded by ``script``, the text between the curly braces is interpreted as a FutharkScript expression (see :ref:`futhark-literate(1)`), which is executed to generate the input.-It must use only functions explicitly declared as entry points.  If-the expression produces an *n*-element tuple, it will be unpacked and-its components passed as *n* distinct arguments to the test function.-The only builtin function supported is ``$loaddata``.+It must use only functions explicitly declared as entry points. If the+expression produces an *n*-element tuple, it will be unpacked and its+components passed as *n* distinct arguments to the test function. The+only builtin functions supported are ``$loaddata`` and ``$loadbytes``.  If ``input`` is followed by an ``@`` and a file name (which must not contain any whitespace) instead of curly braces, values will be read

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

@@ -50,8 +50,18 @@     grow deps (Let pat _ (Op op)) =       let op_deps = map (depsOfNames deps) (opDependencies op)           pat_deps = map (depsOfNames deps . freeIn) (patElems pat)-       in M.fromList (zip (patNames pat) $ zipWith (<>) pat_deps op_deps)-            `M.union` deps+       in if length op_deps /= length pat_deps+            then+              error . unlines $+                [ "dataDependencies':",+                  "Pattern size: " <> show (length pat_deps),+                  "Op deps size: " <> show (length op_deps),+                  "Expression:",+                  prettyString op+                ]+            else+              M.fromList (zip (patNames pat) $ zipWith (<>) pat_deps op_deps)+                `M.union` deps     grow deps (Let pat _ (Match c cases defbody _)) =       let cases_deps = map (dataDependencies' deps . caseBody) cases           defbody_deps = dataDependencies' deps defbody

@@ -367,7 +367,7 @@    report' <-     maybe (throwError "Program produced invalid profiling report.") pure $-      profilingInfoFromText (T.unlines report)+      profilingReportFromText (T.unlines report)    maybe_expected <-     liftIO $ maybe (pure Nothing) (fmap Just . getExpectedValues) expected_spec

@@ -329,7 +329,7 @@   when (col /= pos1) empty  afterExp :: Parser ()-afterExp = choice [atStartOfLine, void eol]+afterExp = choice [atStartOfLine, choice [void eol, eof]]  withParsedSource :: Parser a -> (a -> T.Text -> b) -> Parser b withParsedSource p f = do@@ -369,12 +369,12 @@             $> DirectiveImg             <*> parseExp postlexeme             <*> parseImgParams-            <* eol,+            <* choice [void eol, eof],           directiveName "plot2d"             $> DirectivePlot             <*> parseExp postlexeme             <*> parsePlotParams-            <* eol,+            <* choice [void eol, eof],           directiveName "gnuplot"             $> DirectiveGnuplot             <*> parseExp postlexeme@@ -388,7 +388,7 @@             $> DirectiveAudio             <*> parseExp postlexeme             <*> parseAudioParams-            <* eol+            <* choice [void eol, eof]         ]     directiveName s = try $ token (":" <> s) 

@@ -2,6 +2,7 @@  import Control.Exception (catch) import Data.ByteString.Lazy.Char8 qualified as BS+import Data.List qualified as L import Data.Map qualified as M import Data.Text qualified as T import Data.Text.IO qualified as T@@ -9,6 +10,7 @@ import Futhark.Util (showText) import Futhark.Util.Options import System.Directory (createDirectoryIfMissing, removePathForcibly)+import System.Exit import System.FilePath import System.IO import Text.Printf@@ -35,11 +37,19 @@ padLeft :: Int -> T.Text -> T.Text padLeft k s = T.replicate (k - T.length s) " " <> s +data EvSummary = EvSummary+  { evCount :: Integer,+    evSum :: Double,+    evMin :: Double,+    evMax :: Double+  }+ tabulateEvents :: [ProfilingEvent] -> T.Text tabulateEvents = mkRows . M.toList . M.fromListWith comb . map pair   where-    pair (ProfilingEvent name dur _) = (name, (1, dur))-    comb (xn, xdur) (yn, ydur) = (xn + yn, xdur + ydur)+    pair (ProfilingEvent name dur _) = (name, EvSummary 1 dur dur dur)+    comb (EvSummary xn xdur xmin xmax) (EvSummary yn ydur ymin ymax) =+      EvSummary (xn + yn) (xdur + ydur) (min xmin ymin) (max xmax ymax)     numpad = 15     mkRows rows =       let longest = foldl max numpad $ map (T.length . fst) rows@@ -47,9 +57,9 @@           splitter = T.map (const '-') header           bottom =             T.unwords-              [ showText (sum (map (fst . snd) rows)),-                "events with a total runtime of ",-                T.pack $ printf "%.2fμs" $ sum $ map (snd . snd) rows+              [ showText (sum (map (evCount . snd) rows)),+                "events with a total runtime of",+                T.pack $ printf "%.2fμs" $ sum $ map (evSum . snd) rows               ]        in T.unlines $             header@@ -60,23 +70,63 @@       T.unwords         [ padLeft longest "Cost centre",           padLeft numpad "count",-          padLeft numpad "total",-          padLeft numpad "mean"+          padLeft numpad "sum",+          padLeft numpad "avg",+          padLeft numpad "min",+          padLeft numpad "max"         ]-    mkRow longest (name, (n, dur)) =+    mkRow longest (name, ev) =       T.unwords         [ padRight longest name,-          padLeft numpad (showText n),-          padLeft numpad $ T.pack $ printf "%.2fμs" dur,-          padLeft numpad $ T.pack $ printf "%.2fμs" $ dur / fromInteger n+          padLeft numpad (showText (evCount ev)),+          padLeft numpad $ T.pack $ printf "%.2fμs" (evSum ev),+          padLeft numpad $ T.pack $ printf "%.2fμs" $ evSum ev / fromInteger (evCount ev),+          padLeft numpad $ T.pack $ printf "%.2fμs" (evMin ev),+          padLeft numpad $ T.pack $ printf "%.2fμs" (evMax ev)         ] -analyseProfileReport :: FilePath -> [BenchResult] -> IO ()-analyseProfileReport json_path bench_results = do+timeline :: [ProfilingEvent] -> T.Text+timeline = T.unlines . L.intercalate [""] . map onEvent+  where+    onEvent (ProfilingEvent name duration description) =+      [name, "Duration: " <> showText duration <> " μs"] <> T.lines description++data TargetFiles = TargetFiles+  { summaryFile :: FilePath,+    timelineFile :: FilePath+  }++writeAnalysis :: TargetFiles -> ProfilingReport -> IO ()+writeAnalysis tf r = do+  T.writeFile (summaryFile tf) $+    memoryReport (profilingMemory r)+      <> "\n\n"+      <> tabulateEvents (profilingEvents r)+  T.writeFile (timelineFile tf) $+    timeline (profilingEvents r)++prepareDir :: FilePath -> IO FilePath+prepareDir json_path = do   let top_dir = takeFileName json_path -<.> "prof"   T.hPutStrLn stderr $ "Writing results to " <> T.pack top_dir <> "/"-  T.hPutStrLn stderr $ "Stripping '" <> T.pack prefix <> "' from program paths."   removePathForcibly top_dir+  pure top_dir++analyseProfilingReport :: FilePath -> ProfilingReport -> IO ()+analyseProfilingReport json_path r = do+  top_dir <- prepareDir json_path+  createDirectoryIfMissing True top_dir+  let tf =+        TargetFiles+          { summaryFile = top_dir </> "summary",+            timelineFile = top_dir </> "timeline"+          }+  writeAnalysis tf r++analyseBenchResults :: FilePath -> [BenchResult] -> IO ()+analyseBenchResults json_path bench_results = do+  top_dir <- prepareDir json_path+  T.hPutStrLn stderr $ "Stripping '" <> T.pack prefix <> "' from program paths."   mapM_ (onBenchResult top_dir) bench_results   where     prefix = longestCommonPrefix $ map benchResultProg bench_results@@ -105,10 +155,12 @@       case report res of         Nothing -> problem prog_name name "no profiling information"         Just r ->-          T.writeFile (name' <> ".summary") $-            memoryReport (profilingMemory r)-              <> "\n\n"-              <> tabulateEvents (profilingEvents r)+          let tf =+                TargetFiles+                  { summaryFile = name' <> ".summary",+                    timelineFile = name' <> ".timeline"+                  }+           in writeAnalysis tf r  readFileSafely :: FilePath -> IO (Either String BS.ByteString) readFileSafely filepath =@@ -116,21 +168,24 @@   where     couldNotRead e = pure $ Left $ show (e :: IOError) -decodeFileBenchResults ::-  FilePath ->-  IO (Either String [BenchResult])-decodeFileBenchResults path = do-  file <- readFileSafely path-  pure $ file >>= decodeBenchResults- -- | Run @futhark profile@. main :: String -> [String] -> IO () main = mainWithOptions () [] "<file>" f   where     f [json_path] () = Just $ do-      res_either <- decodeFileBenchResults json_path--      case res_either of-        Left a -> hPutStrLn stderr a-        Right a -> analyseProfileReport json_path a+      s <- readFileSafely json_path+      case s of+        Left a -> do+          hPutStrLn stderr a+          exitWith $ ExitFailure 2+        Right s' ->+          case decodeBenchResults s' of+            Left _ ->+              case decodeProfilingReport s' of+                Nothing -> do+                  hPutStrLn stderr $+                    "Cannot recognise " <> json_path <> " as benchmark results or a profiling report."+                Just pr ->+                  analyseProfilingReport json_path pr+            Right br -> analyseBenchResults json_path br     f _ _ = Nothing

@@ -605,15 +605,15 @@     let bucket_fun_deps' = lambdaDependencies mempty lam (depsOfArrays w arrs)         -- Bucket function results are indices followed by values.         -- Reshape this to align with list of histogram operations.-        ranks = [length (histShape op) | op <- ops]-        value_lengths = [length (histNeutral op) | op <- ops]+        ranks = map (shapeRank . histShape) ops+        value_lengths = map (length . histNeutral) ops         (indices, values) = splitAt (sum ranks) bucket_fun_deps'         bucket_fun_deps =           zipWith             concatIndicesToEachValue             (chunks ranks indices)             (chunks value_lengths values)-     in mconcat $ zipWith (<>) bucket_fun_deps (map depsOfHistOp ops)+     in mconcat $ zipWith (zipWith (<>)) bucket_fun_deps (map depsOfHistOp ops)     where       depsOfHistOp (HistOp dest_shape rf dests nes op) =         let shape_deps = depsOfShape dest_shape@@ -625,9 +625,10 @@          in map (is_flat <>) vs   opDependencies (Scatter w arrs lam outputs) =     let deps = lambdaDependencies mempty lam (depsOfArrays w arrs)-     in map flattenGroups (groupScatterResults' outputs deps)+     in map flattenGroups (groupScatterResults outputs deps)     where-      flattenGroups (indicess, values) = mconcat indicess <> values+      flattenGroups (_, _, ivs) =+        mconcat (map (mconcat . fst) ivs) <> mconcat (map snd ivs)   opDependencies (JVP lam args vec) =     mconcat $       replicate 2 $

@@ -999,8 +999,7 @@   where   cheapOp _ = False   safeOp _ = True-  opDependencies op =-    replicate (length . kernelBodyResult $ segBody op) (freeIn op)+  opDependencies op = replicate (length (segOpType op)) (freeIn op)  --- Simplification 

@@ -26,6 +26,7 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State+import Data.List (find) import Data.Map.Strict qualified as M import Futhark.IR.SOACS import Futhark.MonadFreshNames@@ -137,8 +138,14 @@ -- | Add opaque types.  If the types are already known, they will not -- be added. addOpaques :: OpaqueTypes -> InternaliseM ()-addOpaques ts = modify $ \s ->-  s {stateTypes = stateTypes s <> ts}+addOpaques ts@(OpaqueTypes ts') = modify $ \s ->+  -- TODO: handle this better (#1960)+  case find (knownButDifferent (stateTypes s)) ts' of+    Just (x, _) -> error $ "addOpaques: multiple incompatible definitions of type " <> nameToString x+    Nothing -> s {stateTypes = stateTypes s <> ts}+  where+    knownButDifferent (OpaqueTypes old_ts) (v, def) =+      any (\(v_old, v_def) -> v == v_old && def /= v_def) old_ts  -- | Add a function definition to the program being constructed. addFunDef :: FunDef SOACS -> InternaliseM ()

@@ -2,7 +2,8 @@ module Futhark.Profile   ( ProfilingEvent (..),     ProfilingReport (..),-    profilingInfoFromText,+    profilingReportFromText,+    decodeProfilingReport,   ) where @@ -11,6 +12,7 @@ import Data.Aeson.KeyMap qualified as JSON import Data.Bifunctor import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Map qualified as M import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8Builder)@@ -61,5 +63,8 @@       <$> o JSON..: "events"       <*> (JSON.toMapText <$> o JSON..: "memory") -profilingInfoFromText :: T.Text -> Maybe ProfilingReport-profilingInfoFromText = JSON.decode . toLazyByteString . encodeUtf8Builder+decodeProfilingReport :: LBS.ByteString -> Maybe ProfilingReport+decodeProfilingReport = JSON.decode++profilingReportFromText :: T.Text -> Maybe ProfilingReport+profilingReportFromText = JSON.decode . toLazyByteString . encodeUtf8Builder

@@ -35,6 +35,7 @@ import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bifunctor (bimap)+import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Char import Data.Foldable (toList)@@ -356,20 +357,33 @@     Just vs ->       pure $ V.ValueTuple $ map V.ValueAtom vs --- | Handles the following builtin functions: @loaddata@.  Fails for--- everything else.  The 'FilePath' indicates the directory that files--- should be read relative to.-scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m-scriptBuiltin dir "loaddata" vs =+pathArg ::+  (MonadError T.Text f) =>+  FilePath ->+  T.Text ->+  [V.Compound V.Value] ->+  f FilePath+pathArg dir cmd vs =   case vs of     [V.ValueAtom v]-      | Just path <- V.getValue v -> do-          let path' = map (chr . fromIntegral) (path :: [Word8])-          loadData $ dir </> path'+      | Just path <- V.getValue v ->+          pure $ dir </> map (chr . fromIntegral) (path :: [Word8])     _ ->       throwError $-        "$loaddata does not accept arguments of types: "+        "$"+          <> cmd+          <> " does not accept arguments of types: "           <> T.intercalate ", " (map (prettyText . fmap V.valueType) vs)++-- | Handles the following builtin functions: @loaddata@, @loadbytes@.+-- Fails for everything else. The 'FilePath' indicates the directory+-- that files should be read relative to.+scriptBuiltin :: (MonadIO m, MonadError T.Text m) => FilePath -> EvalBuiltin m+scriptBuiltin dir "loaddata" vs = do+  loadData =<< pathArg dir "loaddata" vs+scriptBuiltin dir "loadbytes" vs = do+  fmap (V.ValueAtom . V.putValue1) . liftIO . BS.readFile+    =<< pathArg dir "loadbytes" vs scriptBuiltin _ f _ =   throwError $ "Unknown builtin function $" <> prettyText f 

@@ -529,7 +529,7 @@          | '...['     ']' { SizeExpAny (srcspan $1 $>) }  FunParam :: { PatBase NoInfo Name ParamType }-FunParam : InnerPat { fmap (toParam Observe) $1 }+FunParam : ParamPat { fmap (toParam Observe) $1 }  FunParams1 :: { (PatBase NoInfo Name ParamType, [PatBase NoInfo Name ParamType]) } FunParams1 : FunParam            { ($1, []) }@@ -783,39 +783,52 @@        | Case Cases           { NE.cons $1 $2 }  Case :: { CaseBase NoInfo Name }-      : case CPat '->' Exp+      : case Pat '->' Exp         { let loc = srcspan $1 $> in CasePat $2 $> loc } -CPat :: { PatBase NoInfo Name StructType }-          : '#[' AttrInfo ']' CPat    { PatAttr $2 $4 (srcspan $1 $>) }-          | CInnerPat ':' TypeExp     { PatAscription $1 $3 (srcspan $1 $>) }-          | CInnerPat                 { $1 }+Pat :: { PatBase NoInfo Name StructType }+          : '#[' AttrInfo ']' Pat    { PatAttr $2 $4 (srcspan $1 $>) }+          | InnerPat ':' TypeExp     { PatAscription $1 $3 (srcspan $1 $>) }+          | InnerPat                 { $1 }           | Constr ConstrFields       { let (n, loc) = $1;                                             loc' = srcspan loc $>                                         in PatConstr n NoInfo $2 loc'} -CPats1 :: { [PatBase NoInfo Name StructType] }-           : CPat               { [$1] }-           | CPat ',' CPats1 { $1 : $3 }+-- Parameter patterns are slightly restricted; see #2017.+ParamPat :: { PatBase NoInfo Name StructType }+               : id                   { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }+               | '(' BindingBinOp ')' { Id $2 NoInfo (srcspan $1 $>) }+               | '_'                  { Wildcard NoInfo (srclocOf $1) }+               | '(' ')'              { TuplePat [] (srcspan $1 $>) }+               | '(' Pat ')'          { PatParens $2 (srcspan $1 $>) }+               | '(' Pat ',' Pats1 ')'{ TuplePat ($2:$4) (srcspan $1 $>) }+               | '{' CFieldPats '}'   { RecordPat $2 (srcspan $1 $>) }+               | PatLiteralNoNeg      { PatLit (fst $1) NoInfo (srclocOf (snd $1)) }+               | Constr               { let (n, loc) = $1+                                        in PatConstr n NoInfo [] (srclocOf loc) } -CInnerPat :: { PatBase NoInfo Name StructType }-               : id                                 { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }-               | '(' BindingBinOp ')'               { Id $2 NoInfo (srcspan $1 $>) }-               | '_'                                { Wildcard NoInfo (srclocOf $1) }-               | '(' ')'                            { TuplePat [] (srcspan $1 $>) }-               | '(' CPat ')'                       { PatParens $2 (srcspan $1 $>) }-               | '(' CPat ',' CPats1 ')'            { TuplePat ($2:$4) (srcspan $1 $>) }-               | '{' CFieldPats '}'                 { RecordPat $2 (srcspan $1 $>) }-               | CaseLiteral                        { PatLit (fst $1) NoInfo (srclocOf (snd $1)) }-               | Constr                             { let (n, loc) = $1-                                                      in PatConstr n NoInfo [] (srclocOf loc) }+Pats1 :: { [PatBase NoInfo Name StructType] }+           : Pat               { [$1] }+           | Pat ',' Pats1 { $1 : $3 } +InnerPat :: { PatBase NoInfo Name StructType }+               : id                   { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }+               | '(' BindingBinOp ')' { Id $2 NoInfo (srcspan $1 $>) }+               | '_'                  { Wildcard NoInfo (srclocOf $1) }+               | '(' ')'              { TuplePat [] (srcspan $1 $>) }+               | '(' Pat ')'          { PatParens $2 (srcspan $1 $>) }+               | '(' Pat ',' Pats1 ')'{ TuplePat ($2:$4) (srcspan $1 $>) }+               | '{' CFieldPats '}'   { RecordPat $2 (srcspan $1 $>) }+               | PatLiteral           { PatLit (fst $1) NoInfo (srclocOf (snd $1)) }+               | Constr               { let (n, loc) = $1+                                        in PatConstr n NoInfo [] (srclocOf loc) }+ ConstrFields :: { [PatBase NoInfo Name StructType] }-              : CInnerPat                { [$1] }-              | ConstrFields CInnerPat   { $1 ++ [$2] }+              : InnerPat                { [$1] }+              | ConstrFields InnerPat   { $1 ++ [$2] }  CFieldPat :: { (Name, PatBase NoInfo Name StructType) }-               : FieldId '=' CPat+               : FieldId '=' Pat                { (fst $1, $3) }                | FieldId ':' TypeExp                { (fst $1, PatAscription (Id (fst $1) NoInfo (srclocOf (snd $1))) $3 (srcspan (snd $1) $>)) }@@ -830,18 +843,21 @@                  : CFieldPat ',' CFieldPats1 { $1 : $3 }                  | CFieldPat                    { [$1] } -CaseLiteral :: { (PatLit, Loc) }+PatLiteralNoNeg :: { (PatLit, Loc) }              : charlit  { let L loc (CHARLIT x) = $1                           in (PatLitInt (toInteger (ord x)), loc) }              | PrimLit  { (PatLitPrim (fst $1), snd $1) }              | intlit   { let L loc (INTLIT x) = $1 in (PatLitInt x, loc) }              | natlit   { let L loc (NATLIT _ x) = $1 in (PatLitInt x, loc) }              | floatlit { let L loc (FLOATLIT x) = $1 in (PatLitFloat x, loc) }-             | '-' NumLit   { (PatLitPrim (primNegate (fst $2)), snd $2) }-             | '-' intlit   { let L loc (INTLIT x) = $2 in (PatLitInt (negate x), loc) }-             | '-' natlit   { let L loc (NATLIT _ x) = $2 in (PatLitInt (negate x), loc) }-             | '-' floatlit { let L loc (FLOATLIT x) = $2 in (PatLitFloat (negate x), loc) } +PatLiteral :: { (PatLit, Loc) }+             : PatLiteralNoNeg           { $1 }+             | '-' NumLit %prec bottom   { (PatLitPrim (primNegate (fst $2)), snd $2) }+             | '-' intlit %prec bottom   { let L loc (INTLIT x) = $2 in (PatLitInt (negate x), loc) }+             | '-' natlit %prec bottom   { let L loc (NATLIT _ x) = $2 in (PatLitInt (negate x), loc) }+             | '-' floatlit              { let L loc (FLOATLIT x) = $2 in (PatLitFloat (negate x), loc) }+ LoopForm :: { LoopFormBase NoInfo Name } LoopForm : for VarId '<' Exp            { For $2 $4 }@@ -875,41 +891,6 @@ FieldId :: { (Name, Loc) }          : id     { let L loc (ID name) = $1 in (name, loc) }          | natlit { let L loc (NATLIT x _) = $1 in (x, loc) }--Pat :: { PatBase NoInfo Name StructType }-     : '#[' AttrInfo ']' Pat  { PatAttr $2 $4 (srcspan $1 $>) }-     | InnerPat ':' TypeExp   { PatAscription $1 $3 (srcspan $1 $>) }-     | InnerPat               { $1 }--Pats1 :: { [PatBase NoInfo Name StructType] }-       : Pat                    { [$1] }-       | Pat ',' Pats1          { $1 : $3 }--InnerPat :: { PatBase NoInfo Name StructType }-InnerPat : id                               { let L loc (ID name) = $1 in Id name NoInfo (srclocOf loc) }-             | '(' BindingBinOp ')'         { Id $2 NoInfo (srcspan $1 $>) }-             | '_'                          { Wildcard NoInfo (srclocOf $1) }-             | '(' ')'                      { TuplePat [] (srcspan $1 $>) }-             | '(' Pat ')'                  { PatParens $2 (srcspan $1 $>) }-             | '(' Pat ',' Pats1 ')'        { TuplePat ($2:$4) (srcspan $1 $>) }-             | '{' FieldPats '}'            { RecordPat $2 (srcspan $1 $>) }--FieldPat :: { (Name, PatBase NoInfo Name StructType) }-              : FieldId '=' Pat-                { (fst $1, $3) }-              | FieldId ':' TypeExp-                { (fst $1, PatAscription (Id (fst $1) NoInfo (srclocOf (snd $1))) $3 (srcspan (snd $1) $>)) }-              | FieldId-                { (fst $1, Id (fst $1) NoInfo (srclocOf (snd $1))) }--FieldPats :: { [(Name, PatBase NoInfo Name StructType)] }-               : FieldPats1 { $1 }-               |            { [] }--FieldPats1 :: { [(Name, PatBase NoInfo Name StructType)] }-               : FieldPat ',' FieldPats1 { $1 : $3 }-               | FieldPat                    { [$1] }-  maybeAscription(p) : ':' p { Just $2 }                    |       { Nothing }

@@ -50,13 +50,13 @@   pretty = pprMatch (-1)  patternToMatch :: Pat StructType -> Match StructType-patternToMatch (Id _ (Info t) _) = MatchWild $ toStruct t-patternToMatch (Wildcard (Info t) _) = MatchWild $ toStruct t+patternToMatch (Id _ (Info t) _) = MatchWild t+patternToMatch (Wildcard (Info t) _) = MatchWild t patternToMatch (PatParens p _) = patternToMatch p patternToMatch (PatAttr _ p _) = patternToMatch p patternToMatch (PatAscription p _ _) = patternToMatch p patternToMatch (PatLit l (Info t) _) =-  MatchConstr (ConstrLit l) [] $ toStruct t+  MatchConstr (ConstrLit l) [] t patternToMatch p@(TuplePat ps _) =   MatchConstr ConstrTuple (map patternToMatch ps) $     patternStructType p@@ -66,7 +66,7 @@   where     (fnames, ps) = unzip $ sortFields $ M.fromList fs patternToMatch (PatConstr c (Info t) args _) =-  MatchConstr (Constr c) (map patternToMatch args) $ toStruct t+  MatchConstr (Constr c) (map patternToMatch args) t  isConstr :: Match t -> Maybe Name isConstr (MatchConstr (Constr c) _ _) = Just c

@@ -1249,6 +1249,15 @@                   <+> "with 'let' beforehand."               ) +mustBeIrrefutable :: (MonadTypeChecker f) => Pat StructType -> f ()+mustBeIrrefutable p = do+  case unmatched [p] of+    [] -> pure ()+    ps' ->+      typeError p mempty . withIndexLink "refutable-pattern" $+        "Refutable pattern not allowed here.\nUnmatched cases:"+          </> indent 2 (stack (map pretty ps'))+ -- | Traverse the expression, emitting warnings and errors for various -- problems: --@@ -1267,6 +1276,18 @@           typeError loc mempty . withIndexLink "unmatched-cases" $             "Unmatched cases in match expression:"               </> indent 2 (stack (map pretty ps'))+    check e@(AppExp (LetPat _ p _ _ _) _) =+      mustBeIrrefutable p *> recurse e+    check e@(Lambda ps _ _ _ _) =+      mapM_ (mustBeIrrefutable . fmap toStruct) ps *> recurse e+    check e@(AppExp (LetFun _ (_, ps, _, _, _) _ _) _) =+      mapM_ (mustBeIrrefutable . fmap toStruct) ps *> recurse e+    check e@(AppExp (Loop _ p _ form _ _) _) = do+      mustBeIrrefutable (fmap toStruct p)+      case form of+        ForIn form_p _ -> mustBeIrrefutable form_p+        _ -> pure ()+      recurse e     check e@(IntLit x ty loc) =       e <$ case ty of         Info (Scalar (Prim t)) -> errorBounds (inBoundsI x t) x t loc@@ -1350,6 +1371,7 @@     causalityCheck body''      -- Check for various problems.+    mapM_ (mustBeIrrefutable . fmap toStruct) params'     localChecks body''      bindSpaced [(Term, fname)] $ do