diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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 diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs --- a/src/Clash/Backend/Verilog.hs +++ b/src/Clash/Backend/Verilog.hs @@ -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 diff --git a/src/Clash/Core/DataCon.hs b/src/Clash/Core/DataCon.hs --- a/src/Clash/Core/DataCon.hs +++ b/src/Clash/Core/DataCon.hs @@ -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 diff --git a/src/Clash/Core/FreeVars.hs b/src/Clash/Core/FreeVars.hs --- a/src/Clash/Core/FreeVars.hs +++ b/src/Clash/Core/FreeVars.hs @@ -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. diff --git a/src/Clash/Core/Name.hs b/src/Clash/Core/Name.hs --- a/src/Clash/Core/Name.hs +++ b/src/Clash/Core/Name.hs @@ -52,6 +52,7 @@ instance Uniquable (Name a) where getUnique = nameUniq + setUnique nm u = nm {nameUniq=u} type OccName = Text diff --git a/src/Clash/Core/TyCon.hs b/src/Clash/Core/TyCon.hs --- a/src/Clash/Core/TyCon.hs +++ b/src/Clash/Core/TyCon.hs @@ -83,6 +83,7 @@ instance Uniquable TyCon where getUnique = tyConUniq + setUnique tyCon u = tyCon {tyConUniq=u} -- | TyCon reference type TyConName = Name TyCon diff --git a/src/Clash/Core/Var.hs b/src/Clash/Core/Var.hs --- a/src/Clash/Core/Var.hs +++ b/src/Clash/Core/Var.hs @@ -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 diff --git a/src/Clash/Core/VarEnv.hs b/src/Clash/Core/VarEnv.hs --- a/src/Clash/Core/VarEnv.hs +++ b/src/Clash/Core/VarEnv.hs @@ -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. diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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' diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -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 diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -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 diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs --- a/src/Clash/Normalize/Strategy.hs +++ b/src/Clash/Normalize/Strategy.hs @@ -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 = diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -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 diff --git a/src/Clash/Normalize/Util.hs b/src/Clash/Normalize/Util.hs --- a/src/Clash/Normalize/Util.hs +++ b/src/Clash/Normalize/Util.hs @@ -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'. diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -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 diff --git a/src/Clash/Unique.hs b/src/Clash/Unique.hs --- a/src/Clash/Unique.hs +++ b/src/Clash/Unique.hs @@ -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 diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs --- a/src/Clash/Util.hs +++ b/src/Clash/Util.hs @@ -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 diff --git a/tests/Clash/Tests/Core/FreeVars.hs b/tests/Clash/Tests/Core/FreeVars.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/FreeVars.hs @@ -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) + ] diff --git a/tests/unittests.hs b/tests/unittests.hs new file mode 100644 --- /dev/null +++ b/tests/unittests.hs @@ -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