Fix name shadowing

.github/workflows/ci.yaml

@@ -0,0 +1,31 @@
+name: Purescript Lua CI
+on:
+  pull_request:
+jobs:
+  tests:
+    runs-on: ubuntu-latest
+    steps:
+    - name: "📥 Checkout repository"
+      uses: actions/checkout@v3
+
+    - name: "❄ Install Nix"
+      uses: cachix/install-nix-action@v22
+      with:
+        github_access_token: ${{ secrets.GITHUB_TOKEN }}
+        extra_nix_config: |
+          access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
+          substituters = https://hydra.iohk.io https://cache.nixos.org/
+          trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
+
+    - uses: cachix/cachix-action@v12
+      with:
+        name: purescript-lua
+        authToken: "${{ secrets.CACHIX_AUTH_TOKEN }}"
+
+    - name: "🔨 Build & test"
+      run: >-
+        nix develop
+        --accept-flake-config
+        --allow-import-from-derivation
+        --command
+        cabal test all --test-show-details=direct

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

@@ -19,17 +19,17 @@ import Language.PureScript.Backend.IR.Types
   , RawExp (..)
   , RewriteMod (..)
   , Rewritten (..)
-  , bindingNames
+  , annotateExpM
+  , groupingNames
   , listGrouping
   , rewriteExpTopDown
   )
 import Language.PureScript.Names (ModuleName)
-import Shower (shower)
 
 data EntryPoint = EntryPoint ModuleName [Name]
   deriving stock (Show)
 
-deriving stock instance Show AExp
+-- deriving stock instance Show AExp
 
 eliminateDeadCode ∷ UberModule → UberModule
 eliminateDeadCode uber@UberModule {..} =
@@ -71,9 +71,9 @@ eliminateDeadCode uber@UberModule {..} =
   annotatedBindings ∷ [Grouping (Id, QName, AExp)]
   (annotatedExports, annotatedBindings) = runAnnM do
     annExports ← forM uberModuleExports \(name, expr) →
-      (,name,) <$> nextId <*> annotateExp expr
+      (,name,) <$> nextId <*> annotateExpWithIds expr
     annBindings ← forM uberModuleBindings $ traverse \(qname, expr) →
-      (,qname,) <$> nextId <*> annotateExp expr
+      (,qname,) <$> nextId <*> annotateExpWithIds expr
     pure (annExports, annBindings)
 
   dceAnnotatedExp ∷ AExp → Exp
@@ -201,7 +201,7 @@ eliminateDeadCode uber@UberModule {..} =
           adjacencyListForExpr scope' body
             <> snd (foldl' adjacencyListForGrouping (scope, mempty) groupings)
          where
-          scope' = foldr addToScope scope (bindingNames =<< toList groupings)
+          scope' = foldr addToScope scope (groupingNames =<< toList groupings)
           addToScope (nameId, name) = addLocalToScope nameId name 0
    where
     adjacencyListForGrouping
@@ -288,39 +288,9 @@ nextId = AnnM do
 runAnnM ∷ AnnM a → a
 runAnnM = (`evalState` 0) . unAnnM
 
-annotateExp ∷ Exp → AnnM AExp
-annotateExp = \case
-  LiteralInt i → pure $ LiteralInt i
-  LiteralFloat f → pure $ LiteralFloat f
-  LiteralString s → pure $ LiteralString s
-  LiteralChar c → pure $ LiteralChar c
-  LiteralBool b → pure $ LiteralBool b
-  LiteralArray as → LiteralArray <$> traverse ann as
-  LiteralObject ps → LiteralObject <$> traverse (traverse ann) ps
-  ReflectCtor a → ReflectCtor <$> ann a
-  Eq a b → Eq <$> ann a <*> ann b
-  DataArgumentByIndex index a → DataArgumentByIndex index <$> ann a
-  ArrayLength a → ArrayLength <$> ann a
-  ArrayIndex a index → flip ArrayIndex index <$> ann a
-  ObjectProp a prop → flip ObjectProp prop <$> ann a
-  ObjectUpdate a ps → ObjectUpdate <$> ann a <*> traverse (traverse ann) ps
-  Abs param body → Abs <$> ann_ param <*> ann body
-  App a b → App <$> ann a <*> ann b
-  Ref qname index → pure $ Ref qname index
-  Let binds body →
-    Let
-      <$> traverse (traverse (bitraverse ann_ ann)) binds
-      <*> ann body
-  IfThenElse i t e → IfThenElse <$> ann i <*> ann t <*> ann e
-  Ctor aty ty ctor fs → pure $ Ctor aty ty ctor fs
-  Exception m → pure $ Exception m
-  ForeignImport m p → pure $ ForeignImport m p
- where
-  ann ∷ Annotated Identity RawExp → AnnM (Id, AExp)
-  ann = liftA2 (,) nextId . annotateExp . runIdentity
-
-  ann_ ∷ Identity a → AnnM (Id, a)
-  ann_ p = (,runIdentity p) <$> nextId
+annotateExpWithIds ∷ Exp → AnnM (RawExp ((,) Id))
+annotateExpWithIds =
+  annotateExpM identity (const nextId) (const nextId) (const nextId)
 
 deannotateExp ∷ AExp → Exp
 deannotateExp = \case

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

@@ -13,7 +13,7 @@ import Language.PureScript.Backend.IR.Types
   , QName (QName)
   , Qualified (Imported, Local)
   , RawExp (..)
-  , bindingNames
+  , groupingNames
   , objectProp
   , ref
   , refImported
@@ -92,7 +92,7 @@ qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
   qualifyBinding = bimap (QName moduleName) (qualifyTopRefs moduleName topRefs)
    where
     topRefs ∷ Map Name Index = Map.fromList do
-      (,0) <$> ((moduleBindings >>= bindingNames) <> moduleForeigns)
+      (,0) <$> ((moduleBindings >>= groupingNames) <> moduleForeigns)
 
 qualifyTopRefs ∷ ModuleName → Map Name Index → Exp → Exp
 qualifyTopRefs moduleName = go
@@ -127,7 +127,7 @@ qualifyTopRefs moduleName = go
         qualifyBody = go topNames'
          where
           topNames' = foldr (Map.adjust (+ 1) . unAnn) topNames boundNames
-          boundNames = toList groupings >>= bindingNames
+          boundNames = toList groupings >>= groupingNames
       App argument function → App (go' <$> argument) (go' <$> function)
       LiteralArray as → LiteralArray (go' <<$>> as)
       LiteralObject props → LiteralObject (fmap go' <<$>> props)

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

@@ -1,8 +1,11 @@
 module Language.PureScript.Backend.IR.Optimizer where
 
+import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Language.PureScript.Backend.IR.DCE qualified as DCE
 import Language.PureScript.Backend.IR.Linker (UberModule (..))
+import Language.PureScript.Backend.IR.Query (collectBoundNames)
 import Language.PureScript.Backend.IR.Types
   ( Annotated
   , Exp
@@ -25,9 +28,131 @@ import Language.PureScript.Backend.IR.Types
   , thenRewrite
   , unAnn
   )
+import Language.PureScript.Backend.IR.Types qualified as IR
 
 optimizedUberModule ∷ UberModule → UberModule
-optimizedUberModule = idempotently $ DCE.eliminateDeadCode . optimizeModule
+optimizedUberModule =
+  renameShadowedNames . idempotently (DCE.eliminateDeadCode . optimizeModule)
+
+renameShadowedNames ∷ UberModule → UberModule
+renameShadowedNames UberModule {..} =
+  UberModule
+    { uberModuleBindings = uberModuleBindings'
+    , uberModuleExports = uberModuleExports'
+    }
+ where
+  uberModuleBindings' ∷ [Grouping (QName, Exp)] = uberModuleBindings
+  uberModuleExports' ∷ [(Name, Exp)] =
+    renameShadowedNamesInExpr mempty <<$>> uberModuleExports
+
+type RenamesInScope = Map Name [Name]
+
+renameShadowedNamesInExpr ∷ RenamesInScope → RawExp Identity → RawExp Identity
+renameShadowedNamesInExpr scope = go
+ where
+  go = \case
+    IR.LiteralInt i →
+      IR.LiteralInt i
+    IR.LiteralFloat f →
+      IR.LiteralFloat f
+    IR.LiteralString s →
+      IR.LiteralString s
+    IR.LiteralChar c →
+      IR.LiteralChar c
+    IR.LiteralBool b →
+      IR.LiteralBool b
+    IR.LiteralArray as →
+      IR.LiteralArray (go <<$>> as)
+    IR.LiteralObject ps →
+      IR.LiteralObject ((go <$>) <<$>> ps)
+    IR.ReflectCtor a →
+      IR.ReflectCtor (go <$> a)
+    IR.Eq a b →
+      IR.Eq (go <$> a) (go <$> b)
+    IR.DataArgumentByIndex index a →
+      IR.DataArgumentByIndex index (go <$> a)
+    IR.ArrayLength a →
+      IR.ArrayLength (go <$> a)
+    IR.ArrayIndex a index →
+      IR.ArrayIndex (go <$> a) index
+    IR.ObjectProp a prop →
+      IR.ObjectProp (go <$> a) prop
+    IR.ObjectUpdate a ps →
+      IR.ObjectUpdate (go <$> a) ((go <$>) <<$>> ps)
+    IR.Abs param body →
+      IR.Abs param' (renameShadowedNamesInExpr scope' <$> body)
+     where
+      (param', scope') =
+        case IR.unAnn param of
+          IR.ParamUnused →
+            (param, scope)
+          IR.ParamNamed name →
+            first
+              (pure . IR.ParamNamed)
+              (withScopedName (IR.unAnn body) scope name)
+    IR.App a b →
+      IR.App (go <$> a) (go <$> b)
+    IR.Ref qname index →
+      case qname of
+        IR.Local lname
+          | Just renames ← Map.lookup lname scope
+          , Just rename ← renames !!? fromIntegral (IR.unIndex index) →
+              IR.Ref (IR.Local rename) 0
+        _ → IR.Ref qname index
+    IR.Let binds body →
+      IR.Let (NE.fromList (reverse binds')) body'
+     where
+      scope' ∷ RenamesInScope
+      binds' ∷ [Grouping (Identity Name, Identity Exp)]
+      (scope', binds') = foldl' f (scope, []) (toList binds)
+      f
+        ∷ (RenamesInScope, [Grouping (Identity Name, Identity Exp)])
+        → Grouping (Identity Name, Identity Exp)
+        → (RenamesInScope, [Grouping (Identity Name, Identity Exp)])
+      f (sc, bs) = \case
+        Standalone (IR.unAnn → name, expr) →
+          withScopedName (IR.unAnn expr) sc name & \(name', sc') →
+            let expr' = renameShadowedNamesInExpr sc <$> expr
+             in (sc', Standalone (pure name', expr') : bs)
+        RecursiveGroup (toList → recGroup) →
+          (: bs) . RecursiveGroup . NE.fromList <$> foldl' g (sc, []) recGroup
+         where
+          g
+            ∷ (RenamesInScope, [(Identity Name, Identity Exp)])
+            → (Identity Name, Identity Exp)
+            → (RenamesInScope, [(Identity Name, Identity Exp)])
+          g (sc', recBinds) (IR.unAnn → name, expr) =
+            withScopedName (IR.unAnn expr) sc' name & \(name', sc'') →
+              let expr' = renameShadowedNamesInExpr sc' <$> expr
+               in (sc'', (pure name', expr') : recBinds)
+      body' = renameShadowedNamesInExpr scope' <$> body
+    IR.IfThenElse i t e →
+      IR.IfThenElse (go <$> i) (go <$> t) (go <$> e)
+    IR.Ctor aty ty ctr fs →
+      IR.Ctor aty ty ctr fs
+    IR.Exception m →
+      IR.Exception m
+    IR.ForeignImport m p →
+      IR.ForeignImport m p
+   where
+    withScopedName ∷ Exp → Map Name [Name] → Name → (Name, Map Name [Name])
+    withScopedName e sc name = case Map.lookup name sc of
+      Nothing → (name, Map.insert name [name] sc)
+      Just renames →
+        ( rename
+        , Map.insert rename [] $ Map.insert name (rename : renames) sc
+        )
+       where
+        nextIndex = length renames
+        usedNames = Map.keysSet sc <> collectBoundNames e
+        rename = uniqueName usedNames name nextIndex
+
+    uniqueName ∷ Set Name → Name → Int → Name
+    uniqueName usedNames n i =
+      let nextName = Name (nameToText n <> show i)
+       in if Set.member nextName usedNames
+            then uniqueName usedNames n (i + 1)
+            else nextName
 
 idempotently ∷ Eq a ⇒ (a → a) → a → a
 idempotently = fix $ \i f a →
@@ -43,7 +168,6 @@ optimizeModule UberModule {..} =
   UberModule
     { uberModuleBindings = uberModuleBindings'
     , uberModuleExports = uberModuleExports'
-    , ..
     }
  where
   (uberModuleBindings', uberModuleExports') =

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

@@ -1,15 +1,20 @@
 module Language.PureScript.Backend.IR.Query where
 
+import Control.Monad.Trans.Accum (Accum, add, execAccum)
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Language.PureScript.Backend.IR.Linker (UberModule (..))
 import Language.PureScript.Backend.IR.Types
   ( Exp
   , Name (..)
   , Qualified (..)
   , countFreeRef
   , countFreeRefs
+  , groupingNames
   , listGrouping
+  , traverseExpBottomUp
   )
+import Language.PureScript.Backend.IR.Types qualified as IR
 import Language.PureScript.Names (runModuleName)
 
 usesRuntimeLazy ∷ UberModule → Bool
@@ -37,3 +42,18 @@ findPrimModuleInExpr expr =
   Map.keys (countFreeRefs expr) & any \case
     Local _name → False
     Imported moduleName _name → runModuleName moduleName == "Prim"
+
+collectBoundNames ∷ Exp → Set Name
+collectBoundNames =
+  (`execAccum` Set.empty) . traverseExpBottomUp @_ @(Accum (Set Name)) \e →
+    case e of
+      IR.Abs (IR.unAnn → IR.ParamNamed name) _body →
+        e <$ add (Set.singleton name)
+      IR.Let groupings _body →
+        e <$ add do
+          Set.fromList
+            [ IR.unAnn iname
+            | grouping ← toList groupings
+            , iname ← groupingNames grouping
+            ]
+      _ → pure e