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.4 +version: 0.25.5 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -285,6 +285,7 @@ Futhark.Doc.Generator Futhark.Error Futhark.FreshNames + Futhark.Format Futhark.IR Futhark.IR.Aliases Futhark.IR.GPU @@ -504,7 +505,7 @@ , haskeline , language-c-quote >= 0.12 , lens - , lsp >= 2.1.0.0 + , lsp >= 2.2.0.0 , lsp-types >= 2.0.1.0 , mainland-pretty >=0.7.1 , cmark-gfm >=0.2.1 diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -446,7 +446,7 @@ } else if (isinf(x)) { return fprintf(out, "-f16.inf"); } else { - return fprintf(out, "%.6ff16", x); + return fprintf(out, "%.*ff16", FLT_DIG, x); } } @@ -459,7 +459,7 @@ } else if (isinf(x)) { return fprintf(out, "-f32.inf"); } else { - return fprintf(out, "%.6ff32", x); + return fprintf(out, "%.*ff32", FLT_DIG, x); } } @@ -472,7 +472,7 @@ } else if (isinf(x)) { return fprintf(out, "-f64.inf"); } else { - return fprintf(out, "%.6ff64", *src); + return fprintf(out, "%.*ff64", DBL_DIG, x); } } diff --git a/src/Futhark/CLI/LSP.hs b/src/Futhark/CLI/LSP.hs --- a/src/Futhark/CLI/LSP.hs +++ b/src/Futhark/CLI/LSP.hs @@ -22,7 +22,9 @@ _ <- runServer $ ServerDefinition - { onConfigurationChange = const $ const $ Right (), + { onConfigChange = const $ pure (), + configSection = "Futhark", + parseConfig = const . const $ Right (), defaultConfig = (), doInitialize = \env _req -> pure $ Right env, staticHandlers = handlers state_mvar, diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -17,8 +17,9 @@ import Data.Text.IO qualified as T import Data.Version import Futhark.Compiler +import Futhark.Format (parseFormatString) import Futhark.MonadFreshNames -import Futhark.Util (fancyTerminal) +import Futhark.Util (fancyTerminal, showText) import Futhark.Util.Options import Futhark.Util.Pretty (AnsiStyle, Color (..), Doc, align, annotate, bgColorDull, bold, brackets, color, docText, docTextForHandle, hardline, italicized, oneLine, pretty, putDoc, putDocLn, unAnnotate, (<+>)) import Futhark.Version @@ -223,7 +224,11 @@ case parseDecOrExp prompt line of Left (SyntaxError _ err) -> liftIO $ T.putStrLn err Right (Left d) -> onDec d - Right (Right e) -> onExp e + Right (Right e) -> do + valOrErr <- onExp e + case valOrErr of + Left err -> liftIO $ putDoc err + Right val -> liftIO $ putDocLn $ I.prettyValue val modify $ \s -> s {futharkiCount = futharkiCount s + 1} where inputLine prompt = do @@ -274,22 +279,29 @@ futharkiProg = prog {lpNameSource = src'} } -onExp :: UncheckedExp -> FutharkiM () +onExp :: UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) I.Value) onExp e = do (imports, src, tenv, ienv) <- getIt case T.checkExp imports src tenv e of - (_, Left err) -> liftIO $ putDoc $ T.prettyTypeErrorNoLoc err + (_, Left err) -> pure $ Left $ T.prettyTypeErrorNoLoc err (_, Right (tparams, e')) | null tparams -> do r <- runInterpreter $ I.interpretExp ienv e' case r of - Left err -> liftIO $ print err - Right v -> liftIO $ putDoc $ I.prettyValue v <> hardline - | otherwise -> liftIO $ do - putDocLn $ "Inferred type of expression: " <> align (pretty (typeOf e')) - T.putStrLn $ - "The following types are ambiguous: " - <> T.intercalate ", " (map (nameToText . toName . typeParamName) tparams) + Left err -> pure $ Left $ pretty $ showText err + Right v -> pure $ Right v + | otherwise -> + pure $ + Left $ + ("Inferred type of expression: " <> align (pretty (typeOf e'))) + <> hardline + <> pretty + ( "The following types are ambiguous: " + <> T.intercalate + ", " + (map (nameToText . toName . typeParamName) tparams) + ) + <> hardline prettyBreaking :: Breaking -> T.Text prettyBreaking b = @@ -405,6 +417,23 @@ mtypeCommand :: Command mtypeCommand = genTypeCommand parseModExp T.checkModExp $ pretty . fst +formatCommand :: Command +formatCommand input = do + case parseFormatString input of + Left err -> liftIO $ T.putStrLn err + Right parts -> do + prompt <- getPrompt + case mapM (traverse $ parseExp prompt) parts of + Left (SyntaxError _ err) -> + liftIO $ T.putStr err + Right parts' -> do + parts'' <- mapM sequenceA <$> mapM (traverse onExp) parts' + case parts'' of + Left err -> liftIO $ putDoc err + Right parts''' -> + liftIO . T.putStrLn . mconcat $ + map (either id (docText . I.prettyValue)) parts''' + unbreakCommand :: Command unbreakCommand _ = do top <- gets $ fmap (NE.head . breakingStack) . futharkiBreaking @@ -483,6 +512,15 @@ second time will replace the previously loaded file. It will also replace any declarations entered at the REPL. +|] + ) + ), + ( "format", + ( formatCommand, + [text| +Use format strings to print arbitrary futhark expressions. Usage: + + > :format The value of foo: {foo}. The value of 2+2={2+2} |] ) ), diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs --- a/src/Futhark/CodeGen/Backends/SimpleRep.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -36,15 +36,13 @@ ) where -import Data.Bits (shiftR, xor) -import Data.Char (isAlpha, isAlphaNum, isDigit, ord) +import Data.Char (isAlpha, isAlphaNum, isDigit) import Data.Text qualified as T import Futhark.CodeGen.ImpCode import Futhark.CodeGen.RTS.C (scalarF16H, scalarH) -import Futhark.Util (zEncodeText) +import Futhark.Util (hashText, zEncodeText) import Language.C.Quote.C qualified as C import Language.C.Syntax qualified as C -import Text.Printf -- | The C type corresponding to a signed integer type. intTypeToCType :: IntType -> C.Type @@ -137,22 +135,7 @@ && not (isDigit $ T.head s') && T.all ok s' ok c = isAlphaNum c || c == '_' -opaqueName s = "opaque_" <> hash (zipWith xor [0 ..] $ map ord (nameToString s)) - where - -- FIXME: a stupid hash algorithm; may have collisions. - hash = - T.pack - . printf "%x" - . foldl xor 0 - . map - ( iter - . (* 0x45d9f3b) - . iter - . (* 0x45d9f3b) - . iter - . fromIntegral - ) - iter x = ((x :: Word32) `shiftR` 16) `xor` x +opaqueName s = "opaque_" <> hashText (nameToText s) -- | The 'PrimType' (and sign) correspond to a human-readable scalar -- type name (e.g. @f64@). Beware: partial! diff --git a/src/Futhark/Format.hs b/src/Futhark/Format.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Format.hs @@ -0,0 +1,21 @@ +-- | Parsing of format strings. +module Futhark.Format (parseFormatString) where + +import Data.Bifunctor +import Data.Text qualified as T +import Data.Void +import Text.Megaparsec + +pFormatString :: Parsec Void T.Text [Either T.Text T.Text] +pFormatString = + many (choice [Left <$> pLiteral, Right <$> pInterpolation]) <* eof + where + pInterpolation = "{" *> takeWhileP Nothing (`notElem` braces) <* "}" + pLiteral = takeWhile1P Nothing (`notElem` braces) + braces = "{}" :: String + +-- | The Lefts are pure text; the Rights are the contents of +-- interpolations. +parseFormatString :: T.Text -> Either T.Text [Either T.Text T.Text] +parseFormatString = + first (T.pack . errorBundlePretty) . runParser pFormatString "" diff --git a/src/Futhark/Internalise/Entry.hs b/src/Futhark/Internalise/Entry.hs --- a/src/Futhark/Internalise/Entry.hs +++ b/src/Futhark/Internalise/Entry.hs @@ -12,7 +12,7 @@ import Data.Map qualified as M import Futhark.IR qualified as I import Futhark.Internalise.TypesValues (internalisedTypeSize) -import Futhark.Util.Pretty (prettyText, prettyTextOneLine) +import Futhark.Util.Pretty (prettyTextOneLine) import Language.Futhark qualified as E hiding (TypeArg) import Language.Futhark.Core (Name, Uniqueness (..), VName, nameFromText) import Language.Futhark.Semantic qualified as E @@ -56,7 +56,7 @@ where f (E.TEArray _ te _) = let (d, te') = withoutDims te - in "arr_" <> typeExpOpaqueName te' <> "_" <> nameFromText (prettyText (1 + d)) <> "d" + in nameFromText (mconcat (replicate (1 + d) "[]")) <> typeExpOpaqueName te' f te = nameFromText $ prettyTextOneLine te type GenOpaque = State I.OpaqueTypes diff --git a/src/Futhark/Optimise/CSE.hs b/src/Futhark/Optimise/CSE.hs --- a/src/Futhark/Optimise/CSE.hs +++ b/src/Futhark/Optimise/CSE.hs @@ -71,16 +71,17 @@ . aliasAnalysis $ prog where - onConsts free_in_funs stms = - pure $ - fst $ - runReader - ( cseInStms - (free_in_funs <> consumedInStms stms) - (stmsToList stms) - (pure ()) - ) - (newCSEState cse_arrays) + onConsts free_in_funs stms = do + let free_list = namesToList free_in_funs + (res_als, stms_cons) = mkStmsAliases stms $ varsRes free_list + pure . fst $ + runReader + ( cseInStms + (mconcat res_als <> stms_cons) + (stmsToList stms) + (pure ()) + ) + (newCSEState cse_arrays) onFun _ = pure . cseInFunDef cse_arrays -- | Perform CSE on a single function. @@ -98,17 +99,11 @@ removeFunDefAliases . cseInFunDef cse_arrays . analyseFun -- | Perform CSE on some statements. --- --- If the boolean argument is false, the pass will not perform CSE on --- expressions producing arrays. This should be disabled when the rep has --- memory information, since at that point arrays have identity beyond their --- value. performCSEOnStms :: (AliasableRep rep, CSEInOp (Op (Aliases rep))) => - Bool -> Stms rep -> Stms rep -performCSEOnStms cse_arrays = +performCSEOnStms = fmap removeStmAliases . f . fst . analyseStms mempty where f stms = @@ -119,7 +114,9 @@ (stmsToList stms) (pure ()) ) - (newCSEState cse_arrays) + -- It is never safe to CSE arrays in stms in isolation, + -- because we might introduce additional aliasing. + (newCSEState False) cseInFunDef :: (Aliased rep, CSEInOp (Op rep)) => diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -83,7 +83,7 @@ if any (`calledByConsts` cg) to_inline_now then do consts' <- - simplifyConsts . performCSEOnStms True + simplifyConsts . performCSEOnStms =<< inlineInStms inlinemap consts pure (ST.insertStms (informStms consts') mempty, consts') else pure (vtable, consts) diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -27,6 +27,16 @@ import Futhark.Optimise.Simplify.Rule import Futhark.Pass +funDefUsages :: (FreeIn a) => [a] -> UT.UsageTable +funDefUsages funs = + -- XXX: treat every constant used in the functions as consumed, + -- because it is otherwise complicated to ensure we do not introduce + -- more aliasing than specified by the return types. CSE has the + -- same problem. + let free_in_funs = foldMap freeIn funs + in UT.usages free_in_funs + <> foldMap UT.consumedUsage (namesToList free_in_funs) + -- | Simplify the given program. Even if the output differs from the -- output, meaningful simplification may not have taken place - the -- order of bindings may simply have been rearranged. @@ -41,15 +51,13 @@ let consts = progConsts prog funs = progFuns prog (consts_vtable, consts') <- - simplifyConsts (UT.usages $ foldMap freeIn funs) (mempty, informStms consts) + simplifyConsts (funDefUsages funs) (mempty, informStms consts) -- We deepen the vtable so it will look like the constants are in an -- "outer loop"; this communicates useful information to some -- simplification rules (e.g. see issue #1302). funs' <- parPass (simplifyFun' (ST.deepen consts_vtable) . informFunDef) funs - let funs_uses = UT.usages $ foldMap freeIn funs' - - (_, consts'') <- simplifyConsts funs_uses (mempty, consts') + (_, consts'') <- simplifyConsts (funDefUsages funs') (mempty, consts') pure $ prog diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -780,11 +780,16 @@ (SimplifiableRep rep) => Stms (Wise rep) -> SimpleM rep (Stms (Wise rep)) -simplifyStms stms = do - simplifyStmsWithUsage all_used stms +simplifyStms stms = simplifyStmsWithUsage usage stms where - all_used = - UT.usages (namesFromList (M.keys (scopeOf stms))) + -- XXX: treat everything as consumed, because when these are + -- constants it is otherwise complicated to ensure we do not + -- introduce more aliasing than specified by the return types. + -- CSE has the same problem. + all_bound = M.keys (scopeOf stms) + usage = + UT.usages (namesFromList all_bound) + <> foldMap UT.consumedUsage all_bound simplifyStmsWithUsage :: (SimplifiableRep rep) => diff --git a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs --- a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +++ b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs @@ -239,11 +239,9 @@ ruleBasicOp _ pat _ (Replicate _ se) | [Acc {}] <- patTypes pat = Simplify $ letBind pat $ BasicOp $ SubExp se -ruleBasicOp _ pat _ (Replicate (Shape []) se) = Simplify $ do - se_t <- subExpType se - if primType se_t - then letBind pat $ BasicOp $ SubExp se - else cannotSimplify +ruleBasicOp _ pat _ (Replicate (Shape []) se) + | [Prim _] <- patTypes pat = + Simplify $ letBind pat $ BasicOp $ SubExp se ruleBasicOp vtable pat _ (Replicate shape (Var v)) | Just (BasicOp (Replicate shape2 se), cs) <- ST.lookupExp v vtable, ST.subExpAvailable se vtable =