Skip to content

Commit f7642af

Browse files
UnisayUnisay
committed
Fix name shadowing
1 parent 717fd32 commit f7642af

13 files changed

Lines changed: 519 additions & 87 deletions

File tree

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

Lines changed: 9 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -19,17 +19,17 @@ import Language.PureScript.Backend.IR.Types
1919
, RawExp (..)
2020
, RewriteMod (..)
2121
, Rewritten (..)
22-
, bindingNames
22+
, annotateExpM
23+
, groupingNames
2324
, listGrouping
2425
, rewriteExpTopDown
2526
)
2627
import Language.PureScript.Names (ModuleName)
27-
import Shower (shower)
2828

2929
data EntryPoint = EntryPoint ModuleName [Name]
3030
deriving stock (Show)
3131

32-
deriving stock instance Show AExp
32+
-- deriving stock instance Show AExp
3333

3434
eliminateDeadCode ∷ UberModule → UberModule
3535
eliminateDeadCode uber@UberModule {..} =
@@ -71,9 +71,9 @@ eliminateDeadCode uber@UberModule {..} =
7171
annotatedBindings ∷ [Grouping (Id, QName, AExp)]
7272
(annotatedExports, annotatedBindings) = runAnnM do
7373
annExports ← forM uberModuleExports \(name, expr) →
74-
(,name,) <$> nextId <*> annotateExp expr
74+
(,name,) <$> nextId <*> annotateExpWithIds expr
7575
annBindings ← forM uberModuleBindings $ traverse \(qname, expr) →
76-
(,qname,) <$> nextId <*> annotateExp expr
76+
(,qname,) <$> nextId <*> annotateExpWithIds expr
7777
pure (annExports, annBindings)
7878

7979
dceAnnotatedExp ∷ AExp → Exp
@@ -201,7 +201,7 @@ eliminateDeadCode uber@UberModule {..} =
201201
adjacencyListForExpr scope' body
202202
<> snd (foldl' adjacencyListForGrouping (scope, mempty) groupings)
203203
where
204-
scope' = foldr addToScope scope (bindingNames =<< toList groupings)
204+
scope' = foldr addToScope scope (groupingNames =<< toList groupings)
205205
addToScope (nameId, name) = addLocalToScope nameId name 0
206206
where
207207
adjacencyListForGrouping
@@ -288,39 +288,9 @@ nextId = AnnM do
288288
runAnnM ∷ AnnM a → a
289289
runAnnM = (`evalState` 0) . unAnnM
290290

291-
annotateExp ∷ Exp → AnnM AExp
292-
annotateExp = \case
293-
LiteralInt i → pure $ LiteralInt i
294-
LiteralFloat f → pure $ LiteralFloat f
295-
LiteralString s → pure $ LiteralString s
296-
LiteralChar c → pure $ LiteralChar c
297-
LiteralBool b → pure $ LiteralBool b
298-
LiteralArray as → LiteralArray <$> traverse ann as
299-
LiteralObject ps → LiteralObject <$> traverse (traverse ann) ps
300-
ReflectCtor a → ReflectCtor <$> ann a
301-
Eq a b → Eq <$> ann a <*> ann b
302-
DataArgumentByIndex index a → DataArgumentByIndex index <$> ann a
303-
ArrayLength a → ArrayLength <$> ann a
304-
ArrayIndex a index → flip ArrayIndex index <$> ann a
305-
ObjectProp a prop → flip ObjectProp prop <$> ann a
306-
ObjectUpdate a ps → ObjectUpdate <$> ann a <*> traverse (traverse ann) ps
307-
Abs param body → Abs <$> ann_ param <*> ann body
308-
App a b → App <$> ann a <*> ann b
309-
Ref qname index → pure $ Ref qname index
310-
Let binds body →
311-
Let
312-
<$> traverse (traverse (bitraverse ann_ ann)) binds
313-
<*> ann body
314-
IfThenElse i t e → IfThenElse <$> ann i <*> ann t <*> ann e
315-
Ctor aty ty ctor fs → pure $ Ctor aty ty ctor fs
316-
Exception m → pure $ Exception m
317-
ForeignImport m p → pure $ ForeignImport m p
318-
where
319-
ann ∷ Annotated Identity RawExp → AnnM (Id, AExp)
320-
ann = liftA2 (,) nextId . annotateExp . runIdentity
321-
322-
ann_ ∷ Identity a → AnnM (Id, a)
323-
ann_ p = (,runIdentity p) <$> nextId
291+
annotateExpWithIds ∷ Exp → AnnM (RawExp ((,) Id))
292+
annotateExpWithIds =
293+
annotateExpM identity (const nextId) (const nextId) (const nextId)
324294

325295
deannotateExp ∷ AExp → Exp
326296
deannotateExp = \case

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ import Language.PureScript.Backend.IR.Types
1313
, QName (QName)
1414
, Qualified (Imported, Local)
1515
, RawExp (..)
16-
, bindingNames
16+
, groupingNames
1717
, objectProp
1818
, ref
1919
, refImported
@@ -92,7 +92,7 @@ qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
9292
qualifyBinding = bimap (QName moduleName) (qualifyTopRefs moduleName topRefs)
9393
where
9494
topRefs ∷ Map Name Index = Map.fromList do
95-
(,0) <$> ((moduleBindings >>= bindingNames) <> moduleForeigns)
95+
(,0) <$> ((moduleBindings >>= groupingNames) <> moduleForeigns)
9696

9797
qualifyTopRefs ∷ ModuleName → Map Name Index → Exp → Exp
9898
qualifyTopRefs moduleName = go
@@ -127,7 +127,7 @@ qualifyTopRefs moduleName = go
127127
qualifyBody = go topNames'
128128
where
129129
topNames' = foldr (Map.adjust (+ 1) . unAnn) topNames boundNames
130-
boundNames = toList groupings >>= bindingNames
130+
boundNames = toList groupings >>= groupingNames
131131
App argument function → App (go' <$> argument) (go' <$> function)
132132
LiteralArray as → LiteralArray (go' <<$>> as)
133133
LiteralObject props → LiteralObject (fmap go' <<$>> props)

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

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

3+
import Data.List.NonEmpty qualified as NE
34
import Data.Map qualified as Map
5+
import Data.Set qualified as Set
46
import Language.PureScript.Backend.IR.DCE qualified as DCE
57
import Language.PureScript.Backend.IR.Linker (UberModule (..))
8+
import Language.PureScript.Backend.IR.Query (collectBoundNames)
69
import Language.PureScript.Backend.IR.Types
710
( Annotated
811
, Exp
@@ -25,9 +28,131 @@ import Language.PureScript.Backend.IR.Types
2528
, thenRewrite
2629
, unAnn
2730
)
31+
import Language.PureScript.Backend.IR.Types qualified as IR
2832

2933
optimizedUberModule ∷ UberModule → UberModule
30-
optimizedUberModule = idempotently $ DCE.eliminateDeadCode . optimizeModule
34+
optimizedUberModule =
35+
renameShadowedNames . idempotently (DCE.eliminateDeadCode . optimizeModule)
36+
37+
renameShadowedNames ∷ UberModule → UberModule
38+
renameShadowedNames UberModule {..} =
39+
UberModule
40+
{ uberModuleBindings = uberModuleBindings'
41+
, uberModuleExports = uberModuleExports'
42+
}
43+
where
44+
uberModuleBindings' ∷ [Grouping (QName, Exp)] = uberModuleBindings
45+
uberModuleExports' ∷ [(Name, Exp)] =
46+
renameShadowedNamesInExpr mempty <<$>> uberModuleExports
47+
48+
type RenamesInScope = Map Name [Name]
49+
50+
renameShadowedNamesInExpr ∷ RenamesInScope → RawExp Identity → RawExp Identity
51+
renameShadowedNamesInExpr scope = go
52+
where
53+
go = \case
54+
IR.LiteralInt i →
55+
IR.LiteralInt i
56+
IR.LiteralFloat f →
57+
IR.LiteralFloat f
58+
IR.LiteralString s →
59+
IR.LiteralString s
60+
IR.LiteralChar c →
61+
IR.LiteralChar c
62+
IR.LiteralBool b →
63+
IR.LiteralBool b
64+
IR.LiteralArray as →
65+
IR.LiteralArray (go <<$>> as)
66+
IR.LiteralObject ps →
67+
IR.LiteralObject ((go <$>) <<$>> ps)
68+
IR.ReflectCtor a →
69+
IR.ReflectCtor (go <$> a)
70+
IR.Eq a b →
71+
IR.Eq (go <$> a) (go <$> b)
72+
IR.DataArgumentByIndex index a →
73+
IR.DataArgumentByIndex index (go <$> a)
74+
IR.ArrayLength a →
75+
IR.ArrayLength (go <$> a)
76+
IR.ArrayIndex a index →
77+
IR.ArrayIndex (go <$> a) index
78+
IR.ObjectProp a prop →
79+
IR.ObjectProp (go <$> a) prop
80+
IR.ObjectUpdate a ps →
81+
IR.ObjectUpdate (go <$> a) ((go <$>) <<$>> ps)
82+
IR.Abs param body →
83+
IR.Abs param' (renameShadowedNamesInExpr scope' <$> body)
84+
where
85+
(param', scope') =
86+
case IR.unAnn param of
87+
IR.ParamUnused →
88+
(param, scope)
89+
IR.ParamNamed name →
90+
first
91+
(pure . IR.ParamNamed)
92+
(withScopedName (IR.unAnn body) scope name)
93+
IR.App a b →
94+
IR.App (go <$> a) (go <$> b)
95+
IR.Ref qname index →
96+
case qname of
97+
IR.Local lname
98+
| Just renames ← Map.lookup lname scope
99+
, Just rename ← renames !!? fromIntegral (IR.unIndex index) →
100+
IR.Ref (IR.Local rename) 0
101+
_ → IR.Ref qname index
102+
IR.Let binds body →
103+
IR.Let (NE.fromList (reverse binds')) body'
104+
where
105+
scope' ∷ RenamesInScope
106+
binds' ∷ [Grouping (Identity Name, Identity Exp)]
107+
(scope', binds') = foldl' f (scope, []) (toList binds)
108+
f
109+
∷ (RenamesInScope, [Grouping (Identity Name, Identity Exp)])
110+
→ Grouping (Identity Name, Identity Exp)
111+
→ (RenamesInScope, [Grouping (Identity Name, Identity Exp)])
112+
f (sc, bs) = \case
113+
Standalone (IR.unAnn → name, expr) →
114+
withScopedName (IR.unAnn expr) sc name & \(name', sc') →
115+
let expr' = renameShadowedNamesInExpr sc <$> expr
116+
in (sc', Standalone (pure name', expr') : bs)
117+
RecursiveGroup (toList → recGroup) →
118+
(: bs) . RecursiveGroup . NE.fromList <$> foldl' g (sc, []) recGroup
119+
where
120+
g
121+
∷ (RenamesInScope, [(Identity Name, Identity Exp)])
122+
→ (Identity Name, Identity Exp)
123+
→ (RenamesInScope, [(Identity Name, Identity Exp)])
124+
g (sc', recBinds) (IR.unAnn → name, expr) =
125+
withScopedName (IR.unAnn expr) sc' name & \(name', sc'') →
126+
let expr' = renameShadowedNamesInExpr sc' <$> expr
127+
in (sc'', (pure name', expr') : recBinds)
128+
body' = renameShadowedNamesInExpr scope' <$> body
129+
IR.IfThenElse i t e →
130+
IR.IfThenElse (go <$> i) (go <$> t) (go <$> e)
131+
IR.Ctor aty ty ctr fs →
132+
IR.Ctor aty ty ctr fs
133+
IR.Exception m →
134+
IR.Exception m
135+
IR.ForeignImport m p →
136+
IR.ForeignImport m p
137+
where
138+
withScopedName ∷ Exp → Map Name [Name] → Name → (Name, Map Name [Name])
139+
withScopedName e sc name = case Map.lookup name sc of
140+
Nothing → (name, Map.insert name [name] sc)
141+
Just renames →
142+
( rename
143+
, Map.insert rename [] $ Map.insert name (rename : renames) sc
144+
)
145+
where
146+
nextIndex = length renames
147+
usedNames = Map.keysSet sc <> collectBoundNames e
148+
rename = uniqueName usedNames name nextIndex
149+
150+
uniqueName ∷ Set Name → Name → Int → Name
151+
uniqueName usedNames n i =
152+
let nextName = Name (nameToText n <> show i)
153+
in if Set.member nextName usedNames
154+
then uniqueName usedNames n (i + 1)
155+
else nextName
31156

32157
idempotently ∷ Eq a ⇒ (a → a) → a → a
33158
idempotently = fix $ \i f a →
@@ -43,7 +168,6 @@ optimizeModule UberModule {..} =
43168
UberModule
44169
{ uberModuleBindings = uberModuleBindings'
45170
, uberModuleExports = uberModuleExports'
46-
, ..
47171
}
48172
where
49173
(uberModuleBindings', uberModuleExports') =

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

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,20 @@
11
module Language.PureScript.Backend.IR.Query where
22

3+
import Control.Monad.Trans.Accum (Accum, add, execAccum)
34
import Data.Map qualified as Map
5+
import Data.Set qualified as Set
46
import Language.PureScript.Backend.IR.Linker (UberModule (..))
57
import Language.PureScript.Backend.IR.Types
68
( Exp
79
, Name (..)
810
, Qualified (..)
911
, countFreeRef
1012
, countFreeRefs
13+
, groupingNames
1114
, listGrouping
15+
, traverseExpBottomUp
1216
)
17+
import Language.PureScript.Backend.IR.Types qualified as IR
1318
import Language.PureScript.Names (runModuleName)
1419

1520
usesRuntimeLazy ∷ UberModule → Bool
@@ -37,3 +42,18 @@ findPrimModuleInExpr expr =
3742
Map.keys (countFreeRefs expr) & any \case
3843
Local _name → False
3944
Imported moduleName _name → runModuleName moduleName == "Prim"
45+
46+
collectBoundNames ∷ Exp → Set Name
47+
collectBoundNames =
48+
(`execAccum` Set.empty) . traverseExpBottomUp @_ @(Accum (Set Name)) \e →
49+
case e of
50+
IR.Abs (IR.unAnn → IR.ParamNamed name) _body →
51+
e <$ add (Set.singleton name)
52+
IR.Let groupings _body →
53+
e <$ add do
54+
Set.fromList
55+
[ IR.unAnn iname
56+
| grouping ← toList groupings
57+
, iname ← groupingNames grouping
58+
]
59+
_ → pure e

0 commit comments

Comments
 (0)