Carry substitution all the way through inlineBndrsCleanup loop. Fix #…

…1337

changelog/2020-05-20T12_55_47+02_00_fix1337

@@ -0,0 +1 @@
+FIXES: Fixes issue with one of Clash's transformations, `inlineCleanup`, introducing free variables [#1337](https://github.com/clash-lang/clash-compiler/issues/1337)

clash-lib/clash-lib.cabal

@@ -305,4 +305,6 @@ test-suite unittests
   Other-Modules: Clash.Tests.Core.FreeVars
                  Clash.Tests.Core.Subst
                  Clash.Tests.Util.Interpolate
+                 Clash.Tests.Normalize.Transformations
+
                  Test.Clash.Rewrite

clash-lib/src/Clash/Core/Subst.hs

@@ -42,6 +42,7 @@ module Clash.Core.Subst
   , extendGblSubstList
     -- ** Applying substitutions
   , substTm
+  , maybeSubstTm
   , substAlt
   , substId
     -- * Variable renaming
@@ -523,7 +524,18 @@ substTyVarBndr subst@(TvSubst inScope tenv) oldVar =
          | otherwise    = uniqAway inScope
                             (oldVar {varType = substTyUnchecked subst oldKi})
 
--- | Substitute within a 'Type'
+-- | Substitute within a 'Term'. Just return original term if given
+-- substitution is "Nothing".
+maybeSubstTm
+  :: HasCallStack
+  => Doc ()
+  -> Maybe Subst
+  -> Term
+  -> Term
+maybeSubstTm _doc Nothing = id
+maybeSubstTm doc (Just s) = substTm doc s
+
+-- | Substitute within a 'Term'
 substTm
   :: HasCallStack
   => Doc ()

clash-lib/src/Clash/Normalize/Transformations.hs

@@ -45,6 +45,7 @@ module Clash.Normalize.Transformations
   , disjointExpressionConsolidation
   , removeUnusedExpr
   , inlineCleanup
+  , inlineBndrsCleanup
   , flattenLet
   , splitCastWork
   , inlineCast
@@ -2553,22 +2554,20 @@ inlineBndrsCleanup
   -- ^ The let-binders with their free variables (+ #occurrences), that we want
   -- to keep
   -> [(Id,Term)]
-inlineBndrsCleanup isN origInl = go
+inlineBndrsCleanup isN origInl processed keep =
+  (go Nothing processed keep)
  where
-  go doneInl [] =
+  go sM doneInl [] =
     -- If some of the let-binders that we wanted to inline turn out to be
     -- recursive, then we have to keep those around as well, as we weren't able
     -- to inline them.
-    [ (v,e) | ((v,e),_,Rec) <- eltsVarEnv doneInl ]
-  go !doneInl (((v,e),eFVs):il) =
-    let (sM,_,doneInl1) = foldlWithUniqueVarEnv'
+    [ (v, maybeSubstTm "inlineBndrsCleanup0" sM e) | ((v,e),_,Rec) <- eltsVarEnv doneInl ]
+  go !sM0 !doneInl (((v,e),eFVs):il) =
+    let (sM1,_,doneInl1) = foldlWithUniqueVarEnv'
                             (reduceBindersCleanup isN origInl)
-                            (Nothing, emptyVarEnv, doneInl)
+                            (sM0, emptyVarEnv, doneInl)
                             eFVs
-        e1 = case sM of
-               Nothing -> e
-               Just s  -> substTm "inlineBndrsCleanup" s e
-    in  (v,e1):go doneInl1 il
+    in  (v, maybeSubstTm "inlineBndrsCleanup1" sM1 e):go sM1 doneInl1 il
 {-# SCC inlineBndrsCleanup #-}
 
 -- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into
@@ -2594,7 +2593,8 @@ reduceBindersCleanup
   -- ^ Ignore, artifact of 'foldlWithUniqueVarEnv'
   -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))
   -- ^ Same as the third argument
-reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupVarEnvDirectly u doneInl of
+reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ =
+  case lookupVarEnvDirectly u doneInl of
     Nothing -> case lookupVarEnvDirectly u origInl of
       Nothing ->
         -- let-binding not found, cannot extend the substitution
@@ -2604,7 +2604,7 @@ reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupV
         let (sM,substFVsE,doneInl1) =
               foldlWithUniqueVarEnv'
                 (reduceBindersCleanup isN origInl)
-                ( Nothing
+                ( substM
                 -- It's okay/needed to over-approximate the free variables of
                 -- the range of the new substitution by including the free
                 -- variables of the original let-binder, because this set of
@@ -2622,9 +2622,7 @@ reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupV
                 , extendVarEnv v ((v,e),eFVs,Temp) doneInl)
                 eFVs
 
-            e1 = case sM of
-                   Nothing -> e
-                   Just s  -> substTm "reduceBindersCleanup" s e
+            e1 = maybeSubstTm "reduceBindersCleanup" sM e
         in  if v `elemVarEnv` substFVsE then
               -- We cannot inline recursive let-bindings, so we do not extend
               -- the substitution environment.
@@ -2643,7 +2641,7 @@ reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupV
               -- this process when we encounter it again.
               , extendVarEnv v ((v,e1),substFVsE,Done) doneInl1
               )
-    -- It's already been process, just extend the substitution environment
+    -- It's already been processed, just extend the substitution environment
     Just ((v,e),eFVs,Done) ->
       ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e)
       , unionVarEnv eFVs substFVs

clash-lib/tests/Clash/Tests/Normalize/Transformations.hs

@@ -0,0 +1,58 @@
+{-|
+Copyright  :  (C) 2020, QBayLogic B.V.
+License    :  BSD2 (see the file LICENSE)
+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
+-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Clash.Tests.Normalize.Transformations where
+
+import Clash.Normalize.Transformations (inlineBndrsCleanup)
+import Clash.Core.VarEnv (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv)
+import Clash.Core.FreeVars (countFreeOccurances)
+import Clash.Core.Term
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Test.Clash.Rewrite (parseToTermQQ)
+
+t1337 :: Term
+t1337 = Letrec keep1 result
+ where
+  (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds
+  is = mkInScopeSet (mkVarSet (map fst binds))
+
+  keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]
+
+  Letrec binds result =
+    [parseToTermQQ|
+      let
+        -- Types don't mean anything for this example
+        result_1, a_2, b_3, c_4 :: Int
+
+        result_1 = a_2
+
+        a_2 = b_3
+        b_3 = c_4
+        c_4 = a_2 b_3
+      in
+        result_1
+    |]
+
+t1337result :: Term
+t1337result = [parseToTermQQ|
+  let
+    result_1, b_3 :: Int
+    result_1 = b_3
+    b_3 = b_3 b_3
+  in
+    result_1
+|]
+
+tests :: TestTree
+tests =
+  testGroup
+    "Clash.Tests.Core.Util.Interpolation"
+    [ testCase "T1337" $ t1337result @=? t1337
+    ]

clash-lib/tests/unittests.hs

@@ -5,12 +5,14 @@ import Test.Tasty
 import qualified Clash.Tests.Core.FreeVars
 import qualified Clash.Tests.Core.Subst
 import qualified Clash.Tests.Util.Interpolate
+import qualified Clash.Tests.Normalize.Transformations
 
 tests :: TestTree
 tests = testGroup "Unittests"
   [ Clash.Tests.Core.FreeVars.tests
   , Clash.Tests.Core.Subst.tests
   , Clash.Tests.Util.Interpolate.tests
+  , Clash.Tests.Normalize.Transformations.tests
   ]
 
 main :: IO ()