clash-lib 1.0.0 → 1.0.1

raw patch · 19 files changed

+613/−212 lines, 19 filesdep +clash-libdep +ghc-typelits-knownnatdep +tastydep −ansi-wl-pprintdep ~ansi-terminaldep ~basedep ~clash-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: clash-lib, ghc-typelits-knownnat, tasty, tasty-hunit

Dependencies removed: ansi-wl-pprint

Dependency ranges changed: ansi-terminal, base, clash-prelude, ghc, lens, trifecta

API changes (from Hackage documentation)

Files

• clash-lib.cabal +32/−3
• src/Clash/Backend/Verilog.hs +8/−29
• src/Clash/Core/DataCon.hs +2/−0
• src/Clash/Core/FreeVars.hs +54/−37
• src/Clash/Core/Name.hs +1/−0
• src/Clash/Core/TyCon.hs +1/−0
• src/Clash/Core/Var.hs +14/−4
• src/Clash/Core/VarEnv.hs +28/−20
• src/Clash/Driver.hs +2/−2
• src/Clash/Netlist/BlackBox.hs +15/−17
• src/Clash/Netlist/BlackBox/Util.hs +62/−36
• src/Clash/Normalize/Strategy.hs +3/−1
• src/Clash/Normalize/Transformations.hs +39/−18
• src/Clash/Normalize/Util.hs +158/−29
• src/Clash/Rewrite/Util.hs +83/−14
• src/Clash/Unique.hs +12/−1
• src/Clash/Util.hs +19/−1
• tests/Clash/Tests/Core/FreeVars.hs +67/−0
• tests/unittests.hs +13/−0

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              1.0.0+Version:              1.0.1 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   Clash is a functional hardware description language that borrows both its@@ -84,6 +84,12 @@    default: False    manual: True +flag unittests+  description:+    You can disable testing with unittests using `-f-unittests`.+  default: True+  manual: True+ Library   HS-Source-Dirs:     src @@ -111,7 +117,6 @@    Build-depends:      aeson                   >= 0.6.2.0  && < 1.5,                       ansi-terminal           >= 0.8.0.0  && < 0.10,-                      ansi-wl-pprint          >= 0.6.8.2  && < 1.0,                       attoparsec              >= 0.10.4.0 && < 0.14,                       base                    >= 4.10     && < 5,                       binary                  >= 0.8.5    && < 0.11,@@ -143,7 +148,7 @@                       text-show               >= 3.7      && < 3.9,                       time                    >= 1.4.0.1  && < 1.10,                       transformers            >= 0.5.2.0  && < 0.6,-                      trifecta                >= 1.7.1.1  && < 2.1,+                      trifecta                >= 1.7.1.1  && < 2.2,                       vector                  >= 0.11     && < 1.0,                       vector-binary-instances >= 0.2.3.5  && < 0.3,                       unordered-containers    >= 0.2.3.3  && < 0.3@@ -223,3 +228,27 @@    if flag(history)     cpp-options:      -DHISTORY++test-suite unittests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          unittests.hs+  ghc-options:      -Wall+  hs-source-dirs:   tests++  if !flag(unittests)+    buildable: False+  else+    build-depends:+      clash-prelude,+      clash-lib,++      ghc-typelits-knownnat,++      base,+      ghc,+      lens,+      tasty         >= 1.2      && < 1.3,+      tasty-hunit++  Other-Modules: Clash.Tests.Core.FreeVars

@@ -253,7 +253,7 @@         -> VerilogM Doc sigPort wor pName hwType =     addAttrs (hwTypeAttrs hwType)-      (portType <+> verilogType' True hwType <+> stringS pName <> encodingNote hwType)+      (portType <+> verilogType hwType <+> stringS pName <> encodingNote hwType)   where     portType = case wor of                  Nothing   -> if isBiSignalIn hwType then "inout" else "input"@@ -320,35 +320,14 @@       nets  = mapMaybe (\case {NetDecl' _ _ i _ -> Just i; _ -> Nothing}) $ declarations c   Mon $ idSeen %= (HashMap.unionWith max (HashMap.fromList (concatMap (map (,0)) [iport,oport,nets]))) --- render a type; by default, removing zero-sizes is an aesthetic operation--- and is only valid for decls (e.g. when rendering module ports), so don't--- do it by default to be safe verilogType :: HWType -> VerilogM Doc-verilogType = verilogType' False--verilogType' :: Bool -> HWType -> VerilogM Doc-verilogType' isDecl t =-  let -- if the size is zero, it's single bit, so if we're-      -- emitting a decl, then we can skip it - but we can't-      -- skip it when selecting other values (e.g a slice)-      renderVerilogTySize l-        | l == 0 && isDecl = emptyDoc-        | otherwise        = brackets (int l <> colon <> int 0)--      -- signed types have to be rendered specially-      getVerilogTy (Signed n) = ("signed" <> space, n)-      getVerilogTy _          = (emptyDoc,    typeSize t)--  in case t of-       -- special case: Bit, Bool, clocks and resets-       Clock {} -> emptyDoc-       Reset {} -> emptyDoc-       Bit      -> emptyDoc-       Bool     -> emptyDoc--       -- otherwise, print the type and prefix-       ty | (prefix, sz) <- getVerilogTy ty-         -> prefix <> renderVerilogTySize (sz-1)+verilogType t = case t of+  Signed n -> "signed" <+> brackets (int (n-1) <> colon <> int 0)+  Clock {} -> emptyDoc+  Reset {} -> emptyDoc+  Bit      -> emptyDoc+  Bool     -> emptyDoc+  _        -> brackets (int (typeSize t -1) <> colon <> int 0)  sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc sigDecl d t = verilogType t <+> d

@@ -39,6 +39,7 @@   { dcName :: !DcName   -- ^ Name of the DataCon   , dcUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . dcUniq x ~ nameUniq (dcName x)   , dcTag :: !ConTag   -- ^ Syntactical position in the type definition   , dcType :: !Type@@ -67,6 +68,7 @@  instance Uniquable DataCon where   getUnique = dcUniq+  setUnique dc u = dc {dcUniq=u, dcName=(dcName dc){nameUniq=u}}  -- | Syntactical position of the DataCon in the type definition type ConTag = Int

@@ -45,7 +45,8 @@  import Clash.Core.Term                  (Pat (..), Term (..), TickInfo (..)) import Clash.Core.Type                  (Type (..))-import Clash.Core.Var                   (Id, IdScope (..), TyVar, Var (..))+import Clash.Core.Var+  (Id, IdScope (..), TyVar, Var (..), isLocalId) import Clash.Core.VarEnv                (VarSet, unitVarSet)  -- | Gives the free type-variables in a Type, implemented as a 'Fold'@@ -169,9 +170,7 @@ -- | Calculate the /local/ free identifiers of an expression: the free -- identifiers that are not bound in the global environment. freeLocalIds :: Fold Term Id-freeLocalIds = termFreeVars' isLocalId where-  isLocalId (Id {idScope = LocalId}) = True-  isLocalId _ = False+freeLocalIds = termFreeVars' isLocalId  -- | Calculate the /global/ free identifiers of an expression: the free -- identifiers that are bound in the global environment.@@ -244,13 +243,13 @@   -> Term   -> f Term termFreeVars' interesting f = go IntSet.empty where-  go inScope = \case-    Var v -> v1 <* typeFreeVars' interesting inScope1 f (varType v)+  go inLocalScope = \case+    Var v -> v1 <* typeFreeVars' interesting inLocalScope1 f (varType v)       where         isInteresting = interesting v-        vInScope      = varUniq v `IntSet.member` inScope-        inScope1-          | vInScope  = inScope+        vInScope      = isLocalId v && varUniq v `IntSet.member` inLocalScope+        inLocalScope1+          | vInScope  = inLocalScope           | otherwise = IntSet.empty -- See Note [Closing over type variables]          v1 | isInteresting@@ -259,42 +258,60 @@            | otherwise            = pure (Var v) -    Lam id_ tm -> Lam <$> goBndr inScope id_-                      <*> go (IntSet.insert (varUniq id_) inScope) tm-    TyLam tv tm -> TyLam <$> goBndr inScope tv-                         <*> go (IntSet.insert (varUniq tv) inScope) tm-    App l r -> App <$> go inScope l <*> go inScope r-    TyApp l r -> TyApp <$> go inScope l-                       <*> typeFreeVars' interesting inScope f r-    Letrec bs e -> Letrec <$> traverse (goBind inScope') bs <*> go inScope' e-      where inScope' = foldr IntSet.insert inScope (map (varUniq.fst) bs)-    Case subj ty alts -> Case <$> go inScope subj-                              <*> typeFreeVars' interesting inScope f ty-                              <*> traverse (goAlt inScope) alts-    Cast tm t1 t2 -> Cast <$> go inScope tm-                          <*> typeFreeVars' interesting inScope f t1-                          <*> typeFreeVars' interesting inScope f t2-    Tick tick tm -> Tick <$> goTick inScope tick <*> go inScope tm+    Lam id_ tm ->+      Lam <$> goBndr inLocalScope id_+          <*> go (IntSet.insert (varUniq id_) inLocalScope) tm+    TyLam tv tm ->+      TyLam <$> goBndr inLocalScope tv+            <*> go (IntSet.insert (varUniq tv) inLocalScope) tm++    App l r ->+      App <$> go inLocalScope l <*> go inLocalScope r++    TyApp l r ->+      TyApp <$> go inLocalScope l+            <*> typeFreeVars' interesting inLocalScope f r++    Letrec bs e ->+      Letrec <$> traverse (goBind inLocalScope') bs+             <*> go inLocalScope' e+      where+        inLocalScope' = foldr IntSet.insert inLocalScope (map (varUniq.fst) bs)++    Case subj ty alts ->+      Case <$> go inLocalScope subj+           <*> typeFreeVars' interesting inLocalScope f ty+           <*> traverse (goAlt inLocalScope) alts++    Cast tm t1 t2 ->+      Cast <$> go inLocalScope tm+           <*> typeFreeVars' interesting inLocalScope f t1+           <*> typeFreeVars' interesting inLocalScope f t2++    Tick tick tm ->+      Tick <$> goTick inLocalScope tick+      <*> go inLocalScope tm+     tm -> pure tm -  goBndr inScope v =-    (\t -> v  {varType = t}) <$> typeFreeVars' interesting inScope f (varType v)+  goBndr inLocalScope v =+    (\t -> v  {varType = t}) <$> typeFreeVars' interesting inLocalScope f (varType v) -  goBind inScope (l,r) = (,) <$> goBndr inScope l <*> go inScope r+  goBind inLocalScope (l,r) = (,) <$> goBndr inLocalScope l <*> go inLocalScope r -  goAlt inScope (pat,alt) = case pat of+  goAlt inLocalScope (pat,alt) = case pat of     DataPat dc tvs ids -> (,) <$> (DataPat <$> pure dc-                                           <*> traverse (goBndr inScope') tvs-                                           <*> traverse (goBndr inScope') ids)-                              <*> go inScope' alt+                                           <*> traverse (goBndr inLocalScope') tvs+                                           <*> traverse (goBndr inLocalScope') ids)+                              <*> go inLocalScope' alt       where-        inScope' = foldr IntSet.insert-                         (foldr IntSet.insert inScope (map varUniq tvs))+        inLocalScope' = foldr IntSet.insert+                         (foldr IntSet.insert inLocalScope (map varUniq tvs))                          (map varUniq ids)-    _ -> (,) <$> pure pat <*> go inScope alt+    _ -> (,) <$> pure pat <*> go inLocalScope alt -  goTick inScope = \case-    NameMod m ty -> NameMod m <$> typeFreeVars' interesting inScope f ty+  goTick inLocalScope = \case+    NameMod m ty -> NameMod m <$> typeFreeVars' interesting inLocalScope f ty     tick         -> pure tick  -- | Determine whether a type has no free type variables.

@@ -52,6 +52,7 @@  instance Uniquable (Name a) where   getUnique = nameUniq+  setUnique nm u = nm {nameUniq=u}  type OccName = Text 

@@ -83,6 +83,7 @@  instance Uniquable TyCon where   getUnique = tyConUniq+  setUnique tyCon u = tyCon {tyConUniq=u}  -- | TyCon reference type TyConName = Name TyCon

@@ -11,6 +11,7 @@ {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE ExplicitForAll        #-} {-# LANGUAGE GADTs                 #-}+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE RankNTypes            #-}  module Clash.Core.Var@@ -68,29 +69,38 @@   = TyVar   { varName :: !(Name a)   , varUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x)   , varType :: Kind   }   -- | Constructor for term variables   | Id   { varName :: !(Name a)   , varUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x)   , varType :: Type   , idScope :: IdScope   }   deriving (Show,Generic,NFData,Hashable,Binary) +-- | Gets a _key_ in the DBMS sense: a value that uniquely identifies a+-- Var. In case of a "Var" that is its unique and (if applicable) scope+varKey :: Var a -> (Unique, Maybe IdScope)+varKey TyVar{varUniq} = (varUniq, Nothing)+varKey Id{varUniq,idScope} = (varUniq, Just idScope)+ instance Eq (Var a) where-  (==) = (==) `on` varUniq-  (/=) = (/=) `on` varUniq+  (==) = (==) `on` varKey+  (/=) = (/=) `on` varKey  instance Ord (Var a) where-  compare = compare `on` varUniq+  compare = compare `on` varKey  instance Uniquable (Var a) where   getUnique = varUniq+  setUnique var u = var {varUniq=u, varName=(varName var){nameUniq=u}}  data IdScope = GlobalId | LocalId-  deriving (Show,Generic,NFData,Hashable,Binary)+  deriving (Show,Generic,NFData,Hashable,Binary,Eq,Ord)  -- | Term variable type Id    = Var Term

@@ -72,6 +72,7 @@   , varSetInScope     -- ** Unique generation   , uniqAway+  , uniqAway'     -- * Dual renaming   , RnEnv     -- ** Construction@@ -88,7 +89,7 @@   ) where -import Data.Binary                         (Binary)+import           Data.Binary               (Binary) import           Data.Coerce               (coerce) import qualified Data.List                 as List import           Data.Maybe                (fromMaybe)@@ -394,32 +395,39 @@  -- | Ensure that the 'Unique' of a variable does not occur in the 'InScopeSet' uniqAway-  :: InScopeSet-  -> Var a-  -> Var a-uniqAway inScopeSet var-  | var `elemInScopeSet` inScopeSet -- make a new one-  = uniqAway' inScopeSet var-  | otherwise                       -- Nothing to do-  = var+  :: (Uniquable a, ClashPretty a)+  => InScopeSet+  -> a+  -> a+uniqAway (InScopeSet set n) a =+  uniqAway' (`elemUniqSetDirectly` set) n a  uniqAway'-  :: InScopeSet-  -> Var a-  -> Var a-uniqAway' (InScopeSet set n) var = try 1 where-  origUniq = varUniq var+  :: (Uniquable a, ClashPretty a)+  => (Unique -> Bool)+  -- ^ Unique in scope test+  -> Int+  -- ^ Seed+  -> a+  -> a+uniqAway' inScopeTest n u =+  if inScopeTest (getUnique u) then+    try 1+  else+    u+ where+  origUniq = getUnique u   try k     | debugIsOn && k > 1000     = pprPanic "uniqAway loop:" msg-    | uniq `elemUniqSetDirectly` set+    | inScopeTest uniq     = try (k + 1)     | k > 3-    = pprTraceDebug "uniqAway:" msg (setVarUnique var uniq)+    = pprTraceDebug "uniqAway:" msg (setUnique u uniq)     | otherwise-    = setVarUnique var uniq+    = setUnique u uniq     where-      msg  = fromPretty k <+> "tries" <+> clashPretty (varName var) <+> fromPretty n+      msg  = fromPretty k <+> "tries" <+> clashPretty u <+> fromPretty n       uniq = deriveUnique origUniq (n * k)  deriveUnique@@ -497,7 +505,7 @@   -- Find a new type-binder not in scope in either term   newB | not (bL `elemInScopeSet` inScope) = bL        | not (bR `elemInScopeSet` inScope) = bR-       | otherwise                         = uniqAway' inScope bL+       | otherwise                         = uniqAway inScope bL  {- Note [Rebinding and shadowing] Imagine:@@ -546,7 +554,7 @@   -- Find a new type-binder not in scope in either term   newB | not (bL `elemInScopeSet` inScope) = bL        | not (bR `elemInScopeSet` inScope) = bR-       | otherwise                         = uniqAway' inScope bL+       | otherwise                         = uniqAway inScope bL  -- | Applies 'rnTmBndr' to several variables: the two variable lists must be of -- equal length.

@@ -50,7 +50,6 @@ import           System.IO.Error                  (isDoesNotExistError) import           System.IO.Temp   (getCanonicalTemporaryDirectory, withTempDirectory)-import qualified Text.PrettyPrint.ANSI.Leijen     as ANSI import           Text.Trifecta.Result   (Result(Success, Failure), _errDoc) import           Text.Read                        (readMaybe)@@ -425,7 +424,8 @@     -> m BlackBoxTemplate   parseTempl t = case runParse t of     Failure errInfo-      -> error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "")+      -> error ("Parsing template for blackbox " ++ Data.Text.unpack pNm ++ " failed:\n"+               ++ show (_errDoc errInfo))     Success t'       -> pure t' 

@@ -136,23 +136,21 @@   -> BlackBox   -> BlackBoxContext   -> NetlistMonad (BlackBox,[Declaration])-prepareBlackBox pNm templ bbCtx =-  if verifyBlackBoxContext bbCtx templ-     then do-        (t2,decls) <--          onBlackBox-            (fmap (first BBTemplate) . setSym mkUniqueIdentifier bbCtx)-            (\bbName bbHash bbFunc -> pure (BBFunction bbName bbHash bbFunc, []))-            templ-        return (t2,decls)-     else do-       (_,sp) <- Lens.use curCompNm-       templ' <- onBlackBox (getMon . prettyBlackBox)-                            (\n h f -> return $ Text.pack $ show (BBFunction n h f))-                            templ-       let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ Text.unpack templ' ++-                "\n\nwith context:\n\n" ++ show bbCtx-       throw (ClashException sp msg Nothing)+prepareBlackBox _pNm templ bbCtx =+  case verifyBlackBoxContext bbCtx templ of+    Nothing -> do+      (t2,decls) <-+        onBlackBox+          (fmap (first BBTemplate) . setSym mkUniqueIdentifier bbCtx)+          (\bbName bbHash bbFunc -> pure (BBFunction bbName bbHash bbFunc, []))+          templ+      return (t2,decls)+    Just err0 -> do+      (_,sp) <- Lens.use curCompNm+      let err1 = concat [ "Couldn't instantiate blackbox for "+                        , Data.Text.unpack (bbName bbCtx), ". Verification "+                        , "procedure reported:\n\n" ++ err0 ]+      throw (ClashException sp ($(curLoc) ++ err1) Nothing)  -- | Determine if a term represents a literal isLiteral :: Term -> Bool

@@ -40,7 +40,6 @@ import           Data.Text.Prettyprint.Doc.Extra import           System.FilePath                 (replaceBaseName, takeBaseName,                                                   takeFileName, (<.>))-import qualified Text.PrettyPrint.ANSI.Leijen    as ANSI import           Text.Printf import           Text.Read                       (readEither) import           Text.Trifecta.Result            hiding (Err)@@ -86,35 +85,54 @@   -- ^ Blackbox to verify   -> N.BlackBox   -- ^ Template to check against-  -> Bool-verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) = f bbCtx-verifyBlackBoxContext bbCtx (N.BBTemplate t) = and (concatMap (walkElement verify') t)+  -> Maybe String+verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) =+  if f bbCtx then+    Nothing+  else+    -- TODO: Make TemplateFunction return a string+    Just ("Template function for returned False")+verifyBlackBoxContext bbCtx (N.BBTemplate t) =+  orElses (concatMap (walkElement verify') t)   where+    concatTups = concatMap (\(x, y) -> [x, y])+     verify' e =       Just $       case e of         Lit n ->           case indexMaybe (bbInputs bbCtx) n of-            Just (_, _, b) -> b-            _              -> False+            Just (inp, _, False) ->+              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "+                  ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp)+            _ -> Nothing         Const n ->           case indexMaybe (bbInputs bbCtx) n of-            Just (_, _, b) -> b-            _              -> False+            Just (inp, _, False) ->+              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "+                  ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp)+            _ -> Nothing         Component (Decl n l') ->           case IntMap.lookup n (bbFunctions bbCtx) of-            Just _ ->-              all (\(x,y) ->-                      verifyBlackBoxContext bbCtx (N.BBTemplate x) &&-                         verifyBlackBoxContext bbCtx (N.BBTemplate y)) l'+            Just _func ->+              orElses $+                map+                  (verifyBlackBoxContext bbCtx . N.BBTemplate)+                  (concatTups l')             Nothing ->-              False+              Just ( "Blackbox requested instantiation of function at argument "+                  ++ show n ++ ", but BlackBoxContext did not contain one.")         _ ->           case inputHole e of             Nothing ->-              True+              Nothing             Just n ->-              n < length (bbInputs bbCtx)+              case indexMaybe (bbInputs bbCtx) n of+                Just _ -> Nothing+                Nothing ->+                  Just ( "Blackbox required at least " ++ show (n+1)+                      ++ " arguments, but only " ++ show (length (bbInputs bbCtx))+                      ++ " were passed." )  extractLiterals :: BlackBoxContext                 -> [Expr]@@ -135,6 +153,8 @@     (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty)     return (a,concatMap snd (IntMap.elems decls))   where+    bbnm = Data.Text.unpack (bbName bbCtx)+     setSym'       :: Element       -> StateT ( IntMap.IntMap Identifier@@ -174,7 +194,10 @@             t' <- lift (mkUniqueIdentifierM Basic (Text.toStrict (concatT t)))             _1 %= (IntMap.insert i t')             return (GenSym [Text (Text.fromStrict t')] i)-          Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined")+          Just _ ->+            error ("Symbol #" ++ show (t,i)+                ++ " is already defined in BlackBox for: "+                ++ bbnm)       Component (Decl n l') ->         Component <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l')       IF c t f      -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f@@ -183,19 +206,21 @@       _             -> pure e      concatT :: [Element] -> Text-    concatT = Text.concat-            . map (\case { Text t -> t-                         ; Name i -> case elementToText bbCtx (Name i) of-                                         Right t ->-                                             t-                                         Left msg ->-                                             error $ $(curLoc) ++  "Could not convert "-                                                               ++ "~NAME[" ++ show i ++ "]"-                                                               ++ " to string:" ++ msg-                         ; Result _ | Identifier t _ <- fst (bbResult bbCtx)-                                    -> Text.fromStrict t-                         ; CompName -> Text.fromStrict (bbCompName bbCtx)-                         ; _   -> error "unexpected element in GENSYM"})+    concatT = Text.concat . map (+      \case+        Text t -> t+        Name i ->+          case elementToText bbCtx (Name i) of+            Right t -> t+            Left msg ->+              error $ $(curLoc) ++  "Could not convert ~NAME[" ++ show i ++ "]"+                   ++ " to string:" ++ msg ++ "\n\nError occured while "+                   ++ "processing blackbox for " ++ bbnm+        Result _ | Identifier t _ <- fst (bbResult bbCtx) -> Text.fromStrict t+        CompName -> Text.fromStrict (bbCompName bbCtx)+        _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing "+                  ++ "blackbox for " ++ bbnm+        )  selectNewName     :: Foldable t@@ -317,15 +342,16 @@                    $ renderLazy                    $ layoutPretty layoutOptions block -  if verifyBlackBoxContext b' templ4-    then do+  case verifyBlackBoxContext b' templ4 of+    Nothing -> do       bb <- renderBlackBox libs imps inc templ4 b'       return (renderLazy . layoutPretty layoutOptions . bb)-    else do+    Just err0 -> do       sp <- getSrcSpan-      throw (ClashException sp ($(curLoc) ++ "\nCan't match context:\n"-                                          ++ show b' ++ "\nwith template:\n"-                                          ++ show templ0) Nothing)+      let err1 = concat [ "Couldn't instantiate blackbox for "+                        , Data.Text.unpack (bbName b), ". Verification procedure "+                        , "reported:\n\n" ++ err0 ]+      throw (ClashException sp ($(curLoc) ++ err1) Nothing)  renderElem b (SigD e m) = do   e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e@@ -463,7 +489,7 @@ parseFail :: Text -> BlackBoxTemplate parseFail t = case runParse t of   Failure errInfo ->-    error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "")+    error (show (_errDoc errInfo))   Success templ -> templ  idToExpr

@@ -58,7 +58,9 @@     spec               = bottomupR (applyMany specTransformations)     caseFlattening     = repeatR (topdownR (apply "caseFlat" caseFlat))     dec                = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))-    conSpec            = bottomupR (apply "constantSpec" constantSpec)+    conSpec            = bottomupR  ((apply "appPropCS" appPropFast !->+                                     bottomupR (apply "constantSpec" constantSpec)) >-!+                                     apply "constantSpec" constantSpec)      transPropagateAndInline :: [(String,NormRewrite)]     transPropagateAndInline =

@@ -813,7 +813,7 @@   where     test _ (_,stripTicks -> e) = case isLocalVar e of       True -> return True-      _    -> isConstantNotClockReset e >>= \case+      _    -> isWorkFreeIsh e >>= \case         True -> Lens.use (extra.inlineConstantLimit) >>= \case           0 -> return True           n -> return (termSize e <= n)@@ -834,7 +834,7 @@ letCast _ e = return e  --- | Push cast over an argument to a funtion into that function+-- | Push cast over an argument to a function into that function -- -- This is done by specializing on the casted argument. -- Example:@@ -847,20 +847,24 @@ --   y = f' a --     where f' x' = (\x -> g x) (cast x') -- @+--+-- The reason d'etre for this transformation is that we hope to end up with+-- and expression where two casts are "back-to-back" after which we can+-- eliminate them in 'eliminateCastCast'. argCastSpec :: HasCallStack => NormRewrite-argCastSpec ctx e@(App _ (stripTicks -> Cast e' _ _)) = case e' of-  Var {} -> go-  Cast (Var {}) _ _ -> go-  _ -> warn go-  where-    go = specializeNorm ctx e-    warn = trace (unlines ["WARNING: " ++ $(curLoc) ++ "specializing a function on a possibly non work-free cast."-                          ,"Generated HDL implementation might contain duplicate work."-                          ,"Please report this as a bug."-                          ,""-                          ,"Expression where this occurs:"-                          ,showPpr e-                          ])+argCastSpec ctx e@(App _ (stripTicks -> Cast e' _ _)) =+  if isWorkFree e' then+    go+  else+    warn go+ where+  go = specializeNorm ctx e+  warn = trace (unwords+    [ "WARNING:", $(curLoc), "specializing a function on a non work-free"+    , "cast. Generated HDL implementation might contain duplicate work."+    , "Please report this as a bug.", "\n\nExpression where this occured:"+    , "\n\n" ++ showPpr e+    ]) argCastSpec _ e = return e  -- | Only inline casts that just contain a 'Var', because these are guaranteed work-free.@@ -1017,12 +1021,29 @@ -- | Specialise functions on arguments which are constant, except when they -- are clock, reset generators. constantSpec :: HasCallStack => NormRewrite-constantSpec ctx e@(App e1 e2)+constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2)   | (Var {}, args) <- collectArgs e1   , (_, []) <- Either.partitionEithers args   , null $ Lens.toListOf termFreeTyVars e2-  = do e2Speccable <- canConstantSpec e2-       if e2Speccable then specializeNorm ctx e else return e+  = do specInfo<- constantSpecInfo ctx e2+       if csrFoundConstant specInfo then+         let newBindings = csrNewBindings specInfo in+         if null newBindings then+           -- Whole of e2 is constant+           specializeNorm ctx (App e1 e2)+         else do+           -- Parts of e2 are constant+           let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo)+           -- Deshadow because appPropFast will be called after constantSpec+           deShadowTerm is0+            <$> Letrec newBindings+            <$> specializeNorm+                  (TransformContext is1 tfCtx)+                  (App e1 (csrNewTerm specInfo))++       else+        -- e2 has no constant parts+        return e constantSpec _ e = return e  

@@ -13,7 +13,8 @@ {-# LANGUAGE ViewPatterns      #-}  module Clash.Normalize.Util- ( isConstantArg+ ( ConstantSpecInfo(..)+ , isConstantArg  , shouldReduce  , alreadyInlined  , addNewInline@@ -24,7 +25,7 @@  , classifyFunction  , isCheapFunction  , isNonRecursiveGlobalVar- , canConstantSpec+ , constantSpecInfo  , normalizeTopLvlBndr  , rewriteExpr  , removedTm@@ -33,6 +34,8 @@  import           Control.Lens            ((&),(+~),(%=),(^.),_4,(.=)) import qualified Control.Lens            as Lens+import           Data.Bifunctor          (bimap)+import           Data.Either             (lefts) import qualified Data.List               as List import qualified Data.Map                as Map import qualified Data.HashMap.Strict     as HashMapS@@ -47,23 +50,27 @@ import           Clash.Core.Subst        (deShadowTerm) import           Clash.Core.Term   (Context, CoreContext(AppArg), PrimInfo (..), Term (..), WorkInfo (..),-   collectArgs)+   TickInfo, collectArgs, collectArgsTicks) import           Clash.Core.TyCon        (TyConMap) import           Clash.Core.Type         (Type, undefinedTy)-import           Clash.Core.Util         (isClockOrReset, isPolyFun, termType)+import           Clash.Core.Util+  (isClockOrReset, isPolyFun, termType, mkApps, mkTicks) import           Clash.Core.Var          (Id, Var (..), isGlobalId) import           Clash.Core.VarEnv   (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, extendVarEnvWith,-   lookupVarEnv, unionVarEnvWith, unitVarEnv)+   lookupVarEnv, unionVarEnvWith, unitVarEnv, extendInScopeSetList) import           Clash.Driver.Types      (BindingMap, DebugLevel (..)) import {-# SOURCE #-} Clash.Normalize.Strategy (normalization) import           Clash.Normalize.Types import           Clash.Primitives.Util   (constantArgs) import           Clash.Rewrite.Types-  (RewriteMonad, bindings, curFun, dbgLevel, extra, tcCache)-import           Clash.Rewrite.Util      (runRewrite, specialise)+  (RewriteMonad, TransformContext(..), bindings, curFun, dbgLevel, extra,+   tcCache)+import           Clash.Rewrite.Util+  (runRewrite, specialise, mkTmBinderFor, mkDerivedName) import           Clash.Unique-import           Clash.Util              (SrcSpan, anyM, makeCachedU, traceIf)+import           Clash.Util+  (SrcSpan, anyM, makeCachedU, traceIf, mapAccumLM)  -- | Determine if argument should reduce to a constant given a primitive and -- an argument number. Caches results.@@ -171,36 +178,158 @@           (extra.recursiveComponents) %= extendVarEnv f isR           return isR --- | Test if we can constant specialize current term in current function. The--- rules are, we can constant fold if:+data ConstantSpecInfo =+  ConstantSpecInfo+    { csrNewBindings :: [(Id, Term)]+    -- ^ New let-bindings to be created for all the non-constants found+    , csrNewTerm :: !Term+    -- ^ A term where all the non-constant constructs are replaced by variable+    -- references (found in 'csrNewBindings')+    , csrFoundConstant :: !Bool+    -- ^ Whether the algorithm found a constant at all. (If it didn't, it's no+    -- use creating any new let-bindings!)+    } deriving (Show)++-- | Indicate term is fully constant (don't bind anything)+constantCsr :: Term -> ConstantSpecInfo+constantCsr t = ConstantSpecInfo [] t True++-- | Bind given term to a new variable and indicate that it's fully non-constant+bindCsr+  :: TransformContext+  -> Term+  -> RewriteMonad NormalizeState ConstantSpecInfo+bindCsr ctx@(TransformContext is0 _) oldTerm = do+  -- TODO: Seems like the need to put global ids in scope has been made obsolete+  -- TODO: by a recent change in Clash. Investigate whether this is true.+  tcm <- Lens.view tcCache+  newId <- mkTmBinderFor is0 tcm (mkDerivedName ctx "bindCsr") oldTerm+  pure (ConstantSpecInfo+    { csrNewBindings = [(newId, oldTerm)]+    , csrNewTerm = Var newId+    , csrFoundConstant = False+    })++mergeCsrs+  :: TransformContext+  -> [TickInfo]+  -- ^ Ticks to wrap around proposed new term+  -> Term+  -- ^ "Old" term+  -> ([Either Term Type] -> Term)+  -- ^ Proposed new term in case any constants were found+  -> [Either Term Type]+  -- ^ Subterms+  -> RewriteMonad NormalizeState ConstantSpecInfo+mergeCsrs ctx ticks oldTerm proposedTerm subTerms = do+  subCsrs <- snd <$> mapAccumLM constantSpecInfoFolder ctx subTerms++  -- If any arguments are constant (and hence can be constant specced), a new+  -- term is created with these constants left in, but variable parts let-bound.+  -- There's one edge case: whenever a term has _no_ arguments. This happens for+  -- constructors without fields, or -depending on their WorkInfo- primitives+  -- without args. We still set 'csrFoundConstant', because we know the newly+  -- proposed term will be fully constant.+  let+    anyArgsOrResultConstant =+      null (lefts subCsrs) || any csrFoundConstant (lefts subCsrs)++  if anyArgsOrResultConstant then+    let newTerm = proposedTerm (bimap csrNewTerm id <$> subCsrs)  in+    pure (ConstantSpecInfo+      { csrNewBindings = concatMap csrNewBindings (lefts subCsrs)+      , csrNewTerm = mkTicks newTerm ticks+      , csrFoundConstant = True+      })+  else do+    -- No constructs were found to be constant, so we might as well refer to the+    -- whole thing with a new let-binding (instead of creating a number of+    -- "smaller" let-bindings)+    bindCsr ctx oldTerm++ where+  constantSpecInfoFolder+    :: TransformContext+    -> Either Term Type+    -> RewriteMonad NormalizeState (TransformContext, Either ConstantSpecInfo Type)+  constantSpecInfoFolder localCtx (Right typ) =+    pure (localCtx, Right typ)+  constantSpecInfoFolder localCtx@(TransformContext is0 tfCtx) (Left term) = do+    specInfo <- constantSpecInfo localCtx term+    let newIds = map fst (csrNewBindings specInfo)+    let is1 = extendInScopeSetList is0 newIds+    pure (TransformContext is1 tfCtx, Left specInfo)+++-- | Calculate constant spec info. The goal of this function is to analyze a+-- given term and yield a new term that: -----   * Term does not carry a clock or reset---   * Term is constant is @isConstant@ sense, and additionally when term is a---     global, non-recursive variable+--  * Leaves all the constant parts as they were.+--  * Has all _variable_ parts replaced by a newly generated identifier. ---canConstantSpec-  :: Term-  -> RewriteMonad NormalizeState Bool-canConstantSpec e = do+-- The result structure will additionally contain:+--+--  * Whether the function found any constant parts at all+--  * A list of let-bindings binding the aforementioned identifiers with+--    the term they replaced.+--+-- This can be used in functions wanting to constant specialize over+-- partially constant data structures.+constantSpecInfo+  :: TransformContext+  -> Term+  -> RewriteMonad NormalizeState ConstantSpecInfo+constantSpecInfo ctx e = do   tcm <- Lens.view tcCache+  -- Don't constant spec clocks or resets, they're either:+  --+  --  * A simple wire (Var), therefore not interesting to spec+  --  * A clock/reset generator, and speccing a generator weirds out HDL simulators.+  --+  -- I believe we can remove this special case in the future by looking at the+  -- primitive's workinfo.   if isClockOrReset tcm (termType tcm e) then     case collectArgs e of-      (Prim nm _, _) -> return (nm == "Clash.Transformations.removedArg")-      _              -> return False+      (Prim "Clash.Transformations.removedArg" _, _) ->+        pure (constantCsr e)+      _ -> do+        bindCsr ctx e   else-    case collectArgs e of-      (Data _, args)   -> and <$> mapM (either canConstantSpec (const (pure True))) args-      (Prim _ _, args) -> and <$> mapM (either canConstantSpec (const (pure True))) args-      (Lam _ _, _)     -> pure (not (hasLocalFreeVars e))-      (Var f, args)    -> do-        (curF, _) <- Lens.use curFun+    case collectArgsTicks e of+      (dc@(Data _), args, ticks) ->+        mergeCsrs ctx ticks e (mkApps dc) args -        argsConst <- and <$> mapM (either canConstantSpec (const (pure True))) args+      -- TODO: Work with prim's WorkInfo?+      (prim@(Prim _ _), args, ticks) -> do+        csr <- mergeCsrs ctx ticks e (mkApps prim) args+        if null (csrNewBindings csr) then+          pure csr+        else+          bindCsr ctx e++      (Lam _ _, _, _ticks) ->+        if hasLocalFreeVars e then+          bindCsr ctx e+        else+          pure (constantCsr e)++      (var@(Var f), args, ticks) -> do+        (curF, _) <- Lens.use curFun         isNonRecGlobVar <- isNonRecursiveGlobalVar e-        return (argsConst && isNonRecGlobVar && f /= curF)+        if isNonRecGlobVar && f /= curF then do+          csr <- mergeCsrs ctx ticks e (mkApps var) args+          if null (csrNewBindings csr) then+            pure csr+          else+            bindCsr ctx e+        else+          bindCsr ctx e -      (Literal _,_)    -> pure True-      _                -> pure False+      (Literal _,_, _ticks) ->+        pure (constantCsr e)++      _ ->+        bindCsr ctx e  -- | A call graph counts the number of occurrences that a functions 'g' is used -- in 'f'.

@@ -78,9 +78,9 @@   (Id, IdScope (..), TyVar, Var (..), isLocalId, mkGlobalId, mkLocalId, mkTyVar) import           Clash.Core.VarEnv   (InScopeSet, VarEnv, elemVarSet, extendInScopeSetList, mkInScopeSet,-   notElemVarEnv, uniqAway)+   notElemVarEnv, uniqAway, uniqAway') import           Clash.Driver.Types-  (DebugLevel (..))+  (DebugLevel (..), BindingMap) import           Clash.Netlist.Util          (representableType) import           Clash.Rewrite.Types import           Clash.Unique@@ -300,14 +300,14 @@   -> Either Term Type -- ^ Type or Term to bind   -> m (Either Id TyVar) mkBinderFor is tcm name (Left term) = do-  name' <- cloneName name+  name' <- cloneNameWithInScopeSet is name   let ty = termType tcm term-  return (Left (uniqAway is (mkLocalId ty (coerce name'))))+  return (Left (mkLocalId ty (coerce name')))  mkBinderFor is tcm name (Right ty) = do-  name' <- cloneName name+  name' <- cloneNameWithInScopeSet is name   let ki = typeKind tcm ty-  return (Right (uniqAway is (mkTyVar ki (coerce name'))))+  return (Right (mkTyVar ki (coerce name')))  -- | Make a new, unique, identifier mkInternalVar@@ -480,6 +480,49 @@         _ -> return False      else pure (isConstant e) +-- TODO: Remove function after using WorkInfo in 'isWorkFreeIsh'+isWorkFreeClockOrReset+  :: TyConMap+  -> Term+  -> Maybe Bool+isWorkFreeClockOrReset tcm e =+  let eTy = termType tcm e in+  if isClockOrReset tcm eTy then+    case collectArgs e of+      (Prim nm _,_) -> Just (nm == "Clash.Transformations.removedArg")+      (Var _, []) -> Just True+      _ -> Just False+  else+    Nothing++-- | A conservative version of 'isWorkFree'. Is used to determine in 'bindConstantVar'+-- to determine whether an expression can be "bound" (locally inlined). While+-- binding workfree expressions won't result in extra work for the circuit, it+-- might very well cause extra work for Clash. In fact, using 'isWorkFree' in+-- 'bindConstantVar' makes Clash two orders of magnitude slower for some of our+-- test cases.+--+-- In effect, this function is a version of 'isConstant' that also considers+-- references to clocks and resets constant. This allows us to bind+-- HiddenClock(ResetEnable) constructs, allowing Clash to constant spec+-- subconstants - most notably KnownDomain. Doing that enables Clash to+-- eliminate any case-constructs on it.+isWorkFreeIsh+  :: Term+  -> RewriteMonad extra Bool+isWorkFreeIsh e = do+  tcm <- Lens.view tcCache+  case isWorkFreeClockOrReset tcm e of+    Just b -> pure b+    Nothing ->+      case collectArgs e of+        (Data _, args)   -> allM (either isWorkFreeIsh (pure . const True)) args+        -- TODO: Use WorkInfo+        (Prim _ _, args) -> allM (either isWorkFreeIsh (pure . const True)) args+        (Lam _ _, _)     -> pure (not (hasLocalFreeVars e))+        (Literal _,_)    -> pure True+        _                -> pure False+ inlineOrLiftBinders   :: (LetBinding -> RewriteMonad extra Bool)   -- ^ Property test@@ -535,7 +578,11 @@   tcm       <- Lens.view tcCache   let newBodyTy = termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs   (cf,sp)   <- Lens.use curFun-  newBodyNm <- cloneName (appendToName (varName cf) ("_" `Text.append` nameOcc idName))+  binders <- Lens.use bindings+  newBodyNm <-+    cloneNameWithBindingMap+      binders+      (appendToName (varName cf) ("_" `Text.append` nameOcc idName))   let newBodyId = mkGlobalId newBodyTy newBodyNm {nameSort = Internal}    -- Make a new expression, consisting of the the lifted function applied to@@ -586,6 +633,14 @@  liftBinding _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar" +-- | Ensure that the 'Unique' of a variable does not occur in the 'BindingMap'+uniqAwayBinder+  :: BindingMap+  -> Name a+  -> Name a+uniqAwayBinder binders nm =+  uniqAway' (`elemUniqMapDirectly` binders) (nameUniq nm) nm+ -- | Make a global function for a name-term tuple mkFunction   :: TmName@@ -597,9 +652,10 @@   -> RewriteMonad extra Id   -- ^ Name with a proper unique and the type of the function mkFunction bndrNm sp inl body = do-  tcm    <- Lens.view tcCache+  tcm <- Lens.view tcCache   let bodyTy = termType tcm body-  bodyNm <- cloneName bndrNm+  binders <- Lens.use bindings+  bodyNm <- cloneNameWithBindingMap binders bndrNm   addGlobalBind bodyNm bodyTy sp inl body   return (mkGlobalId bodyTy bodyNm) @@ -615,14 +671,27 @@   let vId = mkGlobalId ty vNm   (ty,body) `deepseq` bindings %= extendUniqMap vNm (vId,sp,inl,body) --- | Create a new name out of the given name, but with another unique-cloneName+-- | Create a new name out of the given name, but with another unique. Resulting+-- unique is guaranteed to not be in the given InScopeSet.+cloneNameWithInScopeSet   :: (Monad m, MonadUnique m)-  => Name a+  => InScopeSet+  -> Name a   -> m (Name a)-cloneName nm = do+cloneNameWithInScopeSet is nm = do   i <- getUniqueM-  return nm {nameUniq = i}+  return (uniqAway is (setUnique nm i))++-- | Create a new name out of the given name, but with another unique. Resulting+-- unique is guaranteed to not be in the given BindingMap.+cloneNameWithBindingMap+  :: (Monad m, MonadUnique m)+  => BindingMap+  -> Name a+  -> m (Name a)+cloneNameWithBindingMap binders nm = do+  i <- getUniqueM+  return (uniqAway' (`elemUniqMapDirectly` binders) i (setUnique nm i))  {-# INLINE isUntranslatable #-} -- | Determine if a term cannot be represented in hardware

@@ -37,6 +37,7 @@     -- *** Searching   , elemUniqMap   , notElemUniqMap+  , elemUniqMapDirectly     -- ** Folding   , foldrWithUnique     -- ** Conversions@@ -90,9 +91,11 @@  class Uniquable a where   getUnique :: a -> Unique+  setUnique :: a -> Unique -> a  instance Uniquable Int where   getUnique i = i+  setUnique _i0 i1 = i1  -- | Map indexed by a 'Uniquable' key newtype UniqMap a = UniqMap (IntMap a)@@ -186,7 +189,15 @@   => a   -> UniqMap b   -> Bool-elemUniqMap k (UniqMap m) = IntMap.member (getUnique k) m+elemUniqMap k = elemUniqMapDirectly (getUnique k)++-- | Check whether an element exists in the uniqmap based on a given `Unique`+elemUniqMapDirectly+  :: Unique+  -> UniqMap b+  -> Bool+elemUniqMapDirectly k (UniqMap m) = k `IntMap.member` m+{-# INLINE elemUniqMapDirectly #-}  -- | Check whether a key is not in the map notElemUniqMap

@@ -36,7 +36,7 @@ import Data.Hashable                  (Hashable) import Data.HashMap.Lazy              (HashMap) import qualified Data.HashMap.Lazy    as HashMapL-import Data.Maybe                     (fromMaybe)+import Data.Maybe                     (fromMaybe, listToMaybe, catMaybes) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String import Data.Version                   (Version)@@ -401,3 +401,21 @@   -> d uncurry3 = \f (a,b,c) -> f a b c {-# INLINE uncurry3 #-}++allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool+allM _ [] = return True+allM p (x:xs) = do+  q <- p x+  if q then+    allM p xs+  else+    return False++-- | Left-biased choice on maybes+orElse :: Maybe a -> Maybe a -> Maybe a+orElse x@(Just _) _y = x+orElse _x y = y++-- | Left-biased choice on maybes+orElses :: [Maybe a] -> Maybe a+orElses = listToMaybe . catMaybes

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module Clash.Tests.Core.FreeVars (tests) where++import           SrcLoc                  (noSrcSpan)+import qualified Control.Lens            as Lens++import           Test.Tasty+import           Test.Tasty.HUnit++import           Clash.Core.FreeVars     (globalIds)+import           Clash.Core.Name         (Name(..), NameSort(..))+import           Clash.Core.Term         (Term(Var, App, Lam))+import           Clash.Core.Type         (ConstTy(..), Type(ConstTy))+import           Clash.Core.Var          (IdScope(..), Var(..))++-- TODO: We need tooling to create these mock constructs+fakeName :: Name a+fakeName =+  Name+    { nameSort=User+    , nameOcc="fake"+    , nameUniq=0+    , nameLoc=noSrcSpan+    }++f :: IdScope -> Var Term+f scope =+  let unique = 20 in+  Id { varName = Name { nameSort=User+                      , nameOcc="f"+                      , nameUniq=unique+                      , nameLoc=noSrcSpan }+     , varUniq = unique+     , varType = ConstTy (TyCon fakeName)+     , idScope = scope }++fLocalId, fGlobalId :: Var Term+fLocalId = f LocalId+fGlobalId = f GlobalId++-- 'term1' is a simple lambda function:+--+--   \f -> g f+--+-- where f and g have the same unique, but f has been marked as _local_ while+-- g is _global_. In other words:+--+--   \f[l] -> f[g] f[l]+--+-- This term is tested against to check whether various functions account for+-- the distinction between local/global variables correctly.+term1 :: Term+term1 =+  Lam fLocalId (Var fGlobalId `App` Var fLocalId)++tests :: TestTree+tests =+  let globs1 = Lens.toListOf globalIds term1 in+  testGroup+    "Clash.Tests.Core.FreeVars"+    [ testCase "globalIds1" $ globs1 @=? [fGlobalId]+    , testCase "globalIds2" $+        assertBool+          "Global and local id can't BOTH be in globs1"+          (fLocalId `notElem` globs1)+    ]

@@ -0,0 +1,13 @@+module Main where++import Test.Tasty++import qualified Clash.Tests.Core.FreeVars++tests :: TestTree+tests = testGroup "Unittests"+  [ Clash.Tests.Core.FreeVars.tests+  ]++main :: IO ()+main = defaultMain tests