Add inlining directives for data types

backend-es/test/snapshots-out/Snapshot.KnownConstructors07.js

@@ -0,0 +1,5 @@
+const test = f => y => {
+  const z = f(y);
+  return {bar: z - 2 | 0, foo: z + 1 | 0};
+};
+export {test};

backend-es/test/snapshots/Snapshot.KnownConstructor07.purs → backend-es/test/snapshots/Snapshot.KnownConstructors07.purs

@@ -1,4 +1,4 @@
-module Snapshot.KnownConstructor07 where
+module Snapshot.KnownConstructors07 where
 
 import Prelude
 

backend-es/test/snapshots/Snapshot.KnownConstructors08.purs

@@ -0,0 +1,15 @@
+-- @inline Data.Show.Generic.genericShowConstructor arity=2
+-- @inline export genericTest.from arity=1
+module Snapshot.KnownConstructors08 where
+
+import Prelude
+
+import Data.Generic.Rep (class Generic)
+import Data.Show.Generic (genericShow)
+
+data Test = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
+
+derive instance genericTest :: Generic Test _
+
+instance Show Test where
+  show = genericShow

src/PureScript/Backend/Optimizer/Analysis.purs

@@ -13,7 +13,7 @@ import Data.Set as Set
 import Data.String.CodeUnits as SCU
 import Data.Traversable (foldMap, foldr)
 import Data.Tuple (Tuple(..), snd)
-import PureScript.Backend.Optimizer.CoreFn (Ident, Literal(..), Qualified)
+import PureScript.Backend.Optimizer.CoreFn (Ident, Literal(..), ProperName, Qualified)
 import PureScript.Backend.Optimizer.Syntax (class HasSyntax, BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendSyntax(..), Level, Pair(..), sndPair, syntaxOf)
 
 data Capture = CaptureNone | CaptureBranch | CaptureClosure
@@ -72,18 +72,18 @@ instance Semigroup Complexity where
 instance Monoid Complexity where
   mempty = Trivial
 
-data ResultTerm = KnownNeutral | Unknown
+data ResultTerm = Known (Set (Tuple (Qualified Ident) ProperName)) | Unknown
 
 derive instance Eq ResultTerm
 
 instance Semigroup ResultTerm where
   append = case _, _ of
     Unknown, _ -> Unknown
     _, Unknown -> Unknown
-    _, _ -> KnownNeutral
+    Known a, Known b -> Known (a <> b)
 
 instance Monoid ResultTerm where
-  mempty = KnownNeutral
+  mempty = Known mempty
 
 newtype BackendAnalysis = BackendAnalysis
   { usages :: Map Level Usage
@@ -118,7 +118,7 @@ instance Monoid BackendAnalysis where
     , args: []
     , rewrite: false
     , deps: Set.empty
-    , result: KnownNeutral
+    , result: mempty
     , externs: false
     }
 
@@ -244,12 +244,12 @@ analyze externAnalysis expr = case expr of
       $ bump
       $ analysisOf a
   Abs args _ ->
-    withResult KnownNeutral
+    withResult mempty
       $ complex KnownSize
       $ capture CaptureClosure
       $ foldr (boundArg <<< snd) (analyzeDefault expr) args
   UncurriedAbs args _ ->
-    withResult KnownNeutral
+    withResult mempty
       $ complex KnownSize
       $ capture CaptureClosure
       $ foldr (boundArg <<< snd) (analyzeDefault expr) args
@@ -265,7 +265,7 @@ analyze externAnalysis expr = case expr of
         $ complex NonTrivial
         $ analyzeDefault expr
   UncurriedEffectAbs args _ ->
-    withResult KnownNeutral
+    withResult mempty
       $ complex KnownSize
       $ capture CaptureClosure
       $ foldr (boundArg <<< snd) (analyzeDefault expr) args
@@ -311,8 +311,8 @@ analyze externAnalysis expr = case expr of
       withResult Unknown
         $ complex NonTrivial
         $ analyzeDefault expr
-  CtorSaturated qi _ _ _ cs ->
-    withResult KnownNeutral
+  CtorSaturated qi _ ty _ cs ->
+    withResult (Known (Set.singleton (Tuple qi ty)))
       $ bump
       $ usedDep qi
       $ foldMap (foldMap analysisOf) cs
@@ -387,7 +387,7 @@ analyze externAnalysis expr = case expr of
         analysis
     where
     analysis =
-      withResult KnownNeutral
+      withResult mempty
         $ analyzeDefault expr
 
 analyzeEffectBlock :: forall a. HasAnalysis a => HasSyntax a => (Qualified Ident -> Maybe String -> Maybe BackendAnalysis) -> BackendSyntax a -> BackendAnalysis

src/PureScript/Backend/Optimizer/Convert.purs

@@ -73,7 +73,7 @@ import Partial.Unsafe (unsafeCrashWith, unsafePartial)
 import PureScript.Backend.Optimizer.Analysis (BackendAnalysis, 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(..), ExternImpl(..), ExternSpine, InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, InlineRef(..), NeutralExpr(..), build, evalExternFromImpl, evalExternRefFromImpl, freeze, optimize)
 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)
@@ -263,7 +263,7 @@ toTopLevelBackendBinding group env (Binding _ ident cfn) = do
                     Just $ Map.union oldDirs dirs
                   Nothing ->
                     Just dirs
-                (EvalExtern (Qualified (Just env.currentModule) ident))
+                (InlineExtern (Qualified (Just env.currentModule) ident))
                 env.directives
             Nothing ->
               env.directives
@@ -276,14 +276,14 @@ inferTransitiveDirective directives impl backendExpr cfn = fromImpl <|> fromBack
   where
   fromImpl = case impl of
     ExternExpr _ (NeutralExpr (App (NeutralExpr (Var qual)) args)) ->
-      case Map.lookup (EvalExtern qual) directives of
+      case Map.lookup (InlineExtern qual) directives of
         Just dirs -> do
           let
             newDirs = foldrWithIndex
               ( \ix dir accum -> case ix, dir of
-                  InlineRef, (InlineArity n) ->
+                  InlineAt, (InlineArity n) ->
                     accum
-                      # Map.insert InlineRef (InlineArity (n - NonEmptyArray.length args))
+                      # Map.insert InlineAt (InlineArity (n - NonEmptyArray.length args))
                   InlineSpineProp prop, _ ->
                     accum
                       # Map.insert (InlineProp prop) dir
@@ -300,22 +300,22 @@ inferTransitiveDirective directives impl backendExpr cfn = fromImpl <|> fromBack
         _ ->
           Nothing
     ExternExpr _ (NeutralExpr (Accessor (NeutralExpr (App (NeutralExpr (Var qual)) _)) (GetProp prop))) ->
-      case Map.lookup (EvalExtern qual) directives >>= Map.lookup (InlineSpineProp prop) of
+      case Map.lookup (InlineExtern qual) directives >>= Map.lookup (InlineSpineProp prop) of
         Just (InlineArity n) ->
-          Just $ Map.singleton InlineRef (InlineArity n)
+          Just $ Map.singleton InlineAt (InlineArity n)
         _ ->
           Nothing
     _ ->
       Nothing
 
   fromBackendExpr = case backendExpr of
     ExprSyntax _ (App (ExprSyntax _ (Var qual)) args) ->
-      case Map.lookup (EvalExtern qual) directives >>= Map.lookup InlineRef of
+      case Map.lookup (InlineExtern qual) directives >>= Map.lookup InlineAt of
         Just (InlineArity n)
           | ExprApp (Ann { meta: Just IsSyntheticApp }) _ _ <- cfn
           , arity <- NonEmptyArray.length args
           , arity >= n ->
-              Just $ Map.singleton InlineRef InlineAlways
+              Just $ Map.singleton InlineAt InlineAlways
         _ ->
           Nothing
     _ ->
@@ -370,6 +370,7 @@ getCtx env = Ctx
           else
             analyze lookupExtern expr
   , effect: false
+  , directives: env.directives
   }
   where
   lookupExtern qual acc = do

src/PureScript/Backend/Optimizer/Directives.purs

@@ -19,8 +19,8 @@ import Data.Maybe (Maybe(..))
 import Data.String (Pattern(..))
 import Data.String as String
 import Data.Tuple (Tuple(..), fst)
-import PureScript.Backend.Optimizer.CoreFn (Comment(..), Ident(..), ModuleName(..), Qualified(..))
-import PureScript.Backend.Optimizer.Semantics (EvalRef(..), InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, insertDirective)
+import PureScript.Backend.Optimizer.CoreFn (Comment(..), Ident(..), ModuleName(..), ProperName(..), Qualified(..))
+import PureScript.Backend.Optimizer.Semantics (InlineAccessor(..), InlineDirective(..), InlineDirectiveMap, InlineRef(..), insertDirective)
 import PureScript.CST.Errors (ParseError(..))
 import PureScript.CST.Lexer (lex)
 import PureScript.CST.Parser.Monad (Parser, PositionedError, eof, runParser, take)
@@ -69,36 +69,36 @@ parseDirectiveHeader moduleName = foldl go { errors: [], locals: Map.empty, expo
   parser =
     Left <$> parseDirectiveExport moduleName <|> Right <$> parseDirective
 
-parseDirectiveLine :: String -> Either PositionedError (Maybe (Tuple EvalRef (Tuple InlineAccessor InlineDirective)))
+parseDirectiveLine :: String -> Either PositionedError (Maybe (Tuple InlineRef (Tuple InlineAccessor InlineDirective)))
 parseDirectiveLine line = fst <$> runParser (lex line) parseDirectiveMaybe
 
-parseDirectiveMaybe :: Parser (Maybe (Tuple EvalRef (Tuple InlineAccessor InlineDirective)))
+parseDirectiveMaybe :: Parser (Maybe (Tuple InlineRef (Tuple InlineAccessor InlineDirective)))
 parseDirectiveMaybe = Just <$> parseDirective <|> (Nothing <$ eof)
 
-parseDirectiveExport :: ModuleName -> Parser (Tuple EvalRef (Tuple InlineAccessor InlineDirective))
+parseDirectiveExport :: ModuleName -> Parser (Tuple InlineRef (Tuple InlineAccessor InlineDirective))
 parseDirectiveExport moduleName =
-  ( ado
-      keyword "export"
-      ident <- unqualified
-      accessor <- parseInlineAccessor
-      directive <- parseInlineDirective
-      in Tuple (EvalExtern (Qualified (Just moduleName) ident)) (Tuple accessor directive)
-  ) <* eof
-
-parseDirective :: Parser (Tuple EvalRef (Tuple InlineAccessor InlineDirective))
+  keyword "export" *> parseWithAccessorAndDirective inlineRef <* eof
+  where
+  inlineRef =
+    InlineDataType <<< Qualified (Just moduleName) <$> unqualifiedProper
+      <|> InlineExtern <<< Qualified (Just moduleName) <$> unqualifiedIdent
+
+parseDirective :: Parser (Tuple InlineRef (Tuple InlineAccessor InlineDirective))
 parseDirective =
-  ( ado
-      qual <- qualified
-      accessor <- parseInlineAccessor
-      directive <- parseInlineDirective
-      in Tuple (EvalExtern qual) (Tuple accessor directive)
-  ) <* eof
+  parseWithAccessorAndDirective inlineRef <* eof
+  where
+  inlineRef =
+    InlineDataType <$> qualifiedProper
+      <|> InlineExtern <$> qualifiedIdent
+
+parseWithAccessorAndDirective :: Parser InlineRef -> Parser (Tuple InlineRef (Tuple InlineAccessor InlineDirective))
+parseWithAccessorAndDirective p = Tuple <$> p <*> (Tuple <$> parseInlineAccessor <*> parseInlineDirective)
 
 parseInlineAccessor :: Parser InlineAccessor
 parseInlineAccessor =
   InlineProp <$> (dot *> label)
     <|> InlineSpineProp <$> (dotDot *> dot *> label)
-    <|> pure InlineRef
+    <|> pure InlineAt
 
 parseInlineDirective :: Parser InlineDirective
 parseInlineDirective =
@@ -107,20 +107,34 @@ parseInlineDirective =
     <|> InlineAlways <$ keyword "always"
     <|> InlineArity <$> (keyword "arity" *> equals *> natural)
 
-qualified :: Parser (Qualified Ident)
-qualified = expectMap case _ of
+qualifiedIdent :: Parser (Qualified Ident)
+qualifiedIdent = expectMap case _ of
   { value: CST.TokLowerName (Just (CST.ModuleName mod)) ident } ->
     Just $ Qualified (Just (ModuleName mod)) (Ident ident)
   _ ->
     Nothing
 
-unqualified :: Parser Ident
-unqualified = expectMap case _ of
+qualifiedProper :: Parser (Qualified ProperName)
+qualifiedProper = expectMap case _ of
+  { value: CST.TokUpperName (Just (CST.ModuleName mod)) ident } ->
+    Just $ Qualified (Just (ModuleName mod)) (ProperName ident)
+  _ ->
+    Nothing
+
+unqualifiedIdent :: Parser Ident
+unqualifiedIdent = expectMap case _ of
   { value: CST.TokLowerName Nothing ident } ->
     Just $ Ident ident
   _ ->
     Nothing
 
+unqualifiedProper :: Parser ProperName
+unqualifiedProper = expectMap case _ of
+  { value: CST.TokUpperName Nothing ident } ->
+    Just $ ProperName ident
+  _ ->
+    Nothing
+
 label :: Parser String
 label = expectMap case _ of
   { value: TokRawString lbl } ->