Prefix names of inlined functions

Identifiers which are assigned an inlined function now have a
prefix with the name of the function that was inlined. This makes
it clearer what the provinence of an assigment is in HDL.

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

@@ -30,8 +30,9 @@ import           Data.IntMap                             (IntMap)
 import qualified Data.Primitive.ByteArray                as BA
 import qualified Data.Vector.Primitive                   as PV
 import           Data.Text                               (Text)
+import qualified Data.Text as Text
 import           Data.Text.Prettyprint.Doc
-import           Debug.Trace                             (trace)
+import           Debug.Trace
 import           GHC.Integer.GMP.Internals
   (Integer (..), BigNat (..))
 import           Clash.Core.DataCon
@@ -356,11 +357,18 @@ force :: Heap -> Stack -> Id -> Maybe State
 force (Heap gh g@(GPureHeap gbl) h ids is) k x' = case lookupVarEnv x' h of
     Nothing -> case lookupVarEnv x' gbl of
       Just e | isGlobalId x'
-        -> Just (Heap gh (GPureHeap (delVarEnv gbl x')) h ids is,GUpdate x':k,e)
+        -> let e' = tickExpr e
+            in do traceM $ "force: " <> (Text.unpack . nameOcc $ varName x')
+                  Just (Heap gh (GPureHeap (delVarEnv gbl x')) h ids is,GUpdate x':k,e')
       _ -> Nothing
-    Just e -> Just (Heap gh g (delVarEnv h x') ids is,Update x':k,e)
+    Just e -> let e' = tickExpr e
+               in Just (Heap gh g (delVarEnv h x') ids is,Update x':k,e')
     -- Removing the heap-bound value on a force ensures we do not get stuck on
     -- expressions such as: "let x = x in x"
+ where
+  tickExpr = Tick (NameMod PrefixName (LitTy . SymTy $ toStr x'))
+  unQualName = snd . Text.breakOnEnd "."
+  toStr = Text.unpack . unQualName . flip Text.snoc '_' . nameOcc . varName
 
 -- | Unwind the stack by 1
 unwind

clash-lib/src/Clash/Driver/Types.hs

@@ -27,10 +27,15 @@ import           Clash.Core.VarEnv              (VarEnv)
 
 import           Clash.Netlist.BlackBox.Types   (HdlSyn (..))
 
+
+-- A function binder in the global environment.
+--
+type Binding = (Id, SrcSpan, InlineSpec, Term)
+
 -- | Global function binders
 --
--- Global functions cannot be mutually recursive, only self-recursive
-type BindingMap = VarEnv (Id,SrcSpan,InlineSpec,Term)
+-- Global functions cannot be mutually recursive, only self-recursive.
+type BindingMap = VarEnv Binding
 
 -- | Debug Message Verbosity
 data DebugLevel

clash-lib/src/Clash/Netlist/Util.hs

@@ -70,13 +70,13 @@ import           Clash.Core.Subst
    extendInScopeIdList, mkSubst, substTm)
 import           Clash.Core.Term
   (Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),
-   collectArgsTicks)
+   collectArgsTicks, collectTicks)
 import           Clash.Core.TyCon
   (TyConName, TyConMap, tyConDataCons)
 import           Clash.Core.Type         (Type (..), TypeView (..),
                                           coreView1, splitTyConAppM, tyView, TyVar)
 import           Clash.Core.Util
-  (collectBndrs, stripTicks, substArgTys, termType, tyLitShow)
+  (collectBndrs, stripTicks, substArgTys, termType, tyLitShow, mkTicks)
 import           Clash.Core.Var
   (Id, Var (..), mkLocalId, modifyVarName, Attr')
 import           Clash.Core.VarEnv
@@ -129,9 +129,9 @@ splitNormalized
   -> Term
   -> (Either String ([Id],[LetBinding],Id))
 splitNormalized tcm expr = case collectBndrs expr of
-  (args,Letrec xes e)
+  (args, collectTicks -> (Letrec xes e, ticks))
     | (tmArgs,[]) <- partitionEithers args -> case stripTicks e of
-        Var v -> Right (tmArgs,xes,v)
+        Var v -> Right (tmArgs, fmap (second (`mkTicks` ticks)) xes,v)
         _     -> Left ($(curLoc) ++ "Not in normal form: res not simple var")
     | otherwise -> Left ($(curLoc) ++ "Not in normal form: tyArgs")
   _ ->

clash-lib/src/Clash/Normalize.hs

@@ -19,6 +19,9 @@
 
 module Clash.Normalize where
 
+import Debug.Trace -- TODO
+import qualified Data.Text as Text
+
 import Data.Either
 
 import           Control.Concurrent.Supply        (Supply)
@@ -49,6 +52,7 @@ import           Clash.Annotations.BitRepresentation.Internal
 import           Clash.Core.Evaluator             (PrimEvaluator)
 import           Clash.Core.FreeVars
   (freeLocalIds, globalIds, globalIdOccursIn, localIdDoesNotOccurIn)
+import           Clash.Core.Name (nameOcc) -- TODO
 import           Clash.Core.Pretty                (showPpr, ppr)
 import           Clash.Core.Subst
   (deShadowTerm, extendGblSubstList, mkSubst, substTm)
@@ -63,7 +67,7 @@ import           Clash.Core.VarEnv
    extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv, mkInScopeSet,
    mkVarEnv, mkVarSet, notElemVarEnv, notElemVarSet, nullVarEnv, unionVarEnv)
 import           Clash.Driver.Types
-  (BindingMap, ClashOpts (..), DebugLevel (..))
+  (BindingMap, Binding, ClashOpts (..), DebugLevel (..))
 import           Clash.Netlist.Types
   (HWType (..), HWMap, FilteredHWType(..))
 import           Clash.Netlist.Util
@@ -233,8 +237,12 @@ cleanupGraph topEntity norm
        return (mkVarEnv $ snd $ callTreeToList [] ctFlat)
 cleanupGraph _ norm = return norm
 
-data CallTree = CLeaf   (Id,(Id,SrcSpan,InlineSpec,Term))
-              | CBranch (Id,(Id,SrcSpan,InlineSpec,Term)) [CallTree]
+-- | A tree of identifiers and their bindings, with branches containing
+-- additional bindings which are used. See "Clash.Driver.Types.Binding".
+--
+data CallTree
+  = CLeaf   (Id, Binding)
+  | CBranch (Id, Binding) [CallTree]
 
 mkCallTree
   :: [Id]
@@ -323,6 +331,7 @@ flattenCallTree (CBranch (nm,(nm',sp,inl,tm)) used) = do
     _  -> do
       -- To have a cheap `appProp` transformation we need to
       -- deshadow, see also Note [AppProp no-shadow invariant]
+      -- TODO Tick inline?
       let tm1 = deShadowTerm emptyInScopeSet (substTm "flattenCallTree.flattenExpr" subst tm)
 #ifdef HISTORY
       -- NB: When HISTORY is on, emit binary data holding the recorded rewrite steps
@@ -349,6 +358,9 @@ flattenCallTree (CBranch (nm,(nm',sp,inl,tm)) used) = do
                                         (Maybe.catMaybes toInline')
         -- To have a cheap `appProp` transformation we need to
         -- deshadow, see also Note [AppProp no-shadow invariant]
+        traceM $ "flattenCallTree: " <> (Text.unpack . nameOcc $ varName nm)
+        -- TODO Adding tickInlined after deShadowTerm makes things crash :(
+        --  Clash.Netlist.Util(138): Not in normal form: no Letrec
         let tm1 = deShadowTerm emptyInScopeSet (substTm "flattenCallTree.flattenCheap" subst' newExpr)
         newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp)
         return (CBranch (nm,(nm',sp,inl,newExpr')) (concat allUsed'))

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

@@ -90,7 +90,7 @@ import           Clash.Annotations.Primitive (extractPrim)
 import           Clash.Core.DataCon          (DataCon (..))
 import           Clash.Core.Evaluator        (PureHeap, whnf')
 import           Clash.Core.Name
-  (Name (..), NameSort (..), mkUnsafeSystemName)
+  (Name (..), NameSort (..), mkUnsafeSystemName, nameOcc)
 import           Clash.Core.FreeVars
   (localIdOccursIn, localIdsDoNotOccurIn, freeLocalIds, termFreeTyVars, typeFreeVars, localVarsDoNotOccurIn)
 import           Clash.Core.Literal          (Literal (..))
@@ -99,9 +99,11 @@ import           Clash.Core.Subst
   (substTm, mkSubst, extendIdSubst, extendIdSubstList, extendTvSubst,
    extendTvSubstList, freshenTm, substTyInVar, deShadowTerm)
 import           Clash.Core.Term
-  (LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..), TickInfo(..), WorkInfo(WorkConstant), Alt,
-   isLambdaBodyCtx, isTickCtx, collectArgs, collectArgsTicks, collectTicks,
-   partitionTicks)
+  ( LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..)
+  , TickInfo(..) , WorkInfo(WorkConstant), Alt, TickInfo
+  , isLambdaBodyCtx, isTickCtx, collectArgs
+  , collectArgsTicks, collectTicks , partitionTicks
+  )
 import           Clash.Core.Type             (Type, TypeView (..), applyFunTy,
                                               isPolyFunCoreTy, isClassTy,
                                               normalizeType, splitFunForallTy,
@@ -377,18 +379,18 @@ inlineNonRep (TransformContext localScope _) e@(Case scrut altsTy alts)
     let scrutTy = termType tcm scrut
         noException = not (exception tcm scrutTy)
     if noException && (Maybe.fromMaybe 0 isInlined) > limit
-      then do
-        traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ showPpr (varName f)
-                             ," already inlined " ++ show limit ++ " times in:"
-                             , showPpr (varName cf)
-                             , "\nType of the subject is: " ++ showPpr scrutTy
-                             , "\nFunction " ++ showPpr (varName cf)
-                             , " will not reach a normal form, and compilation"
-                             , " might fail."
-                             , "\nRun with '-fclash-inline-limit=N' to increase"
-                             , " the inlining limit to N."
-                             ])
-                     (return e)
+      then
+        trace (concat [ $(curLoc) ++ "InlineNonRep: " ++ showPpr (varName f)
+                      ," already inlined " ++ show limit ++ " times in:"
+                      , showPpr (varName cf)
+                      , "\nType of the subject is: " ++ showPpr scrutTy
+                      , "\nFunction " ++ showPpr (varName cf)
+                      , " will not reach a normal form, and compilation"
+                      , " might fail."
+                      , "\nRun with '-fclash-inline-limit=N' to increase"
+                      , " the inlining limit to N."
+                      ])
+              (return e)
       else do
         bodyMaybe   <- lookupVarEnv f <$> Lens.use bindings
         nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator
@@ -399,9 +401,16 @@ inlineNonRep (TransformContext localScope _) e@(Case scrut altsTy alts)
         case (nonRepScrut, bodyMaybe) of
           (True,Just (_,_,_,scrutBody0)) -> do
             Monad.when noException (zoomExtra (addNewInline f cf))
+
+            traceM  $ "inlineNonRep: " <> (Text.unpack . nameOcc $ varName f)
+
             -- See Note [AppProp no-shadow invariant]
             let scrutBody1 = deShadowTerm localScope scrutBody0
-            changed $ Case (mkApps (mkTicks scrutBody1 ticks) args) altsTy alts
+            let scrutBody2 = mkTicks scrutBody1 (mkInlineTick f : ticks)
+            let scrutBody3 = mkApps scrutBody2 args
+
+            changed $ Case scrutBody3 altsTy alts
+
           _ -> return e
   where
     exception = isClassTy
@@ -706,14 +715,17 @@ nonRepANF _ e = return e
 -- the body is a variable-reference.
 topLet :: HasCallStack => NormRewrite
 topLet (TransformContext is0 ctx) e
-  | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e)
+  | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e) && not (isTick e)
   = do
   untranslatable <- isUntranslatable False e
   if untranslatable
     then return e
     else do tcm <- Lens.view tcCache
             argId <- mkTmBinderFor is0 tcm (mkUnsafeSystemName "result" 0) e
             changed (Letrec [(argId, e)] (Var argId))
+ where
+  isTick Tick{} = True
+  isTick _ = False
 
 topLet (TransformContext is0 ctx) e@(Letrec binds body)
   | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx
@@ -968,8 +980,13 @@ inlineWorkFree (TransformContext localScope _) e@(collectArgsTicks -> (Var f,arg
             if isRecBndr
                then return e
                else do
-                 -- See Note [AppProp no-shadow invariant]
-                 changed (mkApps (mkTicks (deShadowTerm localScope body) ticks) args)
+                 traceM  $ "inlineWorkFree: " <> (Text.unpack . nameOcc $ varName f)
+
+                 let tm0 = deShadowTerm localScope body
+                 let tm1 = mkTicks tm0 (mkInlineTick f : ticks)
+
+                 changed $ mkApps tm1 args
+
           _ -> return e
   where
     -- an expression is has work when it contains free local variables,
@@ -1024,9 +1041,19 @@ inlineSmall (TransformContext localScope _) e@(collectArgsTicks -> (Var f,args,t
           isRecBndr <- isRecursiveBndr f
           if not isRecBndr && inl /= NoInline && termSize body < sizeLimit
              then do
+               -- TODO This currently doesn't change clashing names when a
+               -- tick is added, causing tests like LambdaDrop to fail.
+
+               traceM  $ "inlineSmall: " <> (Text.unpack . nameOcc $ varName f)
+
                -- See Note [AppProp no-shadow invariant]
-               changed (mkApps (mkTicks (deShadowTerm localScope body) ticks) args)
+               let tm0 = deShadowTerm localScope body
+               let tm1 = mkTicks tm0 (mkInlineTick f : ticks)
+
+               changed $ mkApps tm1 args
+
              else return e
+
         _ -> return e
 
 inlineSmall _ e = return e
@@ -1690,17 +1717,17 @@ recToLetRec (TransformContext is0 []) e = do
     -- corresponding (sub)field from the target variable.
     --
     -- TODO: See [Note: Breaks on constants and predetermined equality]
-    eqApp tcm v args (collectArgs -> (Var v',args'))
+    eqApp tcm v args (collectArgs . stripTicks -> (Var v',args'))
       | isGlobalId v'
       , v == v'
       , let args2 = Either.lefts args'
       , length args == length args2
       = and (zipWith (eqArg tcm) args args2)
     eqApp _ _ _ _ = False
 
-    eqArg _ v1 v2@(Var {})
+    eqArg _ v1 v2@(stripTicks -> Var {})
       = v1 == v2
-    eqArg tcm v1 v2@(collectArgs -> (Data _, args'))
+    eqArg tcm v1 v2@(collectArgs . stripTicks -> (Data _, args'))
       | let t1 = termType tcm v1
       , let t2 = termType tcm v2
       , t1 == t2
@@ -1733,7 +1760,7 @@ recToLetRec (TransformContext is0 []) e = do
     --     construction of `y` with `(fst x, fst x)`.
     --
     eqDat :: Term -> [Int] -> Term -> Bool
-    eqDat v fTrace (collectArgs -> (Data _, args)) =
+    eqDat v fTrace (collectArgs . stripTicks -> (Data _, args)) =
       and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args))
     eqDat v1 fTrace v2 =
       case stripProjection (reverse fTrace) v1 v2 of

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

@@ -29,6 +29,7 @@ module Clash.Normalize.Util
  , normalizeTopLvlBndr
  , rewriteExpr
  , removedTm
+ , mkInlineTick
  )
  where
 
@@ -40,19 +41,21 @@ import qualified Data.List               as List
 import qualified Data.Map                as Map
 import qualified Data.HashMap.Strict     as HashMapS
 import           Data.Text               (Text)
+import qualified Data.Text as Text
 
 import           BasicTypes              (InlineSpec)
 
 import           Clash.Annotations.Primitive (extractPrim)
 import           Clash.Core.FreeVars
   (globalIds, hasLocalFreeVars, globalIdOccursIn)
+import           Clash.Core.Name         (Name(nameOcc))
 import           Clash.Core.Pretty       (showPpr)
 import           Clash.Core.Subst        (deShadowTerm)
 import           Clash.Core.Term
   (Context, CoreContext(AppArg), PrimInfo (..), Term (..), WorkInfo (..),
-   TickInfo, collectArgs, collectArgsTicks)
+   TickInfo(NameMod), NameMod(PrefixName), collectArgs, collectArgsTicks)
 import           Clash.Core.TyCon        (TyConMap)
-import           Clash.Core.Type         (Type, undefinedTy)
+import           Clash.Core.Type         (Type(LitTy), LitTy(SymTy), undefinedTy)
 import           Clash.Core.Util
   (isClockOrReset, isPolyFun, termType, mkApps, mkTicks)
 import           Clash.Core.Var          (Id, Var (..), isGlobalId)
@@ -432,3 +435,11 @@ removedTm
   -> Term
 removedTm =
   TyApp (Prim "Clash.Transformations.removedArg" (PrimInfo undefinedTy WorkNever))
+
+-- | A tick to prefix an inlined expression with it's original name.
+--
+mkInlineTick :: Id -> TickInfo
+mkInlineTick n = NameMod PrefixName (LitTy . SymTy $ toStr n)
+ where
+  toStr = Text.unpack . snd . Text.breakOnEnd "." . nameOcc . varName
+

tests/shouldwork/Basic/NameInlining.hs

@@ -0,0 +1,55 @@
+module NameInlining where
+
+import qualified Prelude as P
+import           Data.List (isInfixOf)
+import           System.Environment (getArgs)
+import           System.FilePath ((</>), takeDirectory)
+
+import           Clash.Prelude
+
+f :: Int -> Int -> Int
+f a b = g a b * g b a
+{-# ANN f (Synthesize
+    { t_name   = "f"
+    , t_inputs = [PortName "f_x", PortName "f_y"]
+    , t_output = PortName "result"
+    }) #-}
+
+g :: Int -> Int -> Int
+g = setName @"foo" h
+
+h :: Int -> Int -> Int
+h x y = if signum (x - y) == 1 then x else y
+{-# ANN h (Synthesize
+    { t_name   = "h"
+    , t_inputs = [PortName "h_x", PortName "h_y"]
+    , t_output = PortName "diff"
+    }) #-}
+
+assertIn :: String -> String -> IO ()
+assertIn needle haystack
+  | needle `isInfixOf` haystack = return ()
+  | otherwise = P.error $ mconcat [ "Expected:\n\n  ", needle
+                                  , "\n\nIn:\n\n", haystack ]
+
+mainVHDL :: IO ()
+mainVHDL = do
+  [topDir] <- getArgs
+  content  <- readFile (takeDirectory topDir </> "f" </> "f.vhdl")
+
+  assertIn "g_foo" content
+
+mainVerilog :: IO ()
+mainVerilog = do
+  [topDir] <- getArgs
+  content  <- readFile (takeDirectory topDir </> "f" </> "f.v")
+
+  assertIn "g_foo" content
+
+mainSystemVerilog :: IO ()
+mainSystemVerilog = do
+  [topDir] <- getArgs
+  content  <- readFile (takeDirectory topDir </> "f" </> "f.sv")
+
+  assertIn "g_foo" content
+