6bf90f2 · rowtype-yoga/purescript-backend-optimizer

git.iko.soy/rowtype-yoga/purescript-backend-optimizer

Add inline directives for parameterized dictionaries (#19)

* Add inline directives for parameterized dictionaries * Format

commit6bf90f2452e7ca8f62137a2a9aa4e81d7843b0ce authorNathan Faubion <natefaubion@users.noreply.github.com> dateTue 30 Aug 2022, 21:01 (4 years ago) parente2fe19b

15 files changed+415−154

compare with main

unifiedsplit

README.md+20

@@ -148,6 +148,26 @@ Example.semigroupMyData.append arity=2

148148It's possible to refer to unnamed instances through their compiler-generated

149149name, however this is quite difficult to maintain.

150150

151+Sometimes instances are parameterized by other constraints:

152+

153+```purescript

154+module Example where

155+

156+import Prelude

157+

158+data Product f g a = Product (f a) (g a)

159+

160+instance functorProduct :: (Functor f, Functor g) => Functor (Product f g) where

161+ map f (Product a b) = Product (f <$> a) (f <$> b)

162+```

163+

164+```

165+Example.functorProduct(..).map arity=2

166+```

167+

168+Note the `(..)` between the name and the accessor, which will match

169+applications of known instance dictionaries.

170+

151171### Configuration

152172

153173Inlining directives can be configured in three ways:

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Builder.purs+3−3

@@ -31,7 +31,7 @@ import PureScript.Backend.Optimizer.CoreFn.Json (decodeModule)

3131import PureScript.Backend.Optimizer.CoreFn.Sort (sortModules)

3232import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)

3333import PureScript.Backend.Optimizer.Directives.Defaults as Defaults

34−import PureScript.Backend.Optimizer.Semantics (EvalRef, InlineDirective)

34+import PureScript.Backend.Optimizer.Semantics (InlineDirectiveMap)

3535import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)

3636import PureScript.CST.Errors (printParseError)

3737

@@ -53,7 +53,7 @@ readCoreFnModule filePath = do

5353 Right mod ->

5454 pure $ Right mod

5555

56−externalDirectivesFromFile :: FilePath -> Aff (Map EvalRef InlineDirective)

56+externalDirectivesFromFile :: FilePath -> Aff InlineDirectiveMap

5757externalDirectivesFromFile filePath = do

5858 fileContent <- FS.readTextFile UTF8 filePath

5959 let { errors, directives } = parseDirectiveFile fileContent

@@ -65,7 +65,7 @@ externalDirectivesFromFile filePath = do

6565

6666basicBuildMain

6767 :: { resolveCoreFnDirectory :: Aff FilePath

68− , resolveExternalDirectives :: Aff (Map EvalRef InlineDirective)

68+ , resolveExternalDirectives :: Aff InlineDirectiveMap

6969 , foreignSemantics :: Map (Qualified Ident) ForeignEval

7070 , onCodegenBefore :: Aff Unit

7171 , onCodegenAfter :: Aff Unit

backend-es/test/snapshots-out/Snapshot.InlineDirectivePropSpine01.jsnew file+21

@@ -0,0 +1,21 @@

1+// @inline export watUnit(..).wat arity=1

2+import * as $runtime from "../runtime.js";

3+import * as Data$dUnit from "../Data.Unit/index.js";

4+import * as Type$dEquality from "../Type.Equality/index.js";

5+import {testImpl} from "./foreign.js";

6+const watUnit = dictTypeEquals => (

7+ {

8+ wat: (() => {

9+ const $1 = dictTypeEquals.proof(a => a);

10+ return x => testImpl($1(x));

11+ })()

12+ }

13+);

14+const wat = dict => dict.wat;

15+const wat1 = /* #__PURE__ */ (() => watUnit(Type$dEquality.refl).wat)();

16+const g = wat1;

17+const test2 = /* #__PURE__ */ testImpl(Data$dUnit.unit);

18+const f = wat1;

19+const test1 = /* #__PURE__ */ testImpl(Data$dUnit.unit);

20+export {f, g, test1, test2, wat, wat1, watUnit};

21+export * from "./foreign.js";

backend-es/test/snapshots-out/Snapshot.InlineDirectivePropSpine02.jsnew file+19

@@ -0,0 +1,19 @@

1+// @inline export watUnit(..).wat1 arity=1

2+// @inline export watUnit(..).wat2 arity=1

3+import * as $runtime from "../runtime.js";

4+import * as Data$dUnit from "../Data.Unit/index.js";

5+import * as Type$dEquality from "../Type.Equality/index.js";

6+import {testImpl} from "./foreign.js";

7+const watUnit = dictTypeEquals => {

8+ const to = dictTypeEquals.proof(a => a);

9+ return {wat1: x => testImpl(to(x)), wat2: x => testImpl(to(x))};

10+};

11+const watUnit1 = /* #__PURE__ */ watUnit(Type$dEquality.refl);

12+const wat2 = dict => dict.wat2;

13+const wat1 = dict => dict.wat1;

14+const g = /* #__PURE__ */ (() => watUnit1.wat2)();

15+const test2 = /* #__PURE__ */ testImpl(Data$dUnit.unit);

16+const f = /* #__PURE__ */ (() => watUnit1.wat1)();

17+const test1 = /* #__PURE__ */ testImpl(Data$dUnit.unit);

18+export {f, g, test1, test2, wat1, wat2, watUnit, watUnit1};

19+export * from "./foreign.js";

backend-es/test/snapshots-out/Snapshot.ProfunctorLenses02.js+2−1

@@ -1,4 +1,5 @@

1−// @inline Data.Lens.Internal.Forget.choiceForget arity=1

1+// @inline Data.Lens.Internal.Forget.choiceForget(..).left arity=1

2+// @inline Data.Lens.Internal.Forget.choiceForget(..).right arity=1

23import * as $runtime from "../runtime.js";

34import * as Data$dMaybe from "../Data.Maybe/index.js";

45const test4 = a => {

backend-es/test/snapshots-out/Snapshot.RecursiveBindingGroup01.js+1−1

@@ -4,7 +4,7 @@ const test3 = n => {

44 return test1$lazy().bar;

55};

66const test2$lazy = /* #__PURE__ */ $runtime.binding(() => ({baz: test1$lazy().bar}));

7−const test1$lazy = /* #__PURE__ */ $runtime.binding(() => ({foo: test1$lazy().bar, bar: test3(42)}));

7+const test1$lazy = /* #__PURE__ */ $runtime.binding(() => ({foo: test1$lazy().bar, bar: 42}));

88const test2 = /* #__PURE__ */ test2$lazy();

99const test1 = /* #__PURE__ */ test1$lazy();

1010export {test1, test2, test3};

backend-es/test/snapshots-out/Snapshot.Tco04.js+8−2

@@ -20,8 +20,14 @@ const $test2test1 = ($test2test1$b$copy, $test2test1$a0$copy) => {

2020 $test2test1$r = n;

2121 continue;

2222 }

23− $test2test1$b = 0;

24− $test2test1$a0 = n - 1 | 0;

23+ const $1 = n - 1 | 0;

24+ if ($1 === 2) {

25+ $test2test1$c = false;

26+ $test2test1$r = $1;

27+ continue;

28+ }

29+ $test2test1$b = 1;

30+ $test2test1$a0 = $1 - 2 | 0;

2531 continue;

2632 }

2733 };

backend-es/test/snapshots-out/Snapshot.Tco06.js+4−2

@@ -11,8 +11,10 @@ const $gf = ($gf$b$copy, $gf$a0$copy, $gf$a1$copy) => {

1111 }

1212 if ($gf$b === 1) {

1313 const a = $gf$a0, b = $gf$a1;

14− $gf$b = 0;

15− $gf$a0 = a + b | 0;

14+ const $2 = a + b | 0;

15+ $gf$b = 1;

16+ $gf$a0 = $2;

17+ $gf$a1 = $2 + 1 | 0;

1618 continue;

1719 }

1820 };

backend-es/test/snapshots/Snapshot.InlineDirectivePropSpine01.pursnew file+26

@@ -0,0 +1,26 @@

1+-- @inline export watUnit(..).wat arity=1

2+module Snapshot.InlineDirectivePropSpine01 where

4+import Prelude

6+import Data.Tuple (Tuple)

7+import Type.Equality (class TypeEquals)

8+import Type.Equality as TypeEquals

10+foreign import testImpl :: forall a b. Unit -> Unit

11+

12+class Wat a b | b -> a where

13+ wat :: a -> b

14+

15+instance watUnit :: TypeEquals a Unit => Wat a Unit where

16+ wat = testImpl <<< TypeEquals.to

17+

18+-- This results in a partially applied call for `wat` specialized

19+-- to `Unit` TypeEquals dictionary. Without the directive, This

20+-- won't inline via heuristics since it's a CAF. With the directive,

21+-- test1 and test2 get inlined to calls to testImpl.

22+f = wat :: Unit -> Unit

23+g = wat :: Unit -> Unit

24+

25+test1 = f unit :: Unit

26+test2 = g unit :: Unit

backend-es/test/snapshots/Snapshot.InlineDirectivePropSpine02.pursnew file+29

@@ -0,0 +1,29 @@

1+-- @inline export watUnit(..).wat1 arity=1

2+-- @inline export watUnit(..).wat2 arity=1

3+module Snapshot.InlineDirectivePropSpine02 where

5+import Prelude

7+import Data.Tuple (Tuple)

8+import Type.Equality (class TypeEquals)

9+import Type.Equality as TypeEquals

10+

11+foreign import testImpl :: forall a b. Unit -> Unit

12+

13+class Wat a b | b -> a where

14+ wat1 :: a -> b

15+ wat2 :: a -> b

16+

17+instance watUnit :: TypeEquals a Unit => Wat a Unit where

18+ wat1 = testImpl <<< TypeEquals.to

19+ wat2 = testImpl <<< TypeEquals.to

20+

21+-- This results in a partially applied call for `watUnit` specialized

22+-- to `Unit` TypeEquals dictionary. Without the directive, This

23+-- won't inline via heuristics since it's a CAF. With the directive,

24+-- test1 and test2 get inlined to calls to testImpl.

25+f = wat1 :: Unit -> Unit

26+g = wat2 :: Unit -> Unit

27+

28+test1 = f unit :: Unit

29+test2 = g unit :: Unit

backend-es/test/snapshots/Snapshot.ProfunctorLenses02.purs+2−1

@@ -1,4 +1,5 @@

1−-- @inline Data.Lens.Internal.Forget.choiceForget arity=1

1+-- @inline Data.Lens.Internal.Forget.choiceForget(..).left arity=1

2+-- @inline Data.Lens.Internal.Forget.choiceForget(..).right arity=1

23module Snapshot.ProfunctorLenses02 where

45import Prelude

src/PureScript/Backend/Optimizer/Builder.purs+2−2

@@ -16,7 +16,7 @@ import PureScript.Backend.Optimizer.Analysis (BackendAnalysis)

1616import PureScript.Backend.Optimizer.Convert (BackendModule, toBackendModule)

1717import PureScript.Backend.Optimizer.CoreFn (Ann, Ident, Module(..), Qualified)

1818import PureScript.Backend.Optimizer.CoreFn.Sort (sortModules)

19−import PureScript.Backend.Optimizer.Semantics (EvalRef, ExternImpl, InlineDirective)

19+import PureScript.Backend.Optimizer.Semantics (ExternImpl, InlineDirectiveMap)

2020import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)

2121

2222type BuildEnv =

@@ -26,7 +26,7 @@ type BuildEnv =

2626 }

2727

2828type BuildOptions m =

29− { directives :: Map EvalRef InlineDirective

29+ { directives :: InlineDirectiveMap

3030 , foreignSemantics :: Map (Qualified Ident) ForeignEval

3131 , onPrepareModule :: BuildEnv -> Module Ann -> m (Module Ann)

3232 , onCodegenModule :: BuildEnv -> Module Ann -> BackendModule -> m Unit

src/PureScript/Backend/Optimizer/Convert.purs+60−20

@@ -47,7 +47,7 @@ module PureScript.Backend.Optimizer.Convert where

4747

4848import Prelude

4949

50−import Control.Alternative (guard)

50+import Control.Alternative (guard, (<|>))

5151import Control.Monad.RWS (ask)

5252import Data.Array as Array

5353import Data.Array.NonEmpty (NonEmptyArray)

@@ -72,7 +72,7 @@ import Partial.Unsafe (unsafeCrashWith, unsafePartial)

7272import PureScript.Backend.Optimizer.Analysis (BackendAnalysis)

7373import 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)

7474import PureScript.Backend.Optimizer.Directives (DirectiveHeaderResult, parseDirectiveHeader)

75−import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx, DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineDirective(..), NeutralExpr(..), build, evalExternFromImpl, freeze, optimize)

75+import PureScript.Backend.Optimizer.Semantics (BackendExpr(..), BackendSemantics, Ctx, DataTypeMeta, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, NeutralExpr(..), build, evalExternFromImpl, freeze, optimize)

7676import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)

7777import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..))

7878import PureScript.Backend.Optimizer.Utils (foldl1Array)

@@ -95,7 +95,7 @@ type BackendModule =

9595 , reExports :: Set ReExport

9696 , foreign :: Set Ident

9797 , implementations :: BackendImplementations

98− , directives :: Map EvalRef InlineDirective

98+ , directives :: InlineDirectiveMap

9999 }

100100

101101type ConvertEnv =

@@ -105,7 +105,7 @@ type ConvertEnv =

105105 , toLevel :: Map Ident Level

106106 , implementations :: BackendImplementations

107107 , moduleImplementations :: BackendImplementations

108− , directives :: Map EvalRef InlineDirective

108+ , directives :: InlineDirectiveMap

109109 , foreignSemantics :: Map (Qualified Ident) ForeignEval

110110 , rewriteLimit :: Int

111111 }

@@ -239,26 +239,66 @@ toTopLevelBackendBinding group env (Binding _ ident cfn) = do

239239 { accum: env

240240 { implementations = Map.insert (Qualified (Just env.currentModule) ident) impl env.implementations

241241 , moduleImplementations = Map.insert (Qualified (Just env.currentModule) ident) impl env.moduleImplementations

242− , directives = case impl, backendExpr of

243− Tuple _ (ExternExpr _ (NeutralExpr (App (NeutralExpr (Var qual)) args))), _

244− | Just (InlineArity n) <- Map.lookup (EvalExtern qual Nothing) env.directives

245− , arity <- NonEmptyArray.length args

246− , arity < n ->

247− Map.insert (EvalExtern (Qualified (Just env.currentModule) ident) Nothing) (InlineArity (n - arity)) env.directives

248− -- TODO: Ideally, we would track arity annotations as part of

249− -- inlining to make it more reliably transitive.

250− _, ExprSyntax _ (App (ExprSyntax _ (Var qual)) args)

251− | Just (InlineArity n) <- Map.lookup (EvalExtern qual Nothing) env.directives

252− , ExprApp (Ann { meta: Just IsSyntheticApp }) _ _ <- cfn

253− , arity <- NonEmptyArray.length args

254− , arity >= n ->

255− Map.insert (EvalExtern (Qualified (Just env.currentModule) ident) Nothing) InlineAlways env.directives

256− _, _ ->

257− env.directives

242+ , directives =

243+ case inferTransitiveDirective env.directives (snd impl) backendExpr cfn of

244+ Just dirs ->

245+ Map.alter

246+ case _ of

247+ Just oldDirs ->

248+ Just $ Map.union oldDirs dirs

249+ Nothing ->

250+ Just dirs

251+ (EvalExtern (Qualified (Just env.currentModule) ident))

252+ env.directives

253+ Nothing ->

254+ env.directives

258255 }

259256 , value: Tuple ident (Tuple (unwrap (fst impl)).deps expr')

260257 }

261258

259+inferTransitiveDirective :: InlineDirectiveMap -> ExternImpl -> BackendExpr -> Expr Ann -> Maybe (Map InlineAccessor InlineDirective)

260+inferTransitiveDirective directives impl backendExpr cfn = fromImpl <|> fromBackendExpr

261+ where

262+ fromImpl = case impl of

263+ ExternExpr _ (NeutralExpr (App (NeutralExpr (Var qual)) args)) ->

264+ case Map.lookup (EvalExtern qual) directives of

265+ Just dirs -> do

266+ let

267+ newDirs = Map.toUnfoldable dirs # Array.mapMaybe case _ of

268+ Tuple InlineRef (InlineArity n) ->

269+ Just $ Tuple InlineRef (InlineArity (n - NonEmptyArray.length args))

270+ Tuple (InlineSpineProp prop) dir ->

271+ Just $ Tuple (InlineProp prop) dir

272+ _ ->

273+ Nothing

274+ if Array.null newDirs then

275+ Nothing

276+ else

277+ Just $ Map.fromFoldable newDirs

278+ _ ->

279+ Nothing

280+ ExternExpr _ (NeutralExpr (Accessor (NeutralExpr (App (NeutralExpr (Var qual)) _)) (GetProp prop))) ->

281+ case Map.lookup (EvalExtern qual) directives >>= Map.lookup (InlineSpineProp prop) of

282+ Just (InlineArity n) ->

283+ Just $ Map.singleton InlineRef (InlineArity n)

284+ _ ->

285+ Nothing

286+ _ ->

287+ Nothing

288+

289+ fromBackendExpr = case backendExpr of

290+ ExprSyntax _ (App (ExprSyntax _ (Var qual)) args) ->

291+ case Map.lookup (EvalExtern qual) directives >>= Map.lookup InlineRef of

292+ Just (InlineArity n)

293+ | ExprApp (Ann { meta: Just IsSyntheticApp }) _ _ <- cfn

294+ , arity <- NonEmptyArray.length args

295+ , arity >= n ->

296+ Just $ Map.singleton InlineRef InlineAlways

297+ _ ->

298+ Nothing

299+ _ ->

300+ Nothing

301+

262302toExternImpl :: ConvertEnv -> Array (Qualified Ident) -> BackendExpr -> Tuple (Tuple BackendAnalysis ExternImpl) NeutralExpr

263303toExternImpl env group expr = case expr of

264304 ExprSyntax analysis (Lit (LitRecord props)) -> do

src/PureScript/Backend/Optimizer/Directives.purs+32−21

@@ -14,24 +14,22 @@ import Data.Array as Array

1414import Data.Either (Either(..))

1515import Data.Foldable (foldl)

1616import Data.FoldableWithIndex (foldlWithIndex)

17−import Data.Map (Map)

1817import Data.Map as Map

1918import Data.Maybe (Maybe(..))

2019import Data.String (Pattern(..))

2120import Data.String as String

2221import Data.Tuple (Tuple(..), fst)

2322import PureScript.Backend.Optimizer.CoreFn (Comment(..), Ident(..), ModuleName(..), Qualified(..))

24−import PureScript.Backend.Optimizer.Semantics (EvalRef(..), InlineDirective(..))

25−import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..))

23+import PureScript.Backend.Optimizer.Semantics (EvalRef(..), InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, insertDirective)

2624import PureScript.CST.Errors (ParseError(..))

2725import PureScript.CST.Lexer (lex)

28−import PureScript.CST.Parser.Monad (Parser, PositionedError, eof, optional, runParser, take)

26+import PureScript.CST.Parser.Monad (Parser, PositionedError, eof, runParser, take)

2927import PureScript.CST.Types (IntValue(..), SourceToken, Token(..))

3028import PureScript.CST.Types as CST

3129

3230type DirectiveFileResult =

3331 { errors :: Array (Tuple String PositionedError)

34− , directives :: Map EvalRef InlineDirective

32+ , directives :: InlineDirectiveMap

3533 }

3634

3735parseDirectiveFile :: String -> DirectiveFileResult

@@ -42,13 +40,13 @@ parseDirectiveFile = foldlWithIndex go { errors: [], directives: Map.empty } <<<

4240 { errors: Array.snoc errors (Tuple str (err { position { line = line } })), directives }

4341 Right Nothing ->

4442 { errors, directives }

45− Right (Just (Tuple key val)) ->

46− { errors, directives: Map.insert key val directives }

43+ Right (Just (Tuple key (Tuple acc val))) ->

44+ { errors, directives: insertDirective key acc val directives }

4745

4846type DirectiveHeaderResult =

4947 { errors :: Array (Tuple String PositionedError)

50− , locals :: Map EvalRef InlineDirective

51− , exports :: Map EvalRef InlineDirective

48+ , locals :: InlineDirectiveMap

49+ , exports :: InlineDirectiveMap

5250 }

5351

5452parseDirectiveHeader :: ModuleName -> Array Comment -> DirectiveHeaderResult

@@ -61,41 +59,47 @@ parseDirectiveHeader moduleName = foldl go { errors: [], locals: Map.empty, expo

6159 case runParser (lex line') parser of

6260 Left err ->

6361 { errors: Array.snoc errors (Tuple line' err), locals, exports }

64− Right (Tuple (Left (Tuple key val)) _) ->

65− { errors, locals, exports: Map.insert key val exports }

66− Right (Tuple (Right (Tuple key val)) _) ->

67− { errors, locals: Map.insert key val locals, exports }

62+ Right (Tuple (Left (Tuple key (Tuple acc val))) _) ->

63+ { errors, locals, exports: insertDirective key acc val exports }

64+ Right (Tuple (Right (Tuple key (Tuple acc val))) _) ->

65+ { errors, locals: insertDirective key acc val locals, exports }

6866 _ ->

6967 { errors, locals, exports }

7068

7169 parser =

7270 Left <$> parseDirectiveExport moduleName <|> Right <$> parseDirective

7371

74−parseDirectiveLine :: String -> Either PositionedError (Maybe (Tuple EvalRef InlineDirective))

72+parseDirectiveLine :: String -> Either PositionedError (Maybe (Tuple EvalRef (Tuple InlineAccessor InlineDirective)))

7573parseDirectiveLine line = fst <$> runParser (lex line) parseDirectiveMaybe

7674

77−parseDirectiveMaybe :: Parser (Maybe (Tuple EvalRef InlineDirective))

75+parseDirectiveMaybe :: Parser (Maybe (Tuple EvalRef (Tuple InlineAccessor InlineDirective)))

7876parseDirectiveMaybe = Just <$> parseDirective <|> (Nothing <$ eof)

7977

80−parseDirectiveExport :: ModuleName -> Parser (Tuple EvalRef InlineDirective)

78+parseDirectiveExport :: ModuleName -> Parser (Tuple EvalRef (Tuple InlineAccessor InlineDirective))

8179parseDirectiveExport moduleName =

8280 ( ado

8381 keyword "export"

8482 ident <- unqualified

85− accessor <- optional (dot *> label)

83+ accessor <- parseInlineAccessor

8684 directive <- parseInlineDirective

87− in Tuple (EvalExtern (Qualified (Just moduleName) ident) (GetProp <$> accessor)) directive

85+ in Tuple (EvalExtern (Qualified (Just moduleName) ident)) (Tuple accessor directive)

8886 ) <* eof

8987

90−parseDirective :: Parser (Tuple EvalRef InlineDirective)

88+parseDirective :: Parser (Tuple EvalRef (Tuple InlineAccessor InlineDirective))

9189parseDirective =

9290 ( ado

9391 qual <- qualified

94− accessor <- optional (dot *> label)

92+ accessor <- parseInlineAccessor

9593 directive <- parseInlineDirective

96− in Tuple (EvalExtern qual (GetProp <$> accessor)) directive

94+ in Tuple (EvalExtern qual) (Tuple accessor directive)

9795 ) <* eof

9896

97+parseInlineAccessor :: Parser InlineAccessor

98+parseInlineAccessor =

99+ InlineProp <$> (dot *> label)

100+ <|> InlineSpineProp <$> (dotDot *> dot *> label)

101+ <|> pure InlineRef

102+

99103parseInlineDirective :: Parser InlineDirective

100104parseInlineDirective =

101105 InlineDefault <$ keyword "default"

@@ -135,6 +139,13 @@ dot = expectMap case _ of

135139 _ ->

136140 Nothing

137141

142+dotDot :: Parser Unit

143+dotDot = expectMap case _ of

144+ { value: TokSymbolName Nothing ".." } ->

145+ Just unit

146+ _ ->

147+ Nothing

148+

138149equals :: Parser Unit

139150equals = expectMap case _ of

140151 { value: TokEquals } ->

src/PureScript/Backend/Optimizer/Semantics.purs+186−101

@@ -134,23 +134,33 @@ data ExternSpine

134134 | ExternPrimOp BackendOperator1

135135

136136data EvalRef

137− = EvalExtern (Qualified Ident) (Maybe BackendAccessor)

137+ = EvalExtern (Qualified Ident)

138138 | EvalLocal (Maybe Ident) Level

139139

140140derive instance Eq EvalRef

141141derive instance Ord EvalRef

142142

143+data InlineAccessor

144+ = InlineProp String

145+ | InlineSpineProp String

146+ | InlineRef

147+

148+derive instance Eq InlineAccessor

149+derive instance Ord InlineAccessor

150+

143151data InlineDirective

144152 = InlineDefault

145153 | InlineNever

146154 | InlineAlways

147155 | InlineArity Int

148156

157+type InlineDirectiveMap = Map EvalRef (Map InlineAccessor InlineDirective)

158+

149159newtype Env = Env

150160 { currentModule :: ModuleName

151161 , evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

152162 , locals :: Array (LocalBinding BackendSemantics)

153− , directives :: Map EvalRef InlineDirective

163+ , directives :: InlineDirectiveMap

154164 , branchTry :: Maybe (SemTry BackendSemantics)

155165 }

156166

@@ -162,17 +172,23 @@ lookupLocal (Env { locals }) (Level lvl) = Array.index locals lvl

162172bindLocal :: Env -> LocalBinding BackendSemantics -> Env

163173bindLocal (Env env) sem = Env env { locals = Array.snoc env.locals sem }

164174

165−addDirective :: Env -> EvalRef -> InlineDirective -> Env

166−addDirective (Env env) ref dir = Env env { directives = Map.insert ref dir env.directives }

175+insertDirective :: EvalRef -> InlineAccessor -> InlineDirective -> InlineDirectiveMap -> InlineDirectiveMap

176+insertDirective ref acc dir = Map.alter

177+ case _ of

178+ Just dirs ->

179+ Just $ Map.insert acc dir dirs

180+ Nothing ->

181+ Just $ Map.singleton acc dir

182+ ref

167183

168−addStop :: Env -> EvalRef -> Env

169−addStop (Env env) ref = Env env

184+addStop :: Env -> EvalRef -> InlineAccessor -> Env

185+addStop (Env env) ref acc = Env env

170186 { directives = Map.alter

171187 case _ of

172− Just InlineAlways ->

173− Just InlineAlways

188+ Just dirs ->

189+ Just $ Map.insert acc InlineNever dirs

174190 _ ->

175− Just InlineNever

191+ Just $ Map.singleton acc InlineNever

176192 ref

177193 env.directives

178194 }

@@ -822,69 +838,153 @@ primOpOrdNot = case _ of

822838 OpGte -> OpLt

823839

824840evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> BackendSemantics

825−evalExtern env@(Env e) qual spine = case spine of

826− [] | Just InlineNever <- Map.lookup (EvalExtern qual Nothing) e.directives ->

827− NeutStop qual

828− [ ExternAccessor acc ] | Just InlineNever <- Map.lookup (EvalExtern qual (Just acc)) e.directives ->

829− neutralSpine (NeutStop qual) spine

830− _ ->

831− case e.evalExtern env qual spine of

832− Just sem ->

833− sem

834− Nothing ->

835− SemExtern qual spine (defer \_ -> neutralSpine (NeutVar qual) spine)

841+evalExtern env@(Env e) qual spine = case e.evalExtern env qual spine of

842+ Nothing -> SemExtern qual spine (defer \_ -> neutralSpine (NeutVar qual) spine)

843+ Just sem -> sem

844+

845+envForGroup :: Env -> EvalRef -> InlineAccessor -> Array (Qualified Ident) -> Env

846+envForGroup env ref acc group

847+ | Array.null group = env

848+ | otherwise = addStop env ref acc

836849

837850evalExternFromImpl :: Env -> Qualified Ident -> Tuple BackendAnalysis ExternImpl -> Array ExternSpine -> Maybe BackendSemantics

838−evalExternFromImpl env@(Env e) qual (Tuple analysis impl) spine = case impl of

839− ExternExpr [] expr -> do

840− let directive = Map.lookup (EvalExtern qual Nothing) e.directives

841− case expr, spine of

842− NeutralExpr (Lit lit), [] | shouldInlineExternLiteral lit directive ->

843− Just $ eval env expr

844− _, [] | shouldInlineExternReference qual analysis expr directive ->

845− Just $ eval env expr

846− body, [ ExternApp args ] | shouldInlineExternApp qual analysis body args directive ->

847− Just $ evalApp env (eval env body) args

848− _, _ ->

849− Nothing

850− ExternCtor _ ct ty tag fields ->

851− case fields, spine of

852− [], [] ->

851+evalExternFromImpl env@(Env e) qual (Tuple analysis impl) spine = case spine of

852+ [] ->

853+ case impl of

854+ ExternExpr group expr -> do

855+ let ref = EvalExtern qual

856+ case Map.lookup ref e.directives >>= Map.lookup InlineRef of

857+ Just InlineNever ->

858+ Just $ NeutStop qual

859+ Just InlineAlways ->

860+ Just $ eval (envForGroup env ref InlineRef group) expr

861+ Just (InlineArity _) ->

862+ Nothing

863+ _ ->

864+ case expr of

865+ NeutralExpr (Lit lit) | shouldInlineExternLiteral lit ->

866+ Just $ eval (envForGroup env ref InlineRef group) expr

867+ _ | shouldInlineExternReference qual analysis expr ->

868+ Just $ eval (envForGroup env ref InlineRef group) expr

869+ _ ->

870+ Nothing

871+ ExternCtor _ ct ty tag [] ->

853872 Just $ NeutData qual ct ty tag []

854− _, [ ExternApp args ] | Array.length fields == Array.length args ->

873+ _ ->

874+ Nothing

875+ [ ExternAccessor acc@(GetProp prop) ] ->

876+ case impl of

877+ ExternExpr group expr -> do

878+ let ref = EvalExtern qual

879+ case Map.lookup ref e.directives >>= Map.lookup (InlineProp prop) of

880+ Just InlineNever ->

881+ Just $ neutralSpine (NeutStop qual) spine

882+ Just InlineAlways ->

883+ Just $ evalSpine env (eval (envForGroup env ref (InlineProp prop) group) expr) spine

884+ _ ->

885+ Nothing

886+ ExternDict group props | Just (Tuple analysis' body) <- findProp prop props -> do

887+ let ref = EvalExtern qual

888+ case Map.lookup ref e.directives >>= Map.lookup (InlineProp prop) of

889+ Just InlineNever ->

890+ Just $ neutralSpine (NeutStop qual) spine

891+ Just InlineAlways ->

892+ Just $ eval (envForGroup env ref (InlineProp prop) group) body

893+ Just (InlineArity _) ->

894+ Nothing

895+ _ | shouldInlineExternAccessor qual analysis' body acc ->

896+ Just $ eval (envForGroup env ref (InlineProp prop) group) body

897+ _ ->

898+ Nothing

899+ _ ->

900+ Nothing

901+ [ ExternAccessor (GetProp prop), ExternApp args ] ->

902+ case impl of

903+ ExternExpr group expr -> do

904+ let ref = EvalExtern qual

905+ case Map.lookup ref e.directives >>= Map.lookup (InlineProp prop) of

906+ Just InlineNever ->

907+ Just $ neutralSpine (NeutStop qual) spine

908+ Just InlineAlways ->

909+ Just $ evalSpine env (eval (envForGroup env ref (InlineProp prop) group) expr) spine

910+ Just (InlineArity n)

911+ | Array.length args >= n ->

912+ Just $ evalSpine env (eval (envForGroup env ref (InlineProp prop) group) expr) spine

913+ | otherwise ->

914+ Nothing

915+ _ ->

916+ Nothing

917+ ExternDict group props | Just (Tuple analysis' body) <- findProp prop props -> do

918+ let ref = EvalExtern qual

919+ case Map.lookup ref e.directives >>= Map.lookup (InlineProp prop) of

920+ Just InlineNever ->

921+ Just $ neutralSpine (NeutStop qual) spine

922+ Just InlineAlways ->

923+ Just $ evalApp env (eval (envForGroup env ref (InlineProp prop) group) body) args

924+ Just (InlineArity n)

925+ | Array.length args >= n ->

926+ Just $ evalApp env (eval (envForGroup env ref (InlineProp prop) group) body) args

927+ | otherwise ->

928+ Nothing

929+ _ | shouldInlineExternApp qual analysis' body args ->

930+ Just $ evalApp env (eval (envForGroup env ref (InlineProp prop) group) body) args

931+ _ ->

932+ Nothing

933+ _ ->

934+ Nothing

935+ [ ExternApp args ] ->

936+ case impl of

937+ ExternExpr group expr -> do

938+ let ref = EvalExtern qual

939+ case Map.lookup ref e.directives >>= Map.lookup InlineRef of

940+ Just InlineNever ->

941+ Just $ neutralSpine (NeutStop qual) spine

942+ Just InlineAlways ->

943+ Just $ evalApp env (eval (envForGroup env ref InlineRef group) expr) args

944+ Just (InlineArity n)

945+ | Array.length args >= n ->

946+ Just $ evalApp env (eval (envForGroup env ref InlineRef group) expr) args

947+ | otherwise ->

948+ Nothing

949+ _ | shouldInlineExternApp qual analysis expr args ->

950+ Just $ evalApp env (eval (envForGroup env ref InlineRef group) expr) args

951+ _ ->

952+ Nothing

953+ ExternCtor _ ct ty tag fields | Array.length fields == Array.length args ->

855954 Just $ NeutData qual ct ty tag $ Array.zip fields args

856− _, _ ->

955+ _ ->

857956 Nothing

858− ExternDict group props ->

859− case spine of

860− [ ExternAccessor acc@(GetProp prop), ExternApp args ] | Just (Tuple analysis' body) <- findProp prop props -> do

861− let ref = EvalExtern qual (Just acc)

862− let directive = Map.lookup ref e.directives

863− if shouldInlineExternApp qual analysis' body args directive then do

864− let env' = if Array.null group then env else addStop env ref

865− Just $ evalApp env (eval env' body) args

866− else

867− Nothing

868− [ ExternAccessor acc@(GetProp prop) ] | Just (Tuple analysis' body) <- findProp prop props -> do

869− let ref = EvalExtern qual (Just acc)

870− let directive = Map.lookup ref e.directives

871− if shouldInlineExternAccessor qual analysis' body acc directive then do

872− let env' = if Array.null group then env else addStop env ref

873− Just $ eval env' body

874− else

875− Nothing

957+ [ ExternApp _, ExternAccessor (GetProp prop) ] ->

958+ case impl of

959+ ExternExpr group fn -> do

960+ let ref = EvalExtern qual

961+ case Map.lookup ref e.directives >>= Map.lookup (InlineSpineProp prop) of

962+ Just InlineNever ->

963+ Just $ neutralSpine (NeutStop qual) spine

964+ Just InlineAlways ->

965+ Just $ evalSpine env (eval (envForGroup env ref (InlineSpineProp prop) group) fn) spine

966+ _ ->

967+ Nothing

968+ _ ->

969+ Nothing

970+ [ ExternApp _, ExternAccessor (GetProp prop), ExternApp args2 ] ->

971+ case impl of

972+ ExternExpr group fn -> do

973+ let ref = EvalExtern qual

974+ case Map.lookup ref e.directives >>= Map.lookup (InlineSpineProp prop) of

975+ Just InlineNever ->

976+ Just $ neutralSpine (NeutStop qual) spine

977+ Just InlineAlways ->

978+ Just $ evalSpine env (eval (envForGroup env ref (InlineSpineProp prop) group) fn) spine

979+ Just (InlineArity n) | Array.length args2 >= n ->

980+ Just $ evalSpine env (eval (envForGroup env ref (InlineSpineProp prop) group) fn) spine

981+ _ ->

982+ Nothing

876983 _ ->

877984 Nothing

878985 _ ->

879986 Nothing

880987

881−externRefFromSpine :: Qualified Ident -> Array ExternSpine -> EvalRef

882−externRefFromSpine qual spine = case Array.head spine of

883− Just (ExternAccessor acc) ->

884− EvalExtern qual (Just acc)

885− _ ->

886− EvalExtern qual Nothing

887−

888988analysisFromDirective :: BackendAnalysis -> InlineDirective -> BackendAnalysis

889989analysisFromDirective (BackendAnalysis analysis) = case _ of

890990 InlineAlways ->

@@ -1353,52 +1453,37 @@ shouldInlineLet level a b = do

13531453 || (isAbs a && (total == 1 || Map.isEmpty s1.usages || s1.size < 16))

13541454 || (isKnownEffect a && total == 1)

13551455

1356−shouldInlineExternReference :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Maybe InlineDirective -> Boolean

1357−shouldInlineExternReference _ (BackendAnalysis s) _ = case _ of

1358− Just InlineAlways -> true

1359− Just InlineNever -> false

1360− Just (InlineArity _) -> false

1361− _ ->

1362− s.complexity <= Deref && s.size < 16

1456+shouldInlineExternReference :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Boolean

1457+shouldInlineExternReference _ (BackendAnalysis s) _ =

1458+ s.complexity <= Deref && s.size < 16

13631459

1364−shouldInlineExternApp :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Spine BackendSemantics -> Maybe InlineDirective -> Boolean

1365−shouldInlineExternApp _ (BackendAnalysis s) _ args = case _ of

1366− Just InlineAlways -> true

1367− Just InlineNever -> false

1368− Just (InlineArity n) -> Array.length args == n

1369− _ ->

1370− (s.complexity <= Deref && s.size < 16)

1371− || (Map.isEmpty s.usages && Set.isEmpty s.deps && s.size < 64)

1372− || (delayed && Array.length s.args <= Array.length args && s.size < 16)

1373− || (delayed && or (Array.zipWith shouldInlineExternAppArg s.args args) && s.size < 16)

1374− where

1375− delayed = Array.length s.args > 0

1460+shouldInlineExternApp :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Spine BackendSemantics -> Boolean

1461+shouldInlineExternApp _ (BackendAnalysis s) _ args =

1462+ (s.complexity <= Deref && s.size < 16)

1463+ || (Map.isEmpty s.usages && Set.isEmpty s.deps && s.size < 64)

1464+ || (delayed && Array.length s.args <= Array.length args && s.size < 16)

1465+ || (delayed && or (Array.zipWith shouldInlineExternAppArg s.args args) && s.size < 16)

1466+ where

1467+ delayed = Array.length s.args > 0

13761468

13771469shouldInlineExternAppArg :: Usage -> BackendSemantics -> Boolean

13781470shouldInlineExternAppArg (Usage u) = case _ of

13791471 SemLam _ _ -> u.captured <= CaptureBranch && u.total > 0 && u.call == u.total

13801472 _ -> false

13811473

1382−shouldInlineExternAccessor :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> BackendAccessor -> Maybe InlineDirective -> Boolean

1383−shouldInlineExternAccessor _ (BackendAnalysis s) _ _ = case _ of

1384− Just InlineAlways -> true

1385− Just InlineNever -> false

1386− _ ->

1387− s.complexity <= Deref && s.size < 16

1388−

1389−shouldInlineExternLiteral :: Literal NeutralExpr -> Maybe InlineDirective -> Boolean

1390−shouldInlineExternLiteral lit = case _ of

1391− Just InlineAlways -> true

1392− Just InlineNever -> false

1393− _ ->

1394− case lit of

1395− LitInt _ -> true

1396− LitNumber _ -> true

1397− LitString s -> String.length s <= 32

1398− LitChar _ -> true

1399− LitBoolean _ -> true

1400− LitArray a -> Array.null a

1401− LitRecord r -> Array.null r

1474+shouldInlineExternAccessor :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> BackendAccessor -> Boolean

1475+shouldInlineExternAccessor _ (BackendAnalysis s) _ _ =

1476+ s.complexity <= Deref && s.size < 16

1477+

1478+shouldInlineExternLiteral :: Literal NeutralExpr -> Boolean

1479+shouldInlineExternLiteral = case _ of

1480+ LitInt _ -> true

1481+ LitNumber _ -> true

1482+ LitString s -> String.length s <= 32

1483+ LitChar _ -> true

1484+ LitBoolean _ -> true

1485+ LitArray a -> Array.null a

1486+ LitRecord r -> Array.null r

14021487

14031488isAbs :: BackendExpr -> Boolean

14041489isAbs = syntaxOf >>> case _ of