From 24f8b1fbe6b5dc965c1afe49bacfe27c27bdbb7e Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 5 Oct 2023 07:40:31 -0700 Subject: [PATCH 1/3] Float top-level lets This floats immediate top-level lets into proper top-level bindings, opening up additional optimizations (as the let no longer potentially blocks inlining) while increasing sharing (we don't have to inline the let bindings too). --- .../snapshots-out/Snapshot.EffectBind01.js | 18 +- .../snapshots-out/Snapshot.Heterogeneous01.js | 8 +- .../test/snapshots-out/Snapshot.Html.js | 16 +- .../Snapshot.InlineArrayIndex.js | 22 +- .../snapshots-out/Snapshot.PrimOpIntDiv.js | 16 +- .../Snapshot.RecursionSchemes01.js | 30 +- .../Snapshot.RecursiveBindingGroup02.js | 22 +- .../test/snapshots-out/Snapshot.Tco03.js | 102 ++++--- backend-es/test/snapshots/Snapshot.Tco03.purs | 11 + src/PureScript/Backend/Optimizer/Convert.purs | 269 +++++++++++++----- 10 files changed, 331 insertions(+), 183 deletions(-) diff --git a/backend-es/test/snapshots-out/Snapshot.EffectBind01.js b/backend-es/test/snapshots-out/Snapshot.EffectBind01.js index f32a44f3..d57d1056 100644 --- a/backend-es/test/snapshots-out/Snapshot.EffectBind01.js +++ b/backend-es/test/snapshots-out/Snapshot.EffectBind01.js @@ -1,11 +1,9 @@ import * as Effect$dConsole from "../Effect.Console/index.js"; -const test1 = /* #__PURE__ */ (() => { - const $0 = Effect$dConsole.log("1"); - return () => { - $0(); - const value = Effect$dConsole.log("2")(); - Effect$dConsole.log("3")(); - return value; - }; -})(); -export {test1}; +const test1$d0 = /* #__PURE__ */ Effect$dConsole.log("1"); +const test1 = () => { + test1$d0(); + const value = Effect$dConsole.log("2")(); + Effect$dConsole.log("3")(); + return value; +}; +export {test1, test1$d0}; diff --git a/backend-es/test/snapshots-out/Snapshot.Heterogeneous01.js b/backend-es/test/snapshots-out/Snapshot.Heterogeneous01.js index a1ea9bc9..012b4aec 100644 --- a/backend-es/test/snapshots-out/Snapshot.Heterogeneous01.js +++ b/backend-es/test/snapshots-out/Snapshot.Heterogeneous01.js @@ -3,9 +3,7 @@ // @inline Heterogeneous.Mapping.mapRecordWithIndexCons arity=5 // @inline Heterogeneous.Mapping.mapRecordWithIndexNil.mapRecordWithIndexBuilder arity=2 import * as Data$dTuple from "../Data.Tuple/index.js"; -const test2 = /* #__PURE__ */ (() => { - const $0 = Data$dTuple.Tuple("bar"); - return r1 => ({...r1, a: 1 + r1.a | 0, b: $0(r1.b), c: !r1.c}); -})(); +const test2$d0 = /* #__PURE__ */ Data$dTuple.Tuple("bar"); +const test2 = r1 => ({...r1, a: 1 + r1.a | 0, b: test2$d0(r1.b), c: !r1.c}); const test1 = {a: 13, b: /* #__PURE__ */ Data$dTuple.$Tuple("bar", 42.0), c: false}; -export {test1, test2}; +export {test1, test2, test2$d0}; diff --git a/backend-es/test/snapshots-out/Snapshot.Html.js b/backend-es/test/snapshots-out/Snapshot.Html.js index 0aa93981..12110453 100644 --- a/backend-es/test/snapshots-out/Snapshot.Html.js +++ b/backend-es/test/snapshots-out/Snapshot.Html.js @@ -1,19 +1,13 @@ const $Html = (tag, _1, _2) => ({tag, _1, _2}); const Elem = value0 => value1 => $Html("Elem", value0, value1); const Text = value0 => $Html("Text", value0); -const h11 = /* #__PURE__ */ (() => { - const $0 = Elem("h1"); - return x => $0([x]); -})(); -const h21 = /* #__PURE__ */ (() => { - const $0 = Elem("h2"); - return x => $0([x]); -})(); +const h11$d0 = /* #__PURE__ */ Elem("h1"); +const h21$d0 = /* #__PURE__ */ Elem("h2"); const p1 = /* #__PURE__ */ Elem("p"); const section1 = /* #__PURE__ */ Elem("section"); const article1 = /* #__PURE__ */ Elem("article"); const test = user => section1([ - h11($Html("Text", "Posts for " + user)), - article1([h21($Html("Text", "The first post")), p1([$Html("Text", "This is the first post."), $Html("Text", "Not much else to say.")])]) + h11$d0([$Html("Text", "Posts for " + user)]), + article1([h21$d0([$Html("Text", "The first post")]), p1([$Html("Text", "This is the first post."), $Html("Text", "Not much else to say.")])]) ]); -export {$Html, Elem, Text, article1, h11, h21, p1, section1, test}; +export {$Html, Elem, Text, article1, h11$d0, h21$d0, p1, section1, test}; diff --git a/backend-es/test/snapshots-out/Snapshot.InlineArrayIndex.js b/backend-es/test/snapshots-out/Snapshot.InlineArrayIndex.js index d06ee4d3..43ce3d38 100644 --- a/backend-es/test/snapshots-out/Snapshot.InlineArrayIndex.js +++ b/backend-es/test/snapshots-out/Snapshot.InlineArrayIndex.js @@ -19,15 +19,13 @@ const testArrayIndex = arr => ix => { if (ix >= 0 && ix < arr.length) { return Data$dMaybe.$Maybe("Just", arr[ix]); } return Data$dMaybe.Nothing; }; -const main = /* #__PURE__ */ (() => { - const array = [1, 2, 3]; - const $0 = assertEqual("index -1")({expected: Data$dMaybe.Nothing, actual: testArrayIndex(array)(-1)}); - return () => { - $0(); - assertEqual("index 0")({expected: Data$dMaybe.$Maybe("Just", 1), actual: testArrayIndex(array)(0)})(); - assertEqual("index 1")({expected: Data$dMaybe.$Maybe("Just", 2), actual: testArrayIndex(array)(1)})(); - assertEqual("index 2")({expected: Data$dMaybe.$Maybe("Just", 3), actual: testArrayIndex(array)(2)})(); - return assertEqual("index 3")({expected: Data$dMaybe.Nothing, actual: testArrayIndex(array)(3)})(); - }; -})(); -export {assertEqual, main, testArrayIndex}; +const main$darray = [1, 2, 3]; +const main$d0 = /* #__PURE__ */ assertEqual("index -1")({expected: Data$dMaybe.Nothing, actual: /* #__PURE__ */ testArrayIndex(main$darray)(-1)}); +const main = () => { + main$d0(); + assertEqual("index 0")({expected: Data$dMaybe.$Maybe("Just", 1), actual: testArrayIndex(main$darray)(0)})(); + assertEqual("index 1")({expected: Data$dMaybe.$Maybe("Just", 2), actual: testArrayIndex(main$darray)(1)})(); + assertEqual("index 2")({expected: Data$dMaybe.$Maybe("Just", 3), actual: testArrayIndex(main$darray)(2)})(); + return assertEqual("index 3")({expected: Data$dMaybe.Nothing, actual: testArrayIndex(main$darray)(3)})(); +}; +export {assertEqual, main, main$d0, main$darray, testArrayIndex}; diff --git a/backend-es/test/snapshots-out/Snapshot.PrimOpIntDiv.js b/backend-es/test/snapshots-out/Snapshot.PrimOpIntDiv.js index ac4ffc44..dce97160 100644 --- a/backend-es/test/snapshots-out/Snapshot.PrimOpIntDiv.js +++ b/backend-es/test/snapshots-out/Snapshot.PrimOpIntDiv.js @@ -4,12 +4,10 @@ import * as Assert from "../Assert/index.js"; import * as Data$dEq from "../Data.Eq/index.js"; import * as Data$dShow from "../Data.Show/index.js"; const divNoInline = a => b => $runtime.intDiv(a, b); -const main = /* #__PURE__ */ (() => { - const $0 = Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div1")({expected: 0, actual: divNoInline(1)(0)}); - return () => { - $0(); - Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div2")({expected: 1, actual: divNoInline(3)(2)})(); - return Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div3")({expected: -1, actual: divNoInline(3)(-2)})(); - }; -})(); -export {divNoInline, main}; +const main$d0 = /* #__PURE__ */ Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div1")({expected: 0, actual: /* #__PURE__ */ divNoInline(1)(0)}); +const main = () => { + main$d0(); + Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div2")({expected: 1, actual: divNoInline(3)(2)})(); + return Assert.assertEqual(Data$dEq.eqInt)(Data$dShow.showInt)("div3")({expected: -1, actual: divNoInline(3)(-2)})(); +}; +export {divNoInline, main, main$d0}; diff --git a/backend-es/test/snapshots-out/Snapshot.RecursionSchemes01.js b/backend-es/test/snapshots-out/Snapshot.RecursionSchemes01.js index 195e2db0..d6b42126 100644 --- a/backend-es/test/snapshots-out/Snapshot.RecursionSchemes01.js +++ b/backend-es/test/snapshots-out/Snapshot.RecursionSchemes01.js @@ -13,22 +13,16 @@ const functorExprF = { $runtime.fail(); } }; -const test1 = /* #__PURE__ */ (() => { - const go = v => { - if (v.tag === "Add") { return go(v._1) + go(v._2) | 0; } - if (v.tag === "Mul") { return go(v._1) * go(v._2) | 0; } - if (v.tag === "Lit") { return v._1; } - $runtime.fail(); - }; - return go; -})(); -const test2 = /* #__PURE__ */ (() => { - const go = v => { - if (v.tag === "Add") { return go(v._1) + go(v._2) | 0; } - if (v.tag === "Mul") { return go(v._1) * go(v._2) | 0; } - if (v.tag === "Lit") { return v._1 + 1 | 0; } - $runtime.fail(); - }; - return go; -})(); +const test1 = v => { + if (v.tag === "Add") { return test1(v._1) + test1(v._2) | 0; } + if (v.tag === "Mul") { return test1(v._1) * test1(v._2) | 0; } + if (v.tag === "Lit") { return v._1; } + $runtime.fail(); +}; +const test2 = v => { + if (v.tag === "Add") { return test2(v._1) + test2(v._2) | 0; } + if (v.tag === "Mul") { return test2(v._1) * test2(v._2) | 0; } + if (v.tag === "Lit") { return v._1 + 1 | 0; } + $runtime.fail(); +}; export {$ExprF, Add, Lit, Mul, functorExprF, test1, test2}; diff --git a/backend-es/test/snapshots-out/Snapshot.RecursiveBindingGroup02.js b/backend-es/test/snapshots-out/Snapshot.RecursiveBindingGroup02.js index 43ec9239..15f5beb8 100644 --- a/backend-es/test/snapshots-out/Snapshot.RecursiveBindingGroup02.js +++ b/backend-es/test/snapshots-out/Snapshot.RecursiveBindingGroup02.js @@ -1,14 +1,12 @@ // @fails Binding demanded before initialized import * as $runtime from "../runtime.js"; -const test = /* #__PURE__ */ (() => { - const test3 = n => { - if (n < 100) { return n; } - return test1$lazy().bar; - }; - const test2$lazy = $runtime.binding(() => ({baz: test1$lazy().bar})); - const test1$lazy = $runtime.binding(() => ({foo: test2$lazy().baz, bar: test3(42)})); - const test2 = test2$lazy(); - const test1 = test1$lazy(); - return test1.bar; -})(); -export {test}; +const test$dtest3 = n => { + if (n < 100) { return n; } + return test$dtest1$lazy().bar; +}; +const test$dtest2$lazy = /* #__PURE__ */ $runtime.binding(() => ({baz: test$dtest1$lazy().bar})); +const test$dtest1$lazy = /* #__PURE__ */ $runtime.binding(() => ({foo: test$dtest2$lazy().baz, bar: test$dtest3(42)})); +const test$dtest2 = /* #__PURE__ */ test$dtest2$lazy(); +const test$dtest1 = /* #__PURE__ */ test$dtest1$lazy(); +const test = /* #__PURE__ */ (() => test$dtest1.bar)(); +export {test, test$dtest1, test$dtest2, test$dtest3}; diff --git a/backend-es/test/snapshots-out/Snapshot.Tco03.js b/backend-es/test/snapshots-out/Snapshot.Tco03.js index db828d06..44a24bd0 100644 --- a/backend-es/test/snapshots-out/Snapshot.Tco03.js +++ b/backend-es/test/snapshots-out/Snapshot.Tco03.js @@ -1,39 +1,71 @@ -const test = /* #__PURE__ */ (() => { - const go = go$a0$copy => { - let go$a0 = go$a0$copy, go$c = true, go$r; - while (go$c) { - const n = go$a0; - const k = k$a0$copy => { - let k$a0 = k$a0$copy, k$c = true, k$r; - while (k$c) { - const m = k$a0; - if (m === 100) { - k$c = false; - go$a0 = m - 1 | 0; - continue; - } - if (m === 900) { - go$c = k$c = false; - go$r = 42; - continue; - } - k$a0 = m - 1 | 0; +const test2 = test2$a0$copy => { + let test2$a0 = test2$a0$copy, test2$c = true, test2$r; + while (test2$c) { + const n = test2$a0; + const k = k$a0$copy => { + let k$a0 = k$a0$copy, k$c = true, k$r; + while (k$c) { + const m = k$a0; + if (m === 100) { + k$c = false; + test2$a0 = m - 1 | 0; + continue; } - return k$r; - }; - if (n === 0) { - go$c = false; - go$r = n; - continue; + if (m === 900) { + test2$c = k$c = false; + test2$r = 42; + continue; + } + k$a0 = m - 1 | 0; } - if (n <= 100) { - go$a0 = n - 1 | 0; - continue; + return k$r; + }; + if (n === 0) { + test2$c = false; + test2$r = n; + continue; + } + if (n <= 100) { + test2$a0 = n - 1 | 0; + continue; + } + k(n - 1 | 0); + } + return test2$r; +}; +const test = test$a0$copy => { + let test$a0 = test$a0$copy, test$c = true, test$r; + while (test$c) { + const n = test$a0; + const k = k$a0$copy => { + let k$a0 = k$a0$copy, k$c = true, k$r; + while (k$c) { + const m = k$a0; + if (m === 100) { + k$c = false; + test$a0 = m - 1 | 0; + continue; + } + if (m === 900) { + test$c = k$c = false; + test$r = 42; + continue; + } + k$a0 = m - 1 | 0; } - k(n - 1 | 0); + return k$r; + }; + if (n === 0) { + test$c = false; + test$r = n; + continue; + } + if (n <= 100) { + test$a0 = n - 1 | 0; + continue; } - return go$r; - }; - return go; -})(); -export {test}; + k(n - 1 | 0); + } + return test$r; +}; +export {test, test2}; diff --git a/backend-es/test/snapshots/Snapshot.Tco03.purs b/backend-es/test/snapshots/Snapshot.Tco03.purs index 64cef0b1..2ffcb145 100644 --- a/backend-es/test/snapshots/Snapshot.Tco03.purs +++ b/backend-es/test/snapshots/Snapshot.Tco03.purs @@ -14,3 +14,14 @@ test = go if m == 100 then go (m - 1) else if m == 900 then 42 else k (m - 1) + +test2 :: Int -> Int +test2 n = + if n == 0 then n + else if n <= 100 then test2 (n - 1) + else do k (n - 1) + where + k m = + if m == 100 then test2 (m - 1) + else if m == 900 then 42 + else k (m - 1) diff --git a/src/PureScript/Backend/Optimizer/Convert.purs b/src/PureScript/Backend/Optimizer/Convert.purs index b066c1df..2b919f6d 100644 --- a/src/PureScript/Backend/Optimizer/Convert.purs +++ b/src/PureScript/Backend/Optimizer/Convert.purs @@ -56,6 +56,7 @@ import Data.Foldable (foldMap, foldl) import Data.FoldableWithIndex (foldMapWithIndex, foldlWithIndex, foldrWithIndex) import Data.Function (on) import Data.FunctorWithIndex (mapWithIndex) +import Data.Lazy (defer) import Data.Map (Map, SemigroupMap(..)) import Data.Map as Map import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe) @@ -70,10 +71,10 @@ import Data.Traversable (class Foldable, Accum, foldr, for, mapAccumL, mapAccumR import Data.TraversableWithIndex (forWithIndex) import Data.Tuple (Tuple(..), fst, snd) import Partial.Unsafe (unsafeCrashWith, unsafePartial) -import PureScript.Backend.Optimizer.Analysis (BackendAnalysis, analyze, analyzeEffectBlock) +import PureScript.Backend.Optimizer.Analysis (BackendAnalysis(..), analysisOf, analyze, analyzeEffectBlock) import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment, ConstructorType(..), Expr(..), Guard(..), Ident(..), Literal(..), Meta(..), Module(..), ModuleName(..), ProperName, Qualified(..), ReExport, findProp, propKey, propValue, qualifiedModuleName, unQualified) import PureScript.Backend.Optimizer.Directives (DirectiveHeaderResult, parseDirectiveHeader) -import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx(..), DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, evalExternFromImpl, evalExternRefFromImpl, freeze, optimize) +import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics(..), Ctx(..), DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, eval, evalExternFromImpl, evalExternRefFromImpl, freeze, optimize, quote) import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval) import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..)) import PureScript.Backend.Optimizer.Utils (foldl1Array) @@ -220,106 +221,232 @@ toBackendTopLevelBindingGroups binds env = do result { value = (\as -> { recursive: (NonEmptyArray.head as).recursive, bindings: _.bindings =<< NonEmptyArray.toArray as }) <$> - Array.groupBy ((&&) `on` (not <<< _.recursive)) result.value + Array.groupBy ((&&) `on` (not <<< _.recursive)) (join result.value) } -toBackendTopLevelBindingGroup :: ConvertEnv -> Bind Ann -> Accum ConvertEnv (BackendBindingGroup Ident (WithDeps NeutralExpr)) +toBackendTopLevelBindingGroup :: ConvertEnv -> Bind Ann -> Accum ConvertEnv (Array (BackendBindingGroup Ident (WithDeps NeutralExpr))) toBackendTopLevelBindingGroup env = case _ of + NonRec binding -> do + let { floated, binding, directives, optimizationSteps, recursive } = toTopLevelBackendBinding env binding + let res1 = mapAccumL updateEnvForBindingGroup env floated + let res2 = updateEnvForBinding [] res1.accum binding + res2 + { accum + { directives = Map.union res2.accum.directives directives + , optimizationSteps = res2.accum.optimizationSteps <> optimizationSteps + } + , value = Array.snoc res1.value { bindings: [ res2.value ], recursive } + } Rec bindings -> do - let group = (\(Binding _ ident _) -> Qualified (Just env.currentModule) ident) <$> bindings - mapAccumL (toTopLevelBackendBinding group) env bindings - # overValue { recursive: true, bindings: _ } - NonRec binding -> - mapAccumL (toTopLevelBackendBinding []) env [ binding ] - # overValue { recursive: false, bindings: _ } + let + initGroup = (\(Binding _ ident _) -> Qualified (Just env.currentModule) ident) <$> bindings + res = mapAccumL + ( \env' binding -> do + let { floated, binding, directives, optimizationSteps } = toTopLevelBackendBinding env' binding + let regrouped = regroupBackendBindingGroups initGroup floated + let group = Array.nub $ initGroup <> map fst regrouped.bindings + let res1 = mapAccumL updateEnvForBindingGroup env' regrouped.free + let res2 = mapAccumL (updateEnvForBinding group) res1.accum regrouped.bindings + let res3 = updateEnvForBinding group res2.accum binding + { accum: res3.accum + { directives = Map.union res3.accum.directives directives + , optimizationSteps = res3.accum.optimizationSteps <> optimizationSteps + } + , value: + { free: res1.value + , bindings: Array.snoc res2.value res3.value + } + } + ) + env + bindings + res + { value = + Array.snoc (foldMap _.free res.value) + { bindings: foldMap _.bindings res.value + , recursive: true + } + } + +updateEnvForBindingGroup :: ConvertEnv -> BackendBindingGroup (Qualified Ident) BackendExpr -> Accum ConvertEnv (BackendBindingGroup Ident (WithDeps NeutralExpr)) +updateEnvForBindingGroup env bindingGroup = do + let group = if bindingGroup.recursive then fst <$> bindingGroup.bindings else [] + let res = mapAccumL (updateEnvForBinding group) env bindingGroup.bindings + res { value = bindingGroup { bindings = res.value } } + +updateEnvForBinding :: Array (Qualified Ident) -> ConvertEnv -> Tuple (Qualified Ident) BackendExpr -> Accum ConvertEnv (Tuple Ident (WithDeps NeutralExpr)) +updateEnvForBinding group env (Tuple qual expr) = do + let Tuple impl expr' = toExternImpl env group expr + { accum: env + { implementations = Map.insert qual impl env.implementations + , moduleImplementations = Map.insert qual impl env.moduleImplementations + } + , value: Tuple (unQualified qual) (Tuple (unwrap (fst impl)).deps expr') + } + +regroupBackendBindingGroups + :: Array (Qualified Ident) + -> Array (BackendBindingGroup (Qualified Ident) BackendExpr) + -> { free :: Array (BackendBindingGroup (Qualified Ident) BackendExpr) + , bindings :: Array (Tuple (Qualified Ident) BackendExpr) + } +regroupBackendBindingGroups = go [] where - overValue f a = - a { value = f a.value } + go acc group all = do + let { no, yes } = Array.partition (Array.any (addToGroup group <<< snd) <<< _.bindings) all + if Array.length no == Array.length all then + { free: no, bindings: acc } + else do + let newBindings = _.bindings =<< yes + go (acc <> newBindings) (group <> map fst newBindings) no + + addToGroup group expr = do + let (BackendAnalysis s) = analysisOf expr + Array.any (_ `Set.member` s.deps) group --- | For the NonEmptyArray, --- | - `head` = the original expression --- | - `last` = the final optimized expression --- | - everything in-between the two are the steps that were taken from `head` to `last` type OptimizationSteps = Array (Tuple (Qualified Ident) (NonEmptyArray BackendExpr)) -toTopLevelBackendBinding :: Array (Qualified Ident) -> ConvertEnv -> Binding Ann -> Accum ConvertEnv (Tuple Ident (WithDeps NeutralExpr)) -toTopLevelBackendBinding group env (Binding _ ident cfn) = do +type ConvertedBackendBinding = + { binding :: Tuple (Qualified Ident) BackendExpr + , directives :: InlineDirectiveMap + , floated :: Array (BackendBindingGroup (Qualified Ident) BackendExpr) + , optimizationSteps :: OptimizationSteps + , recursive :: Boolean + } + +toTopLevelBackendBinding :: ConvertEnv -> Binding Ann -> ConvertedBackendBinding +toTopLevelBackendBinding env (Binding _ ident cfn) = do let evalEnv = Env { currentModule: env.currentModule, evalExternRef: makeExternEvalRef env, evalExternSpine: makeExternEvalSpine env, locals: [], directives: env.directives } let qualifiedIdent = Qualified (Just env.currentModule) ident let backendExpr = toBackendExpr cfn env let enableTracing = Set.member qualifiedIdent env.traceIdents - let Tuple mbSteps optimizedExpr = optimize enableTracing (getCtx env) evalEnv qualifiedIdent env.rewriteLimit backendExpr - let Tuple impl expr' = toExternImpl env group optimizedExpr - { accum: env - { implementations = Map.insert qualifiedIdent impl env.implementations - , moduleImplementations = Map.insert qualifiedIdent impl env.moduleImplementations - , optimizationSteps = maybe env.optimizationSteps (Array.snoc env.optimizationSteps <<< Tuple qualifiedIdent) $ NonEmptyArray.fromArray mbSteps - , directives = - case inferTransitiveDirective env.directives (snd impl) backendExpr cfn of - Just dirs -> - Map.alter - case _ of - Just oldDirs -> - Just $ Map.union oldDirs dirs - Nothing -> - Just dirs - (EvalExtern (Qualified (Just env.currentModule) ident)) - env.directives - Nothing -> - env.directives - } - , value: Tuple ident (Tuple (unwrap (fst impl)).deps expr') + let quoteCtx = getCtx env + let Tuple steps optimizedExpr = optimize enableTracing quoteCtx evalEnv qualifiedIdent env.rewriteLimit backendExpr + let { expr: finalExpr, floated, recursive } = floatTopLevelBackendBindings quoteCtx evalEnv qualifiedIdent optimizedExpr + let directives = inferTransitiveDirective env.directives cfn backendExpr finalExpr + { floated + , binding: Tuple qualifiedIdent finalExpr + , directives: if Map.size directives > 0 then Map.singleton (EvalExtern qualifiedIdent) directives else Map.empty + , optimizationSteps: case NonEmptyArray.fromArray steps of + Just steps' -> [ Tuple qualifiedIdent steps' ] + Nothing -> [] + , recursive } -inferTransitiveDirective :: InlineDirectiveMap -> ExternImpl -> BackendExpr -> Expr Ann -> Maybe (Map InlineAccessor InlineDirective) -inferTransitiveDirective directives impl backendExpr cfn = fromImpl <|> fromBackendExpr +type FloatedBackendBinding = + { expr :: BackendExpr + , floated :: Array (BackendBindingGroup (Qualified Ident) BackendExpr) + , recursive :: Boolean + } + +floatTopLevelBackendBindings :: Ctx -> Env -> Qualified Ident -> BackendExpr -> FloatedBackendBinding +floatTopLevelBackendBindings quoteCtx evalEnv baseQual@(Qualified mod (Ident baseIdent)) = case _ of + ExprSyntax _ expr@(Let _ _ _ _) -> + go Map.empty [] $ eval evalEnv expr + ExprSyntax _ expr@(LetRec _ _ _) -> + go Map.empty [] $ eval evalEnv expr + other -> + { expr: other, floated: [], recursive: false } where - fromImpl = case impl of - ExternExpr _ (NeutralExpr (App (NeutralExpr (Var qual)) args)) -> - case Map.lookup (EvalExtern qual) directives of - Just dirs -> do + go used acc = case _ of + SemLet ident binding k -> do + let { accum: used', value: topLevelQual } = toTopLevelIdent used ident + let bindingExpr = quote quoteCtx binding + let group = { bindings: [ Tuple topLevelQual bindingExpr ], recursive: false } + go used' (Array.snoc acc group) $ k $ NeutVar topLevelQual + SemLetRec bindings k + | [ Tuple ident binding ] <- NonEmptyArray.toArray bindings -> do + let { accum: used', value: topLevelQual } = toTopLevelIdent used (Just ident) + let groupSems = NonEmptyArray.singleton (Tuple ident (defer \_ -> NeutVar topLevelQual)) + case k groupSems of + NeutVar qual | qual == topLevelQual -> do + let groupSems' = NonEmptyArray.singleton (Tuple ident (defer \_ -> NeutVar baseQual)) + { expr: quote quoteCtx (binding groupSems') + , floated: acc + , recursive: true + } + sem -> do + let bindingExpr = quote quoteCtx (binding groupSems) + let group = { bindings: [ Tuple topLevelQual bindingExpr ], recursive: true } + go used' (Array.snoc acc group) sem + | otherwise -> do + let { accum: used', value: topLevelQuals } = mapAccumL (\a -> toTopLevelIdent a <<< Just <<< fst) used bindings + let groupSems = NonEmptyArray.zipWith (\a b -> a $> defer \_ -> NeutVar b) bindings topLevelQuals let - newDirs = foldrWithIndex - ( \ix dir accum -> case ix, dir of - InlineRef, (InlineArity n) -> - accum - # Map.insert InlineRef (InlineArity (n - NonEmptyArray.length args)) - InlineSpineProp prop, _ -> - accum - # Map.insert (InlineProp prop) dir - # Map.insert (InlineSpineProp prop) dir - _, _ -> - accum + bindingExprs = NonEmptyArray.zipWith + ( \topLevelQual (Tuple _ binding) -> + Tuple topLevelQual (quote quoteCtx (binding groupSems)) ) - Map.empty - dirs - if Map.isEmpty newDirs then - Nothing - else - Just newDirs + topLevelQuals + bindings + let group = { bindings: NonEmptyArray.toArray bindingExprs, recursive: true } + go used' (Array.snoc acc group) $ k groupSems + other -> + { expr: quote quoteCtx other + , floated: acc + , recursive: true + } + + toTopLevelIdent used = case _ of + Just ident + | Just n <- Map.lookup ident used -> + { accum: Map.insert ident (n + 1) used + , value: Qualified mod $ Ident $ baseIdent <> "." <> unwrap ident <> "$" <> show n + } + | otherwise -> + { accum: Map.insert ident 1 used + , value: Qualified mod $ Ident $ baseIdent <> "." <> unwrap ident + } + Nothing -> do + let n = fromMaybe 0 $ Map.lookup (Ident "") used + { accum: Map.insert (Ident "") 1 used + , value: Qualified mod $ Ident $ baseIdent <> "." <> show n + } + +inferTransitiveDirective :: InlineDirectiveMap -> Expr Ann -> BackendExpr -> BackendExpr -> Map InlineAccessor InlineDirective +inferTransitiveDirective directives cfn originalExpr optimizedExpr = fromOptimized <|> fromOriginal + where + fromOptimized = case optimizedExpr of + ExprSyntax _ (App (ExprSyntax _ (Var qual)) args) -> + case Map.lookup (EvalExtern qual) directives of + Just dirs -> + foldrWithIndex + ( \ix dir accum -> case ix, dir of + InlineRef, (InlineArity n) -> + accum + # Map.insert InlineRef (InlineArity (n - NonEmptyArray.length args)) + InlineSpineProp prop, _ -> + accum + # Map.insert (InlineProp prop) dir + # Map.insert (InlineSpineProp prop) dir + _, _ -> + accum + ) + Map.empty + dirs _ -> - Nothing - ExternExpr _ (NeutralExpr (Accessor (NeutralExpr (App (NeutralExpr (Var qual)) _)) (GetProp prop))) -> + Map.empty + ExprSyntax _ (Accessor (ExprSyntax _ (App (ExprSyntax _ (Var qual)) _)) (GetProp prop)) -> case Map.lookup (EvalExtern qual) directives >>= Map.lookup (InlineSpineProp prop) of Just (InlineArity n) -> - Just $ Map.singleton InlineRef (InlineArity n) + Map.singleton InlineRef (InlineArity n) _ -> - Nothing + Map.empty _ -> - Nothing + Map.empty - fromBackendExpr = case backendExpr of + fromOriginal = case originalExpr of ExprSyntax _ (App (ExprSyntax _ (Var qual)) args) -> case Map.lookup (EvalExtern qual) directives >>= Map.lookup InlineRef of Just (InlineArity n) | ExprApp (Ann { meta: Just IsSyntheticApp }) _ _ <- cfn , arity <- NonEmptyArray.length args , arity >= n -> - Just $ Map.singleton InlineRef InlineAlways + Map.singleton InlineRef InlineAlways _ -> - Nothing + Map.empty _ -> - Nothing + Map.empty toExternImpl :: ConvertEnv -> Array (Qualified Ident) -> BackendExpr -> Tuple (Tuple BackendAnalysis ExternImpl) NeutralExpr toExternImpl env group expr = case expr of From 747fcac4961969180851ab199d4f722c608cd015 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 5 Oct 2023 11:30:33 -0700 Subject: [PATCH 2/3] Fix naming issue --- src/PureScript/Backend/Optimizer/Convert.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/PureScript/Backend/Optimizer/Convert.purs b/src/PureScript/Backend/Optimizer/Convert.purs index 2b919f6d..4c5be717 100644 --- a/src/PureScript/Backend/Optimizer/Convert.purs +++ b/src/PureScript/Backend/Optimizer/Convert.purs @@ -399,7 +399,7 @@ floatTopLevelBackendBindings quoteCtx evalEnv baseQual@(Qualified mod (Ident bas } Nothing -> do let n = fromMaybe 0 $ Map.lookup (Ident "") used - { accum: Map.insert (Ident "") 1 used + { accum: Map.insert (Ident "") (n + 1) used , value: Qualified mod $ Ident $ baseIdent <> "." <> show n } From 366d06a171756c831f69fc94c4f62c811acfc365 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 13 Nov 2023 10:47:59 -0800 Subject: [PATCH 3/3] Snapshot --- .../test/snapshots-out/Snapshot.Tco07.js | 34 +++++++++++++++++++ backend-es/test/snapshots/Snapshot.Tco07.purs | 13 +++++++ 2 files changed, 47 insertions(+) create mode 100644 backend-es/test/snapshots-out/Snapshot.Tco07.js create mode 100644 backend-es/test/snapshots/Snapshot.Tco07.purs diff --git a/backend-es/test/snapshots-out/Snapshot.Tco07.js b/backend-es/test/snapshots-out/Snapshot.Tco07.js new file mode 100644 index 00000000..0b97894d --- /dev/null +++ b/backend-es/test/snapshots-out/Snapshot.Tco07.js @@ -0,0 +1,34 @@ +const $gf$djf = ($gf$djf$b$copy, $gf$djf$a0$copy, $gf$djf$a1$copy) => { + let $gf$djf$b = $gf$djf$b$copy, $gf$djf$a0 = $gf$djf$a0$copy, $gf$djf$a1 = $gf$djf$a1$copy, $gf$djf$c = true, $gf$djf$r; + while ($gf$djf$c) { + if ($gf$djf$b === 0) { + const n = $gf$djf$a0; + $gf$djf$b = 2; + $gf$djf$a0 = n; + $gf$djf$a1 = n - 1 | 0; + continue; + } + if ($gf$djf$b === 1) { + const n = $gf$djf$a0; + if (n === 100) { + $gf$djf$b = 2; + $gf$djf$a0 = n; + $gf$djf$a1 = n - 1 | 0; + continue; + } + $gf$djf$b = 1; + $gf$djf$a0 = n + 1 | 0; + continue; + } + if ($gf$djf$b === 2) { + const a = $gf$djf$a0, b = $gf$djf$a1; + $gf$djf$b = 1; + $gf$djf$a0 = a + b | 0; + } + } + return $gf$djf$r; +}; +const g = n => $gf$djf(0, n); +const f$dj = n => $gf$djf(1, n); +const f = a => b => $gf$djf(2, a, b); +export {f, f$dj, g}; diff --git a/backend-es/test/snapshots/Snapshot.Tco07.purs b/backend-es/test/snapshots/Snapshot.Tco07.purs new file mode 100644 index 00000000..f45a97db --- /dev/null +++ b/backend-es/test/snapshots/Snapshot.Tco07.purs @@ -0,0 +1,13 @@ +module Snapshot.Tco07 where + +import Prelude + +f :: Int -> Int -> Unit +f = (\a b -> j (a + b)) + where + j n + | n == 100 = g n + | otherwise = j (n + 1) + +g :: Int -> Unit +g n = f n (n - 1)