diff --git a/backend-es/test/snapshots-out/Snapshot.EffectBind01.js b/backend-es/test/snapshots-out/Snapshot.EffectBind01.js index f32a44f..d57d105 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 a1ea9bc..012b4ae 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 0aa9398..1211045 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 d06ee4d..43ce3d3 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 ac4ffc4..dce9716 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 195e2db..d6b4212 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 43ec923..15f5beb 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 db828d0..44a24bd 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-out/Snapshot.Tco07.js b/backend-es/test/snapshots-out/Snapshot.Tco07.js new file mode 100644 index 0000000..0b97894 --- /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.Tco03.purs b/backend-es/test/snapshots/Snapshot.Tco03.purs index 64cef0b..2ffcb14 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/backend-es/test/snapshots/Snapshot.Tco07.purs b/backend-es/test/snapshots/Snapshot.Tco07.purs new file mode 100644 index 0000000..f45a97d --- /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) diff --git a/src/PureScript/Backend/Optimizer/Convert.purs b/src/PureScript/Backend/Optimizer/Convert.purs index b066c1d..4c5be71 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 "") (n + 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