diff --git a/backend-es/test/snapshots-out/Snapshot.RecursionInlined01.js b/backend-es/test/snapshots-out/Snapshot.RecursionInlined01.js new file mode 100644 index 00000000..1a780ffd --- /dev/null +++ b/backend-es/test/snapshots-out/Snapshot.RecursionInlined01.js @@ -0,0 +1,41 @@ +// @inline Snapshot.RecursionInlined01.append always +import * as $runtime from "../runtime.js"; +const $List = (tag, _1, _2) => ({tag, _1, _2}); +const Nil = /* #__PURE__ */ $List("Nil"); +const Cons = value0 => value1 => $List("Cons", value0, value1); +const append = v => v1 => { + if (v.tag === "Nil") { return v1; } + if (v.tag === "Cons") { return $List("Cons", v._1, append(v._2)(v1)); } + $runtime.fail(); +}; +const test1 = /* #__PURE__ */ $List( + "Cons", + "a", + /* #__PURE__ */ $List( + "Cons", + "b", + /* #__PURE__ */ $List( + "Cons", + "c", + /* #__PURE__ */ $List("Cons", "d", /* #__PURE__ */ $List("Cons", "e", /* #__PURE__ */ $List("Cons", "f", /* #__PURE__ */ $List("Cons", "g", Nil)))) + ) + ) +); +const test2 = z => $List( + "Cons", + "a", + $List( + "Cons", + "b", + $List( + "Cons", + "c", + (() => { + if (z.tag === "Nil") { return $List("Cons", "d", $List("Cons", "e", $List("Cons", "f", $List("Cons", "g", Nil)))); } + if (z.tag === "Cons") { return $List("Cons", z._1, append(z._2)($List("Cons", "d", $List("Cons", "e", $List("Cons", "f", $List("Cons", "g", Nil)))))); } + $runtime.fail(); + })() + ) + ) +); +export {$List, Cons, Nil, append, test1, test2}; diff --git a/backend-es/test/snapshots-out/Snapshot.RecursionInlined02.js b/backend-es/test/snapshots-out/Snapshot.RecursionInlined02.js new file mode 100644 index 00000000..9c8a958e --- /dev/null +++ b/backend-es/test/snapshots-out/Snapshot.RecursionInlined02.js @@ -0,0 +1,26 @@ +// @inline Snapshot.RecursionInlined02.addStuff always +const $List = (tag, _1, _2) => ({tag, _1, _2}); +const Nil = /* #__PURE__ */ $List("Nil"); +const Cons = value0 => value1 => $List("Cons", value0, value1); +const addStuff = x => ys => { + if (x > 0) { return 1 + addStuff(x - 1 | 0)(ys) | 0; } + if (x < 0) { return -1 + addStuff(x + 1 | 0)(ys) | 0; } + return ys; +}; +const test1 = 42; +const test2 = z => 2 + addStuff(1)((() => { + if (z > 0) { + const $0 = z - 1 | 0; + if ($0 > 0) { return 2 + addStuff($0 - 1 | 0)(5) | 0; } + if ($0 < 0) { return 0 + addStuff($0 + 1 | 0)(5) | 0; } + return 6; + } + if (z < 0) { + const $0 = z + 1 | 0; + if ($0 > 0) { return 0 + addStuff($0 - 1 | 0)(5) | 0; } + if ($0 < 0) { return -2 + addStuff($0 + 1 | 0)(5) | 0; } + return 4; + } + return 5; +})()) | 0; +export {$List, Cons, Nil, addStuff, test1, test2}; diff --git a/backend-es/test/snapshots-out/Snapshot.RecursionInlined03.js b/backend-es/test/snapshots-out/Snapshot.RecursionInlined03.js new file mode 100644 index 00000000..97adba14 --- /dev/null +++ b/backend-es/test/snapshots-out/Snapshot.RecursionInlined03.js @@ -0,0 +1,48 @@ +// @inline Snapshot.RecursionInlined03.append always +// This doesn't quite work yet, because the inlining of append depends +// on the analysis of the local `b`, which we don't have (easy) access to. +// If we can somehow grab its usage, we'd likely see that access + case == total +import * as Partial from "../Partial/index.js"; +const List = x => x; +const nil = {type: "nil", value: undefined}; +const cons = head => tail => ({type: "cons", value: {head, tail}}); +const append = v => b => { + if (v.type === "cons") { return {type: "cons", value: {head: v.value.head, tail: append(v.value.tail)(b)}}; } + if (v.type === "nil") { return b; } + return Partial._crashWith("Data.Variant: pattern match failure [" + v.type + "]"); +}; +const test1 = { + type: "cons", + value: { + head: "a", + tail: { + type: "cons", + value: { + head: "b", + tail: /* #__PURE__ */ append({type: "cons", value: {head: "c", tail: nil}})({ + type: "cons", + value: {head: "d", tail: {type: "cons", value: {head: "e", tail: {type: "cons", value: {head: "f", tail: {type: "cons", value: {head: "g", tail: nil}}}}}}} + }) + } + } + } +}; +const test2 = z => ( + { + type: "cons", + value: { + head: "a", + tail: { + type: "cons", + value: { + head: "b", + tail: append({type: "cons", value: {head: "c", tail: z}})({ + type: "cons", + value: {head: "d", tail: {type: "cons", value: {head: "e", tail: {type: "cons", value: {head: "f", tail: {type: "cons", value: {head: "g", tail: nil}}}}}}} + }) + } + } + } + } +); +export {List, append, cons, nil, test1, test2}; diff --git a/backend-es/test/snapshots-out/Snapshot.RecursionInlinedBroken.js b/backend-es/test/snapshots-out/Snapshot.RecursionInlinedBroken.js new file mode 100644 index 00000000..d3aabe35 --- /dev/null +++ b/backend-es/test/snapshots-out/Snapshot.RecursionInlinedBroken.js @@ -0,0 +1,17 @@ +// @inline Snapshot.RecursionInlinedBroken.addStuffBroken always +// This will recurse out of control and stop when it hits the recursion limit +const $List = (tag, _1, _2) => ({tag, _1, _2}); +const Nil = /* #__PURE__ */ $List("Nil"); +const Cons = value0 => value1 => $List("Cons", value0, value1); +const addStuffBroken = v => v1 => { + if (v === 0) { return v1; } + return 1 + addStuffBroken(v - 1 | 0)(v1) | 0; +}; +const test1 = v => 2 + addStuffBroken(-5)(4) | 0; +const test2 = z => 2 + addStuffBroken(-5)((() => { + if (z === 0) { return 5; } + const $0 = z - 1 | 0; + if ($0 === 0) { return 6; } + return 2 + addStuffBroken($0 - 1 | 0)(5) | 0; +})()) | 0; +export {$List, Cons, Nil, addStuffBroken, test1, test2}; diff --git a/backend-es/test/snapshots/Snapshot.RecursionInlined01.purs b/backend-es/test/snapshots/Snapshot.RecursionInlined01.purs new file mode 100644 index 00000000..38657386 --- /dev/null +++ b/backend-es/test/snapshots/Snapshot.RecursionInlined01.purs @@ -0,0 +1,16 @@ +-- @inline Snapshot.RecursionInlined01.append always +module Snapshot.RecursionInlined01 where + +data List a = Nil | Cons a (List a) +infixr 5 Cons as : + +append :: forall a. List a -> List a -> List a +append Nil ys = ys +append (Cons x xs) ys = Cons x (append xs ys) + +infixr 4 append as <> + +test1 :: List String +test1 = ("a" : "b" : "c" : Nil) <> ("d" : "e" : "f" : "g" : Nil) +test2 :: List String -> List String +test2 z = ("a" : "b" : "c" : z) <> ("d" : "e" : "f" : "g" : Nil) \ No newline at end of file diff --git a/backend-es/test/snapshots/Snapshot.RecursionInlined02.purs b/backend-es/test/snapshots/Snapshot.RecursionInlined02.purs new file mode 100644 index 00000000..cb3425b0 --- /dev/null +++ b/backend-es/test/snapshots/Snapshot.RecursionInlined02.purs @@ -0,0 +1,20 @@ +-- @inline Snapshot.RecursionInlined02.addStuff always +module Snapshot.RecursionInlined02 where + +import Prelude + +data List a = Nil | Cons a (List a) +infixr 5 Cons as : + +addStuff :: Int -> Int -> Int +addStuff x ys + | x > 0 = 1 + addStuff (x - 1) ys + | x < 0 = (-1) + addStuff (x + 1) ys + | otherwise = ys + +infixr 4 addStuff as ++ + +test1 :: Int +test1 = 38 ++ 4 +test2 :: Int -> Int +test2 z = 3 ++ z ++ 5 \ No newline at end of file diff --git a/backend-es/test/snapshots/Snapshot.RecursionInlined03.purs b/backend-es/test/snapshots/Snapshot.RecursionInlined03.purs new file mode 100644 index 00000000..aefd068a --- /dev/null +++ b/backend-es/test/snapshots/Snapshot.RecursionInlined03.purs @@ -0,0 +1,31 @@ +-- @inline Snapshot.RecursionInlined03.append always +-- This doesn't quite work yet, because the inlining of append depends +-- on the analysis of the local `b`, which we don't have (easy) access to. +-- If we can somehow grab its usage, we'd likely see that access + case == total +module Snapshot.RecursionInlined03 where + +import Prelude + +import Data.Variant (Variant, inj, case_, on) +import Type.Proxy (Proxy(..)) + +newtype List a = List (Variant (nil :: Unit, cons :: { head :: a, tail :: List a })) + +cons :: forall a. a -> List a -> List a +cons head tail = List $ inj (Proxy :: _ "cons") {head, tail} +nil :: forall a. List a +nil = List $ inj (Proxy :: _ "nil") unit +infixr 5 cons as : + +append :: forall a. List a -> List a -> List a +append (List a) b = (case_ + # on (Proxy :: _ "nil") (\_ -> b) + # on (Proxy :: _ "cons") (\{head, tail} -> cons head (append tail b))) a + +infixr 4 append as <> + +test1 :: List String +test1 = ("a" : "b" : "c" : nil) <> ("d" : "e" : "f" : "g" : nil) + +test2 :: List String -> List String +test2 z = ("a" : "b" : "c" : z) <> ("d" : "e" : "f" : "g" : nil) \ No newline at end of file diff --git a/backend-es/test/snapshots/Snapshot.RecursionInlinedBroken.purs b/backend-es/test/snapshots/Snapshot.RecursionInlinedBroken.purs new file mode 100644 index 00000000..9628c151 --- /dev/null +++ b/backend-es/test/snapshots/Snapshot.RecursionInlinedBroken.purs @@ -0,0 +1,22 @@ +-- @inline Snapshot.RecursionInlinedBroken.addStuffBroken always +-- This will recurse out of control and stop when it hits the recursion limit +module Snapshot.RecursionInlinedBroken where + +import Prelude + +data List a = Nil | Cons a (List a) +infixr 5 Cons as : + +addStuffBroken :: Int -> Int -> Int +addStuffBroken 0 ys = ys +addStuffBroken x ys = 1 + addStuffBroken (x - 1) ys + +infixr 4 addStuffBroken as ++ + +-- we make this Unit -> Int so that the module can be loaded with an +-- import statement. otherwise, it will execute the broken (-3) ++ 4 and the +-- tests will fail +test1 :: Unit -> Int +test1 _ = (-3) ++ 4 +test2 :: Int -> Int +test2 z = (-3) ++ z ++ 5 \ No newline at end of file diff --git a/src/PureScript/Backend/Optimizer/Convert.purs b/src/PureScript/Backend/Optimizer/Convert.purs index 04f68146..b21c56a5 100644 --- a/src/PureScript/Backend/Optimizer/Convert.purs +++ b/src/PureScript/Backend/Optimizer/Convert.purs @@ -234,7 +234,7 @@ toBackendTopLevelBindingGroup env = case _ of toTopLevelBackendBinding :: Array (Qualified Ident) -> ConvertEnv -> Binding Ann -> Accum ConvertEnv (Tuple Ident (WithDeps NeutralExpr)) toTopLevelBackendBinding group env (Binding _ ident cfn) = do - let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], directives: env.directives } + let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], punt: Set.empty, directives: env.directives, blockNextRecursion: false } let backendExpr = toBackendExpr cfn env let Tuple impl expr' = toExternImpl env group (optimize (getCtx env) evalEnv (Qualified (Just env.currentModule) ident) env.rewriteLimit backendExpr) { accum: env diff --git a/src/PureScript/Backend/Optimizer/Semantics.purs b/src/PureScript/Backend/Optimizer/Semantics.purs index 24f9d360..eb07f81a 100644 --- a/src/PureScript/Backend/Optimizer/Semantics.purs +++ b/src/PureScript/Backend/Optimizer/Semantics.purs @@ -48,6 +48,7 @@ data BackendSemantics | NeutLocal (Maybe Ident) Level | NeutVar (Qualified Ident) | NeutStop (Qualified Ident) + | RecurseWithRecklessAbandon (Qualified Ident) | NeutData (Qualified Ident) ConstructorType ProperName Ident (Array (Tuple String BackendSemantics)) | NeutCtorDef (Qualified Ident) ConstructorType ProperName Ident (Array String) | NeutApp BackendSemantics (Spine BackendSemantics) @@ -86,6 +87,7 @@ data BackendRewrite | RewriteLetAssoc (Array (LetBindingAssoc BackendExpr)) BackendExpr | RewriteEffectBindAssoc (Array (EffectBindingAssoc BackendExpr)) BackendExpr | RewriteStop (Qualified Ident) + | RewriteRecurse (Qualified Ident) | RewriteUnpackOp (Maybe Ident) Level UnpackOp BackendExpr | RewriteDistBranchesLet (Maybe Ident) Level (NonEmptyArray (Pair BackendExpr)) BackendExpr BackendExpr | RewriteDistBranchesOp (NonEmptyArray (Pair BackendExpr)) BackendExpr DistOp @@ -164,6 +166,8 @@ newtype Env = Env , evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics , locals :: Array (LocalBinding BackendSemantics) , directives :: InlineDirectiveMap + , punt :: Set.Set (Qualified Ident) + , blockNextRecursion :: Boolean } derive instance Newtype Env _ @@ -183,6 +187,16 @@ insertDirective ref acc dir = Map.alter Just $ Map.singleton acc dir ref +recursable :: Array BackendSemantics -> Boolean +recursable = go + where + go arr + | Just { head, tail } <- Array.uncons arr = case head of + NeutData _ _ _ _ _ -> go tail + NeutLit _ -> go tail + _ -> false + | otherwise = true + addStop :: Env -> EvalRef -> InlineAccessor -> Env addStop (Env env) ref acc = Env env { directives = Map.alter @@ -195,13 +209,19 @@ addStop (Env env) ref acc = Env env env.directives } +puntMe :: Env -> Array (Qualified Ident) -> Env +puntMe (Env env) quals = Env env + { punt = Set.union env.punt (Set.fromFoldable quals) + } + class Eval f where eval :: Env -> f -> BackendSemantics instance Eval f => Eval (BackendSyntax f) where - eval env = case _ of - Var qual -> - evalExtern env qual [] + eval env@(Env envx@{ punt }) = case _ of + Var qual + | qual `Set.member` punt -> RecurseWithRecklessAbandon qual + | otherwise -> evalExtern env qual [] Local ident lvl -> case lookupLocal env lvl of Just (One sem) -> sem @@ -209,8 +229,11 @@ instance Eval f => Eval (BackendSyntax f) where force sem _ -> unsafeCrashWith $ "Unbound local at level " <> show (unwrap lvl) - App hd tl -> - evalApp env (eval env hd) (NonEmptyArray.toArray (eval env <$> tl)) + App hd tl -> do + let tailEvaled = NonEmptyArray.toArray (eval env <$> tl) + let canRecurse = recursable tailEvaled + let headEvaled = eval (Env envx { blockNextRecursion = not canRecurse }) hd + evalApp env headEvaled tailEvaled UncurriedApp hd tl -> evalUncurriedApp env (eval env hd) (eval env <$> tl) UncurriedAbs idents body -> do @@ -274,11 +297,12 @@ instance Eval f => Eval (BackendSyntax f) where guardFailOver snd (map (eval env) <$> fields) $ NeutData qual ct ty tag instance Eval BackendExpr where - eval = go + eval (Env e@{ blockNextRecursion }) = go (Env e { blockNextRecursion = false }) where go env = case _ of ExprRewrite _ rewrite -> case rewrite of + RewriteRecurse ident -> if blockNextRecursion then mkSemExtern ident [] else eval env (Var ident :: BackendSyntax BackendExpr) RewriteInline _ _ binding body -> go (bindLocal env (One (eval env binding))) body RewriteUncurry ident _ args binding body -> @@ -826,9 +850,12 @@ primOpOrdNot = case _ of OpGt -> OpLte OpGte -> OpLt +mkSemExtern :: Qualified Ident -> Array ExternSpine -> BackendSemantics +mkSemExtern qual spine = SemExtern qual spine (defer \_ -> neutralSpine (NeutVar qual) spine) + evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> BackendSemantics evalExtern env@(Env e) qual spine = case e.evalExtern env qual spine of - Nothing -> SemExtern qual spine (defer \_ -> neutralSpine (NeutVar qual) spine) + Nothing -> mkSemExtern qual spine Just sem -> sem envForGroup :: Env -> EvalRef -> InlineAccessor -> Array (Qualified Ident) -> Env @@ -846,15 +873,15 @@ evalExternFromImpl env@(Env e) qual (Tuple analysis impl) spine = case spine of Just InlineNever -> Just $ NeutStop qual Just InlineAlways -> - Just $ eval (envForGroup env ref InlineRef group) expr + Just $ eval (puntMe env group) expr Just (InlineArity _) -> Nothing _ -> case expr of NeutralExpr (Lit lit) | shouldInlineExternLiteral lit -> - Just $ eval (envForGroup env ref InlineRef group) expr + Just $ eval (puntMe env group) expr _ | shouldInlineExternReference qual analysis expr -> - Just $ eval (envForGroup env ref InlineRef group) expr + Just $ eval (puntMe env group) expr _ -> Nothing ExternCtor _ ct ty tag [] -> @@ -1056,6 +1083,7 @@ quote = go foldr (buildBranchCond ctx) (quote ctx <<< force $ def) branches' -- Non-block constructors + RecurseWithRecklessAbandon ident -> ExprRewrite (withRewrite (analyzeDefault ctx (Var ident))) $ RewriteRecurse ident SemExtern _ _ sem -> go ctx (force sem) SemLam ident k -> do @@ -1529,6 +1557,8 @@ freeze init = Tuple (analysisOf init) (go init) NeutralExpr $ Let ident level (NeutralExpr (Abs args (go binding))) (go body) RewriteStop qual -> NeutralExpr $ Var qual + RewriteRecurse qual -> + NeutralExpr $ Var qual RewriteLetAssoc bindings body -> case NonEmptyArray.fromArray bindings of Just bindings' -> do