clash-lib-1.10.2: src/Clash/Driver.hs
{-|
Copyright : (C) 2012-2016, University of Twente,
2016-2017, Myrtle Software Ltd,
2017 , QBayLogic, Google Inc.
2020-2024, QBayLogic,
2022 , Google Inc.
2026 , Martijn Bastiaan
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Module that connects all the parts of the Clash compiler library
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.Driver where
import Control.Concurrent (MVar, modifyMVar, modifyMVar_, newMVar, withMVar)
import Control.Concurrent.Async (mapConcurrently_)
import Control.DeepSeq
import Control.Exception (evaluate, throw, Exception)
import qualified Control.Monad as Monad
import Control.Monad (unless, foldM, forM)
import Control.Monad.Catch (MonadThrow (throwM), try)
import Control.Monad.Extra (whenM, ifM, unlessM)
import Control.Monad.State (evalState, get)
import Control.Monad.State.Strict (State)
import qualified Control.Monad.State.Strict as State
import qualified Crypto.Hash.SHA256 as Sha256
import Data.Bifunctor (first, second)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteStringLazy
import qualified Data.ByteString.Lazy.Char8 as ByteStringLazyChar8
import Data.Char (isAscii, isAlphaNum)
import Data.Default
import Data.Hashable (Hashable, hash)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import Data.Proxy (Proxy(..))
import Data.List (intercalate)
import qualified Data.List as List
import qualified Data.List.Extra as List
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe, maybeToList, mapMaybe)
import qualified Data.Map.Ordered as OMap
import Data.Map.Ordered.Extra ()
import Data.Monoid (Ap(..))
import qualified Data.Text
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import Data.Text.Lazy.Encoding as Text
import qualified Data.Text.Lazy.IO as Text
import Data.Text.Prettyprint.Doc.Extra
(Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy)
import qualified Data.Time.Clock as Clock
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Extension as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import qualified System.Directory as Directory
import System.Directory
(doesPathExist, listDirectory, doesDirectoryExist, createDirectoryIfMissing,
removeDirectoryRecursive, doesFileExist)
import System.Environment (getExecutablePath)
import System.FilePath ((</>), (<.>), takeDirectory, takeFileName, isAbsolute)
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import System.IO.Temp
(getCanonicalTemporaryDirectory, withTempDirectory)
import Text.Trifecta.Result
(Result(Success, Failure), _errDoc)
import GHC.Builtin.Names (eqTyConKey, ipClassKey)
import GHC.Types.SrcLoc (SrcSpan)
import GHC.BasicTypes.Extra ()
import Clash.Annotations.Primitive
(HDL (..), extractPrim)
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs)
import Clash.Annotations.TopEntity
(TopEntity (..), PortName(PortName, PortProduct))
import Clash.Annotations.TopEntity.Extra ()
import Clash.Backend
import Clash.Core.PartialEval as PE (Evaluator)
import Clash.Core.Evaluator.Types as WHNF (Evaluator)
import Clash.Core.HasType
import Clash.Core.Name (Name (..))
import Clash.Core.Pretty (PrettyOptions(..), showPpr')
import Clash.Core.Type
(Type(ForAllTy, LitTy, AnnType), TypeView(..), tyView, mkFunTy, LitTy(SymTy))
import Clash.Core.TyCon (TyConMap)
import Clash.Core.Util (shouldSplit)
import Clash.Core.Var
(Id, varName, varUniq, varType)
import Clash.Core.VarEnv
(elemVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv, lookupVarEnvDirectly, eltsVarEnv, VarEnv)
import Clash.Debug (debugIsOn)
import qualified Clash.Driver.BrokenGhcs as BrokenGhcs
import Clash.Driver.Types
import Clash.Driver.Manifest
(Manifest(..), readFreshManifest, UnexpectedModification, pprintUnexpectedModifications,
mkManifest, writeManifest, manifestFilename)
import Clash.Edalize.Edam
import Clash.Netlist (genNetlist, genTopNames)
import Clash.Netlist.BlackBox.Parser (runParse)
import Clash.Netlist.BlackBox.Types (BlackBoxTemplate, BlackBoxFunction)
import qualified Clash.Netlist.Id as Id
import Clash.Netlist.Types
(IdentifierText, BlackBox (..), Component (..), FilteredHWType, HWMap, SomeBackend (..),
TopEntityT(..), TemplateFunction, ComponentMap, findClocks, ComponentMeta(..))
import Clash.Netlist.Util (checkTopEntityPorts)
import Clash.Normalize (checkNonRecursive, cleanupGraph,
normalize, runNormalization)
import Clash.Normalize.Util (callGraph, tvSubstWithTyEq)
import qualified Clash.Primitives.Sized.Signed as P
import qualified Clash.Primitives.Sized.ToInteger as P
import qualified Clash.Primitives.Sized.Vector as P
import qualified Clash.Primitives.GHC.Int as P
import qualified Clash.Primitives.GHC.Word as P
import qualified Clash.Primitives.Intel.ClockGen as P
import qualified Clash.Primitives.Magic as P
import qualified Clash.Primitives.Verification as P
import qualified Clash.Primitives.Xilinx.ClockGen as P
import Clash.Primitives.Types
import Clash.Signal.Internal
import Clash.Unique (Unique, getUnique, fromGhcUnique)
import Clash.Util
(ClashException(..), reportTimeDiff,
wantedLanguageExtensions, unwantedLanguageExtensions, curLoc)
import Clash.Util.Graph (reverseTopSort)
import qualified Clash.Util.Interpolate as I
import qualified Clash.Util.Supply as Supply
-- | Worker function of 'splitTopEntityT'
splitTopAnn
:: TyConMap
-> SrcSpan
-- ^ Source location of top entity (for error reporting)
-> Type
-- ^ Top entity body
-> TopEntity
-- ^ Port annotations for top entity
-> TopEntity
-- ^ New top entity with split ports (or the old one if not applicable)
splitTopAnn tcm sp typ@(tyView -> FunTy {}) t@Synthesize{t_inputs} =
t{t_inputs=go typ t_inputs}
where
go :: Type -> [PortName] -> [PortName]
go _ [] = []
go (tyView -> FunTy a res) (p:ps)
| shouldNotHavePortName a
-- Insert dummy PortName for args for which the user shouldn't have
-- to provide a name.
-- Ideally this would be any (non Hidden{Clock,Reset,Enable}) constraint.
-- But because we can't properly detect constraints,
-- we only skip some specific one. see "shouldNotHavePortName"
= PortName "" : go res (p:ps)
| otherwise =
case shouldSplit tcm a of
Just (_,_,argTys@(_:_:_)) ->
-- Port must be split up into 'n' pieces.. can it?
case p of
PortProduct nm portNames0 ->
let
n = length argTys
newPortNames = map (PortName . show) [(0::Int)..]
portNames1 = map (prependName nm) (portNames0 ++ newPortNames)
newLam = foldr1 mkFunTy (argTys ++ [res])
in
go newLam (take n portNames1 ++ ps)
PortName nm ->
throw (flip (ClashException sp) Nothing $ [I.i|
Couldn't separate clock, reset, or enable from a product type due
to a malformed Synthesize annotation. All clocks, resets, and
enables should be given a unique port name. Type to be split:
#{showPpr' (PrettyOptions False True False False) a}
Given port annotation: #{p}. You might want to use the
following instead: PortProduct #{show nm} []. This allows Clash to
autogenerate names based on the name #{show nm}.
|])
_ ->
-- No need to split the port, carrying on..
p : go res ps
go (ForAllTy _tyVar ty) ps = go ty ps
go _ty ps = ps
prependName :: String -> PortName -> PortName
prependName "" pn = pn
prependName p (PortProduct nm ps) = PortProduct (p ++ "_" ++ nm) ps
prependName p (PortName nm) = PortName (p ++ "_" ++ nm)
-- Returns True for
-- * type equality constraints (~)
-- * HasCallStack
shouldNotHavePortName :: Type -> Bool
shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs)
| tcUniq == fromGhcUnique eqTyConKey = True
| tcUniq == fromGhcUnique ipClassKey
, [LitTy (SymTy "callStack"), _] <- tcArgs = True
shouldNotHavePortName _ = False
splitTopAnn tcm sp (ForAllTy _tyVar typ) t = splitTopAnn tcm sp typ t
splitTopAnn tcm sp (AnnType _anns typ) t = splitTopAnn tcm sp typ t
splitTopAnn _tcm _sp _typ t = t
-- When splitting up a single argument into multiple arguments (see docs of
-- 'separateArguments') we should make sure to update TopEntity annotations
-- accordingly. See: https://github.com/clash-lang/clash-compiler/issues/1033
splitTopEntityT
:: HasCallStack
=> TyConMap
-> BindingMap
-> TopEntityT
-> TopEntityT
splitTopEntityT tcm bindingsMap tt@(TopEntityT id_ (Just t@(Synthesize {})) _) =
case lookupVarEnv id_ bindingsMap of
Just (Binding _id sp _ _ _ _) ->
tt{topAnnotation=Just (splitTopAnn tcm sp (coreTypeOf id_) t)}
Nothing ->
error "Internal error in 'splitTopEntityT'. Please report as a bug."
splitTopEntityT _ _ t = t
-- | Remove constraints such as 'a ~ 3'.
removeForAll :: TopEntityT -> TopEntityT
removeForAll (TopEntityT var annM isTb) =
TopEntityT var{varType=tvSubstWithTyEq (coreTypeOf var)} annM isTb
-- | Given a list of all found top entities and _maybe_ a top entity (+dependencies)
-- passed in by '-main-is', return the list of top entities Clash needs to
-- compile.
selectTopEntities :: [TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT]
selectTopEntities topEntities mainTopEntity =
maybe topEntities (uncurry (:)) mainTopEntity
-- | Get modification data of current clash binary.
getClashModificationDate :: IO Clock.UTCTime
getClashModificationDate = Directory.getModificationTime =<< getExecutablePath
hdlFromBackend :: forall backend. Backend backend => Proxy backend -> HDL
hdlFromBackend _ = hdlKind (undefined :: backend)
replaceChar :: Char -> Char -> String -> String
replaceChar a b = map go
where
go c
| c == a = b
| otherwise = c
removeHistoryFile :: Maybe FilePath -> IO ()
removeHistoryFile =
maybe (pure ()) removeHistory
where
removeHistory path =
whenM (Directory.doesFileExist path) (Directory.removeFile path)
prefixModuleName
:: HDL
-> Maybe Data.Text.Text
-> Maybe TopEntity
-> String
-> (String, Maybe String)
prefixModuleName hdl compPrefix annM modName =
case compPrefix of
Just (Data.Text.unpack -> p)
| not (null p) -> case annM of
Just ann ->
let nm = p <> "_" <> t_name ann
in (nm, Just nm)
Nothing ->
(p <> "_" <> modName, Just p)
| Just ann <- annM -> case hdl of
VHDL -> (t_name ann, Just modName)
_ -> (t_name ann, Nothing)
_ -> case annM of
Just ann -> case hdl of
VHDL -> (t_name ann, Just modName)
_ -> (t_name ann, Just modName)
_ -> (modName, Nothing)
-- | Create a set of target HDL files for a set of functions
generateHDL
:: forall backend . Backend backend
=> ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-- ^ Hardcoded 'Type' -> 'HWType' translator
-> PE.Evaluator
-- ^ Hardcoded evaluator for partial evaluation
-> WHNF.Evaluator
-- ^ Hardcoded evaluator for WHNF (old evaluator)
-> Maybe (TopEntityT, [TopEntityT])
-- ^ Main top entity to compile. If Nothing, all top entities in the
-- 'ClashDesign' argument will be compiled.
-> Clock.UTCTime
-> IO ()
generateHDL env design hdlState typeTrans peEval eval mainTopEntity startTime = do
let bindingsMap = designBindings design
let tcm = envTyConMap env
let topEntities0 = designEntities design
let opts = envOpts env
-- Detect "broken" GHCs and throw an error (unless silenced)
unless (opt_ignoreBrokenGhcs opts) BrokenGhcs.assertWorking
removeHistoryFile (dbg_historyFile (opt_debug opts))
unless (opt_cachehdl opts) $
putStrLn "Clash: Ignoring previously made caches"
let topEntities1 = fmap (removeForAll . splitTopEntityT tcm bindingsMap)
(selectTopEntities topEntities0 mainTopEntity)
hdl = hdlFromBackend (Proxy @backend)
(compNames, initIs) = genTopNames opts hdl topEntities1
(tes, deps) = sortTop bindingsMap topEntities1
-- TODO This is here because of some minimal effort refactoring. At some
-- point generateHDL should be better laid out so this can be closer to
-- the few places it is needed.
let topEntityMap = mkVarEnv (fmap (\x -> (topId x, x)) topEntities1)
-- Data which is updated and used when updating the different top entities
-- is kept in an MVar.
idSet <- newMVar initIs
edamFiles <- newMVar HashMap.empty
ioLock <- newMVar ()
let
maybeMapConcurrently_
| opt_concurrentTopEntities opts = mapConcurrently_
| otherwise = mapM_
maybeMapConcurrently_ (go compNames idSet edamFiles ioLock deps topEntityMap) tes
time <- Clock.getCurrentTime
let diff = reportTimeDiff time startTime
putStrLn $ "Clash: Total compilation took " ++ diff
where
go
:: VarEnv Id.Identifier
-> MVar Id.IdentifierSet
-> MVar (HashMap Unique [EdamFile])
-> MVar ()
-> HashMap Unique [Unique]
-> VarEnv TopEntityT
-> TopEntityT
-> IO ()
go compNames seenV edamFilesV ioLockV deps topEntityMap (TopEntityT topEntity annM isTb) = do
let domainConfs = envDomains env
let bindingsMap = designBindings design
let primMap = envPrimitives env
let topEntities0 = designEntities design
let opts = envOpts env
prevTime <- Clock.getCurrentTime
let topEntityS = Data.Text.unpack (nameOcc (varName topEntity))
withMVar ioLockV . const $
putStrLn ("Clash: Compiling " ++ topEntityS)
let modName1 = filter (\c -> isAscii c && (isAlphaNum c || c == '_')) (replaceChar '.' '_' topEntityS)
modifyMVar_ seenV $ \seen ->
pure $! State.execState (Id.addRaw (Data.Text.pack modName1)) seen
let topNm = lookupVarEnv' compNames topEntity
(modNameS, fmap Data.Text.pack -> prefixM) = prefixModuleName (hdlKind (undefined :: backend)) (opt_componentPrefix opts) annM modName1
modNameT = Data.Text.pack modNameS
hdlState' = setDomainConfigurations domainConfs
$ setModName modNameT
$ setTopName topNm
$ fromMaybe (initBackend @backend opts) hdlState
hdlDir = fromMaybe (Clash.Backend.name hdlState') (opt_hdlDir opts) </> topEntityS
manPath = hdlDir </> manifestFilename
ite = ifThenElseExpr hdlState'
topNmT = Id.toText topNm
-- Get manifest file if cache is not stale and caching is enabled. This is used
-- to prevent unnecessary recompilation.
clashModDate <- getClashModificationDate
(userModifications, maybeManifest, topHashWithSubHashes) <-
readFreshManifest topEntities0 (bindingsMap, topEntity) primMap opts clashModDate manPath
let topEntityNames = map topId (eltsVarEnv topEntityMap)
case maybeManifest of
Just manifest0@Manifest{fileNames} | Just [] <- userModifications -> do
-- Found a 'manifest' files. Use it to extend "seen" set. Generate EDAM
-- files if necessary.
withMVar ioLockV . const $
putStrLn ("Clash: Using cached result for: " ++ topEntityS)
modifyMVar_ seenV $ \seen ->
pure $! State.execState (mapM_ Id.addRaw (componentNames manifest0)) seen
fileNames1 <- modifyMVar edamFilesV $ \edamFiles ->
if opt_edalize opts
then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles fileNames
else pure (edamFiles, fileNames)
writeManifest manPath manifest0{fileNames=fileNames1}
topTime <- Clock.getCurrentTime
let topDiff = reportTimeDiff topTime prevTime
withMVar ioLockV . const $
putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff)
return ()
_ -> do
-- 1. Prepare HDL directory
--
-- [Note] Create HDL dir before netlist generation
--
-- Already create the directory where the HDL ends up being generated, as
-- we use directories relative to this final directory to find manifest
-- files belonging to other top entities. Failing to do so leads to #463
prepareDir hdlDir opts userModifications
-- 2. Validate the top entity's 'Synthesize' port annotation. This is done
-- before normalization so that "trivial" port errors are reported quickly,
-- instead of only after a (potentially long) normalization (#3305).
--
-- 'annM' is already split (by 'splitTopEntityT') and 'topEntity' has been
-- through 'removeForAll', so the types and ports line up; see
-- 'checkTopEntityPorts' for how the check is kept equivalent to the one in
-- 'mkUniqueNormalized'.
--
-- XXX: Because the types are split to match, reported errors may refer to
-- ports the user didn't directly write.
evaluate
(checkTopEntityPorts typeTrans (envCustomReprs env) (envTyConMap env)
topEntity annM)
-- 3. Normalize topEntity
supplyN <- Supply.newSupply
transformedBindings <- normalizeEntity env bindingsMap typeTrans peEval
eval topEntityNames supplyN topEntity
normTime <- transformedBindings `deepseq` Clock.getCurrentTime
let prepNormDiff = reportTimeDiff normTime prevTime
withMVar ioLockV . const $
putStrLn ("Clash: Normalization took " ++ prepNormDiff)
-- 4. Generate netlist for topEntity
(topComponent, netlist) <- modifyMVar seenV $ \seen -> do
(topComponent, netlist, seen') <-
-- TODO My word, this has far too many arguments.
genNetlist env peEval isTb transformedBindings topEntityMap compNames
typeTrans ite (SomeBackend hdlState') seen hdlDir prefixM topEntity
pure (seen', (topComponent, netlist))
netlistTime <- netlist `deepseq` Clock.getCurrentTime
let normNetDiff = reportTimeDiff netlistTime normTime
withMVar ioLockV . const $
putStrLn ("Clash: Netlist generation took " ++ normNetDiff)
-- 5. Generate topEntity wrapper
(hdlDocs, dfiles, mfiles) <- withMVar seenV $ \seen ->
pure $! createHDL hdlState' opts modNameT seen netlist domainConfs topComponent topNmT
-- TODO: Data files should go into their own directory
-- FIXME: Files can silently overwrite each other
hdlDocDigests <- mapM (writeHDL hdlDir) hdlDocs
dataFilesDigests <- copyDataFiles hdlDir dfiles
memoryFilesDigests <- writeMemoryDataFiles hdlDir mfiles
let
components = map (snd . snd) (OMap.assocs netlist)
filesAndDigests0 =
-- FIXME: We should track dependencies of `mfiles` and `dfiles` and
-- maintain the proper topological sort of all these.
zip (map fst mfiles) memoryFilesDigests
<> zip (map fst dfiles) dataFilesDigests
<> zip (map fst hdlDocs) hdlDocDigests
filesAndDigests1 <- modifyMVar edamFilesV $ \edamFiles ->
if opt_edalize opts
then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles filesAndDigests0
else pure (edamFiles, filesAndDigests0)
let
depUniques = fromMaybe [] (HashMap.lookup (getUnique topEntity) deps)
depBindings = mapMaybe (flip lookupVarEnvDirectly bindingsMap) depUniques
depIds = map bindingId depBindings
manifest =
mkManifest
hdlState' domainConfs opts topComponent components depIds
filesAndDigests1 topHashWithSubHashes
writeManifest manPath manifest
topTime <- hdlDocs `seq` Clock.getCurrentTime
let topDiff = reportTimeDiff topTime prevTime
withMVar ioLockV . const $
putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff)
-- | Whether a function should be interpreted as a 'BlackBoxFunction' or a
-- 'TemplateFunction'.
data InterpretFunctionType
= InterpretBlackBoxFunction
| InterpretTemplateFunction
deriving (Eq, Ord, Show, Generic, Hashable)
-- | A single function that needs to be interpreted with Hint in order to
-- compile a primitive. Multiple primitives referencing the same function map
-- to the same request, so interpreting the distinct requests of a primitive
-- map compiles each function exactly once.
data InterpretFunctionRequest = InterpretFunctionRequest
{ ifrModNames :: [String]
-- ^ Module the function lives in, one entry per module name component
, ifrFuncName :: String
-- ^ Function name
, ifrType :: InterpretFunctionType
-- ^ Type to interpret the function at
, ifrSource :: Maybe Text
-- ^ Inline Haskell source of the module, if the primitive provided one
} deriving (Eq, Ord, Show, Generic, Hashable)
-- | Module the function of an 'InterpretFunctionRequest' lives in, as a
-- qualified module name
interpretFunctionRequestToModuleName :: InterpretFunctionRequest -> Hint.ModuleName
interpretFunctionRequestToModuleName = intercalate "." . ifrModNames
-- | The result of interpreting an 'InterpretFunctionRequest'
data InterpretFunctionResult
= InterpretBBF BlackBoxFunction
| InterpretTF TemplateFunction
type InterpretResults =
HashMap InterpretFunctionRequest
(Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult)
-- | Language extensions in effect when interpreting inline primitive sources
hintLanguageExtensions :: [Hint.Extension]
hintLanguageExtensions =
map Hint.asExtension $
map show wantedLanguageExtensions ++
map ("No" ++ ) (map show unwantedLanguageExtensions)
-- | The functions a primitive needs interpreted before it can be compiled by
-- 'compilePrimitiveWith'. Functions in 'knownBlackBoxFunctions' or
-- 'knownTemplateFunctions' need no interpretation and yield no request.
neededInterpRequests :: ResolvedPrimitive -> [InterpretFunctionRequest]
neededInterpRequests (BlackBoxHaskell _ _ _ _ bbGenName source)
| HashMap.member fullName knownBlackBoxFunctions = []
| otherwise =
[InterpretFunctionRequest modNames funcName InterpretBlackBoxFunction source]
where
fullName = intercalate "." modNames ++ "." ++ funcName
BlackBoxFunctionName modNames funcName = bbGenName
neededInterpRequests (BlackBox _ _ _ _ _ _ _ _ _ _ incs rM riM templ) =
concatMap go (templ : rM ++ riM ++ map snd incs)
where
go ((TTemplate, _), _) = []
go ((THaskell, BlackBoxFunctionName modNames funcName), source@(Just _)) =
[InterpretFunctionRequest modNames funcName InterpretTemplateFunction source]
go ((THaskell, BlackBoxFunctionName modNames funcName), Nothing)
| HashMap.member fullName knownTemplateFunctions = []
| otherwise =
[InterpretFunctionRequest modNames funcName InterpretTemplateFunction Nothing]
where
fullName = intercalate "." modNames ++ "." ++ funcName
neededInterpRequests (Primitive {}) = []
-- | Interpret the given functions in a single shared Hint session. Starting a
-- session is expensive (it initializes a full GHC session, including reading
-- all package databases), so sharing one session over all requests is much
-- faster than a session per function. For each request this action tries two
-- things:
--
-- 1. Interpret without explicitly loading the module. This will succeed if
-- the module can be found in the package databases (passed in as
-- @-package-db@ interpreter arguments).
--
-- 2. If (1) fails, try to load the module explicitly: either from the
-- inline source a primitive provided, or from the import directories.
-- If this also fails, an error is recorded for the request.
--
-- All (1) attempts run before the first (2) attempt, so that interpreting
-- against the package databases is never influenced by locally loaded
-- modules. Note that 'Hint.loadModules' resets previously loaded modules, so
-- (2) attempts cannot see each other's modules either.
interpretFunctions
:: [FilePath]
-- ^ Import directories (-i flag)
-> [FilePath]
-- ^ Package databases
-> FilePath
-- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
-- can be found
-> [InterpretFunctionRequest]
-- ^ Functions to interpret
-> IO InterpretResults
interpretFunctions _ _ _ [] = pure HashMap.empty
interpretFunctions idirs pkgDbs topDir reqs = do
sessionRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do
-- NB: capture the pristine search path once; 'Hint.get' returns the
-- current (possibly already extended) value in a shared session.
defaultPath <- Hint.get Hint.searchPath
Hint.set [Hint.searchPath Hint.:= (defaultPath ++ idirs)]
-- Phase 1: try to interpret all functions from the package databases
globalResults <- forM reqs $ \req -> do
Hint.liftIO $ Monad.when debugIsOn $
putStr "Hint: Interpreting " >> putStrLn (interpretFunctionRequestToModuleName req ++ "." ++ ifrFuncName req)
res <- tryInterp (interpretGlobal req)
pure (req, res)
-- Phase 2: functions that failed phase 1 are interpreted as local
-- modules, compiled from inline source or the import directories
Monad.unless (null [() | (_, Left _) <- globalResults]) $
Hint.set [Hint.languageExtensions Hint.:= hintLanguageExtensions]
forM globalResults $ \(req, globalRes) ->
case globalRes of
Right res -> pure (req, Right res)
Left globalException -> do
localRes <- tryInterp (interpretLocal defaultPath req)
case localRes of
Left localException ->
pure (req, Left (globalException :| [localException]))
Right res -> pure (req, Right res)
case sessionRes of
-- The session itself failed to initialize; attribute the error to every
-- request.
Left e -> pure (HashMap.fromList [(req, Left (e :| [])) | req <- reqs])
Right results -> pure (HashMap.fromList results)
where
interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs
tryInterp
:: Hint.InterpreterT IO InterpretFunctionResult
-> Hint.InterpreterT IO (Either Hint.InterpreterError InterpretFunctionResult)
tryInterp = try
interpret req = case ifrType req of
InterpretBlackBoxFunction ->
InterpretBBF <$> Hint.unsafeInterpret (ifrFuncName req) "BlackBoxFunction"
InterpretTemplateFunction ->
InterpretTF <$> Hint.unsafeInterpret (ifrFuncName req) "TemplateFunction"
interpretGlobal req = do
Hint.setImports
["Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", interpretFunctionRequestToModuleName req]
interpret req
interpretLocal defaultPath req = withSourceDir $ \extraDirs -> do
Hint.set [Hint.searchPath Hint.:= (extraDirs ++ idirs ++ defaultPath)]
Hint.loadModules [interpretFunctionRequestToModuleName req]
Hint.setImports
["Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", interpretFunctionRequestToModuleName req]
interpret req
where
-- Write the inline source (if any) of a request to a temporary
-- directory, and pass that directory as an extra search path
withSourceDir act = case ifrSource req of
Nothing -> act []
Just source -> do
tmpDir0 <- Hint.liftIO getCanonicalTemporaryDirectory
withTempDirectory tmpDir0 "clash-prim-compile" $ \tmpDir1 -> do
let modDir = foldl (</>) tmpDir1 (init (ifrModNames req))
Hint.liftIO $ do
Directory.createDirectoryIfMissing True modDir
Text.writeFile (modDir </> last (ifrModNames req) <.> "hs") source
act [tmpDir1]
-- | List of known BlackBoxFunctions used to prevent Hint from firing. This
-- improves Clash startup times.
knownBlackBoxFunctions :: HashMap String BlackBoxFunction
knownBlackBoxFunctions =
HashMap.fromList $ map (first show) $
[ ('P.checkBBF, P.checkBBF)
, ('P.bvToIntegerVHDL, P.bvToIntegerVHDL)
, ('P.bvToIntegerVerilog, P.bvToIntegerVerilog)
, ('P.clashCompileErrorBBF, P.clashCompileErrorBBF)
, ('P.foldBBF, P.foldBBF)
, ('P.indexIntVerilog, P.indexIntVerilog)
, ('P.indexToIntegerVerilog, P.indexToIntegerVerilog)
, ('P.indexToIntegerVHDL, P.indexToIntegerVHDL)
, ('P.intTF, P.intTF)
, ('P.iterateBBF, P.iterateBBF)
, ('P.signedToIntegerVerilog, P.signedToIntegerVerilog)
, ('P.signedToIntegerVHDL, P.signedToIntegerVHDL)
, ('P.unsignedToIntegerVerilog, P.unsignedToIntegerVerilog)
, ('P.unsignedToIntegerVHDL, P.unsignedToIntegerVHDL)
, ('P.wordTF, P.wordTF)
]
-- | List of known TemplateFunctions used to prevent Hint from firing. This
-- improves Clash startup times.
knownTemplateFunctions :: HashMap String TemplateFunction
knownTemplateFunctions =
HashMap.fromList $ map (first show) $
[ ('P.altpllQsysTF, P.altpllQsysTF)
, ('P.alteraPllQsysTF, P.alteraPllQsysTF)
, ('P.alteraPllTF, P.alteraPllTF)
, ('P.altpllTF, P.altpllTF)
, ('P.fromIntegerTFvhdl, P.fromIntegerTFvhdl)
, ('P.clockWizardTF, P.clockWizardTF)
, ('P.clockWizardDifferentialTF, P.clockWizardDifferentialTF)
, ('P.clockWizardTclTF, P.clockWizardTclTF)
, ('P.clockWizardDifferentialTclTF, P.clockWizardDifferentialTclTF)
]
-- | Compiles the blackbox functions of and parses the blackbox templates in
-- a primitive map. All blackbox functions are interpreted in a single shared
-- Hint session (see 'interpretFunctions'), and every distinct function is
-- interpreted exactly once, no matter how many primitives reference it.
compilePrimitives
:: [FilePath]
-- ^ Import directories (-i flag)
-> [FilePath]
-- ^ Package databases
-> FilePath
-- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
-- can be found
-> ResolvedPrimMap
-- ^ Primitives to compile
-> IO CompiledPrimMap
compilePrimitives idirs pkgDbs topDir primMapR = do
let reqs =
List.nubOrd $
concatMap
neededInterpRequests
(mapMaybe extractPrim (HashMap.elems primMapR))
results <- interpretFunctions idirs pkgDbs topDir reqs
traverse (traverse (compilePrimitiveWith (lookupInterpResult results))) primMapR
-- | Compiles a single primitive. Provided for backwards compatibility; when
-- compiling multiple primitives, 'compilePrimitives' only pays the cost of
-- starting a Hint session once.
compilePrimitive
:: [FilePath]
-- ^ Import directories (-i flag)
-> [FilePath]
-- ^ Package databases
-> FilePath
-- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
-- can be found
-> ResolvedPrimitive
-- ^ Primitive to compile
-> IO CompiledPrimitive
compilePrimitive idirs pkgDbs topDir prim = do
let reqs = HashSet.toList (HashSet.fromList (neededInterpRequests prim))
results <- interpretFunctions idirs pkgDbs topDir reqs
compilePrimitiveWith (lookupInterpResult results) prim
-- | Look up the interpreter result of a request. All requests are
-- interpreted before primitives are compiled, so a missing result is an
-- internal error: 'neededInterpRequests' diverged from the requests
-- 'compilePrimitiveWith' consumes.
lookupInterpResult
:: InterpretResults
-> InterpretFunctionRequest
-> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult)
lookupInterpResult results req =
case HashMap.lookup req results of
Just res -> pure res
Nothing -> error ($(curLoc) ++ "Internal error: no interpreter result for "
++ show req)
-- | Compiles the blackbox functions of and parses the blackbox templates in
-- a primitive, given an action that produces the interpreted functions the
-- primitive needs (see 'neededInterpRequests').
compilePrimitiveWith
:: (InterpretFunctionRequest -> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult))
-- ^ Look up the interpreter result for a request
-> ResolvedPrimitive
-- ^ Primitive to compile
-> IO CompiledPrimitive
compilePrimitiveWith lookupInterp (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName source) = do
bbFunc <-
case HashMap.lookup fullName knownBlackBoxFunctions of
Just f -> pure f
Nothing -> do
r <- lookupInterp (InterpretFunctionRequest modNames funcName InterpretBlackBoxFunction source)
expectBBF =<< processHintErrors (show bbGenName) bbName r
pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc))
where
fullName = qualMod ++ "." ++ funcName
qualMod = intercalate "." modNames
BlackBoxFunctionName modNames funcName = bbGenName
expectBBF :: InterpretFunctionResult -> IO BlackBoxFunction
expectBBF (InterpretBBF f) = pure f
expectBBF _ = error ($(curLoc) ++ "Internal error: expected a BlackBoxFunction for "
++ fullName)
compilePrimitiveWith lookupInterp
(BlackBox pNm wf rVoid multiRes tkind () outputUsage libM imps fPlural incs rM riM templ) = do
libM' <- mapM parseTempl libM
imps' <- mapM parseTempl imps
incs' <- mapM (traverse parseBB) incs
templ' <- parseBB templ
rM' <- traverse parseBB rM
riM' <- traverse parseBB riM
return (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM' imps' fPlural incs' rM' riM' templ')
where
parseTempl
:: Applicative m
=> Text
-> m BlackBoxTemplate
parseTempl t = case runParse t of
Failure errInfo
-> error ("Parsing template for blackbox " ++ Data.Text.unpack pNm ++ " failed:\n"
++ show (_errDoc errInfo))
Success t'
-> pure t'
interpretTF :: InterpretFunctionRequest -> IO TemplateFunction
interpretTF req = do
r <- lookupInterp req
res <- processHintErrors (show (BlackBoxFunctionName (ifrModNames req) (ifrFuncName req))) pNm r
case res of
InterpretTF f -> pure f
_ -> error ($(curLoc) ++ "Internal error: expected a TemplateFunction for "
++ interpretFunctionRequestToModuleName req ++ "." ++ ifrFuncName req)
parseBB
:: ((TemplateFormat,BlackBoxFunctionName), Maybe Text)
-> IO BlackBox
parseBB ((TTemplate,_),Just t) = BBTemplate <$> parseTempl t
parseBB ((TTemplate,_),Nothing) =
error ("No template specified for blackbox: " ++ show pNm)
parseBB ((THaskell,bbGenName),source@(Just source')) = do
let BlackBoxFunctionName modNames funcName = bbGenName
qualMod = intercalate "." modNames
hsh = hash (qualMod, source')
BBFunction (Data.Text.unpack pNm) hsh <$>
interpretTF (InterpretFunctionRequest modNames funcName InterpretTemplateFunction source)
parseBB ((THaskell,bbGenName),Nothing) = do
let BlackBoxFunctionName modNames funcName = bbGenName
qualMod = intercalate "." modNames
hsh = hash qualMod
fullName = qualMod ++ "." ++ funcName
tf <-
case HashMap.lookup fullName knownTemplateFunctions of
Just f -> pure f
Nothing ->
interpretTF (InterpretFunctionRequest modNames funcName InterpretTemplateFunction Nothing)
pure (BBFunction (Data.Text.unpack pNm) hsh tf)
compilePrimitiveWith _ (Primitive pNm wf typ) =
return (Primitive pNm wf typ)
{-# SCC compilePrimitiveWith #-}
newtype HintError = HintError String deriving (Exception)
instance Show HintError where
showsPrec :: Int -> HintError -> ShowS
showsPrec _ (HintError e) = showString e
processHintErrors ::
(MonadThrow m, Monad m) =>
-- | Function to interpret
String ->
-- | BlackBox function name
Data.Text.Text ->
-- | Hint result
Either (NonEmpty Hint.InterpreterError) t ->
m t
processHintErrors fun bb r = case r of
Left es -> throwM $ HintError (formatExceptions (NonEmpty.toList es))
Right f -> pure f
where
formatExceptions es = [I.i|
Encountered one or more exceptions when compiling blackbox template function
'#{fun}' for function '#{bb}'.
|] <> "\n\n" <> intercalate "\n\n" (map formatException es)
formatException e = [I.i|
Encountered:
#{e}
|]
-- | Pretty print Components to HDL Documents
createHDL
:: Backend backend
=> backend
-- ^ Backend
-> ClashOpts
-- ^ Global Clash options
-> IdentifierText
-- ^ Module hierarchy root
-> Id.IdentifierSet
-- ^ Component names
-> ComponentMap
-- ^ List of components
-> HashMap Data.Text.Text VDomainConfiguration
-- ^ Known domains to configurations
-> Component
-- ^ Top component
-> IdentifierText
-- ^ Name of the manifest file
-> ([(String,Doc)],[(String,FilePath)],[(String,String)])
-- ^ The pretty-printed HDL documents
-- + The data files that need to be copied
createHDL backend opts modName seen components domainConfs top topName = flip evalState backend $ getAp $ do
let componentsL = map snd (OMap.assocs components)
(hdlNmDocs0,incs) <-
fmap unzip $
forM componentsL $ \(ComponentMeta{cmLoc, cmScope,cmUsage}, comp) ->
genHDL opts modName cmLoc (Id.union seen cmScope) cmUsage comp
hwtys <- HashSet.toList <$> extractTypes <$> Ap get
typesPkg0 <- mkTyPackage modName hwtys
dataFiles <- Ap getDataFiles
memFiles <- Ap getMemoryDataFiles
let
typesPkg1 = map (first (<.> Clash.Backend.extension backend)) typesPkg0
hdlNmDocs1 = map (first (<.> Clash.Backend.extension backend)) hdlNmDocs0
topFiles = concat incs ++ typesPkg1 ++ hdlNmDocs1
topClks = findClocks top
sdcInfo = fmap findDomainConfig <$> topClks
sdcFile = Data.Text.unpack topName <.> "sdc"
sdcDoc = (sdcFile, pprSDC (SdcInfo sdcInfo))
sdc = if null sdcInfo then Nothing else Just sdcDoc
return (maybeToList sdc <> topFiles, dataFiles, memFiles)
where
findDomainConfig dom =
HashMap.lookupDefault
(error $ $(curLoc) ++ "Unknown synthesis domain: " ++ show dom)
dom
domainConfs
writeEdam ::
FilePath ->
(Id.Identifier, Unique) ->
HashMap Unique [Unique] ->
HashMap Unique [EdamFile] ->
[(FilePath, ByteString)] ->
IO (HashMap Unique [EdamFile], [(FilePath, ByteString)])
writeEdam hdlDir (topNm, topEntity) deps edamFiles0 filesAndDigests = do
let
(edamFiles1, edamInfo) =
createEDAM (topNm, topEntity) deps edamFiles0 (map fst filesAndDigests)
edamDigest <- writeHDL hdlDir ("edam.py", pprEdam edamInfo)
pure (edamFiles1, ("edam.py", edamDigest) : filesAndDigests)
-- | Create an Edalize metadata file for using Edalize to build the project.
--
-- TODO: Handle libraries. Also see: https://github.com/olofk/edalize/issues/220
createEDAM ::
-- Top entity name and unique
(Id.Identifier, Unique) ->
-- | Top entity dependency map
HashMap Unique [Unique] ->
-- | Edam files of each top entity
HashMap Unique [EdamFile] ->
-- | Files to include in Edam file
[FilePath] ->
-- | (updated map, edam)
(HashMap Unique [EdamFile], Edam)
createEDAM (topName, topUnique) deps edamFileMap files =
(HashMap.insert topUnique (edamFiles edam) edamFileMap, edam)
where
edam = Edam
{ edamProjectName = Id.toText topName
, edamTopEntity = Id.toText topName
, edamFiles = fmap (asEdamFile topName) files <> fmap asIncFile incFiles
, edamToolOptions = def
}
incFiles =
concatMap
(\u -> HashMap.lookupDefault [] u edamFileMap)
(HashMap.lookupDefault [] topUnique deps)
asIncFile f =
f { efName = ".." </> Data.Text.unpack (efLogicalName f) </> efName f }
asEdamFile :: Id.Identifier -> FilePath -> EdamFile
asEdamFile topName path =
EdamFile path edamFileType (Id.toText topName)
where
edamFileType =
case FilePath.takeExtension path of
".vhdl" -> VhdlSource
".v" -> VerilogSource
".sv" -> SystemVerilogSource
".tcl" -> TclSource
".qsys" -> QSYS
".sdc" -> SDC
_ -> Clash.Edalize.Edam.Unknown
-- | Prepares directory for writing HDL files.
prepareDir ::
-- | HDL directory to prepare
FilePath ->
-- | Relevant options: @-fclash-no-clean@
ClashOpts ->
-- | Did directory contain unexpected modifications? See 'readFreshManifest'
Maybe [UnexpectedModification] ->
IO ()
prepareDir hdlDir ClashOpts{opt_clear} mods = do
ifM
(doesPathExist hdlDir)
(ifM
(doesDirectoryExist hdlDir)
(detectCaseIssues >> clearOrError >> createDir)
(error [I.i|Tried to write HDL files to #{hdlDir}, but it wasn't a directory.|]))
createDir
where
createDir = createDirectoryIfMissing True hdlDir
-- Windows considers 'foo' and 'FOO' the same directory. Error if users tries
-- to synthesize two top entities with conflicting (in this sense) names.
detectCaseIssues = do
allPaths <- listDirectory (takeDirectory hdlDir)
unless (takeFileName hdlDir `elem` allPaths) (error [I.i|
OS indicated #{hdlDir} existed, but Clash could not find it among the
list of existing directories in #{takeDirectory hdlDir}:
#{allPaths}
This probably means your OS or filesystem is case-insensitive. Rename your
top level binders in order to prevent this error message.
|])
clearOrError =
case mods of
Just [] ->
-- No unexpected changes, so no user work will get lost
removeDirectoryRecursive hdlDir
_ | opt_clear ->
-- Unexpected changes / non-empty directory, but @-fclash-clear@ was
-- set, so remove directory anyway.
removeDirectoryRecursive hdlDir
Just unexpected ->
-- Unexpected changes; i.e. modifications were made after last Clash run
error [I.i|
Changes were made to #{hdlDir} after last Clash run:
#{pprintUnexpectedModifications 5 unexpected}
Use '-fclash-clear' if you want Clash to clear out the directory.
Warning: this will remove the complete directory, be cautious of data
loss.
|]
Nothing ->
-- No manifest file was found. Refuse to write if directory isn't empty.
unlessM
(null <$> listDirectory hdlDir)
(error [I.i|
Tried to write HDL files to #{hdlDir}, but directory wasn't empty. This
message will be supressed if Clash can detect that no files have
changed since it was last run. If you're seeing this message even
though you haven't modified any files, Clash encountered a problem
reading "#{manifestFilename :: String}". This can happen when upgrading
Clash.
Use '-fclash-clear' if you want Clash to clear out the directory.
Warning: this will remove the complete directory, be cautious of data
loss.
|])
-- | Write a file to disk in chunks. Returns SHA256 sum of file contents.
writeAndHash :: FilePath -> ByteStringLazy.ByteString -> IO ByteString
writeAndHash path bs =
IO.withFile path IO.WriteMode $ \handle ->
fmap Sha256.finalize
$ foldM (writeChunk handle) Sha256.init
$ ByteStringLazy.toChunks bs
where
writeChunk :: IO.Handle -> Sha256.Ctx -> ByteString -> IO Sha256.Ctx
writeChunk h !ctx chunk = do
ByteString.hPut h chunk
pure (Sha256.update ctx chunk)
-- | Writes a HDL file to the given directory. Returns SHA256 hash of written
-- file.
writeHDL :: FilePath -> (FilePath, Doc) -> IO ByteString
writeHDL dir (cname, hdl) = do
let
layout = LayoutOptions (AvailablePerLine 120 0.4)
rendered0 = renderLazy (layoutPretty layout hdl)
rendered1 = Text.unlines (map Text.stripEnd (Text.lines rendered0))
writeAndHash (dir </> cname) (Text.encodeUtf8 (rendered1 <> "\n"))
-- | Copy given files
writeMemoryDataFiles
:: FilePath
-- ^ Directory to copy files to
-> [(FilePath, String)]
-- ^ (filename, content)
-> IO [ByteString]
writeMemoryDataFiles dir files =
forM files $ \(fname, content) ->
writeAndHash (dir </> fname) (ByteStringLazyChar8.pack content)
-- | Copy data files added with ~FILE, assumes the files are canonicalized already.
-- Throws an error on relative paths as sanity check.
copyDataFiles
:: FilePath
-- ^ Directory to copy to
-> [(FilePath,FilePath)]
-- ^ [(name of newly made file in HDL output dir, file to copy)]
-> IO [ByteString]
-- ^ SHA256 hashes of written files
copyDataFiles targetDir = mapM copyDataFile
where
copyDataFile :: (FilePath, FilePath) -> IO ByteString
copyDataFile (newName, toCopy)
| isAbsolute toCopy = do
ifM
(doesFileExist toCopy)
(copyAndHash toCopy (targetDir </> newName))
(error [I.i|Could not find data file #{show toCopy}. Does it exist?|])
| otherwise = error [I.i|copyDataFiles received a relative path #{show toCopy}. This is a bug in Clash, please report it.|]
copyAndHash src dst = do
ifM
(doesPathExist dst)
(error [I.i|
Tried to copy data file #{src} to #{dst} but a file or directory with
that name already existed. This is a bug in Clash, please report it.
|])
(ByteStringLazy.readFile src >>= writeAndHash dst)
-- | Normalize a complete hierarchy
normalizeEntity
:: ClashEnv
-> BindingMap
-- ^ All bindings
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-- ^ Hardcoded 'Type' -> 'HWType' translator
-> PE.Evaluator
-- ^ Hardcoded evaluator for partial evaluation
-> WHNF.Evaluator
-- ^ Hardcoded evaluator for WHNF (old evaluator)
-> [Id]
-- ^ TopEntities
-> Supply.Supply
-- ^ Unique supply
-> Id
-- ^ root of the hierarchy
-> IO BindingMap
normalizeEntity env bindingsMap typeTrans peEval eval topEntities supply tm = transformedBindings
where
doNorm = do norm <- normalize [tm]
let normChecked = checkNonRecursive norm
cleaned <- cleanupGraph tm normChecked
return cleaned
transformedBindings = runNormalization env supply bindingsMap
typeTrans peEval eval emptyVarEnv
topEntities doNorm
-- | Reverse topologically sort given top entities. Also returns a mapping that
-- maps a top entity to its reverse topologically sorted transitive dependencies.
sortTop ::
BindingMap ->
[TopEntityT] ->
( [TopEntityT]
, HashMap Unique [Unique]
)
sortTop bindingsMap topEntities =
case reverseTopSort nodes edges of
Left msg -> error msg
Right tops -> (tops, mapFrom tops)
where
nodes = [(varUniq topE, t) | t@(TopEntityT topE _ _) <- topEntities]
edges = concatMap getEdges topEntities
getEdges (TopEntityT topE _ _) =
map
(\top -> (varUniq topE, topToUnique top))
(getTransitiveRefs topE)
getTransitiveRefs top =
let allDeps = callGraph bindingsMap top
in filter (\t -> topId t /= top && topId t `elemVarEnv` allDeps) topEntities
topToUnique = varUniq . topId
mapFrom tops =
let
topIndices = HashMap.fromList (zip (map topToUnique tops) [(0 :: Unique)..])
nonOrdered = HashMap.fromListWith (<>) (map (second pure) edges)
orderFunc k = HashMap.lookup k topIndices
in
HashMap.map (List.sortOn orderFunc) nonOrdered