Skip to content

Commit 6caf468

Browse files
UnisayUnisay
committed
Improve inlining of foreign imports
1 parent 8a5a813 commit 6caf468

8 files changed

Lines changed: 340 additions & 144 deletions

File tree

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

Lines changed: 4 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -35,24 +35,11 @@ eliminateDeadCode uber@UberModule {..} =
3535
-- trace ("\nadjacencyList:\n" <> shower adjacencyList <> "\n") $
3636
-- trace ("\nreachableIds:\n" <> shower reachableIds <> "\n\n") $
3737
uber
38-
{ uberModuleForeigns = preservedForeigns
38+
{ uberModuleForeigns
3939
, uberModuleBindings = preserveBindings
4040
, uberModuleExports = preservedExports
4141
}
4242
where
43-
preservedForeigns ∷ [(ModuleName, FilePath, NonEmpty Name)]
44-
preservedForeigns = do
45-
(modname, path, foreignNames) ← annotatedForeigns
46-
case NE.nonEmpty (preservedNames foreignNames) of
47-
Nothing → []
48-
Just names → [(modname, path, names)]
49-
where
50-
preservedNames ∷ [(Id, Name)] → [Name]
51-
preservedNames foreignNames = do
52-
(idName, foreignName) ← foreignNames
53-
guard $ idName `Set.member` reachableIds
54-
pure foreignName
55-
5643
preserveBindings ∷ [Grouping (QName, Exp)]
5744
preserveBindings = do
5845
grouping ← annotatedBindings
@@ -78,15 +65,12 @@ eliminateDeadCode uber@UberModule {..} =
7865

7966
annotatedExports ∷ [(Id, Name, AExp)]
8067
annotatedBindings ∷ [Grouping (Id, QName, AExp)]
81-
annotatedForeigns ∷ [(ModuleName, FilePath, [(Id, Name)])]
82-
(annotatedExports, annotatedBindings, annotatedForeigns) = runAnnM do
68+
(annotatedExports, annotatedBindings) = runAnnM do
8369
annExports ← forM uberModuleExports \(name, expr) →
8470
(,name,) <$> nextId <*> annotateExp expr
8571
annBindings ← forM uberModuleBindings $ traverse \(qname, expr) →
8672
(,qname,) <$> nextId <*> annotateExp expr
87-
annForeignNames ← forM uberModuleForeigns \(modname, path, names) →
88-
(modname,path,) <$> forM (toList names) \name → fmap (,name) nextId
89-
pure (annExports, annBindings, annForeignNames)
73+
pure (annExports, annBindings)
9074

9175
dceAnnotatedExp ∷ AExp → Exp
9276
dceAnnotatedExp =
@@ -141,10 +125,7 @@ eliminateDeadCode uber@UberModule {..} =
141125

142126
adjacencyList ∷ [((), Id, [Id])]
143127
adjacencyList =
144-
DL.toList $
145-
adjacencyListFromExports
146-
<> adjacencyListFromBindings
147-
<> adjacencyListFromForeigns
128+
DL.toList $ adjacencyListFromExports <> adjacencyListFromBindings
148129

149130
adjacencyListFromExports ∷ DList ((), Id, [Id])
150131
adjacencyListFromExports =
@@ -160,22 +141,13 @@ eliminateDeadCode uber@UberModule {..} =
160141
recBinds & foldMap \(nodeId, _qname, expr) →
161142
adjacencyListForExpr bindingsInScope (nodeId, expr)
162143

163-
adjacencyListFromForeigns ∷ DList ((), Id, [Id])
164-
adjacencyListFromForeigns =
165-
annotatedForeigns & foldMap \(_modname, _path, names) →
166-
DL.fromList (((),,[]) . fst <$> names)
167-
168144
bindingsInScope ∷ Map (Qualified Name, Index) Id
169145
bindingsInScope =
170146
Map.fromList $
171147
[ ((Imported modname name, 0), bindId)
172148
| grouping ← annotatedBindings
173149
, (bindId, QName modname name, _boundExpr) ← listGrouping grouping
174150
]
175-
<> [ ((Imported modname name, 0), foreignNameId)
176-
| (modname, _path, foreignNames) ← annotatedForeigns
177-
, (foreignNameId, name) ← foreignNames
178-
]
179151

180152
adjacencyListFromExport ∷ Id → AExp → DList ((), Id, [Id])
181153
adjacencyListFromExport = curry (adjacencyListForExpr bindingsInScope)

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

Lines changed: 17 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,20 @@
11
module Language.PureScript.Backend.IR.Linker where
22

33
import Data.Graph (graphFromEdges', reverseTopSort)
4-
import Data.List.NonEmpty qualified as NE
54
import Data.Map qualified as Map
65
import Language.PureScript.Backend.IR.Types
76
( Exp
87
, Grouping (..)
98
, Index
109
, Module (..)
11-
, Name
10+
, Name (..)
1211
, Parameter (ParamNamed)
12+
, PropName (..)
1313
, QName (QName)
1414
, Qualified (Imported, Local)
1515
, RawExp (..)
1616
, bindingNames
17+
, objectProp
1718
, ref
1819
, refImported
1920
, unAnn
@@ -30,7 +31,7 @@ data LinkMode
3031

3132
data UberModule = UberModule
3233
{ uberModuleBindings ∷ [Grouping (QName, Exp)]
33-
, uberModuleForeigns ∷ [(ModuleName, FilePath, NonEmpty Name)]
34+
, uberModuleForeigns ∷ [(ModuleName, FilePath)]
3435
, uberModuleExports ∷ [(Name, Exp)]
3536
}
3637
deriving stock (Show, Eq)
@@ -62,23 +63,27 @@ makeUberModule linkMode modules =
6263

6364
qualifiedModuleBindings ∷ Module → [Grouping (QName, Exp)]
6465
qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
65-
moduleBindings <&> \case
66+
foreignBindings <> flip fmap moduleBindings \case
6667
Standalone binding → Standalone $ qualifyBinding binding
6768
RecursiveGroup bindings → RecursiveGroup $ qualifyBinding <$> bindings
6869
where
70+
foreignModule = refImported moduleName (Name "foreign") 0
71+
foreignBindings ∷ [Grouping (QName, Exp)] =
72+
moduleForeigns <&> \name →
73+
Standalone
74+
( QName moduleName name
75+
, objectProp foreignModule (PropName (nameToText name))
76+
)
77+
6978
qualifyBinding ∷ (Name, Exp) → (QName, Exp)
7079
qualifyBinding = bimap (QName moduleName) (qualifyTopRefs moduleName topRefs)
71-
72-
topRefs ∷ Map Name Index
73-
topRefs =
74-
Map.fromList $
80+
where
81+
topRefs ∷ Map Name Index = Map.fromList do
7582
(,0) <$> ((moduleBindings >>= bindingNames) <> moduleForeigns)
7683

77-
qualifiedModuleForeigns ∷ Module → [(ModuleName, FilePath, NonEmpty Name)]
84+
qualifiedModuleForeigns ∷ Module → [(ModuleName, FilePath)]
7885
qualifiedModuleForeigns Module {moduleName, modulePath, moduleForeigns} =
79-
case NE.nonEmpty moduleForeigns of
80-
Nothing → []
81-
Just foreignNames → [(moduleName, modulePath, foreignNames)]
86+
[(moduleName, modulePath) | not (null moduleForeigns)]
8287

8388
qualifyTopRefs ∷ ModuleName → Map Name Index → Exp → Exp
8489
qualifyTopRefs moduleName = go

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

Lines changed: 1 addition & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -136,6 +136,7 @@ newtype CtorName = CtorName {renderCtorName ∷ Text}
136136
deriving stock (Generic)
137137
deriving (Show) via (Quiet CtorName)
138138

139+
-- TODO: is it used at all?
139140
newtype FieldName = FieldName {renderFieldName ∷ Text}
140141
deriving newtype (Eq, Ord)
141142
deriving stock (Generic)
@@ -157,69 +158,7 @@ qualifiedQName QName {qnameModuleName, qnameName} =
157158
-- Instances -------------------------------------------------------------------
158159

159160
$(deriveEq1 ''Grouping)
160-
-- $(deriveEq1 ''RawExp)
161-
162161
$(deriveOrd1 ''Grouping)
163-
-- $(deriveOrd1 ''RawExp)
164-
165-
{-
166-
\$(deriveShow1 ''Grouping)
167-
-- $(deriveShow1 ''RawExp)
168-
169-
instance Show a ⇒ Show (RawExp a) where
170-
show ∷ RawExp a → String
171-
show = \case
172-
LiteralInt i →
173-
"LiteralInt (" +|| i ||+ ")"
174-
LiteralFloat f →
175-
"LiteralFloat (" +|| f ||+ ")"
176-
LiteralString s →
177-
"LiteralString (" +|| s ||+ ")"
178-
LiteralChar c →
179-
"LiteralChar (" +|| c ||+ ")"
180-
LiteralBool b →
181-
"LiteralBool (" +|| b ||+ ")"
182-
LiteralArray as →
183-
"LiteralArray (" +|| as ||+ ")"
184-
LiteralObject ps →
185-
"LiteralObject (" +|| ps ||+ ")"
186-
Ctor algebraicType tyName ctorName fieldNames →
187-
"Ctor ("
188-
+|| algebraicType
189-
||+ ") ("
190-
+|| tyName
191-
||+ ") ("
192-
+|| ctorName
193-
||+ ") ("
194-
+|| fieldNames
195-
||+ ")"
196-
ReflectCtor a →
197-
"ReflectCtor (" +|| a ||+ ")"
198-
Eq a b →
199-
"Eq (" +|| a ||+ ") (" +|| b ||+ ")"
200-
DataArgumentByIndex index a →
201-
"DataArgumentByIndex (" +|| index ||+ ") (" +|| a ||+ ")"
202-
ArrayIndex a index →
203-
"ArrayIndex (" +|| a ||+ ") (" +|| index ||+ ")"
204-
ArrayLength a →
205-
"ArrayLength (" +|| a ||+ ")"
206-
ObjectProp a propName →
207-
"ObjectProp (" +|| a ||+ ") (" +|| propName ||+ ")"
208-
ObjectUpdate a patches →
209-
"ObjectUpdate (" +|| a ||+ ") (" +|| patches ||+ ")"
210-
Abs argument a →
211-
"Abs (" +|| argument ||+ ") (" +|| a ||+ ")"
212-
App a b →
213-
"App (" +|| a ||+ ") (" +|| b ||+ ")"
214-
Ref qname index →
215-
"Ref (" +|| qname ||+ ") (" +|| index ||+ ")"
216-
Let bindings a →
217-
"Let (" +|| bindings ||+ ") (" +|| a ||+ ")"
218-
IfThenElse p t e →
219-
"IfThenElse (" +|| p ||+ ") (" +|| t ||+ ") (" +|| e ||+ ")"
220-
Exception msg →
221-
"Exception (" +|| msg ||+ ")"
222-
-}
223162

224163
deriving stock instance Show Module
225164

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

Lines changed: 12 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -50,26 +50,18 @@ fromUberModule
5050
→ ExceptT (Variant e) IO Lua.Chunk
5151
fromUberModule foreigns needsRuntimeLazy appOrModule uber = do
5252
foreignBindings ←
53-
Linker.uberModuleForeigns uber & foldMapM \(moduleName, path, names) → do
54-
moduleForeign ←
55-
if null names
56-
then pure []
57-
else do
58-
moduleForeign ←
59-
Oops.hoistEither =<< liftIO do
60-
Foreign.resolveForModule path (untag foreigns)
61-
<&> first LinkerErrorForeign
62-
pure . Lua.ForeignSourceCode . Text.strip . decodeUtf8
63-
<$> readFileBS (toFilePath moduleForeign)
64-
65-
let qfname = qualifyName moduleName [Lua.name|foreign|]
66-
foreignTable = Lua.local1 qfname (Lua.thunks moduleForeign)
67-
foreignFields =
68-
toList names <&> \name →
69-
Lua.local1
70-
(fromQName moduleName name)
71-
(Lua.varField (Lua.varName qfname) (fromName name))
72-
pure $ foreignTable : foreignFields
53+
forM (Linker.uberModuleForeigns uber) \(moduleName, path) → do
54+
moduleForeign ← do
55+
moduleForeign ←
56+
Oops.hoistEither =<< liftIO do
57+
Foreign.resolveForModule path (untag foreigns)
58+
<&> first LinkerErrorForeign
59+
pure . Lua.ForeignSourceCode . Text.strip . decodeUtf8
60+
<$> readFileBS (toFilePath moduleForeign)
61+
pure $
62+
Lua.local1
63+
(qualifyName moduleName [Lua.name|foreign|])
64+
(Lua.thunks moduleForeign)
7365

7466
bindings ←
7567
Linker.uberModuleBindings uber & foldMapM \case

‎test/ps/output/Golden.TestForeign/golden.ir‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,10 @@
11
UberModule
22
{ uberModuleBindings = [], uberModuleForeigns =
3+
[ ( ModuleName "Golden.TestForeign", "golden/Golden/TestForeign.purs" ) ], uberModuleExports =
34
[
4-
( ModuleName "Golden.TestForeign", "golden/Golden/TestForeign.purs", Name "foo" :| [] )
5-
], uberModuleExports =
6-
[ ( Name "foo", Ref ( Imported ( ModuleName "Golden.TestForeign" ) ( Name "foo" ) ) 0 ) ]
5+
( Name "foo", ObjectProp
6+
( Identity ( Ref ( Imported ( ModuleName "Golden.TestForeign" ) ( Name "foreign" ) ) 0 ) )
7+
( PropName "foo" )
8+
)
9+
]
710
}

‎test/ps/output/Golden.TestForeign/golden.lua‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,5 +2,4 @@ local Golden_TestForeign_I_foreign = (function()
22
local fooBar = 42
33
return { foo = fooBar }
44
end)()
5-
local Golden_TestForeign_I_foo = Golden_TestForeign_I_foreign.foo
6-
return { foo = Golden_TestForeign_I_foo }
5+
return { foo = Golden_TestForeign_I_foreign.foo }

‎test/ps/output/Golden.TestHelloPrelude/golden.ir‎

Lines changed: 32 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,10 @@ UberModule
3131
{ qnameModuleName = ModuleName "Effect", qnameName = Name "bindEffect" }, LiteralObject
3232
[
3333
( PropName "bind", Identity
34-
( Ref ( Imported ( ModuleName "Effect" ) ( Name "bindE" ) ) 0 )
34+
( ObjectProp
35+
( Identity ( Ref ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) )
36+
( PropName "bindE" )
37+
)
3538
),
3639
( PropName "Apply0", Identity
3740
( Abs ( Identity ParamUnused )
@@ -54,7 +57,10 @@ UberModule
5457
}, LiteralObject
5558
[
5659
( PropName "pure", Identity
57-
( Ref ( Imported ( ModuleName "Effect" ) ( Name "pureE" ) ) 0 )
60+
( ObjectProp
61+
( Identity ( Ref ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) )
62+
( PropName "pureE" )
63+
)
5864
),
5965
( PropName "Apply0", Identity
6066
( Abs ( Identity ParamUnused )
@@ -378,10 +384,22 @@ UberModule
378384
)
379385
], uberModuleForeigns =
380386
[
381-
( ModuleName "Data.Unit", ".spago/prelude/v6.0.3/src/Data/Unit.purs", Name "unit" :| [] ),
382-
( ModuleName "Effect", ".spago/effect/v4.0.0/src/Effect.purs", Name "pureE" :|
383-
[ Name "bindE" ]
384-
)
387+
( ModuleName "Data.Symbol", ".spago/prelude/v6.0.3/src/Data/Symbol.purs" ),
388+
( ModuleName "Data.Unit", ".spago/prelude/v6.0.3/src/Data/Unit.purs" ),
389+
( ModuleName "Record.Unsafe", ".spago/prelude/v6.0.3/src/Record/Unsafe.purs" ),
390+
( ModuleName "Data.HeytingAlgebra", ".spago/prelude/v6.0.3/src/Data/HeytingAlgebra.purs" ),
391+
( ModuleName "Data.Eq", ".spago/prelude/v6.0.3/src/Data/Eq.purs" ),
392+
( ModuleName "Data.Semigroup", ".spago/prelude/v6.0.3/src/Data/Semigroup.purs" ),
393+
( ModuleName "Data.Show", ".spago/prelude/v6.0.3/src/Data/Show.purs" ),
394+
( ModuleName "Data.Semiring", ".spago/prelude/v6.0.3/src/Data/Semiring.purs" ),
395+
( ModuleName "Data.Ring", ".spago/prelude/v6.0.3/src/Data/Ring.purs" ),
396+
( ModuleName "Data.Ord", ".spago/prelude/v6.0.3/src/Data/Ord.purs" ),
397+
( ModuleName "Data.Functor", ".spago/prelude/v6.0.3/src/Data/Functor.purs" ),
398+
( ModuleName "Control.Apply", ".spago/prelude/v6.0.3/src/Control/Apply.purs" ),
399+
( ModuleName "Control.Bind", ".spago/prelude/v6.0.3/src/Control/Bind.purs" ),
400+
( ModuleName "Data.Bounded", ".spago/prelude/v6.0.3/src/Data/Bounded.purs" ),
401+
( ModuleName "Data.EuclideanRing", ".spago/prelude/v6.0.3/src/Data/EuclideanRing.purs" ),
402+
( ModuleName "Effect", ".spago/effect/v4.0.0/src/Effect.purs" )
385403
], uberModuleExports =
386404
[
387405
( Name "main", App
@@ -398,7 +416,14 @@ UberModule
398416
( Identity ( Ref ( Local ( Name "dictApplicative" ) ) 0 ) )
399417
)
400418
)
401-
( Identity ( Ref ( Imported ( ModuleName "Data.Unit" ) ( Name "unit" ) ) 0 ) )
419+
( Identity
420+
( ObjectProp
421+
( Identity
422+
( Ref ( Imported ( ModuleName "Data.Unit" ) ( Name "foreign" ) ) 0 )
423+
)
424+
( PropName "unit" )
425+
)
426+
)
402427
)
403428
)
404429
)

0 commit comments

Comments
 (0)