{-| Copyright : (C) 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Functions to read, write, and handle manifest files. -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Driver.Manifest where import Control.Exception (tryJust) import Control.Monad (guard, forM) import Control.Monad.State (evalState) import qualified Crypto.Hash.SHA256 as Sha256 import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson import Data.Aeson (ToJSON(toJSON), FromJSON(parseJSON), KeyValue ((.=)), (.:), (.:?)) import Data.Aeson.Types (Parser) import qualified Data.Binary as Binary import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as ByteStringLazy import Data.ByteString (ByteString) import Data.Char (toLower) #if MIN_VERSION_base16_bytestring(1,0,0) import Data.Either (fromRight) #endif import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes) import Data.Monoid (Ap(getAp)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText import Data.Text (Text) import Data.Text.Prettyprint.Doc.Extra (renderOneLine) import Data.Time (UTCTime) import qualified Data.Set as Set import Data.String (IsString) import GHC.Generics (Generic) import System.IO.Error (isDoesNotExistError) import System.FilePath (takeDirectory, ()) import System.Directory (listDirectory, doesFileExist) import Text.Read (readMaybe) import Clash.Annotations.TopEntity.Extra () import Clash.Backend (Backend (hdlType), Usage (External)) import Clash.Core.Name (nameOcc) import Clash.Driver.Bool (OverridingBool(..)) import Clash.Driver.Types import Clash.Primitives.Types import Clash.Core.Var (Id, varName) import Clash.Netlist.Types (TopEntityT, Component(..), HWType (Clock, ClockN), hwTypeDomain) import qualified Clash.Netlist.Types as Netlist import qualified Clash.Netlist.Id as Id import Clash.Netlist.Util (typeSize) import Clash.Primitives.Util (hashCompiledPrimMap) import Clash.Signal (VDomainConfiguration(..)) import Clash.Util.Graph (callGraphBindings) data PortDirection = In | Out | InOut deriving (Generic, Eq, Read, Show) instance ToJSON PortDirection where toJSON = Aeson.genericToJSON Aeson.defaultOptions { Aeson.constructorTagModifier = fmap toLower } instance FromJSON PortDirection where parseJSON = Aeson.genericParseJSON Aeson.defaultOptions { Aeson.constructorTagModifier = fmap toLower } data ManifestPort = ManifestPort { mpName :: Text -- ^ Port name (as rendered in HDL) , mpTypeName :: Text -- ^ Type name (as rendered in HDL) , mpDirection :: PortDirection -- ^ Port direction (in / out / inout) , mpWidth :: Int -- ^ Port width in bits , mpIsClock :: Bool -- ^ Is this port a clock? , mpDomain :: Maybe Text -- ^ Domain this port belongs to. This is currently only included for clock, -- reset, and enable ports. TODO: add to all ports originally defined as a -- @Signal@ too. } deriving (Show,Read,Eq) instance ToJSON ManifestPort where toJSON (ManifestPort{..}) = Aeson.object $ [ "name" .= mpName , "type_name" .= mpTypeName , "direction" .= mpDirection , "width" .= mpWidth , "is_clock" .= mpIsClock ] <> (case mpDomain of Just dom -> ["domain" .= dom] Nothing -> [] ) instance FromJSON ManifestPort where parseJSON = Aeson.withObject "ManifestPort" $ \v -> ManifestPort <$> v .: "name" <*> v .: "type_name" <*> v .: "direction" <*> v .: "width" <*> v .: "is_clock" <*> v .:? "domain" -- | Just the 'fileNames' part of 'Manifest' newtype FilesManifest = FilesManifest [(FilePath, ByteString)] instance FromJSON FilesManifest where parseJSON = Aeson.withObject "FilesManifest" $ fmap FilesManifest . parseFiles -- | Information about the generated HDL between (sub)runs of the compiler data Manifest = Manifest { manifestHash :: ByteString -- ^ Hash digest of the TopEntity and all its dependencies. , successFlags :: (Int, Int) -- ^ Compiler flags used to achieve successful compilation: -- -- * opt_inlineLimit -- * opt_specLimit , ports :: [ManifestPort] -- ^ Ports in the generated @TopEntity@. , componentNames :: [Text] -- ^ Names of all the generated components for the @TopEntity@ (does not -- include the names of the components of the @TestBench@ accompanying -- the @TopEntity@). -- -- This list is reverse topologically sorted. I.e., a component might depend -- on any component listed before it, but not after it. , topComponent :: Text -- ^ Design entry point. This is usually the component annotated with a -- @TopEntity@ annotation. , fileNames :: [(FilePath, ByteString)] -- ^ Names and hashes of all the generated files for the @TopEntity@. Hashes -- are SHA256. -- -- This list is reverse topologically sorted. I.e., a component might depend -- on any component listed before it, but not after it. , domains :: HashMap Text VDomainConfiguration -- ^ Domains encountered in design , transitiveDependencies :: [Text] -- ^ Dependencies of this design (fully qualified binder names). Is a -- transitive closure of all dependencies. -- -- This list is reverse topologically sorted. I.e., a component might depend -- on any component listed before it, but not after it. } deriving (Show,Read,Eq) instance ToJSON Manifest where toJSON (Manifest{..}) = Aeson.object [ "version" .= ("unstable" :: Text) , "hash" .= toHexDigest manifestHash , "flags" .= successFlags -- TODO: add nested ports (i.e., how Clash split/filtered arguments) , "components" .= componentNames , "top_component" .= Aeson.object [ "name" .= topComponent , "ports_flat" .= ports ] , "files" .= [ Aeson.object [ "name" .= fName , "sha256" .= toHexDigest fHash -- TODO: Add Edam like fields ] | (fName, fHash) <- fileNames] , "domains" .= HashMap.fromList [ ( domNm , Aeson.object [ "period" .= vPeriod , "active_edge" .= show vActiveEdge , "reset_kind" .= show vResetKind , "init_behavior" .= show vInitBehavior , "reset_polarity" .= show vResetPolarity ] ) | (domNm, VDomainConfiguration{..}) <- HashMap.toList domains ] , "dependencies" .= Aeson.object [ "transitive" .= transitiveDependencies ] ] -- Note [Failed hex digest decodes] -- -- 'unsafeFromHexDigest' may fail to decode a hex digest if it contains characters -- outside of [a-fA-F0-9]. In this case, it will return a broken digest. Because -- this module discards any data covered by the broken digest if it does not match -- a freshly calculated one, this poses no problem. -- | Decode a hex digest to a ByteString. Returns a broken digest if the decode -- fails - hence it being marked as unsafe. unsafeFromHexDigest :: Text -> ByteString unsafeFromHexDigest = #if MIN_VERSION_base16_bytestring(1,0,0) fromRight "failed decode" . Base16.decode . Text.encodeUtf8 #else fst . Base16.decode . Text.encodeUtf8 #endif -- | Encode a ByteString to a hex digest. toHexDigest :: ByteString -> Text toHexDigest = Text.decodeUtf8 . Base16.encode -- | Parse @files@ part of a Manifest file parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)] parseFiles v = do files <- v .: "files" forM files $ \obj -> do fName <- obj .: "name" sha256 <- obj .: "sha256" -- See Note [Failed hex digest decodes] pure (fName, unsafeFromHexDigest sha256) instance FromJSON Manifest where parseJSON = Aeson.withObject "Manifest" $ \v -> let topComponent = v .: "top_component" in Manifest -- See Note [Failed hex digest decodes] <$> (unsafeFromHexDigest <$> v .: "hash") <*> v .: "flags" <*> (topComponent >>= (.: "ports_flat")) <*> v .: "components" <*> (topComponent >>= (.: "name")) <*> parseFiles v <*> (v .: "domains" >>= HashMap.traverseWithKey parseDomain) <*> (v .: "dependencies" >>= (.: "transitive")) where parseDomain :: Text -> Aeson.Object -> Parser VDomainConfiguration parseDomain nm v = VDomainConfiguration <$> pure (Text.unpack nm) <*> (v .: "period") <*> parseWithRead "active_edge" v <*> parseWithRead "reset_kind" v <*> parseWithRead "init_behavior" v <*> parseWithRead "reset_polarity" v parseWithRead field obj = do v <- obj .:? field case readMaybe =<< v of Just a -> pure a Nothing -> fail $ "Could not read field: " <> show field data UnexpectedModification -- | Clash generated file was modified = Modified FilePath -- | Non-clash generated file was added | Added FilePath -- | Clash generated file was removed | Removed FilePath deriving (Show) mkManifestPort :: Backend backend => -- | Backend used to lookup port type names backend -> -- | Port name Id.Identifier -> -- | Port type HWType -> PortDirection -> ManifestPort mkManifestPort backend portId portType portDir = ManifestPort{..} where mpName = Id.toText portId mpWidth = typeSize portType mpDirection = portDir mpIsClock = case portType of {Clock _ -> True; ClockN _ -> True; _ -> False} mpDomain = hwTypeDomain portType mpTypeName = flip evalState backend $ getAp $ do LText.toStrict . renderOneLine <$> hdlType (External mpName) portType -- | Filename manifest file should be written to and read from manifestFilename :: IsString a => a manifestFilename = "clash-manifest.json" mkManifest :: Backend backend => -- | Backend used to lookup port type names backend -> -- | Domains encountered in design HashMap Text VDomainConfiguration -> -- | Options Clash was run with ClashOpts -> -- | Component of top entity Component -> -- | All other entities [Component] -> -- | Names of dependencies (transitive closure) [Id] -> -- | Files and their hashes [(FilePath, ByteString)] -> -- | Hash returned by 'readFreshManifest' ByteString -> -- | New manifest Manifest mkManifest backend domains ClashOpts{..} Component{..} components deps files topHash = Manifest { manifestHash = topHash , ports = inPorts <> inOutPorts <> outPorts , componentNames = map Id.toText compNames , topComponent = Id.toText componentName , fileNames = files , successFlags = (opt_inlineLimit, opt_specLimit) , domains = domains , transitiveDependencies = map (nameOcc . varName) deps } where compNames = map Netlist.componentName components inPorts = [mkManifestPort backend pName pType In | p@(pName, pType) <- inputs, not (Netlist.isBiDirectional p)] inOutPorts = [mkManifestPort backend pName pType InOut | p@(pName, pType) <- inputs, Netlist.isBiDirectional p] outPorts = [mkManifestPort backend pName pType Out | (_, (pName, pType), _) <- outputs] -- | Pretty print an unexpected modification as a list item. pprintUnexpectedModification :: UnexpectedModification -> String pprintUnexpectedModification = \case Modified p -> "Unexpected modification in " <> p Added p -> "Unexpected extra file " <> p Removed p -> "Unexpected removed file " <> p -- | Pretty print a list of unexpected modifications. Print a maximum of /n/ -- modifications. pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String pprintUnexpectedModifications 0 us = pprintUnexpectedModifications maxBound us pprintUnexpectedModifications _ [] = [] pprintUnexpectedModifications _ [u] = "* " <> pprintUnexpectedModification u pprintUnexpectedModifications 1 (u:us) = "* and " <> show (length (u:us)) <> " more unexpected changes" pprintUnexpectedModifications n (u:us) = "* " <> pprintUnexpectedModification u <> "\n" <> pprintUnexpectedModifications (n-1) us -- | Reads a manifest file. Does not return manifest file if: -- -- * Caching is disabled through @-fclash-no-cache@. -- * Manifest could not be found. -- * Cache is stale. This could be triggered by any of the given arguments. -- -- Raises an exception if the manifest file or any of the files it is referring -- to was inaccessible. -- readFreshManifest :: -- | "This" top entity plus all that depend on it. [TopEntityT] -> -- | Core expressions and entry point. Any changes in the call graph will -- trigger a recompile. (BindingMap, Id) -> -- | Any changes in any primitive will trigger a recompile. CompiledPrimMap -> -- | Certain options will trigger recompiles if changed ClashOpts -> -- | Clash modification date UTCTime -> -- | Path to manifest file. FilePath -> -- | ( Nothing if no manifest file was found -- , Nothing on stale cache, disabled cache, or not manifest file found ) IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString) readFreshManifest tops (bindingsMap, topId) primMap opts@(ClashOpts{..}) clashModDate path = do modificationsM <- traverse (isUserModified path) =<< readManifest path manifestM <- readManifest path pure ( modificationsM , checkManifest =<< if opt_cachehdl then manifestM else Nothing , topHash ) where optsHash = hash opts { -- Ignore the following settings, they don't affect the generated HDL: -- 1. Debug opt_debug = opt_debug { dbg_invariants = False , dbg_transformations = Set.empty , dbg_historyFile = Nothing } -- 2. Caching , opt_cachehdl = True -- 3. Warnings , opt_primWarn = True , opt_color = Auto , opt_errorExtra = False , opt_checkIDir = True -- 4. Optional output , opt_edalize = False -- Ignore the following settings, they don't affect the generated HDL. However, -- they do influence whether HDL can be generated at all. -- -- We therefore check whether the new flags changed in such a way that -- they could affect successful compilation, and use that information -- to decide whether to use caching or not (see: XXXX). -- -- 5. termination measures , opt_inlineLimit = 20 , opt_specLimit = 20 -- Finally, also ignore the HDL dir setting, because when a user moves the -- entire dir with generated HDL, they probably still want to use that as -- a cache , opt_hdlDir = Nothing } -- TODO: Binary encoding does not account for alpha equivalence (nor should -- it?), so the cache behaves more pessimisticly than it could. topHash = Sha256.hashlazy $ Binary.encode ( tops , hashCompiledPrimMap primMap , show clashModDate , callGraphBindings bindingsMap topId , optsHash ) checkManifest manifest@Manifest{manifestHash,successFlags} | (cachedInline, cachedSpec) <- successFlags -- Higher limits shouldn't affect HDL , cachedInline <= opt_inlineLimit , cachedSpec <= opt_specLimit -- Callgraph hashes should correspond , manifestHash == topHash = Just manifest -- One or more checks failed | otherwise = Nothing -- | Determines whether the HDL directory the given 'LocatedManifest' was found -- in contains any user made modifications. This is used by Clash to protect the -- user against lost work. isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification] isUserModified (takeDirectory -> topDir) (FilesManifest fileNames) = do let manifestFiles = Set.fromList (map fst fileNames) currentFiles <- (Set.delete manifestFilename . Set.fromList) <$> listDirectory topDir let removedFiles = Set.toList (manifestFiles `Set.difference` currentFiles) addedFiles = Set.toList (currentFiles `Set.difference` manifestFiles) changedFiles <- catMaybes <$> mapM detectModification fileNames pure ( map Removed removedFiles <> map Added addedFiles <> map Modified changedFiles ) where detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath) detectModification (filename, manifestDigest) = do let fullPath = topDir filename fileExists <- doesFileExist fullPath if fileExists then do contents <- ByteStringLazy.readFile fullPath if manifestDigest == Sha256.hashlazy contents then pure Nothing else pure (Just filename) else -- Will be caught by @removedFiles@ pure Nothing -- | Read a manifest file from disk. Returns 'Nothing' if file does not exist. -- Any other IO exception is re-raised. readManifest :: FromJSON a => FilePath -> IO (Maybe a) readManifest path = do contentsE <- tryJust (guard . isDoesNotExistError) (Aeson.decodeFileStrict path) pure (either (const Nothing) id contentsE) -- | Write manifest file to disk writeManifest :: FilePath -> Manifest -> IO () writeManifest path = ByteStringLazy.writeFile path . Aeson.encodePretty -- | Serialize a manifest. -- -- TODO: This should really yield a 'ByteString'. serializeManifest :: Manifest -> Text serializeManifest = LText.toStrict . LText.decodeUtf8 . Aeson.encodePretty