Float compiler-synthesized function applications · purescript/purescript@56d6837 · GitHub
Skip to content

Commit 56d6837

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 fcf0acb commit 56d6837

27 files changed

Lines changed: 816 additions & 75 deletions

File tree

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

Lines changed: 2 additions & 0 deletions

‎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: 38 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -26,9 +26,10 @@ 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
32+
import Language.PureScript.CoreImp.Optimizer.Common (replaceIdents)
3233
import Language.PureScript.CoreFn
3334
import Language.PureScript.Crash
3435
import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
@@ -56,7 +57,8 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
5657
let mnLookup = renameImports usedNames imps
5758
let decls' = renameModules mnLookup decls
5859
jsDecls <- mapM bindToJs decls'
59-
optimized <- traverse (traverse optimize) jsDecls
60+
let expander = buildExpander (concat jsDecls)
61+
optimized <- traverse (traverse (optimize expander)) jsDecls
6062
let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
6163
let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
6264
`S.union` M.keysSet reExps
@@ -67,7 +69,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
6769
comments <- not <$> asks optionsNoComments
6870
let strict = AST.StringLiteral Nothing "use strict"
6971
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_]
72+
let foreign' = [AST.VariableIntroduction Nothing "$foreign" (fmap (UnknownPurity,) foreign_) | not $ null foreigns || isNothing foreign_]
7173
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
7274
let foreignExps = exps `intersect` foreigns
7375
let standardExps = exps \\ foreignExps
@@ -127,7 +129,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
127129
let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
128130
let moduleBody = AST.App Nothing (AST.Var Nothing "require")
129131
[AST.StringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn') </> "index.js"))]
130-
withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
132+
withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just (UnknownPurity, moduleBody))
131133

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

181189
withPos :: SourceSpan -> AST -> m AST
182190
withPos ss js = do
@@ -265,7 +273,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
265273
ret <- valueToJs val
266274
return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) []
267275
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
268-
return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $
276+
return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just . (UnknownPurity,) $
269277
AST.ObjectLiteral Nothing [("create",
270278
AST.Function Nothing Nothing ["value"]
271279
(AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
@@ -307,8 +315,8 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
307315
jsNewObj = AST.Var Nothing newObj
308316
jsEvaluatedObj = AST.Var Nothing evaluatedObj
309317
block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj])
310-
evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj)
311-
objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
318+
evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just (UnknownPurity, obj))
319+
objAssign = AST.VariableIntroduction Nothing newObj (Just (IsPure, AST.ObjectLiteral Nothing []))
312320
copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
313321
cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
314322
assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
@@ -337,7 +345,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
337345
bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
338346
bindersToJs ss binders vals = do
339347
valNames <- replicateM (length vals) freshName
340-
let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
348+
let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map (Just . (UnknownPurity,)) vals)
341349
jss <- forM binders $ \(CaseAlternative bs result) -> do
342350
ret <- guardsToJs result
343351
go valNames ret bs
@@ -386,7 +394,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
386394
binderToJs' varName done (LiteralBinder _ l) =
387395
literalToBinderJS varName done l
388396
binderToJs' varName done (VarBinder _ ident) =
389-
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
397+
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (IsPure, AST.Var Nothing varName)) : done)
390398
binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
391399
binderToJs varName done b
392400
binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
@@ -404,12 +412,12 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
404412
argVar <- freshName
405413
done'' <- go remain done'
406414
js <- binderToJs argVar done'' binder
407-
return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
415+
return (AST.VariableIntroduction Nothing argVar (Just (UnknownPurity, accessorString (mkString $ identToJs field) $ AST.Var Nothing varName)) : js)
408416
binderToJs' _ _ ConstructorBinder{} =
409417
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
410418
binderToJs' varName done (NamedBinder _ ident binder) = do
411419
js <- binderToJs varName done binder
412-
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
420+
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (IsPure, AST.Var Nothing varName)) : js)
413421

414422
literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
415423
literalToBinderJS varName done (NumericLiteral num) =
@@ -430,7 +438,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
430438
propVar <- freshName
431439
done'' <- go done' bs'
432440
js <- binderToJs propVar done'' binder
433-
return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
441+
return (AST.VariableIntroduction Nothing propVar (Just (UnknownPurity, accessorString prop (AST.Var Nothing varName))) : js)
434442
literalToBinderJS varName done (ArrayLiteral bs) = do
435443
js <- go done 0 bs
436444
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]
@@ -441,7 +449,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
441449
elVar <- freshName
442450
done'' <- go done' (index + 1) bs'
443451
js <- binderToJs elVar done'' binder
444-
return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
452+
return (AST.VariableIntroduction Nothing elVar (Just (UnknownPurity, AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
445453

446454
-- Check that all integers fall within the valid int range for JavaScript.
447455
checkIntegers :: AST -> m ()
@@ -462,3 +470,19 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ =
462470
then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt
463471
else return js
464472
go other = return other
473+
474+
-- |
475+
-- Take all top-level ASTs and return a function for expanding top-level
476+
-- variables during the various inlining steps in `optimize`.
477+
--
478+
-- Everything that gets inlined as an optimization is of a form that would
479+
-- have been lifted to a top-level binding during CSE, so for purposes of
480+
-- inlining we can save some time by only expanding variables bound at that
481+
-- level and not worrying about any inner scopes.
482+
--
483+
buildExpander :: [AST] -> AST -> AST
484+
buildExpander = replaceIdents . foldr go []
485+
where
486+
go = \case
487+
AST.VariableIntroduction _ name (Just (IsPure, e)) -> ((name, e) :)
488+
_ -> id

‎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
@@ -176,6 +176,9 @@ zshr = "zshr"
176176
complement :: forall a. (IsString a) => a
177177
complement = "complement"
178178

179+
identity :: forall a. (IsString a) => a
180+
identity = "identity"
181+
179182
-- Prelude Values
180183

181184
zero :: forall a. (IsString a) => a
@@ -349,6 +352,9 @@ semigroupString = "semigroupString"
349352
semigroupoidFn :: forall a. (IsString a) => a
350353
semigroupoidFn = "semigroupoidFn"
351354

355+
categoryFn :: forall a. (IsString a) => a
356+
categoryFn = "categoryFn"
357+
352358
-- Generic Deriving
353359

354360
generic :: forall a. (IsString a) => a
@@ -403,6 +409,9 @@ pattern ControlBind = ModuleName "Control.Bind"
403409
controlBind :: forall a. (IsString a) => a
404410
controlBind = "Control_Bind"
405411

412+
controlCategory :: forall a. (IsString a) => a
413+
controlCategory = "Control_Category"
414+
406415
controlMonadEffUncurried :: forall a. (IsString a) => a
407416
controlMonadEffUncurried = "Control_Monad_Eff_Uncurried"
408417

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

Lines changed: 1 addition & 1 deletion

0 commit comments

Comments
 (0)