From 728a681943af45d38cdd85d22e91792cfdfef57c Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 24 Nov 2021 01:32:04 -0500 Subject: [PATCH] Rewrite `Partial` optimization to be cleaner This feature shrinks the generated JS code for declarations that use empty type classes, such as `Partial`, but is otherwise not expected to have user-visible consequences. A previous issue involving `Partial` resulted in an ad-hoc optimization pass added to the CoreFn phase. This pass consumed code generated by the exhaustiveness checker, which used `UnusedIdent` in a questionable manner, and ran a rewrite on it that assumed that the only part of the compile that would use `UnusedIdent` in such a questionable manner was necessarily the exhaustiveness checker. This commit: * simplifies the code generated by the exhaustiveness checker for partial matches, in particular removing any use of `UnusedIdent`s; * removes the offending CoreFn optimization pass; * solves the problem originally motivating said optimization pass by using an `UnusedIdent` for the generated parameter when type-checking a value constrained by an empty type class (such parameters, importantly for our sanity, are actually unused); * and backs out a related hack in TCO that worked around such generated parameters being present but called without an argument. The intended result is simpler compiler code; happy side effects include simpler error messages involving partial pattern matches (seen here in a few golden test output changes) and simpler generated code (fewer unused function parameters, fewer local variables in some TCO-triggering functions). --- .../feature_rewrite-partial-optimization.md | 5 +++ src/Language/PureScript/CoreFn/Optimizer.hs | 11 +---- .../PureScript/CoreImp/Optimizer/TCO.hs | 4 -- src/Language/PureScript/Linter/Exhaustive.hs | 44 ++++--------------- src/Language/PureScript/TypeChecker/Types.hs | 16 +++++-- tests/purs/failing/2806.out | 11 ++--- tests/purs/failing/NonExhaustivePatGuard.out | 11 ++--- tests/purs/failing/Superclasses5.out | 13 ++---- 8 files changed, 38 insertions(+), 77 deletions(-) create mode 100644 CHANGELOG.d/feature_rewrite-partial-optimization.md diff --git a/CHANGELOG.d/feature_rewrite-partial-optimization.md b/CHANGELOG.d/feature_rewrite-partial-optimization.md new file mode 100644 index 0000000000..2ed2d14788 --- /dev/null +++ b/CHANGELOG.d/feature_rewrite-partial-optimization.md @@ -0,0 +1,5 @@ +* Rewrite `Partial` optimization to be cleaner + + This feature shrinks the generated JS code for declarations that use + empty type classes, such as `Partial`, but is otherwise not expected to + have user-visible consequences. diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index b876dfdff5..29fa7259d7 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -27,8 +27,7 @@ optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity transformExprs - = optimizeUnusedPartialFn - . optimizeClosedRecordUpdate + = optimizeClosedRecordUpdate . optimizeDataFunctionApply optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann @@ -52,14 +51,6 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = collect _ = Nothing closedRecordFields _ = Nothing --- | See https://github.com/purescript/purescript/issues/3157 -optimizeUnusedPartialFn :: Expr a -> Expr a -optimizeUnusedPartialFn (Let _ - [NonRec _ UnusedIdent _] - (App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) = - originalCoreFn -optimizeUnusedPartialFn e = e - optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of (App a (App _ (Var _ (Qualified (Just (ModuleName mn)) (Ident fn))) x) y) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index f63b499ee1..f93c6a93df 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -9,7 +9,6 @@ import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) import qualified Data.Set as S import Data.Text (Text, pack) -import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) @@ -175,9 +174,6 @@ tco = flip evalState 0 . everywhereTopDownM convert where rootSS = Nothing collectArgs :: [[AST]] -> AST -> [[AST]] - collectArgs acc (App _ fn []) = - -- count 0-argument applications as single-argument so we get the correct number of args - collectArgs ([Var Nothing C.undefined] : acc) fn collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn collectArgs acc _ = acc diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index dc4131bda9..2d124b16ea 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -15,12 +15,11 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class -import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) +import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) import qualified Data.Map as M -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.Binders @@ -268,49 +267,22 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' case rr of Left Incomplete -> tellIncomplete _ -> return () - if null bss - then return expr + return $ if null bss + then expr else addPartialConstraint (second null (splitAt 5 bss)) expr where tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck - -- | We add a Partial constraint by adding a call to the following identity function: - -- - -- partial :: forall a. Partial => a -> a + -- | We add a Partial constraint by annotating the expression to have type `Partial => _`. -- -- The binder information is provided so that it can be embedded in the constraint, -- and then included in the error message. - addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr - addPartialConstraint (bss, complete) e = do - tyVar <- ("p" <>) . T.pack . show <$> fresh - var <- freshName - return $ - Let - FromLet - [ partial var tyVar ] - $ App (Var ss (Qualified Nothing UnusedIdent)) e + addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr + addPartialConstraint (bss, complete) e = + TypedValue True e $ + srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) srcTypeWildcard where - partial :: Text -> Text -> Declaration - partial var tyVar = - ValueDecl (ss, []) UnusedIdent Private [] - [MkUnguarded - (TypedValue - True - (Abs (VarBinder ss (Ident var)) (Var ss (Qualified Nothing (Ident var)))) - (ty tyVar)) - ] - - ty :: Text -> SourceType - ty tyVar = - srcForAll tyVar - Nothing - ( srcConstrainedType - (srcConstraint C.Partial [] [] (Just constraintData)) - $ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar) - ) - Nothing - constraintData :: ConstraintData constraintData = PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c0c37d042f..b5b3d0c4fa 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -75,6 +75,12 @@ data TypedValue' = TypedValue' Bool Expr SourceType tvToExpr :: TypedValue' -> Expr tvToExpr (TypedValue' c e t) = TypedValue c e t +-- | Lookup data about a type class in the @Environment@ +lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData +lookupTypeClass name = + let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name + in gets (findClass . typeClasses . checkEnv) + -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf @@ -116,8 +122,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- ambiguous types to be inferred if they can be solved by some functional -- dependency. conData <- forM unsolved $ \(_, _, con) -> do - let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con) - TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) + TypeClassData{ typeClassDependencies } <- lookupTypeClass $ constraintClass con let -- The set of unknowns mentioned in each argument. unknownsForArg :: [S.Set Int] @@ -670,8 +675,11 @@ check' val (ForAll ann ident mbK ty _) = do | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _ _) ty) = do - dictName <- freshIdent ("dict" <> className) +check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do + TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls + -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` + -- that wraps empty dictionary solutions in `Unused`. + dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t diff --git a/tests/purs/failing/2806.out b/tests/purs/failing/2806.out index b089ac5a1b..f5daaaf170 100644 --- a/tests/purs/failing/2806.out +++ b/tests/purs/failing/2806.out @@ -9,13 +9,10 @@ at tests/purs/failing/2806.purs:6:1 - 6:29 (line 6, column 1 - line 6, column 29 Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t1 -> t1 - to argument case e of  -  e | L x <- e -> x -while checking that expression $__unused (case e of  -  e | L x <- e -> x -  )  +while checking that type Partial => t1 + is at least as general as type a0 +while checking that expression case e of  +  e | L x <- e -> x has type a0 in value declaration g diff --git a/tests/purs/failing/NonExhaustivePatGuard.out b/tests/purs/failing/NonExhaustivePatGuard.out index 51b24a58fd..18d547672b 100644 --- a/tests/purs/failing/NonExhaustivePatGuard.out +++ b/tests/purs/failing/NonExhaustivePatGuard.out @@ -9,13 +9,10 @@ at tests/purs/failing/NonExhaustivePatGuard.purs:4:1 - 4:16 (line 4, column 1 - Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t0 -> t0 - to argument case x of  -  x | 1 <- x -> x -while checking that expression $__unused (case x of  -  x | 1 <- x -> x -  )  +while checking that type Partial => t0 + is at least as general as type Int +while checking that expression case x of  +  x | 1 <- x -> x has type Int in value declaration f diff --git a/tests/purs/failing/Superclasses5.out b/tests/purs/failing/Superclasses5.out index 2e708648e2..9514bdf756 100644 --- a/tests/purs/failing/Superclasses5.out +++ b/tests/purs/failing/Superclasses5.out @@ -9,15 +9,10 @@ at tests/purs/failing/Superclasses5.purs:17:1 - 18:18 (line 17, column 1 - line Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t0 -> t0 - to argument case $0 of  -  [ x ] -> [ su x -  ]  -while inferring the type of $__unused (case $0 of  -  [ x ] -> [ ... -  ]  -  )  +while checking that expression case $0 of  +  [ x ] -> [ su x +  ]  + has type t0 in value declaration suArray where t0 is an unknown type