Substitute inlined vars in resulting letrecs too in inlineBndrsCleanup

Fix #1337

(cherry picked from commit 6073164)

changelog/2020-05-20T16_14_07+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

@@ -304,4 +304,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/Core/VarEnv.hs

@@ -71,6 +71,7 @@ module Clash.Core.VarEnv
     -- ** Working with predicates
     -- *** Searching
   , elemInScopeSet
+  , elemUniqInScopeSet
   , notElemInScopeSet
   , varSetInScope
     -- ** Unique generation
@@ -401,6 +402,14 @@ elemInScopeSet
   -> Bool
 elemInScopeSet v (InScopeSet s _) = elemVarSet v s
 
+-- | Check whether an element exists in the set based on the `Unique` contained
+-- in that element
+elemUniqInScopeSet
+  :: Unique
+  -> InScopeSet
+  -> Bool
+elemUniqInScopeSet u (InScopeSet s _) = u `elemUniqSetDirectly` s
+
 -- | Is the variable not in scope
 notElemInScopeSet
   :: Var a

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

@@ -15,6 +15,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Clash.Normalize.Transformations
@@ -45,6 +46,7 @@ module Clash.Normalize.Transformations
   , disjointExpressionConsolidation
   , removeUnusedExpr
   , inlineCleanup
+  , inlineBndrsCleanup
   , flattenLet
   , splitCastWork
   , inlineCast
@@ -116,7 +118,7 @@ import           Clash.Core.VarEnv
    notElemVarSet, unionVarEnvWith, unionInScope, unitVarEnv,
    unitVarSet, mkVarSet, mkInScopeSet, uniqAway, elemInScopeSet, elemVarEnv,
    foldlWithUniqueVarEnv', lookupVarEnvDirectly, extendVarEnv, unionVarEnv,
-   eltsVarEnv, mkVarEnv)
+   eltsVarEnv, mkVarEnv, elemUniqInScopeSet)
 import           Clash.Debug
 import           Clash.Driver.Types          (Binding(..), DebugLevel (..))
 import           Clash.Netlist.BlackBox.Types (Element(Err))
@@ -133,8 +135,9 @@ import           Clash.Primitives.Types
 import           Clash.Rewrite.Combinators
 import           Clash.Rewrite.Types
 import           Clash.Rewrite.Util
-import           Clash.Unique                (Unique, lookupUniqMap)
+import           Clash.Unique
 import           Clash.Util
+import qualified Clash.Util.Interpolate as I
 
 inlineOrLiftNonRep :: HasCallStack => NormRewrite
 inlineOrLiftNonRep ctx eLet@(Letrec _ body) =
@@ -2485,6 +2488,21 @@ inlineCleanup (TransformContext is0 _) (Letrec binds body) = do
       -> (Id,((Id, Term), VarEnv Int))
       -> Bool
     isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_))
+      -- Try to keep user defined names, but inline names generated by GHC or
+      -- Clash. For example, if a user were to write:
+      --
+      --    x = 2 * y
+      --
+      -- Even if 'x' is only used once, we'd like to keep it around to produce
+      -- more readable HDL. In contrast, if a user were to write:
+      --
+      --    let x = f (2 * y)
+      --
+      -- ANF would transform that to:
+      --
+      --    let x = f f_arg; f_arg = 2 * y
+      --
+      -- In that case, there's no harm in inlining f_arg.
       | nameSort (varName id_) /= User
       , id_ `notElemVarSet` bodyFVs
       = case tm of
@@ -2538,7 +2556,8 @@ data Mark = Temp | Done | Rec
 -- | Used by 'inlineCleanup' to inline binders that we want to inline into the
 -- binders that we want to keep.
 inlineBndrsCleanup
-  :: InScopeSet
+  :: HasCallStack
+  => InScopeSet
   -- ^ Current InScopeSet
   -> VarEnv ((Id,Term),VarEnv Int)
   -- ^ Original let-binders with their free variables (+ #occurrences), that we
@@ -2558,23 +2577,29 @@ inlineBndrsCleanup isN origInl = go
   go 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'
+    -- to inline them. Furthermore, for every recursive binder there might still
+    -- be non-inlined variables left, see #1337.
+    flip map [ (ve, eFvs) | (ve,eFvs,Rec) <- eltsVarEnv doneInl ] $ \((v, e), eFvs) ->
+      let
+        (substM, _, _) = foldlWithUniqueVarEnv'
+                           (reduceBindersCleanup isN emptyVarEnv)
+                           (Nothing, emptyVarEnv, doneInl)
+                           eFvs
+      in (v, maybeSubstTm "inlineBndrsCleanup_0" substM e)
+  go !doneInl_0 (((v,e),eFVs):il) =
+    let (sM,_,doneInl_1) = foldlWithUniqueVarEnv'
                             (reduceBindersCleanup isN origInl)
-                            (Nothing, emptyVarEnv, doneInl)
+                            (Nothing, emptyVarEnv, doneInl_0)
                             eFVs
-        e1 = case sM of
-               Nothing -> e
-               Just s  -> substTm "inlineBndrsCleanup" s e
-    in  (v,e1):go doneInl1 il
+        e1 = maybeSubstTm "inlineBndrsCleanup_1" sM e
+    in  (v,e1):go doneInl_1 il
 {-# SCC inlineBndrsCleanup #-}
 
 -- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into
 -- the other to-inline let-binders.
 reduceBindersCleanup
-  :: InScopeSet
+  :: HasCallStack
+  => InScopeSet
   -- ^ Current InScopeSet
   -> VarEnv ((Id,Term),VarEnv Int)
   -- ^ Original let-binders with their free variables (+ #occurrences)
@@ -2594,11 +2619,19 @@ 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
-        (substM,substFVs,doneInl)
+        if elemUniqInScopeSet u isN then
+          (substM,substFVs,doneInl)
+        else
+          error [I.i|
+            Internal error: 'reduceBindersCleanup' encountered a variable
+            reference that was neither in 'doneInl', 'origInl', or in the
+            transformation's in scope set. Unique was: '#{u}'.
+          |]
       Just ((v,e),eFVs) ->
         -- Simplify the transitive dependencies
         let (sM,substFVsE,doneInl1) =
@@ -2622,9 +2655,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 +2674,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,133 @@
+{-|
+Copyright  :  (C) 2020, QBayLogic B.V.
+License    :  BSD2 (see the file LICENSE)
+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
+-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Clash.Tests.Normalize.Transformations where
+
+import Clash.Normalize.Transformations (inlineBndrsCleanup)
+import Clash.Core.VarEnv
+  (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv, extendInScopeSetList)
+import Clash.Core.FreeVars (countFreeOccurances)
+import Clash.Core.Term
+import Clash.Unique (UniqSet, extendUniqSet, unitUniqSet)
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Test.Clash.Rewrite (parseToTermQQ, parseToTerm)
+
+import Debug.Trace
+import Clash.Core.Pretty (showPpr)
+
+t1337a :: Term
+t1337a = 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
+    |]
+
+t1337a_result :: Term
+t1337a_result = [parseToTermQQ|
+  let
+    result_1, b_3 :: Int
+    result_1 = b_3
+    b_3 = b_3 b_3
+  in
+    result_1
+|]
+
+t1337b :: Term
+t1337b = 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, d_5 :: Int
+
+        result_1 = a_2
+
+        a_2 = b_3
+        b_3 = c_4
+        c_4 = d_5
+        d_5 = a_2 b_3 c_4
+      in
+        result_1
+    |]
+
+t1337b_result :: Term
+t1337b_result = [parseToTermQQ|
+  let
+    result_1, c_4 :: Int
+    result_1 = c_4
+    c_4 = c_4 c_4 c_4
+  in
+    result_1
+|]
+
+t1337c :: Term
+t1337c = Letrec keep1 result
+ where
+  (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds
+  Var fv = parseToTerm "freevar_5 :: Int"
+  is = mkInScopeSet (mkVarSet (fv : map fst binds))
+
+  keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]
+
+  Letrec binds result =
+    [parseToTermQQ|
+      let
+        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 (freevar_5 :: Int)
+      in
+        result_1
+    |]
+
+t1337c_result :: Term
+t1337c_result = [parseToTermQQ|
+  let
+    result_1, b_3 :: Int
+    result_1 = b_3
+    b_3 = b_3 b_3 (freevar_5 :: Int)
+  in
+    result_1
+|]
+
+tests :: TestTree
+tests =
+  testGroup
+    "Clash.Tests.Core.Util.Interpolation"
+    [ testCase "T1337a" $ t1337a_result @=? t1337a
+    , testCase "T1337b" $ t1337b_result @=? t1337b
+    , testCase "T1337c" $ t1337c_result @=? t1337c
+    ]

clash-lib/tests/Test/Clash/Rewrite.hs

@@ -124,6 +124,11 @@ runSingleTransformation rwEnv rwState is trans term = t
 -- | Run a single transformation with an empty environment and empty
 -- InScopeSet. See Default instances ^ to inspect the precise definition of
 -- "empty".
+--
+-- Note that at the time of writing (May 2020) the default environment does not
+-- include a type translator, evaluator, current function, or global heap. Maps,
+-- like the primitive and tycon map, are also empty. If the transformation under
+-- test needs these definitions, you should add them manually.
 runSingleTransformationDef :: Default extra => Rewrite extra -> C.Term -> C.Term
 runSingleTransformationDef = runSingleTransformation def def def
 

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 ()