diff --git a/changelog.d/20260709_114305_unisay_known_ctor_through_let.md b/changelog.d/20260709_114305_unisay_known_ctor_through_let.md new file mode 100644 index 00000000..d13ae962 --- /dev/null +++ b/changelog.d/20260709_114305_unisay_known_ctor_through_let.md @@ -0,0 +1,21 @@ +### Added + +- Case-of-known-constructor through a let-bound scrutinee in the IR optimizer + (#214). When a `Standalone` Let binding's RHS is a saturated constructor + application and the binder is read only through constructor-eliminating reads, + the reads fold: `ReflectCtor v` becomes the tag string, and each field read + (`ObjectProp v "valueᵢ"`, `DataArgumentByIndex i v`) becomes a fresh + field-binder bound once to the iᵗʰ argument — GHC's case-binder to + field-binder split, so a non-trivial argument read at several sites is + evaluated once, not duplicated. The binding is then dropped, its unread + arguments discarded with the same licence `reduceKnownConstructor` drops a + field read's siblings. Trivial and dead field-binders inline or DCE away, and + the folded reads let the surrounding `Eq` / `if` collapse to its live arm, + reaching the case-of-known-constructor payoff of #177 through a Let. This + extends the in-place fold to the multiply-read scrutinee that beta reduction + Let-binds — the shape a dictionary method's several scrutinee reads produce — + so it is the enabler that makes dictionary-method inlining (#180) pay off. The + rule declines when the binder is read as a whole value, which dropping it + would dangle and keeping it would duplicate the arguments. Standalone impact + is near zero: the shape only shows up once #180 inlines a dictionary method, + so on its own this pass leaves generated code essentially unchanged. diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs index 4a48bcae..0b55405b 100644 --- a/lib/Language/PureScript/Backend/IR/Optimizer.hs +++ b/lib/Language/PureScript/Backend/IR/Optimizer.hs @@ -1,5 +1,6 @@ module Language.PureScript.Backend.IR.Optimizer where +import Control.Lens (over, toListOf) import Control.Monad.Writer.CPS (WriterT, runWriterT, tell) import Data.Foldable (foldrM) import Data.List qualified as List @@ -13,7 +14,9 @@ import Language.PureScript.Backend.IR.Inliner (Annotation (..)) import Language.PureScript.Backend.IR.Linker (UberModule (..)) import Language.PureScript.Backend.IR.MagicDo (magicDo) import Language.PureScript.Backend.IR.Names - ( Name (..) + ( FieldName + , Name (..) + , PropName , QName , Qualified (Local) , qualifiedQName @@ -28,7 +31,7 @@ import Language.PureScript.Backend.IR.Pass , runSteps , runStepsChecked ) -import Language.PureScript.Backend.IR.Supply (SupplyM, runSupply) +import Language.PureScript.Backend.IR.Supply (SupplyM, freshName, runSupply) import Language.PureScript.Backend.IR.Types ( AlgebraicType (SumType) , Ann @@ -47,6 +50,7 @@ import Language.PureScript.Backend.IR.Types , isForeignImport , isNonRecursiveLiteral , lets + , listGrouping , literalBool , literalFloat , literalInt @@ -55,6 +59,7 @@ import Language.PureScript.Backend.IR.Types , primNot , rewriteExpBottomUpM , setAnn + , subexpressions , substituteCopyM , substituteMoveM , thenRewrite @@ -382,6 +387,7 @@ optimizedExpressionM = ( constantFolding `thenRewrite` reduceObjectProp `thenRewrite` reduceKnownConstructor + `thenRewrite` propagateKnownCtorThroughLet `thenRewrite` betaReduce `thenRewrite` removeUnreachableThenBranch `thenRewrite` removeUnreachableElseBranch @@ -607,6 +613,171 @@ reduceKnownConstructor = Just (setAnn ann arg) _ → Nothing +{- | Case-of-known-constructor through a let-bound scrutinee (issue #214). + +'reduceKnownConstructor' only fires on a constructor that is in place, and a +scrutinee read more than once is never in place: 'betaReduce' Let-binds a +non-trivial argument rather than substitute it (Note [Beta reduction and +local inlining share an inlining guard]), and a dictionary method reads its +scrutinee several times — a tag test, a payload read, a fallthrough tag +test. So an inlined and beta-reduced method lands on + +> let v = Just (x + 1) in +> if justTag == ReflectCtor v then … v.value0 … +> else if nothingTag == ReflectCtor v then Nothing else … + +and nothing folds: the rules see @ReflectCtor (Ref v)@ and +@ObjectProp (Ref v) "value0"@, never the constructor. + +This propagates a known constructor from a 'Standalone' Let binding into the +binder's reads. When the RHS is a saturated 'Ctor' application and the binder +is read /only/ through constructor-eliminating reads: + + * each @ReflectCtor v@ becomes the tag string (sum types only, as in + 'reduceKnownConstructor'); + * each field read (@ObjectProp v "valueᵢ"@, @DataArgumentByIndex i v@) + becomes a fresh field-binder @fᵢ@ bound once to the iᵗʰ argument — GHC's + case-binder to field-binder split, so an argument read at several sites + is evaluated once, not duplicated (the discipline 'betaReduce' keeps); + * the @v@ binding is dropped, its unread arguments discarded with the same + licence 'reduceKnownConstructor' drops a field read's siblings. + +Trivial and dead field-binders then inline or DCE away, and the folded reads +let the surrounding @Eq@ / @if@ meet 'constantFolding' and +'removeUnreachable*', collapsing the decision tree to its live arm. + +The rule declines when the binder is read as a whole value — a sibling RHS, +or a non-eliminating position such as an argument to a function. Dropping it +would dangle the reference, and keeping it while binding the fields would +duplicate the arguments. A product-type @ReflectCtor@ read has no tag row to +fold to, so it too leaves a whole-value read and the rule declines. GUC keeps +the fresh field-binders unique and the binder resolved by name. +-} +propagateKnownCtorThroughLet ∷ RewriteRuleM SupplyM Ann +propagateKnownCtorThroughLet = \case + Let ann groupings body + | Just (before, (name, algTy, fields, args, tag), after) ← + findCtorBinding (toList groupings) + , all ((== 0) . countFreeRefGrouping name) (before <> after) + , countFreeRef (Local name) body > 0 + , not (hasWholeValueRead name algTy fields body) → do + let readIndices = readFieldIndices name fields body + freshFields ← + Map.fromList + <$> traverse + (\i → (i,) <$> freshName "$field") + (toList readIndices) + let body' = foldCtorReads name algTy tag fields freshFields body + fieldBinds = + [ Standalone (Nothing, f, arg) + | (i, f) ← Map.toAscList freshFields + , Just arg ← [args !!? fromIntegral i] + ] + pure . Just $ case nonEmpty (before <> fieldBinds <> after) of + Nothing → body' + Just gs → Let ann gs body' + _ → pure Nothing + where + -- The first Standalone binding whose RHS is a saturated constructor + -- application, split out from its siblings. + findCtorBinding + ∷ [Grouping (Ann, Name, Exp)] + → Maybe + ( [Grouping (Ann, Name, Exp)] + , (Name, AlgebraicType, [FieldName], [Exp], Text) + , [Grouping (Ann, Name, Exp)] + ) + findCtorBinding = go [] + where + go + ∷ [Grouping (Ann, Name, Exp)] + → [Grouping (Ann, Name, Exp)] + → Maybe + ( [Grouping (Ann, Name, Exp)] + , (Name, AlgebraicType, [FieldName], [Exp], Text) + , [Grouping (Ann, Name, Exp)] + ) + go _before [] = Nothing + go before (grouping : after) = case grouping of + Standalone (_bAnn, name, rhs) + | (Ctor _ algTy modName tyName ctorName fields, args) ← unwindApp rhs + , length args == length fields + , -- A self-referencing RHS cannot arise under GUC (a Standalone RHS + -- does not see its own binder), but 'optimizedExpression' also runs + -- on non-GUC input; dropping the binding would then dangle the + -- field-binder that copied the reference (cf. 'inlineLocalBinding'). + countFreeRef (Local name) rhs == 0 → + Just + ( reverse before + , (name, algTy, fields, args, ctorId modName tyName ctorName) + , after + ) + _ → go (grouping : before) after + + countFreeRefGrouping ∷ Name → Grouping (Ann, Name, Exp) → Natural + countFreeRefGrouping name grouping = + sum [countFreeRef (Local name) e | (_ann, _n, e) ← listGrouping grouping] + + -- True when some @Ref name@ is reached other than through a foldable + -- eliminating read — the residue that would dangle if the binding dropped. + hasWholeValueRead ∷ Name → AlgebraicType → [FieldName] → Exp → Bool + hasWholeValueRead name algTy fields = go + where + go = \case + ReflectCtor _ (Ref _ (Local n)) | n == name, SumType ← algTy → False + ObjectProp _ (Ref _ (Local n)) prop + | n == name, isJust (fieldIndex fields prop) → False + -- An out-of-range index reads no existing field, so it is not a + -- foldable eliminating read: it falls through to the whole-value read + -- below, forcing the rule to decline (as 'reduceKnownConstructor' + -- does), rather than minting a fresh field-binder the argument list + -- cannot bind. Well-typed input never indexes past the arity; the + -- guard keeps the rule sound on the non-GUC / generated input + -- 'optimizedExpression' also runs on. + DataArgumentByIndex _ i (Ref _ (Local n)) + | n == name, i < fromIntegral (length fields) → False + Ref _ (Local n) | n == name → True + other → any go (toListOf subexpressions other) + + readFieldIndices ∷ Name → [FieldName] → Exp → Set Natural + readFieldIndices name fields = go + where + go e = self e <> foldMap go (toListOf subexpressions e) + self = \case + ObjectProp _ (Ref _ (Local n)) prop + | n == name, Just i ← fieldIndex fields prop → Set.singleton i + DataArgumentByIndex _ i (Ref _ (Local n)) | n == name → Set.singleton i + _ → mempty + + foldCtorReads + ∷ Name + → AlgebraicType + → Text + → [FieldName] + → Map Natural Name + → Exp + → Exp + foldCtorReads name algTy tag fields freshFields = go + where + go = \case + ReflectCtor rcAnn (Ref _ (Local n)) + | n == name, SumType ← algTy → LiteralString rcAnn tag + ObjectProp opAnn (Ref _ (Local n)) prop + | n == name + , Just i ← fieldIndex fields prop + , Just f ← Map.lookup i freshFields → + Ref opAnn (Local f) + DataArgumentByIndex daAnn i (Ref _ (Local n)) + | n == name + , Just f ← Map.lookup i freshFields → + Ref daAnn (Local f) + other → over subexpressions go other + + fieldIndex ∷ [FieldName] → PropName → Maybe Natural + fieldIndex fields prop = + fromIntegral + <$> List.findIndex ((renderPropName prop ==) . renderFieldName) fields + {- Note [Beta reduction and local inlining share an inlining guard] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'betaReduce' and 'inlineLocalBinding' decide whether to paste an expression diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index 9f2bb864..badc5ffd 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -529,6 +529,182 @@ spec = describe "IR Optimizer" do optimizedExpression (objectProp app (PropName ("value" <> show index))) === kept + describe "propagates a known constructor through a let (#214)" do + let m = moduleNameFromString "M" + maybeMod = moduleNameFromString "Data.Maybe" + maybeTy = TyName "Maybe" + justName = CtorName "Just" + nothingName = CtorName "Nothing" + justCtor = ctor SumType maybeMod maybeTy justName [FieldName "value0"] + nothingCtor = ctor SumType maybeMod maybeTy nothingName [] + just = application justCtor + justTag = ctorId maybeMod maybeTy justName + nothingTag = ctorId maybeMod maybeTy nothingName + value0 = PropName "value0" + + tupleMod = moduleNameFromString "Data.Tuple" + tupleTy = TyName "Tuple" + tupleCtor = + ctor + ProductType + tupleMod + tupleTy + (CtorName "Tuple") + [FieldName "value0", FieldName "value1"] + + -- An application: re-evaluating it would repeat the work, so it is + -- the shape the field-binder must not duplicate. + nonTrivial = application (refImported m (Name "g")) (literalInt 1) + + here = refLocal (Name "here") + gone = refLocal (Name "gone") + + it "folds a tag read through the let and collapses to the live branch" do + -- The key unlock: with the tag folded the surrounding Eq/if meets + -- constant folding and the unreachable-branch rules. + let original = + let1 (Name "v") nothingCtor $ + ifThenElse + (eq (literalString nothingTag) (reflectCtor (refLocal (Name "v")))) + here + gone + optimizedExpression original `shouldBe` here + + it "drops the constructor payload when only the tag is read" do + -- The payload is never read, so it is discarded with the binding, + -- the same licence the in-place fold has for a field read's siblings. + let original = + let1 (Name "v") (just nonTrivial) $ + ifThenElse + (eq (literalString justTag) (reflectCtor (refLocal (Name "v")))) + here + gone + optimizedExpression original `shouldBe` here + + it "binds a field read at several sites once (no duplication)" do + -- v.value0 read twice with a non-trivial argument: the argument is + -- bound to one field-binder read twice, never copied to each site. + let original = + let1 (Name "v") (just nonTrivial) $ + application + ( application + (refImported m (Name "pair")) + (objectProp (refLocal (Name "v")) value0) + ) + (objectProp (refLocal (Name "v")) value0) + -- The field-binder's name is whatever the fresh-name supply draws; + -- compare up to alpha-equivalence so the test pins the structure -- + -- one field-binder bound once, read twice -- not the incidental name. + field = Name "$field0" + expected = + let1 + field + nonTrivial + ( application + (application (refImported m (Name "pair")) (refLocal field)) + (refLocal field) + ) + optimizedExpression original `shouldSatisfy` alphaEq expected + + it "declines when the binder is read as a whole value" do + -- v flows into a function as a whole value, so it cannot be dropped + -- (nor is it inlinable, so the binding survives untouched). + let original = + let1 (Name "v") (just (literalInt 1)) $ + application + (application (refImported m (Name "pair")) (refLocal (Name "v"))) + (refLocal (Name "v")) + optimizedExpression original `shouldBe` original + + it "declines a partially applied constructor binding" do + -- Tuple has two fields; one argument leaves it a function, so the + -- binding is not a saturated constructor. + let original = + let1 (Name "v") (application tupleCtor (literalInt 1)) $ + eq + (dataArgumentByIndex 0 (refLocal (Name "v"))) + (dataArgumentByIndex 0 (refLocal (Name "v"))) + optimizedExpression original `shouldBe` original + + it "collapses an inlined-method match to straight-line code" do + -- End to end through the checked pipeline: it runs DCE (so the + -- field-binder inlines and the dropped binding disappears) and lints + -- every pass's contract, so a GUC or scoping violation from folding + -- through the Let would fail here rather than pass silently. 'main' is + -- exported twice so it is not itself inlined away, leaving its + -- optimized body to inspect (mirrors the leak-guard test above). + let mainMod = moduleNameFromString "Main" + body = + let1 (Name "v") (just (literalInt 1)) $ + ifThenElse + (eq (literalString justTag) (reflectCtor (refLocal (Name "v")))) + ( application + (refImported mainMod (Name "use")) + (objectProp (refLocal (Name "v")) value0) + ) + nothingCtor + optimized ← + either (fail . show) pure . optimizedUberModuleChecked $ + Linker.UberModule + { uberModuleForeigns = [] + , uberModuleBindings = + [Standalone (QName mainMod (Name "main"), body)] + , uberModuleExports = + [ (Name "r1", refImported mainMod (Name "main")) + , (Name "r2", refImported mainMod (Name "main")) + ] + } + let mainBody = + [ e + | Standalone (QName _ (Name "main"), e) ← + Linker.uberModuleBindings optimized + ] + mainBody + `shouldBe` [application (refImported mainMod (Name "use")) (literalInt 1)] + + prop "eliminates the binding without growing the reference multiset" do + -- Across scalar payloads, folding drops v (proof the rule fired: with + -- the constructor Let-bound, nothing else can) and never invents or + -- multiplies a free reference. + payload ← forAll Gen.scalarExp + let original = + let1 (Name "v") (just payload) $ + ifThenElse + (eq (literalString justTag) (reflectCtor (refLocal (Name "v")))) + ( application + (refImported m (Name "use")) + (objectProp (refLocal (Name "v")) value0) + ) + gone + optimized = optimizedExpression original + countFreeRef (Local (Name "v")) optimized === 0 + Map.isSubmapOfBy (<=) (countFreeRefs optimized) (countFreeRefs original) + === True + + prop "declines an out-of-range field read, staying well-scoped" do + -- A DataArgumentByIndex past the constructor's arity reads no existing + -- field: folding it would mint a fresh field-binder the (saturated) + -- argument list cannot bind, then drop the ctor binding, stranding both. + -- The rule must decline and leave the term well-scoped. Well-typed CoreFn + -- never indexes past the arity, so the shape is fuzzed structurally -- + -- the arity is random and the index may exceed it -- and the oracle is + -- well-scopedness (a stranded binder shows up as an unbound local). This + -- is the guard the reviewer had to point out by hand; the property now + -- exercises it. + arity ← forAll (Gen.int (Range.linear 0 3)) + index ← forAll (Gen.integral (Range.linear 0 5)) + let fields = + [FieldName (Text.pack ("value" <> show k)) | k ← [0 .. arity - 1]] + ctorApp = + foldl' + application + (ctor SumType m (TyName "T") (CtorName "K") fields) + (replicate arity (literalInt 1)) + original = + let1 (Name "v") ctorApp $ + dataArgumentByIndex index (refLocal (Name "v")) + unboundLocals (optimizedExpression original) === [] + -- See Note [Folding primops follows Lua 5.1] in the optimizer. describe "folds primops (#178)" do it "folds integer arithmetic exactly" do