diff --git a/docs/error-index.rst b/docs/error-index.rst --- a/docs/error-index.rst +++ b/docs/error-index.rst @@ -841,6 +841,31 @@ :ref:`See here ` 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" diff --git a/docs/glossary.rst b/docs/glossary.rst --- a/docs/glossary.rst +++ b/docs/glossary.rst @@ -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 diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst --- a/docs/man/futhark-literate.rst +++ b/docs/man/futhark-literate.rst @@ -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, diff --git a/docs/man/futhark-profile.rst b/docs/man/futhark-profile.rst --- a/docs/man/futhark-profile.rst +++ b/docs/man/futhark-profile.rst @@ -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 ======== diff --git a/docs/man/futhark-test.rst b/docs/man/futhark-test.rst --- a/docs/man/futhark-test.rst +++ b/docs/man/futhark-test.rst @@ -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 diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/src/Futhark/Analysis/DataDependencies.hs b/src/Futhark/Analysis/DataDependencies.hs --- a/src/Futhark/Analysis/DataDependencies.hs +++ b/src/Futhark/Analysis/DataDependencies.hs @@ -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 diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -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 diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -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) diff --git a/src/Futhark/CLI/Profile.hs b/src/Futhark/CLI/Profile.hs --- a/src/Futhark/CLI/Profile.hs +++ b/src/Futhark/CLI/Profile.hs @@ -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 () [] "" 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 diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs --- a/src/Futhark/IR/SOACS/SOAC.hs +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -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 $ diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -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 diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -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 () diff --git a/src/Futhark/Profile.hs b/src/Futhark/Profile.hs --- a/src/Futhark/Profile.hs +++ b/src/Futhark/Profile.hs @@ -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 diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -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 diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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 } diff --git a/src/Language/Futhark/TypeChecker/Match.hs b/src/Language/Futhark/TypeChecker/Match.hs --- a/src/Language/Futhark/TypeChecker/Match.hs +++ b/src/Language/Futhark/TypeChecker/Match.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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