Skip to content

Commit 7c7b7b7

Browse files
UnisayUnisay
committed
DCE for foreign imports.
1 parent 4ad858c commit 7c7b7b7

File tree

46 files changed

+339
-212
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

46 files changed

+339
-212
lines changed

‎lib/Language/PureScript/Backend.hs

-1
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Language.PureScript.Backend.Lua.Types qualified as Lua
1313
import Language.PureScript.Backend.Types (AppOrModule (..), entryPointModule)
1414
import Language.PureScript.CoreFn.Reader qualified as CoreFn
1515
import Path (Abs, Dir, Path, SomeBase)
16-
import Text.Pretty.Simple (pPrint)
1716
import Prelude hiding (show)
1817

1918
data CompilationResult = CompilationResult

‎lib/Language/PureScript/Backend/IR.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -96,7 +96,7 @@ mkModule cfnModule contextDataTypes = do
9696
moduleImports ← mkImports
9797
moduleExports ← mkExports
9898
moduleReExports ← mkReExports
99-
moduleForeigns ← mkForeign
99+
moduleForeigns ← mkForeigns
100100
pure
101101
Module
102102
{ moduleName = Cfn.moduleName cfnModule
@@ -148,8 +148,8 @@ mkReExports =
148148
Map.fromAscList . fmap (identToName <<$>>) . Map.toAscList
149149
<$> gets (contextModule >>> Cfn.moduleReExports)
150150

151-
mkForeign ∷ RepM [(Ann, Name)]
152-
mkForeign = do
151+
mkForeigns ∷ RepM [(Ann, Name)]
152+
mkForeigns = do
153153
idents ← gets (contextModule >>> Cfn.moduleForeign)
154154
forM idents \ident → do
155155
let name = identToName ident

‎lib/Language/PureScript/Backend/IR/DCE.hs

+174-79
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,19 @@
1-
module Language.PureScript.Backend.IR.DCE where
1+
module Language.PureScript.Backend.IR.DCE
2+
( EntryPoint (..)
3+
, eliminateDeadCode
4+
) where
25

36
import Data.DList (DList)
47
import Data.DList qualified as DL
58
import Data.Graph (Graph, Vertex, graphFromEdges, reachable)
69
import Data.List.NonEmpty qualified as NE
710
import Data.Map qualified as Map
11+
import Data.Set (member)
812
import Data.Set qualified as Set
913
import Language.PureScript.Backend.IR.Linker (UberModule (..))
1014
import Language.PureScript.Backend.IR.Names
1115
( ModuleName
12-
, Name
16+
, Name (..)
1317
, QName (..)
1418
, Qualified (..)
1519
)
@@ -33,23 +37,50 @@ data EntryPoint = EntryPoint ModuleName [Name]
3337

3438
type Scope = Map (Qualified Name, Index) Id
3539

40+
type Node = ((), Id, [Id])
41+
3642
eliminateDeadCode ∷ UberModule → UberModule
3743
eliminateDeadCode uber@UberModule {..} =
38-
-- trace ("\n\nannotatedBindings:\n" <> toString (pShow annotatedBindings) <> "\n") $
39-
-- trace ("\nannotatedExports:\n" <> toString (pShow annotatedExports) <> "\n") $
40-
-- trace ("\nadjacencyList:\n" <> toString (pShow adjacencyList) <> "\n") $
41-
-- trace ("\nreachableIds:\n" <> toString (pShow reachableIds) <> "\n\n") $
44+
-- traceIt "annotatedForeigns" annotatedForeigns $
45+
-- traceIt "annotatedBindings" annotatedBindings $
46+
-- traceIt "annotatedExports" annotatedExports $
47+
-- traceIt "topLevelScope" topLevelScope $
48+
-- traceIt "adjacencyList" adjacencyList $
49+
-- traceIt "reachableIds" reachableIds $
4250
uber
43-
{ uberModuleBindings = preserveBindings
51+
{ uberModuleForeigns = preservedForeigns
52+
, uberModuleBindings = preservedBindings
4453
, uberModuleExports = preservedExports
4554
}
4655
where
47-
preserveBindings ∷ [Grouping (QName, Exp)]
48-
preserveBindings = do
49-
grouping ← annotatedBindings
50-
case grouping of
56+
-- traceIt ∷ ∀ a b. Show a ⇒ String → a → b → b
57+
-- traceIt label it =
58+
-- trace ("\n\n" <> label <> ":\n" <> pp it <> "\n")
59+
-- where
60+
-- pp =
61+
-- toString
62+
-- . pShowOpt
63+
-- defaultOutputOptionsDarkBg
64+
-- { outputOptionsCompact = True
65+
-- }
66+
67+
preservedForeigns ∷ [(QName, Exp)]
68+
preservedForeigns = do
69+
(name, expr) ← annotatedForeigns
70+
guard $ nodeId expr `member` reachableIds
71+
pure . (name,) $ case expr of
72+
ForeignImport (_id, ann) modname path names →
73+
ForeignImport
74+
ann
75+
modname
76+
path
77+
[(a, n) | ((i, a), n) ← names, i `member` reachableIds]
78+
other → dceAnnotatedExp other
79+
80+
preservedBindings ∷ [Grouping (QName, Exp)] =
81+
annotatedBindings >>= \case
5182
Standalone (qname, expr) → do
52-
guard $ nodeId expr `Set.member` reachableIds
83+
guard $ nodeId expr `member` reachableIds
5384
[Standalone (qname, dceAnnotatedExp expr)]
5485
RecursiveGroup recBinds →
5586
case NE.nonEmpty (preservedRecBinds (toList recBinds)) of
@@ -59,29 +90,38 @@ eliminateDeadCode uber@UberModule {..} =
5990
preservedRecBinds ∷ [(QName, AExp)] → [(QName, Exp)]
6091
preservedRecBinds recBinds = do
6192
(qname, expr) ← recBinds
62-
guard $ nodeId expr `Set.member` reachableIds
93+
guard $ nodeId expr `member` reachableIds
6394
pure (qname, dceAnnotatedExp expr)
6495

6596
preservedExports ∷ [(Name, Exp)]
6697
preservedExports = do
6798
(name, annotatedExp) ← annotatedExports
6899
pure (name, dceAnnotatedExp annotatedExp)
69100

70-
( annotatedExports ∷ [(Name, AExp)]
101+
-- run these computations in the same monad
102+
-- so that we can share the state of the ID counter
103+
( annotatedForeigns ∷ [(QName, AExp)]
71104
, annotatedBindings ∷ [Grouping (QName, AExp)]
105+
, annotatedExports ∷ [(Name, AExp)]
72106
) = runAnnM do
73-
-- run both computations in the same monad
74-
-- so that we can share the state of the ID counter
75-
exports ← traverse (traverse assignUniqueIds) uberModuleExports
76-
binds ← traverse (traverse (traverse assignUniqueIds)) uberModuleBindings
77-
pure (exports, binds)
107+
liftA3
108+
(,,)
109+
(traverse (traverse assignUniqueIds) uberModuleForeigns)
110+
(traverse (traverse (traverse assignUniqueIds)) uberModuleBindings)
111+
(traverse (traverse assignUniqueIds) uberModuleExports)
112+
113+
annotatedForeignImports ∷ [(QName, AExp)] =
114+
[i | i@(_qname, ForeignImport {}) ← annotatedForeigns]
115+
116+
annotatedForeignBindings ∷ [(QName, AExp)] =
117+
[b | b@(_qname, ObjectProp {}) ← annotatedForeigns]
78118

79119
dceAnnotatedExp ∷ AExp → Exp
80120
dceAnnotatedExp =
81121
deannotateExp <$> rewriteExpTopDown do
82122
pure . \case
83123
Abs ann param b
84-
| not (paramId `Set.member` reachableIds) →
124+
| not (paramId `member` reachableIds) →
85125
Rewritten Recurse (Abs ann param' b)
86126
where
87127
paramId ∷ Id =
@@ -101,7 +141,7 @@ eliminateDeadCode uber@UberModule {..} =
101141
preservedBinds =
102142
toList binds >>= \case
103143
b@(Standalone ((expId, _ann), _name, _expr)) →
104-
[b | expId `Set.member` reachableIds]
144+
[b | expId `member` reachableIds]
105145
RecursiveGroup recBinds →
106146
case NE.nonEmpty preservedRecBinds of
107147
Nothing → []
@@ -110,7 +150,7 @@ eliminateDeadCode uber@UberModule {..} =
110150
preservedRecBinds =
111151
[ b
112152
| b@((nameId, _ann), _, _) ← toList recBinds
113-
, nameId `Set.member` reachableIds
153+
, nameId `member` reachableIds
114154
]
115155
_ → NoChange
116156

@@ -132,39 +172,93 @@ eliminateDeadCode uber@UberModule {..} =
132172
-- Building a graph of nodes -------------------------------------------------
133173

134174
( graph ∷ Graph
135-
, vertexToV ∷ Vertex → ((), Id, [Id])
175+
, vertexToV ∷ Vertex → Node
136176
, keyToVertex ∷ Id → Maybe Vertex
137-
) = graphFromEdges adjacencyList
177+
) = graphFromEdges (toList adjacencyList)
178+
179+
-- Crash if the adjacency list is not complete:
180+
-- every referenced node must be present in the list.
181+
-- assertAdjacencyListIsComplete
182+
-- ∷ HasCallStack
183+
-- ⇒ [Node]
184+
-- → [Node]
185+
-- assertAdjacencyListIsComplete al =
186+
-- if referencedNodes `isSubsetOf` nodes
187+
-- then al
188+
-- else
189+
-- error . unlines $
190+
-- [ "Incomplete adjacency list: "
191+
-- , toText (pShow al)
192+
-- , "Nodes: " <> toText (pShow nodes)
193+
-- , "Referenced nodes: " <> toText (pShow referencedNodes)
194+
-- ]
195+
-- where
196+
-- nodes = Set.fromList (al <&> \((), node, _) → node)
197+
-- referencedNodes = Set.fromList (al >>= \((), _, refs) → refs)
198+
199+
mkNode ∷ Id → [Id] → Node
200+
mkNode = ((),,)
201+
202+
adjacencyList ∷ DList Node =
203+
adjacencyListFromForeignImports
204+
<> adjacencyListFromForeignBindings
205+
<> adjacencyListFromExports
206+
<> adjacencyListFromBindings
138207

139-
adjacencyList ∷ [((), Id, [Id])]
140-
adjacencyList =
141-
DL.toList $ adjacencyListFromExports <> adjacencyListFromBindings
208+
adjacencyListFromForeignImports ∷ DList Node = DL.fromList do
209+
annotatedForeignImports <&> \(_qname, expr) → mkNode (nodeId expr) []
142210

143-
adjacencyListFromExports ∷ DList ((), Id, [Id])
144-
adjacencyListFromExports =
211+
-- The functionality which builds adjacency list for foreign bindings
212+
-- depends on the particular sturcture emitted by the 'Linker' and therefore
213+
-- is not generic.
214+
adjacencyListFromForeignBindings ∷ DList Node =
215+
annotatedForeignBindings & foldMap \case
216+
( QName bindingModule bindingName
217+
, ObjectProp (objPropId, _) (Ref (objRefId, _) _ 0) _prop
218+
) →
219+
DL.fromList do
220+
mkNode objPropId (objRefId : map fst foreignImportForBinding)
221+
: mkNode objRefId (map snd foreignImportForBinding)
222+
: [mkNode propId [] | (propId, _) ← foreignImportForBinding]
223+
where
224+
foreignImportForBinding ∷ [(Id, Id)] =
225+
[ (propId, importId)
226+
| ( QName importModule _foreign
227+
, ForeignImport (importId, _) _ _ propNames
228+
) ←
229+
annotatedForeignImports
230+
, bindingModule == importModule
231+
, ((propId, _ann), propName) ← propNames
232+
, propName == bindingName
233+
]
234+
_ → DL.empty
235+
236+
adjacencyListFromExports ∷ DList Node =
145237
annotatedExports & foldMap \(_name, expr) →
146-
adjacencyListForExpr bindingsInScope expr
238+
adjacencyListForExpr topLevelScope expr
147239

148-
adjacencyListFromBindings ∷ DList ((), Id, [Id])
149-
adjacencyListFromBindings =
240+
adjacencyListFromBindings ∷ DList Node =
150241
annotatedBindings & foldMap \case
151242
Standalone (_qname, expr) →
152-
adjacencyListForExpr bindingsInScope expr
243+
adjacencyListForExpr topLevelScope expr
153244
RecursiveGroup recBinds →
154245
recBinds & foldMap \(_qname, expr) →
155-
adjacencyListForExpr bindingsInScope expr
156-
157-
bindingsInScope ∷ Scope
158-
bindingsInScope =
159-
Map.fromList $
160-
[ ((Imported modname name, 0), nodeId expr)
161-
| grouping ← annotatedBindings
162-
, (QName modname name, expr) ← listGrouping grouping
163-
]
246+
adjacencyListForExpr topLevelScope expr
164247

165-
adjacencyListForExpr ∷ Scope → AExp → DList ((), Id, [Id])
248+
topLevelScope ∷ Scope =
249+
Map.fromList (foreignsInScope <> bindingsInScope)
250+
where
251+
foreignsInScope = do
252+
(QName modname name, expr) ← annotatedForeigns
253+
pure ((Imported modname name, 0), nodeId expr)
254+
255+
bindingsInScope = do
256+
(QName modname name, expr) ← listGrouping =<< annotatedBindings
257+
pure ((Imported modname name, 0), nodeId expr)
258+
259+
adjacencyListForExpr ∷ Scope → AExp → DList Node
166260
adjacencyListForExpr scope expr =
167-
((), nodeId expr, expressionDependsOnIds scope expr)
261+
mkNode (nodeId expr) (expressionDependsOnIds scope expr)
168262
`DL.cons` case expr of
169263
LiteralInt {} → mempty
170264
LiteralFloat {} → mempty
@@ -204,7 +298,7 @@ eliminateDeadCode uber@UberModule {..} =
204298
ParamUnused _ann' → adjacencyListForExpr scope b
205299
ParamNamed (paramId, _ann) name →
206300
DL.cons
207-
((), paramId, [])
301+
(mkNode paramId [])
208302
(adjacencyListForExpr (addLocalToScope paramId name 0 scope) b)
209303
Let _ann groupings body →
210304
adjacencyListForExpr scope' body
@@ -216,21 +310,21 @@ eliminateDeadCode uber@UberModule {..} =
216310
addLocalToScope nameId name 0
217311
where
218312
adjacencyListForGrouping
219-
∷ (Scope, DList ((), Id, [Id]))
313+
∷ (Scope, DList Node)
220314
→ Grouping ((Id, Ann), Name, AExp)
221-
→ (Scope, DList ((), Id, [Id]))
315+
→ (Scope, DList Node)
222316
adjacencyListForGrouping (groupingScope, adj) = \case
223317
Standalone binding@((nameId, _ann), _name, boundExpr) →
224318
( updateScope binding groupingScope
225319
, DL.cons
226-
((), nameId, [nodeId boundExpr])
320+
(mkNode nameId [nodeId boundExpr])
227321
(adjacencyListForExpr groupingScope boundExpr <> adj)
228322
)
229323
RecursiveGroup recBinds →
230324
( scope'
231325
, recBinds & foldMap \((nameId, _ann), _name, boundExpr) →
232326
DL.cons
233-
((), nameId, [nodeId boundExpr])
327+
(mkNode nameId [nodeId boundExpr])
234328
(adjacencyListForExpr scope' boundExpr <> adj)
235329
)
236330
where
@@ -239,39 +333,40 @@ eliminateDeadCode uber@UberModule {..} =
239333
updateScope ∷ ((Id, Ann), Name, AExp) → Scope → Scope
240334
updateScope ((nameId, _ann), name, _expr) = addLocalToScope nameId name 0
241335

242-
expressionDependsOnIds ∷ Scope → AExp → [Id]
243-
expressionDependsOnIds exprScope = \case
244-
LiteralArray _ann as → nodeId <$> as
245-
LiteralObject _ann ps → nodeId . snd <$> ps
246-
LiteralInt {} → []
247-
LiteralFloat {} → []
248-
LiteralString {} → []
249-
LiteralChar {} → []
250-
LiteralBool {} → []
251-
Exception {} → []
252-
ForeignImport {} → []
253-
Ctor {} → []
254-
ReflectCtor _ann a → [nodeId a]
255-
Eq _ann a b → [nodeId a, nodeId b]
256-
DataArgumentByIndex _ann _idx a → [nodeId a]
257-
ArrayLength _ann as → [nodeId as]
258-
ArrayIndex _ann a _idx → [nodeId a]
259-
ObjectProp _ann a _prp → [nodeId a]
260-
ObjectUpdate _ann o patches → nodeId o : toList (nodeId . snd <$> patches)
261-
Abs _ann _ b → [nodeId b]
262-
App _ann a b → [nodeId a, nodeId b]
263-
IfThenElse _ann i t e → [nodeId i, nodeId t, nodeId e]
264-
Ref _ann qname idx → maybeToList $ Map.lookup (qname, idx) exprScope
265-
Let _ann _groupings body → [nodeId body]
336+
expressionDependsOnIds ∷ Scope → AExp → [Id]
337+
expressionDependsOnIds exprScope = \case
338+
LiteralArray _ann as → nodeId <$> as
339+
LiteralObject _ann ps → nodeId . snd <$> ps
340+
LiteralInt {} → []
341+
LiteralFloat {} → []
342+
LiteralString {} → []
343+
LiteralChar {} → []
344+
LiteralBool {} → []
345+
Exception {} → []
346+
ForeignImport {} → []
347+
Ctor {} → []
348+
ReflectCtor _ann a → [nodeId a]
349+
Eq _ann a b → [nodeId a, nodeId b]
350+
DataArgumentByIndex _ann _idx a → [nodeId a]
351+
ArrayLength _ann as → [nodeId as]
352+
ArrayIndex _ann a _idx → [nodeId a]
353+
ObjectProp _ann a _prp → [nodeId a]
354+
ObjectUpdate _ann o patches → nodeId o : toList (nodeId . snd <$> patches)
355+
Abs _ann _ b → [nodeId b]
356+
App _ann a b → [nodeId a, nodeId b]
357+
IfThenElse _ann i t e → [nodeId i, nodeId t, nodeId e]
358+
Ref _ann qname idx → maybeToList $ Map.lookup (qname, idx) exprScope
359+
Let _ann _groupings body → [nodeId body]
266360

267361
addLocalToScope ∷ Id → Name → Index → Scope → Scope
268362
addLocalToScope nid name index s =
269-
let lname = Local name
270-
in case Map.lookup (lname, index) s of
271-
Nothing → Map.insert (lname, index) nid s
272-
Just nid' →
273-
Map.insert (lname, index) nid $
274-
addLocalToScope nid' name (succ index) s
363+
case Map.lookup (lname, index) s of
364+
Nothing → Map.insert (lname, index) nid s
365+
Just nid' →
366+
Map.insert (lname, index) nid $
367+
addLocalToScope nid' name (succ index) s
368+
where
369+
lname = Local name
275370

276371
--------------------------------------------------------------------------------
277372
-- Annotating expressions with IDs ---------------------------------------------

0 commit comments

Comments
 (0)