Float compiler-synthesized function applications · purescript/purescript@0eab8ce · GitHub
Skip to content

Commit 0eab8ce

Browse files
rhendricrhendric
committed
Float compiler-synthesized function applications
This commit implements a common subexpression elimination pass during CoreFn optimization. The optimizer only targets `App`s that the compiler has created, meaning: applying functions to typeclass dictionaries, accessing superclasses from a typeclass dictionary, or creating new instances of `IsSymbol`. Furthermore, the pass only moves subexpressions if they can be moved to an outer function or if the subexpression appears more than once inside the scope to which it would be moved.
1 parent 1835443 commit 0eab8ce

32 files changed

Lines changed: 919 additions & 74 deletions

‎CHANGELOG.d/feature_cse-for-typeclass-dicts.md‎

Lines changed: 10 additions & 0 deletions

‎lib/purescript-cst/src/Control/Monad/Supply.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,8 @@ import Control.Monad.Reader
1111
import Control.Monad.State
1212
import Control.Monad.Writer
1313

14+
import Data.Functor.Identity
15+
1416
newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
1517
deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)
1618

@@ -19,3 +21,8 @@ runSupplyT n = flip runStateT n . unSupplyT
1921

2022
evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
2123
evalSupplyT n = fmap fst . runSupplyT n
24+
25+
type Supply = SupplyT Identity
26+
27+
runSupply :: Integer -> Supply a -> (a, Integer)
28+
runSupply n = runIdentity . runSupplyT n

‎lib/purescript-cst/src/Control/Monad/Supply/Class.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Control.Monad.Supply.Class where
77
import Prelude.Compat
88

99
import Control.Monad.Supply
10+
import Control.Monad.RWS
1011
import Control.Monad.State
1112
import Control.Monad.Writer
1213
import Data.Text (Text, pack)
@@ -28,6 +29,7 @@ instance Monad m => MonadSupply (SupplyT m) where
2829

2930
instance MonadSupply m => MonadSupply (StateT s m)
3031
instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)
32+
instance (Monoid w, MonadSupply m) => MonadSupply (RWST r w s m)
3133

3234
freshName :: MonadSupply m => m Text
3335
freshName = fmap (("$" <> ) . pack . show) fresh

‎purescript.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -197,6 +197,7 @@ library
197197
Language.PureScript.CoreFn
198198
Language.PureScript.CoreFn.Ann
199199
Language.PureScript.CoreFn.Binders
200+
Language.PureScript.CoreFn.CSE
200201
Language.PureScript.CoreFn.Desugar
201202
Language.PureScript.CoreFn.Expr
202203
Language.PureScript.CoreFn.FromJSON

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 20 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import qualified Data.Text as T
2626

2727
import Language.PureScript.AST.SourcePos
2828
import Language.PureScript.CodeGen.JS.Common as Common
29-
import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan)
29+
import Language.PureScript.CoreImp.AST (AST, PurityAnnotation(..), everywhereTopDownM, withSourceSpan)
3030
import qualified Language.PureScript.CoreImp.AST as AST
3131
import Language.PureScript.CoreImp.Optimizer
3232
import Language.PureScript.CoreFn
@@ -56,7 +56,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
5656
let mnLookup = renameImports usedNames imps
5757
let decls' = renameModules mnLookup decls
5858
jsDecls <- mapM bindToJs decls'
59-
optimized <- traverse (traverse optimize) jsDecls
59+
optimized <- optimize (map identToJs exps) jsDecls
6060
let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
6161
let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
6262
`S.union` M.keysSet reExps
@@ -67,7 +67,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
6767
comments <- not <$> asks optionsNoComments
6868
let strict = AST.StringLiteral Nothing "use strict"
6969
let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
70-
let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
70+
let foreign' = [AST.VariableIntroduction Nothing "$foreign" (fmap (UnknownPurity,) foreign_) | not $ null foreigns || isNothing foreign_]
7171
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
7272
let foreignExps = exps `intersect` foreigns
7373
let standardExps = exps \\ foreignExps
@@ -127,7 +127,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
127127
let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
128128
let moduleBody = AST.App Nothing (AST.Var Nothing "require")
129129
[AST.StringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn') </> "index.js"))]
130-
withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
130+
withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just (UnknownPurity, moduleBody))
131131

132132
-- | Replaces the `ModuleName`s in the AST so that the generated code refers to
133133
-- the collision-avoiding renamed module imports.
@@ -180,7 +180,13 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
180180
else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
181181
nonRecToJS (ss, _, _, _) ident val = do
182182
js <- valueToJs val
183-
withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js)
183+
withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just (guessPurity val, js))
184+
185+
guessPurity :: Expr Ann -> AST.PurityAnnotation
186+
guessPurity = \case
187+
Var _ (Qualified Nothing _) -> IsPure
188+
App (_, _, _, Just IsSyntheticApp) _ _ -> IsPure
189+
_ -> UnknownPurity
184190

185191
withPos :: SourceSpan -> AST -> m AST
186192
withPos ss js = do
@@ -257,7 +263,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
257263
ret <- valueToJs val
258264
return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) []
259265
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
260-
return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $
266+
return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just . (UnknownPurity,) $
261267
AST.ObjectLiteral Nothing [("create",
262268
AST.Function Nothing Nothing ["value"]
263269
(AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
@@ -299,8 +305,8 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
299305
jsNewObj = AST.Var Nothing newObj
300306
jsEvaluatedObj = AST.Var Nothing evaluatedObj
301307
block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj])
302-
evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj)
303-
objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
308+
evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just (UnknownPurity, obj))
309+
objAssign = AST.VariableIntroduction Nothing newObj (Just (IsPure, AST.ObjectLiteral Nothing []))
304310
copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
305311
cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
306312
assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
@@ -329,7 +335,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
329335
bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
330336
bindersToJs ss binders vals = do
331337
valNames <- replicateM (length vals) freshName
332-
let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
338+
let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map (Just . (UnknownPurity,)) vals)
333339
jss <- forM binders $ \(CaseAlternative bs result) -> do
334340
ret <- guardsToJs result
335341
go valNames ret bs
@@ -378,7 +384,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
378384
binderToJs' varName done (LiteralBinder _ l) =
379385
literalToBinderJS varName done l
380386
binderToJs' varName done (VarBinder _ ident) =
381-
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
387+
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (IsPure, AST.Var Nothing varName)) : done)
382388
binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
383389
binderToJs varName done b
384390
binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
@@ -396,12 +402,12 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
396402
argVar <- freshName
397403
done'' <- go remain done'
398404
js <- binderToJs argVar done'' binder
399-
return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
405+
return (AST.VariableIntroduction Nothing argVar (Just (UnknownPurity, accessorString (mkString $ identToJs field) $ AST.Var Nothing varName)) : js)
400406
binderToJs' _ _ ConstructorBinder{} =
401407
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
402408
binderToJs' varName done (NamedBinder _ ident binder) = do
403409
js <- binderToJs varName done binder
404-
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
410+
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (IsPure, AST.Var Nothing varName)) : js)
405411

406412
literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
407413
literalToBinderJS varName done (NumericLiteral num) =
@@ -422,7 +428,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
422428
propVar <- freshName
423429
done'' <- go done' bs'
424430
js <- binderToJs propVar done'' binder
425-
return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
431+
return (AST.VariableIntroduction Nothing propVar (Just (UnknownPurity, accessorString prop (AST.Var Nothing varName))) : js)
426432
literalToBinderJS varName done (ArrayLiteral bs) = do
427433
js <- go done 0 bs
428434
return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing]
@@ -433,7 +439,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
433439
elVar <- freshName
434440
done'' <- go done' (index + 1) bs'
435441
js <- binderToJs elVar done'' binder
436-
return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
442+
return (AST.VariableIntroduction Nothing elVar (Just (UnknownPurity, AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
437443

438444
-- Check that all integers fall within the valid int range for JavaScript.
439445
checkIntegers :: AST -> m ()

‎src/Language/PureScript/CodeGen/JS/Printer.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ literals = mkPattern' match'
7171
match (Var _ ident) = return $ emit ident
7272
match (VariableIntroduction _ ident value) = mconcat <$> sequence
7373
[ return $ emit $ "var " <> ident
74-
, maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
74+
, maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS' . snd) value
7575
]
7676
match (Assignment _ target value) = mconcat <$> sequence
7777
[ prettyPrintJS' target

‎src/Language/PureScript/Constants/Prelude.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -113,6 +113,9 @@ zshr = "zshr"
113113
complement :: forall a. (IsString a) => a
114114
complement = "complement"
115115

116+
identity :: forall a. (IsString a) => a
117+
identity = "identity"
118+
116119
-- Prelude Values
117120

118121
zero :: forall a. (IsString a) => a
@@ -265,6 +268,9 @@ semigroupString = "semigroupString"
265268
semigroupoidFn :: forall a. (IsString a) => a
266269
semigroupoidFn = "semigroupoidFn"
267270

271+
categoryFn :: forall a. (IsString a) => a
272+
categoryFn = "categoryFn"
273+
268274
-- Data.Symbol
269275

270276
pattern DataSymbol :: ModuleName
@@ -297,6 +303,9 @@ pattern ControlBind = ModuleName "Control.Bind"
297303
controlBind :: forall a. (IsString a) => a
298304
controlBind = "Control_Bind"
299305

306+
controlCategory :: forall a. (IsString a) => a
307+
controlCategory = "Control_Category"
308+
300309
controlMonadEffUncurried :: forall a. (IsString a) => a
301310
controlMonadEffUncurried = "Control_Monad_Eff_Uncurried"
302311

‎src/Language/PureScript/CoreFn/Binders.hs‎

Lines changed: 1 addition & 1 deletion

0 commit comments

Comments
 (0)