Skip to content

Commit a1ae24e

Browse files
UnisayUnisay
committed
Fix bug in countFreeRefs
1 parent edebc73 commit a1ae24e

5 files changed

Lines changed: 143 additions & 15 deletions

File tree

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

Lines changed: 11 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,13 @@
11
module Language.PureScript.Backend.IR.Optimizer where
22

3+
import Data.Map qualified as Map
34
import Language.PureScript.Backend.IR.DCE qualified as DCE
45
import Language.PureScript.Backend.IR.Linker (UberModule (..))
56
import Language.PureScript.Backend.IR.Types
67
( Annotated
78
, Exp
89
, Grouping (..)
9-
, Name
10+
, Name (..)
1011
, QName (..)
1112
, Qualified (..)
1213
, RawExp (..)
@@ -15,6 +16,7 @@ import Language.PureScript.Backend.IR.Types
1516
, Rewritten (..)
1617
, bindingExprs
1718
, countFreeRef
19+
, countFreeRefs
1820
, isNonRecursiveLiteral
1921
, literalBool
2022
, qualifiedQName
@@ -63,11 +65,14 @@ optimizeModule UberModule {..} =
6365
else (Standalone (qname, expr) : bindings, exports)
6466
where
6567
isUsedOnce name =
66-
1
67-
== sum
68-
( countFreeRef (qualifiedQName name)
69-
<$> ((bindingExprs =<< bindings) <> map snd exports)
70-
)
68+
1 == Map.findWithDefault 0 (qualifiedQName name) uberModuleFreeRefs
69+
uberModuleFreeRefs ∷ Map (Qualified Name) Natural =
70+
foldr
71+
(\e m → Map.unionWith (+) m (countFreeRefs e))
72+
mempty
73+
uberModuleExprs
74+
uberModuleExprs =
75+
(bindingExprs =<< uberModuleBindings) <> map snd exports
7176
RecursiveGroup recGroup →
7277
( RecursiveGroup (optimizedExpression <<$>> recGroup) : bindings
7378
, exports

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

Lines changed: 18 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -477,13 +477,16 @@ countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty
477477
→ Exp
478478
→ MonoidMap (Qualified Name) (Sum Natural)
479479
countFreeRefs' minIndexes = \case
480-
Ref qname index
481-
| Map.findWithDefault 0 qname minIndexes <= index →
482-
MMap.singleton qname (Sum 1)
483-
Abs (unAnn → ParamNamed name) (unAnn → body) →
484-
countFreeRefs' minIndexes' body
485-
where
486-
minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes
480+
Ref qname index →
481+
if Map.findWithDefault 0 qname minIndexes <= index
482+
then MMap.singleton qname (Sum 1)
483+
else mempty
484+
Abs (unAnn → param) (unAnn → body) →
485+
case param of
486+
ParamNamed name → countFreeRefs' minIndexes' body
487+
where
488+
minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes
489+
ParamUnused → countFreeRefs' minIndexes body
487490
Let binds (unAnn → body) → fold (countsInBody : countsInBinds)
488491
where
489492
countsInBody = countFreeRefs' minIndexes' body
@@ -525,7 +528,14 @@ countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty
525528
go a <> foldMap (go . unAnn . snd) patches
526529
IfThenElse (unAnn → p) (unAnn → th) (unAnn → el) →
527530
go p <> go th <> go el
528-
_ → mempty
531+
-- Non-recursives:
532+
LiteralInt {} → mempty
533+
LiteralBool {} → mempty
534+
LiteralFloat {} → mempty
535+
LiteralString {} → mempty
536+
LiteralChar {} → mempty
537+
Ctor {} → mempty
538+
Exception {} → mempty
529539
where
530540
go = countFreeRefs' minIndexes
531541

‎pslua.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -157,6 +157,7 @@ test-suite spec
157157
Language.PureScript.Backend.IR.DCESpec
158158
Language.PureScript.Backend.IR.Gen
159159
Language.PureScript.Backend.IR.OptimizerSpec
160+
Language.PureScript.Backend.IR.TypesSpec
160161
Language.PureScript.Backend.IRSpec
161162
Language.PureScript.Backend.Lua.DeadCodeEliminatorSpec
162163
Language.PureScript.Backend.Lua.Gen

‎test/Language/PureScript/Backend/IR/TypesSpec.hs‎

Lines changed: 110 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,110 @@
1+
module Language.PureScript.Backend.IR.TypesSpec where
2+
3+
import Data.Map qualified as Map
4+
import Hedgehog ((===))
5+
import Language.PureScript.Backend.IR.Types
6+
( Exp
7+
, Grouping (..)
8+
, Name (..)
9+
, Parameter (ParamNamed, ParamUnused)
10+
, Qualified (Imported, Local)
11+
, RawExp (..)
12+
, abstraction
13+
, application
14+
, countFreeRefs
15+
, lets
16+
)
17+
import Language.PureScript.Names (ModuleName (..))
18+
import Test.Hspec (Spec, describe)
19+
import Test.Hspec.Hedgehog.Extended (test)
20+
21+
spec ∷ Spec
22+
spec = describe "Types" do
23+
test "countFreeRefs" do
24+
countFreeRefs expr
25+
=== Map.fromList
26+
[ (Imported (ModuleName "Data.Array") (Name "add"), 1)
27+
, (Imported (ModuleName "Data.Array") (Name "eq1"), 1)
28+
, (Imported (ModuleName "Data.Array") (Name "findLastIndex"), 1)
29+
, (Imported (ModuleName "Data.Array") (Name "fromJust"), 1)
30+
, (Imported (ModuleName "Data.Array") (Name "insertAt"), 1)
31+
, (Imported (ModuleName "Data.Maybe") (Name "maybe"), 1)
32+
, (Imported (ModuleName "Data.Ordering") (Name "GT"), 1)
33+
, (Imported (ModuleName "Partial.Unsafe") (Name "unsafePartial"), 1)
34+
]
35+
36+
expr ∷ Exp
37+
expr =
38+
abstraction
39+
(ParamNamed (Name "cmp"))
40+
( abstraction
41+
(ParamNamed (Name "x"))
42+
( abstraction
43+
(ParamNamed (Name "ys"))
44+
( lets
45+
( Standalone
46+
( Name "i"
47+
, application
48+
( application
49+
( application
50+
(Ref (Imported (ModuleName "Data.Maybe") (Name "maybe")) 0)
51+
(LiteralInt 0)
52+
)
53+
( abstraction
54+
(ParamNamed (Name "v"))
55+
( application
56+
( application
57+
(Ref (Imported (ModuleName "Data.Array") (Name "add")) 0)
58+
(Ref (Local (Name "v")) 0)
59+
)
60+
(LiteralInt 1)
61+
)
62+
)
63+
)
64+
( application
65+
( application
66+
(Ref (Imported (ModuleName "Data.Array") (Name "findLastIndex")) 0)
67+
( abstraction
68+
(ParamNamed (Name "y"))
69+
( application
70+
( application
71+
(Ref (Imported (ModuleName "Data.Array") (Name "eq1")) 0)
72+
( application
73+
( application
74+
(Ref (Local (Name "cmp")) 0)
75+
(Ref (Local (Name "x")) 0)
76+
)
77+
(Ref (Local (Name "y")) 0)
78+
)
79+
)
80+
(Ref (Imported (ModuleName "Data.Ordering") (Name "GT")) 0)
81+
)
82+
)
83+
)
84+
(Ref (Local (Name "ys")) 0)
85+
)
86+
)
87+
:| []
88+
)
89+
( application
90+
(Ref (Imported (ModuleName "Partial.Unsafe") (Name "unsafePartial")) 0)
91+
( abstraction
92+
ParamUnused
93+
( application
94+
(Ref (Imported (ModuleName "Data.Array") (Name "fromJust")) 0)
95+
( application
96+
( application
97+
( application
98+
(Ref (Imported (ModuleName "Data.Array") (Name "insertAt")) 0)
99+
(Ref (Local (Name "i")) 0)
100+
)
101+
(Ref (Local (Name "x")) 0)
102+
)
103+
(Ref (Local (Name "ys")) 0)
104+
)
105+
)
106+
)
107+
)
108+
)
109+
)
110+
)

‎test/Main.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,19 +2,21 @@ module Main where
22

33
import Language.PureScript.Backend.IR.DCESpec qualified as IrDce
44
import Language.PureScript.Backend.IR.OptimizerSpec qualified as IROptimizer
5+
import Language.PureScript.Backend.IR.TypesSpec qualified as Types
56
import Language.PureScript.Backend.IRSpec qualified as IR
67
import Language.PureScript.Backend.Lua.DeadCodeEliminatorSpec qualified as LuaDce
78
import Language.PureScript.Backend.Lua.GoldenSpec qualified as Golden
89
import Language.PureScript.Backend.Lua.OptimizerSpec qualified as LuaOptimizer
910
import Language.PureScript.Backend.Lua.PrinterSpec qualified as Printer
1011
import Test.Hspec (hspec)
1112

12-
main :: IO ()
13+
main ∷ IO ()
1314
main = hspec do
1415
IR.spec
1516
Golden.spec
1617
IrDce.spec
1718
LuaDce.spec
19+
Types.spec
1820
IROptimizer.spec
1921
LuaOptimizer.spec
2022
Printer.spec

0 commit comments

Comments
 (0)