{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017     , QBayLogic, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Module that connects all the parts of the Clash compiler library
-}

{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TupleSections            #-}

module Clash.Driver where

import qualified Control.Concurrent.Supply        as Supply
import           Control.DeepSeq
import           Control.Exception                (tryJust, bracket)
import           Control.Lens                     (view, (^.), _4)
import           Control.Monad                    (guard, when, unless, foldM)
import           Control.Monad.Catch              (MonadMask)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.State              (evalState, get)
import           Control.Monad.State.Strict       (State)
import           Data.Hashable                    (hash)
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMap
import qualified Data.HashSet                     as HashSet
import           Data.IntMap                      (IntMap)
import           Data.List                        (intercalate)
import           Data.Maybe                       (fromMaybe)
import           Data.Semigroup.Monad
import qualified Data.Text
import           Data.Text.Lazy                   (Text)
import qualified Data.Text.Lazy                   as Text
import qualified Data.Text.Lazy.IO                as Text
import           Data.Text.Prettyprint.Doc        (pretty)
import           Data.Text.Prettyprint.Doc.Extra
  (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy,
   renderOneLine)
import qualified Data.Time.Clock                  as Clock
import qualified Language.Haskell.Interpreter     as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import qualified System.Directory                 as Directory
import           System.Environment               (getExecutablePath)
import           System.FilePath                  ((</>), (<.>))
import qualified System.FilePath                  as FilePath
import qualified System.IO                        as IO
import           System.IO.Error                  (isDoesNotExistError)
import           System.IO.Temp
  (getCanonicalTemporaryDirectory, withTempDirectory)
import           Text.Trifecta.Result
  (Result(Success, Failure), _errDoc)
import           Text.Read                        (readMaybe)
import           SrcLoc                           (SrcSpan)
import           GHC.BasicTypes.Extra             ()

import           Clash.Annotations.Primitive
  (HDL (..))
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs)
import           Clash.Annotations.TopEntity      (TopEntity (..))
import           Clash.Annotations.TopEntity.Extra ()
import           Clash.Backend
import           Clash.Core.Evaluator             (PrimEvaluator)
import           Clash.Core.Name                  (Name (..))
import           Clash.Core.Term                  (Term)
import           Clash.Core.Type                  (Type)
import           Clash.Core.TyCon                 (TyConMap, TyConName)
import           Clash.Core.Var                   (Id, varName)
import           Clash.Core.VarEnv                (emptyVarEnv)
import           Clash.Driver.Types
import           Clash.Netlist                    (genNetlist)
import           Clash.Netlist.Util               (genComponentName, genTopComponentName)
import           Clash.Netlist.BlackBox.Parser    (runParse)
import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction)
import           Clash.Netlist.Types
  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap)
import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,
                                                   normalize, runNormalization)
import           Clash.Normalize.Util             (callGraph)
import           Clash.Primitives.Types
import           Clash.Primitives.Util            (hashCompiledPrimMap)
import           Clash.Unique                     (keysUniqMap, lookupUniqMap')
import           Clash.Util                       (first, reportTimeDiff)

-- | Get modification data of current clash binary.
getClashModificationDate :: IO Clock.UTCTime
getClashModificationDate :: IO UTCTime
getClashModificationDate = FilePath -> IO UTCTime
Directory.getModificationTime (FilePath -> IO UTCTime) -> IO FilePath -> IO UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
getExecutablePath

-- | Create a set of target HDL files for a set of functions
generateHDL
  :: forall backend . Backend backend
  => CustomReprs
  -> BindingMap
  -- ^ Set of functions
  -> Maybe backend
  -> CompiledPrimMap
  -- ^ Primitive / BlackBox Definitions
  -> TyConMap
  -- ^ TyCon cache
  -> IntMap TyConName
  -- ^ Tuple TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> PrimEvaluator
  -- ^ Hardcoded evaluator (delta-reduction)
  -> [( Id
      , Maybe TopEntity
      , Maybe Id
      )]
  -- ^ topEntity bndr
  -- + (maybe) TopEntity annotation
  -- + (maybe) testBench bndr
  -> ClashOpts
  -- ^ Debug information level for the normalization process
  -> (Clock.UTCTime,Clock.UTCTime)
  -> IO ()
generateHDL :: CustomReprs
-> BindingMap
-> Maybe backend
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> PrimEvaluator
-> [(Id, Maybe TopEntity, Maybe Id)]
-> ClashOpts
-> (UTCTime, UTCTime)
-> IO ()
generateHDL reprs :: CustomReprs
reprs bindingsMap :: BindingMap
bindingsMap hdlState :: Maybe backend
hdlState primMap :: CompiledPrimMap
primMap tcm :: TyConMap
tcm tupTcm :: IntMap TyConName
tupTcm typeTrans :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans eval :: PrimEvaluator
eval
  topEntities :: [(Id, Maybe TopEntity, Maybe Id)]
topEntities opts :: ClashOpts
opts (startTime :: UTCTime
startTime,prepTime :: UTCTime
prepTime) = UTCTime
-> HashMap Text Word -> [(Id, Maybe TopEntity, Maybe Id)] -> IO ()
go UTCTime
prepTime HashMap Text Word
forall k v. HashMap k v
HashMap.empty [(Id, Maybe TopEntity, Maybe Id)]
topEntities where

  go :: UTCTime
-> HashMap Text Word -> [(Id, Maybe TopEntity, Maybe Id)] -> IO ()
go prevTime :: UTCTime
prevTime _ [] = FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Total compilation took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
prevTime UTCTime
startTime

  -- Process the next TopEntity
  go prevTime :: UTCTime
prevTime seen :: HashMap Text Word
seen ((topEntity :: Id
topEntity,annM :: Maybe TopEntity
annM,benchM :: Maybe Id
benchM):topEntities' :: [(Id, Maybe TopEntity, Maybe Id)]
topEntities') = do
  let topEntityS :: FilePath
topEntityS = Text -> FilePath
Data.Text.unpack (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
topEntity))
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Compiling " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
topEntityS

  -- Some initial setup
  let modName1 :: FilePath
modName1 = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') FilePath
topEntityS
      (modName :: FilePath
modName,prefixM :: (Maybe Text, Maybe Text)
prefixM) = case ClashOpts -> Maybe FilePath
opt_componentPrefix ClashOpts
opts of
        Just p :: FilePath
p
          | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
p) -> case Maybe TopEntity
annM of
            -- Prefix top names with 'p', prefix other with 'p_tname'
            Just ann ->
              let nm :: FilePath
nm = FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ('_'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:TopEntity -> FilePath
t_name TopEntity
ann)
              in  (FilePath
nm,(Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack FilePath
p),Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack FilePath
nm)))
            -- Prefix top names with 'p', prefix other with 'p'
            _ ->  (FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ '_'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
modName1,(Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack FilePath
p),Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack FilePath
p)))
          | Just ann <- Maybe TopEntity
annM -> case backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend) of
              -- Prefix other with 't_name'
              VHDL -> (TopEntity -> FilePath
t_name TopEntity
ann,(Maybe Text
forall a. Maybe a
Nothing,Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack (TopEntity -> FilePath
t_name TopEntity
ann))))
              _    -> (TopEntity -> FilePath
t_name TopEntity
ann,(Maybe Text
forall a. Maybe a
Nothing,Maybe Text
forall a. Maybe a
Nothing))
        _ -> case Maybe TopEntity
annM of
          Just ann -> case backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend) of
            VHDL -> (TopEntity -> FilePath
t_name TopEntity
ann, (Maybe Text
forall a. Maybe a
Nothing,Maybe Text
forall a. Maybe a
Nothing))
            -- Prefix other with 't_name'
            _    -> (TopEntity -> FilePath
t_name TopEntity
ann, (Maybe Text
forall a. Maybe a
Nothing,Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Data.Text.pack (TopEntity -> FilePath
t_name TopEntity
ann))))
          _ -> (FilePath
modName1, (Maybe Text
forall a. Maybe a
Nothing,Maybe Text
forall a. Maybe a
Nothing))
      iw :: Int
iw        = ClashOpts -> Int
opt_intWidth ClashOpts
opts
      hdlsyn :: HdlSyn
hdlsyn    = ClashOpts -> HdlSyn
opt_hdlSyn ClashOpts
opts
      escpIds :: Bool
escpIds   = ClashOpts -> Bool
opt_escapedIds ClashOpts
opts
      forceUnd :: Maybe (Maybe Int)
forceUnd  = ClashOpts -> Maybe (Maybe Int)
opt_forceUndefined ClashOpts
opts
      hdlState' :: backend
hdlState' = Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName (FilePath -> Text
Data.Text.pack FilePath
modName)
                (backend -> backend) -> backend -> backend
forall a b. (a -> b) -> a -> b
$ backend -> Maybe backend -> backend
forall a. a -> Maybe a -> a
fromMaybe (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend
forall state.
Backend state =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> state
initBackend Int
iw HdlSyn
hdlsyn Bool
escpIds Maybe (Maybe Int)
forceUnd :: backend) Maybe backend
hdlState
      hdlDir :: FilePath
hdlDir    = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "." (ClashOpts -> Maybe FilePath
opt_hdlDir ClashOpts
opts) FilePath -> FilePath -> FilePath
</>
                        backend -> FilePath
forall state. Backend state => state -> FilePath
Clash.Backend.name backend
hdlState' FilePath -> FilePath -> FilePath
</>
                        (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') FilePath
topEntityS
      mkId :: IdType -> Text -> Text
mkId      = State backend (IdType -> Text -> Text)
-> backend -> IdType -> Text -> Text
forall s a. State s a -> s -> a
evalState State backend (IdType -> Text -> Text)
forall state. Backend state => State state (IdType -> Text -> Text)
mkIdentifier backend
hdlState'
      extId :: IdType -> Text -> Text -> Text
extId     = State backend (IdType -> Text -> Text -> Text)
-> backend -> IdType -> Text -> Text -> Text
forall s a. State s a -> s -> a
evalState State backend (IdType -> Text -> Text -> Text)
forall state.
Backend state =>
State state (IdType -> Text -> Text -> Text)
extendIdentifier backend
hdlState'
      ite :: Bool
ite       = backend -> Bool
forall state. Backend state => state -> Bool
ifThenElseExpr backend
hdlState'
      topNm :: Text
topNm     = Bool
-> (IdType -> Text -> Text)
-> (Maybe Text, Maybe Text)
-> Maybe TopEntity
-> Id
-> Text
genTopComponentName (ClashOpts -> Bool
opt_newInlineStrat ClashOpts
opts) IdType -> Text -> Text
mkId (Maybe Text, Maybe Text)
prefixM
                                      Maybe TopEntity
annM Id
topEntity
      topNmU :: FilePath
topNmU    = Text -> FilePath
Data.Text.unpack Text
topNm

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ClashOpts -> Bool
opt_cachehdl ClashOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn "Clash: Ignoring .manifest files"

  -- Calculate the hash over the callgraph and the topEntity annotation
  (sameTopHash :: Bool
sameTopHash,sameBenchHash :: Bool
sameBenchHash,manifest :: Manifest
manifest) <- do
    UTCTime
clashModDate <- IO UTCTime
getClashModificationDate

    let primMapHash :: Int
primMapHash = CompiledPrimMap -> Int
hashCompiledPrimMap CompiledPrimMap
primMap

    let
      topHash :: Int
topHash =
        (Maybe TopEntity, Int, FilePath, [Term]) -> Int
forall a. Hashable a => a -> Int
hash ( Maybe TopEntity
annM
             , Int
primMapHash
             , UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
clashModDate
             , BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
topEntity
             )

    let
      benchHashM :: Maybe Int
benchHashM =
        case Maybe Id
benchM of
          Nothing -> Maybe Int
forall a. Maybe a
Nothing
          Just bench ->
            let terms :: [Term]
terms = BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
bench in
            Int -> Maybe Int
forall a. a -> Maybe a
Just ((Maybe TopEntity, Int, FilePath, [Term]) -> Int
forall a. Hashable a => a -> Int
hash (Maybe TopEntity
annM, Int
primMapHash, UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
clashModDate, [Term]
terms))

    let manifestI :: Manifest
manifestI  = (Int, Maybe Int)
-> [Text] -> [Text] -> [Text] -> [Text] -> [Text] -> Manifest
Manifest (Int
topHash,Maybe Int
benchHashM) [] [] [] [] []

    let
      manFile :: FilePath
manFile =
        case Maybe TopEntity
annM of
          Nothing -> FilePath
hdlDir FilePath -> FilePath -> FilePath
</> FilePath
topNmU FilePath -> FilePath -> FilePath
<.> "manifest"
          _       -> FilePath
hdlDir FilePath -> FilePath -> FilePath
</> FilePath
topNmU FilePath -> FilePath -> FilePath
</> FilePath
topNmU FilePath -> FilePath -> FilePath
<.> "manifest"

    Maybe Manifest
manM <- if Bool -> Bool
not (ClashOpts -> Bool
opt_cachehdl ClashOpts
opts)
            then Maybe Manifest -> IO (Maybe Manifest)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Manifest
forall a. Maybe a
Nothing -- ignore manifest file because -fclash-nocache
            else (Maybe FilePath -> (FilePath -> Maybe Manifest) -> Maybe Manifest
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Manifest
forall a. Read a => FilePath -> Maybe a
readMaybe) (Maybe FilePath -> Maybe Manifest)
-> (Either () FilePath -> Maybe FilePath)
-> Either () FilePath
-> Maybe Manifest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Maybe FilePath)
-> (FilePath -> Maybe FilePath)
-> Either () FilePath
-> Maybe FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe FilePath -> () -> Maybe FilePath
forall a b. a -> b -> a
const Maybe FilePath
forall a. Maybe a
Nothing) FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Either () FilePath -> Maybe Manifest)
-> IO (Either () FilePath) -> IO (Maybe Manifest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (IOError -> Maybe ()) -> IO FilePath -> IO (Either () FilePath)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (FilePath -> IO FilePath
readFile FilePath
manFile)
    (Bool, Bool, Manifest) -> IO (Bool, Bool, Manifest)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Bool, Manifest)
-> (Manifest -> (Bool, Bool, Manifest))
-> Maybe Manifest
-> (Bool, Bool, Manifest)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False,Bool
False,Manifest
manifestI)
                  (\man :: Manifest
man -> ((Int, Maybe Int) -> Int
forall a b. (a, b) -> a
fst (Manifest -> (Int, Maybe Int)
manifestHash Manifest
man) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
topHash
                           ,(Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd (Manifest -> (Int, Maybe Int)
manifestHash Manifest
man) Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
benchHashM
                           ,Manifest
man {manifestHash :: (Int, Maybe Int)
manifestHash = (Int
topHash,Maybe Int
benchHashM)}
                           ))
                  Maybe Manifest
manM)

  (supplyN :: Supply
supplyN,supplyTB :: Supply
supplyTB) <- Supply -> (Supply, Supply)
Supply.splitSupply
                    (Supply -> (Supply, Supply))
-> (Supply -> Supply) -> Supply -> (Supply, Supply)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Supply) -> Supply
forall a b. (a, b) -> b
snd
                    ((Int, Supply) -> Supply)
-> (Supply -> (Int, Supply)) -> Supply -> Supply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Supply -> (Int, Supply)
Supply.freshId
                   (Supply -> (Supply, Supply)) -> IO Supply -> IO (Supply, Supply)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Supply
Supply.newSupply
  let topEntityNames :: [Id]
topEntityNames = ((Id, Maybe TopEntity, Maybe Id) -> Id)
-> [(Id, Maybe TopEntity, Maybe Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: Id
x,_,_) -> Id
x) [(Id, Maybe TopEntity, Maybe Id)]
topEntities

  (topTime :: UTCTime
topTime,manifest' :: Manifest
manifest',seen' :: HashMap Text Word
seen') <- if Bool
sameTopHash
    then do
      FilePath -> IO ()
putStrLn ("Clash: Using cached result for: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Data.Text.unpack (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
topEntity)))
      UTCTime
topTime <- IO UTCTime
Clock.getCurrentTime
      (UTCTime, Manifest, HashMap Text Word)
-> IO (UTCTime, Manifest, HashMap Text Word)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
topTime,Manifest
manifest,(Word -> Word -> Word)
-> HashMap Text Word -> HashMap Text Word -> HashMap Text Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max ([(Text, Word)] -> HashMap Text Word
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Text -> (Text, Word)) -> [Text] -> [(Text, Word)]
forall a b. (a -> b) -> [a] -> [b]
map (,0) (Manifest -> [Text]
componentNames Manifest
manifest))) HashMap Text Word
seen)
    else do
      -- 1. Normalise topEntity
      let transformedBindings :: BindingMap
transformedBindings = CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> PrimEvaluator
-> [Id]
-> ClashOpts
-> Supply
-> Id
-> BindingMap
normalizeEntity CustomReprs
reprs BindingMap
bindingsMap CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm
                                  CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans PrimEvaluator
eval [Id]
topEntityNames ClashOpts
opts Supply
supplyN
                                  Id
topEntity

      UTCTime
normTime <- BindingMap
transformedBindings BindingMap -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let prepNormDiff :: FilePath
prepNormDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
normTime UTCTime
prevTime
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Normalisation took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prepNormDiff

      -- 2. Generate netlist for topEntity

      -- [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
      let dir :: FilePath
dir = FilePath
hdlDir FilePath -> FilePath -> FilePath
</> FilePath -> (TopEntity -> FilePath) -> Maybe TopEntity -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (FilePath -> TopEntity -> FilePath
forall a b. a -> b -> a
const FilePath
modName) Maybe TopEntity
annM
      Bool -> FilePath -> FilePath -> IO ()
prepareDir (ClashOpts -> Bool
opt_cleanhdl ClashOpts
opts) (backend -> FilePath
forall state. Backend state => state -> FilePath
extension backend
hdlState') FilePath
dir
      -- Now start the netlist generation
      (netlist :: [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist,seen' :: HashMap Text Word
seen') <-
        Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [(Id, Maybe TopEntity, Maybe Id)]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> Int
-> (IdType -> Text -> Text)
-> (IdType -> Text -> Text -> Text)
-> Bool
-> HashMap Text Word
-> FilePath
-> (Maybe Text, Maybe Text)
-> Id
-> IO
     ([([Bool], SrcSpan, HashMap Text Word, Component)],
      HashMap Text Word)
genNetlist Bool
False ClashOpts
opts CustomReprs
reprs BindingMap
transformedBindings [(Id, Maybe TopEntity, Maybe Id)]
topEntities CompiledPrimMap
primMap
                   TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans Int
iw IdType -> Text -> Text
mkId IdType -> Text -> Text -> Text
extId Bool
ite HashMap Text Word
seen FilePath
hdlDir (Maybe Text, Maybe Text)
prefixM Id
topEntity

      UTCTime
netlistTime <- [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist [([Bool], SrcSpan, HashMap Text Word, Component)]
-> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let normNetDiff :: FilePath
normNetDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
netlistTime UTCTime
normTime
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Netlist generation took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
normNetDiff

      -- 3. Generate topEntity wrapper
      let topComponent :: Component
topComponent = Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
-> ([Bool], SrcSpan, HashMap Text Word, Component) -> Component
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
forall s t a b. Field4 s t a b => Lens s t a b
_4 (([Bool], SrcSpan, HashMap Text Word, Component) -> Component)
-> ([([Bool], SrcSpan, HashMap Text Word, Component)]
    -> ([Bool], SrcSpan, HashMap Text Word, Component))
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Bool], SrcSpan, HashMap Text Word, Component)]
-> ([Bool], SrcSpan, HashMap Text Word, Component)
forall a. [a] -> a
head ([([Bool], SrcSpan, HashMap Text Word, Component)] -> Component)
-> [([Bool], SrcSpan, HashMap Text Word, Component)] -> Component
forall a b. (a -> b) -> a -> b
$ (([Bool], SrcSpan, HashMap Text Word, Component) -> Bool)
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
Data.Text.isSuffixOf Text
topNm (Text -> Bool)
-> (([Bool], SrcSpan, HashMap Text Word, Component) -> Text)
-> ([Bool], SrcSpan, HashMap Text Word, Component)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> Text
componentName (Component -> Text)
-> (([Bool], SrcSpan, HashMap Text Word, Component) -> Component)
-> ([Bool], SrcSpan, HashMap Text Word, Component)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
-> ([Bool], SrcSpan, HashMap Text Word, Component) -> Component
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
forall s t a b. Field4 s t a b => Lens s t a b
_4) [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist
          (hdlDocs :: [(FilePath, Doc)]
hdlDocs,manifest' :: Manifest
manifest',dfiles :: [(FilePath, FilePath)]
dfiles,mfiles :: [(FilePath, FilePath)]
mfiles)  = backend
-> Text
-> HashMap Text Word
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
-> (Text, Either Manifest Manifest)
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
forall backend.
Backend backend =>
backend
-> Text
-> HashMap Text Word
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
-> (Text, Either Manifest Manifest)
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
createHDL backend
hdlState' (FilePath -> Text
Data.Text.pack FilePath
modName) HashMap Text Word
seen' [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist Component
topComponent
                                   (Text
topNm, Manifest -> Either Manifest Manifest
forall a b. b -> Either a b
Right Manifest
manifest)
      ((FilePath, Doc) -> IO ()) -> [(FilePath, Doc)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> (FilePath, Doc) -> IO ()
writeHDL FilePath
dir) [(FilePath, Doc)]
hdlDocs
      [FilePath] -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyDataFiles (ClashOpts -> [FilePath]
opt_importPaths ClashOpts
opts) FilePath
dir [(FilePath, FilePath)]
dfiles
      FilePath -> [(FilePath, FilePath)] -> IO ()
writeMemoryDataFiles FilePath
dir [(FilePath, FilePath)]
mfiles

      UTCTime
topTime <- [(FilePath, Doc)]
hdlDocs [(FilePath, Doc)] -> IO UTCTime -> IO UTCTime
forall a b. a -> b -> b
`seq` IO UTCTime
Clock.getCurrentTime
      (UTCTime, Manifest, HashMap Text Word)
-> IO (UTCTime, Manifest, HashMap Text Word)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
topTime,Manifest
manifest',HashMap Text Word
seen')

  UTCTime
benchTime <- case Maybe Id
benchM of
    Just tb :: Id
tb | Bool -> Bool
not Bool
sameBenchHash -> do
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Compiling " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Data.Text.unpack (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
tb))

      let modName' :: Text
modName'  = Bool
-> HashMap Text Word
-> (IdType -> Text -> Text)
-> (Maybe Text, Maybe Text)
-> Id
-> Text
genComponentName (ClashOpts -> Bool
opt_newInlineStrat ClashOpts
opts) HashMap Text Word
forall k v. HashMap k v
HashMap.empty
                                       IdType -> Text -> Text
mkId (Maybe Text, Maybe Text)
prefixM Id
tb
          hdlState2 :: backend
hdlState2 = Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName Text
modName' backend
hdlState'

      -- 1. Normalise testBench
      let transformedBindings :: BindingMap
transformedBindings = CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> PrimEvaluator
-> [Id]
-> ClashOpts
-> Supply
-> Id
-> BindingMap
normalizeEntity CustomReprs
reprs BindingMap
bindingsMap CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm
                                  CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans PrimEvaluator
eval [Id]
topEntityNames ClashOpts
opts Supply
supplyTB Id
tb
      UTCTime
normTime <- BindingMap
transformedBindings BindingMap -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let prepNormDiff :: FilePath
prepNormDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
normTime UTCTime
topTime
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Testbench normalisation took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prepNormDiff

      -- 2. Generate netlist for topEntity

      -- See [Note] Create HDL dir before netlist generation
      let dir :: FilePath
dir = FilePath
hdlDir FilePath -> FilePath -> FilePath
</> FilePath -> (TopEntity -> FilePath) -> Maybe TopEntity -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" TopEntity -> FilePath
t_name Maybe TopEntity
annM FilePath -> FilePath -> FilePath
</> Text -> FilePath
Data.Text.unpack Text
modName'
      Bool -> FilePath -> FilePath -> IO ()
prepareDir (ClashOpts -> Bool
opt_cleanhdl ClashOpts
opts) (backend -> FilePath
forall state. Backend state => state -> FilePath
extension backend
hdlState2) FilePath
dir
      -- Now start the netlist generation
      (netlist :: [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist,seen'' :: HashMap Text Word
seen'') <-
        Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [(Id, Maybe TopEntity, Maybe Id)]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> Int
-> (IdType -> Text -> Text)
-> (IdType -> Text -> Text -> Text)
-> Bool
-> HashMap Text Word
-> FilePath
-> (Maybe Text, Maybe Text)
-> Id
-> IO
     ([([Bool], SrcSpan, HashMap Text Word, Component)],
      HashMap Text Word)
genNetlist Bool
True ClashOpts
opts CustomReprs
reprs BindingMap
transformedBindings [(Id, Maybe TopEntity, Maybe Id)]
topEntities CompiledPrimMap
primMap
                   TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans Int
iw IdType -> Text -> Text
mkId IdType -> Text -> Text -> Text
extId Bool
ite HashMap Text Word
seen' FilePath
hdlDir (Maybe Text, Maybe Text)
prefixM Id
tb

      UTCTime
netlistTime <- [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist [([Bool], SrcSpan, HashMap Text Word, Component)]
-> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let normNetDiff :: FilePath
normNetDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
netlistTime UTCTime
normTime
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Testbench netlist generation took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
normNetDiff

      -- 3. Write HDL
      let (hdlDocs :: [(FilePath, Doc)]
hdlDocs,_,dfiles :: [(FilePath, FilePath)]
dfiles,mfiles :: [(FilePath, FilePath)]
mfiles) = backend
-> Text
-> HashMap Text Word
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
-> (Text, Either Manifest Manifest)
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
forall backend.
Backend backend =>
backend
-> Text
-> HashMap Text Word
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
-> (Text, Either Manifest Manifest)
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
createHDL backend
hdlState2 Text
modName' HashMap Text Word
seen'' [([Bool], SrcSpan, HashMap Text Word, Component)]
netlist Component
forall a. HasCallStack => a
undefined
                           (Text
topNm, Manifest -> Either Manifest Manifest
forall a b. a -> Either a b
Left Manifest
manifest')
      FilePath -> (FilePath, Doc) -> IO ()
writeHDL (FilePath
hdlDir FilePath -> FilePath -> FilePath
</> FilePath -> (TopEntity -> FilePath) -> Maybe TopEntity -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" TopEntity -> FilePath
t_name Maybe TopEntity
annM) ([(FilePath, Doc)] -> (FilePath, Doc)
forall a. [a] -> a
head [(FilePath, Doc)]
hdlDocs)
      ((FilePath, Doc) -> IO ()) -> [(FilePath, Doc)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> (FilePath, Doc) -> IO ()
writeHDL FilePath
dir) ([(FilePath, Doc)] -> [(FilePath, Doc)]
forall a. [a] -> [a]
tail [(FilePath, Doc)]
hdlDocs)
      [FilePath] -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyDataFiles (ClashOpts -> [FilePath]
opt_importPaths ClashOpts
opts) FilePath
dir [(FilePath, FilePath)]
dfiles
      FilePath -> [(FilePath, FilePath)] -> IO ()
writeMemoryDataFiles FilePath
dir [(FilePath, FilePath)]
mfiles

      [(FilePath, Doc)]
hdlDocs [(FilePath, Doc)] -> IO UTCTime -> IO UTCTime
forall a b. a -> b -> b
`seq` IO UTCTime
Clock.getCurrentTime

    Just tb :: Id
tb -> do
      let tb' :: FilePath
tb' = Text -> FilePath
Data.Text.unpack (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
tb))
      FilePath -> IO ()
putStrLn ("Clash: Compiling: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tb')
      FilePath -> IO ()
putStrLn ("Clash: Using cached result for: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tb')
      UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
topTime

    Nothing -> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
topTime

  UTCTime
-> HashMap Text Word -> [(Id, Maybe TopEntity, Maybe Id)] -> IO ()
go UTCTime
benchTime HashMap Text Word
seen' [(Id, Maybe TopEntity, Maybe Id)]
topEntities'

-- | Interpret a specific function from a specific module. This action tries
-- two things:
--
--   1. Interpret without explicitly loading the module. This will succeed if
--      the module was already loaded through a package database (set using
--      'interpreterArgs').
--
--   2. If (1) fails, it does try to load it explicitly. If this also fails,
--      an error is returned.
--
loadImportAndInterpret
  :: (MonadIO m, MonadMask m)
  => [String]
  -- ^ Extra search path (usually passed as -i)
  -> [String]
  -- ^ Interpreter args
  -> String
  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
  -- can be found
  -> Hint.ModuleName
  -- ^ Module function lives in
  -> String
  -- ^ Function name
  -> String
  -- ^ Type name ("BlackBoxFunction" or "TemplateFunction")
  -> m (Either Hint.InterpreterError a)
loadImportAndInterpret :: [FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m (Either InterpreterError a)
loadImportAndInterpret iPaths0 :: [FilePath]
iPaths0 interpreterArgs :: [FilePath]
interpreterArgs topDir :: FilePath
topDir qualMod :: FilePath
qualMod funcName :: FilePath
funcName typ :: FilePath
typ = do
  -- Try to interpret function *without* loading module explicitly. If this
  -- succeeds, the module was already in the global package database(s).
  Either InterpreterError a
bbfE <- [FilePath]
-> FilePath -> InterpreterT m a -> m (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> FilePath -> InterpreterT m a -> m (Either InterpreterError a)
Hint.unsafeRunInterpreterWithArgsLibdir [FilePath]
interpreterArgs FilePath
topDir (InterpreterT m a -> m (Either InterpreterError a))
-> InterpreterT m a -> m (Either InterpreterError a)
forall a b. (a -> b) -> a -> b
$ do
    [FilePath]
iPaths1 <- ([FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++[FilePath]
iPaths0) ([FilePath] -> [FilePath])
-> InterpreterT m [FilePath] -> InterpreterT m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Option (InterpreterT m) [FilePath] -> InterpreterT m [FilePath]
forall (m :: * -> *) a. MonadInterpreter m => Option m a -> m a
Hint.get Option (InterpreterT m) [FilePath]
forall (m :: * -> *). MonadInterpreter m => Option m [FilePath]
Hint.searchPath
    [OptionVal (InterpreterT m)] -> InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => [OptionVal m] -> m ()
Hint.set [Option (InterpreterT m) [FilePath]
forall (m :: * -> *). MonadInterpreter m => Option m [FilePath]
Hint.searchPath Option (InterpreterT m) [FilePath]
-> [FilePath] -> OptionVal (InterpreterT m)
forall (m :: * -> *) a. Option m a -> a -> OptionVal m
Hint.:= [FilePath]
iPaths1]
    [FilePath] -> InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => [FilePath] -> m ()
Hint.setImports [ "Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", FilePath
qualMod]
    FilePath -> FilePath -> InterpreterT m a
forall (m :: * -> *) a.
MonadInterpreter m =>
FilePath -> FilePath -> m a
Hint.unsafeInterpret FilePath
funcName FilePath
typ

  case Either InterpreterError a
bbfE of
    Left _ -> do
      -- Try to interpret module as a local module, not yet present in the
      -- global package database(s).
      [FilePath]
-> FilePath -> InterpreterT m a -> m (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> FilePath -> InterpreterT m a -> m (Either InterpreterError a)
Hint.unsafeRunInterpreterWithArgsLibdir [FilePath]
interpreterArgs FilePath
topDir (InterpreterT m a -> m (Either InterpreterError a))
-> InterpreterT m a -> m (Either InterpreterError a)
forall a b. (a -> b) -> a -> b
$ do
        InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => m ()
Hint.reset
        [FilePath]
iPaths1 <- ([FilePath]
iPaths0[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++) ([FilePath] -> [FilePath])
-> InterpreterT m [FilePath] -> InterpreterT m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Option (InterpreterT m) [FilePath] -> InterpreterT m [FilePath]
forall (m :: * -> *) a. MonadInterpreter m => Option m a -> m a
Hint.get Option (InterpreterT m) [FilePath]
forall (m :: * -> *). MonadInterpreter m => Option m [FilePath]
Hint.searchPath
        [OptionVal (InterpreterT m)] -> InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => [OptionVal m] -> m ()
Hint.set [Option (InterpreterT m) [FilePath]
forall (m :: * -> *). MonadInterpreter m => Option m [FilePath]
Hint.searchPath Option (InterpreterT m) [FilePath]
-> [FilePath] -> OptionVal (InterpreterT m)
forall (m :: * -> *) a. Option m a -> a -> OptionVal m
Hint.:= [FilePath]
iPaths1]
        [FilePath] -> InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => [FilePath] -> m ()
Hint.loadModules [FilePath
qualMod]
        [FilePath] -> InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => [FilePath] -> m ()
Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", FilePath
qualMod]
        FilePath -> FilePath -> InterpreterT m a
forall (m :: * -> *) a.
MonadInterpreter m =>
FilePath -> FilePath -> m a
Hint.unsafeInterpret FilePath
funcName FilePath
typ
    Right _ -> do
      Either InterpreterError a -> m (Either InterpreterError a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either InterpreterError a
bbfE

-- | Compiles blackbox functions and parses blackbox templates.
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 :: [FilePath]
-> [FilePath]
-> FilePath
-> ResolvedPrimitive
-> IO CompiledPrimitive
compilePrimitive idirs :: [FilePath]
idirs pkgDbs :: [FilePath]
pkgDbs topDir :: FilePath
topDir (BlackBoxHaskell bbName :: Text
bbName wf :: WorkInfo
wf bbGenName :: BlackBoxFunctionName
bbGenName source :: Maybe Text
source) = do
  let interpreterArgs :: [FilePath]
interpreterArgs = (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (("-package-db"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[])) [FilePath]
pkgDbs
  -- Compile a blackbox template function or fetch it from an already compiled file.
  Either InterpreterError BlackBoxFunction
r <- [FilePath]
-> Maybe Text -> IO (Either InterpreterError BlackBoxFunction)
go [FilePath]
interpreterArgs Maybe Text
source
  FilePath
-> Text
-> (BlackBoxFunction -> CompiledPrimitive)
-> Either InterpreterError BlackBoxFunction
-> IO CompiledPrimitive
forall (m :: * -> *) t r.
Monad m =>
FilePath -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError
    (BlackBoxFunctionName -> FilePath
forall a. Show a => a -> FilePath
show BlackBoxFunctionName
bbGenName)
    Text
bbName
    (\bbFunc :: BlackBoxFunction
bbFunc -> Text
-> WorkInfo
-> BlackBoxFunctionName
-> (Int, BlackBoxFunction)
-> CompiledPrimitive
forall a b c d.
Text -> WorkInfo -> BlackBoxFunctionName -> d -> Primitive a b c d
BlackBoxHaskell Text
bbName WorkInfo
wf BlackBoxFunctionName
bbGenName (Maybe Text -> Int
forall a. Hashable a => a -> Int
hash Maybe Text
source, BlackBoxFunction
bbFunc))
    Either InterpreterError BlackBoxFunction
r
  where
    qualMod :: FilePath
qualMod = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "." [FilePath]
modNames
    BlackBoxFunctionName modNames :: [FilePath]
modNames funcName :: FilePath
funcName = BlackBoxFunctionName
bbGenName

    -- | Create directory based on base name and directory. Return path
    -- of directory just created.
    createDirectory'
      :: FilePath
      -> FilePath
      -> IO FilePath
    createDirectory' :: FilePath -> FilePath -> IO FilePath
createDirectory' base :: FilePath
base sub :: FilePath
sub =
      let new :: FilePath
new = FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
sub in
      FilePath -> IO ()
Directory.createDirectory FilePath
new IO () -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
new

    go
      :: [String]
      -> Maybe Text
      -> IO (Either Hint.InterpreterError BlackBoxFunction)
    go :: [FilePath]
-> Maybe Text -> IO (Either InterpreterError BlackBoxFunction)
go args :: [FilePath]
args (Just source' :: Text
source') = do
      -- Create a temporary directory with user module in it, add it to the
      -- list of import direcotries, and run as if it were a "normal" compiled
      -- module.
      FilePath
tmpDir0 <- IO FilePath
getCanonicalTemporaryDirectory
      FilePath
-> FilePath
-> (FilePath -> IO (Either InterpreterError BlackBoxFunction))
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
withTempDirectory FilePath
tmpDir0 "clash-prim-compile" ((FilePath -> IO (Either InterpreterError BlackBoxFunction))
 -> IO (Either InterpreterError BlackBoxFunction))
-> (FilePath -> IO (Either InterpreterError BlackBoxFunction))
-> IO (Either InterpreterError BlackBoxFunction)
forall a b. (a -> b) -> a -> b
$ \tmpDir1 :: FilePath
tmpDir1 -> do
        FilePath
modDir <- (FilePath -> FilePath -> IO FilePath)
-> FilePath -> [FilePath] -> IO FilePath
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FilePath -> FilePath -> IO FilePath
createDirectory' FilePath
tmpDir1 ([FilePath] -> [FilePath]
forall a. [a] -> [a]
init [FilePath]
modNames)
        FilePath -> Text -> IO ()
Text.writeFile (FilePath
modDir FilePath -> FilePath -> FilePath
</> ([FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
modNames FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".hs")) Text
source'
        [FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m (Either InterpreterError a)
loadImportAndInterpret (FilePath
tmpDir1FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
idirs) [FilePath]
args FilePath
topDir FilePath
qualMod FilePath
funcName "BlackBoxFunction"

    go args :: [FilePath]
args Nothing = do
      [FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m (Either InterpreterError a)
loadImportAndInterpret [FilePath]
idirs [FilePath]
args FilePath
topDir FilePath
qualMod FilePath
funcName "BlackBoxFunction"

compilePrimitive idirs :: [FilePath]
idirs pkgDbs :: [FilePath]
pkgDbs topDir :: FilePath
topDir (BlackBox pNm :: Text
pNm wf :: WorkInfo
wf tkind :: TemplateKind
tkind () oReg :: Bool
oReg libM :: [Text]
libM imps :: [Text]
imps incs :: [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs templ :: ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ) = do
  [BlackBoxTemplate]
libM'  <- (Text -> IO BlackBoxTemplate) -> [Text] -> IO [BlackBoxTemplate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> IO BlackBoxTemplate
forall (m :: * -> *). Applicative m => Text -> m BlackBoxTemplate
parseTempl [Text]
libM
  [BlackBoxTemplate]
imps'  <- (Text -> IO BlackBoxTemplate) -> [Text] -> IO [BlackBoxTemplate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> IO BlackBoxTemplate
forall (m :: * -> *). Applicative m => Text -> m BlackBoxTemplate
parseTempl [Text]
imps
  [((Text, Text), BlackBox)]
incs'  <- (((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
 -> IO ((Text, Text), BlackBox))
-> [((Text, Text),
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> IO [((Text, Text), BlackBox)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> ((Text, Text),
    ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> IO ((Text, Text), BlackBox)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB) [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs
  BlackBox
templ' <- ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ
  CompiledPrimitive -> IO CompiledPrimitive
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
-> WorkInfo
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [((Text, Text), b)]
-> b
-> Primitive a b c d
BlackBox Text
pNm WorkInfo
wf TemplateKind
tkind () Bool
oReg [BlackBoxTemplate]
libM' [BlackBoxTemplate]
imps' [((Text, Text), BlackBox)]
incs' BlackBox
templ')
 where
  iArgs :: [FilePath]
iArgs = (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (("-package-db"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[])) [FilePath]
pkgDbs

  parseTempl
    :: Applicative m
    => Text
    -> m BlackBoxTemplate
  parseTempl :: Text -> m BlackBoxTemplate
parseTempl t :: Text
t = case Text -> Result BlackBoxTemplate
runParse Text
t of
    Failure errInfo :: ErrInfo
errInfo
      -> FilePath -> m BlackBoxTemplate
forall a. HasCallStack => FilePath -> a
error ("Parsing template for blackbox " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
Data.Text.unpack Text
pNm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " failed:\n"
               FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc AnsiStyle -> FilePath
forall a. Show a => a -> FilePath
show (ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
errInfo))
    Success t' :: BlackBoxTemplate
t'
      -> BlackBoxTemplate -> m BlackBoxTemplate
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlackBoxTemplate
t'

  parseBB
    :: ((TemplateFormat,BlackBoxFunctionName), Maybe Text)
    -> IO BlackBox
  parseBB :: ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB ((TTemplate,_),Just t :: Text
t)     = BlackBoxTemplate -> BlackBox
BBTemplate (BlackBoxTemplate -> BlackBox)
-> IO BlackBoxTemplate -> IO BlackBox
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO BlackBoxTemplate
forall (m :: * -> *). Applicative m => Text -> m BlackBoxTemplate
parseTempl Text
t
  parseBB ((TTemplate,_),Nothing)    =
    FilePath -> IO BlackBox
forall a. HasCallStack => FilePath -> a
error ("No template specified for blackbox: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
pNm)
  parseBB ((THaskell,bbGenName :: BlackBoxFunctionName
bbGenName),Just source :: Text
source) = do
    let BlackBoxFunctionName modNames :: [FilePath]
modNames funcName :: FilePath
funcName = BlackBoxFunctionName
bbGenName
        qualMod :: FilePath
qualMod = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "." [FilePath]
modNames
    FilePath
tmpDir <- IO FilePath
getCanonicalTemporaryDirectory
    Either InterpreterError TemplateFunction
r <- FilePath
-> FilePath
-> (FilePath -> IO (Either InterpreterError TemplateFunction))
-> IO (Either InterpreterError TemplateFunction)
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
withTempDirectory FilePath
tmpDir "clash-prim-compile" ((FilePath -> IO (Either InterpreterError TemplateFunction))
 -> IO (Either InterpreterError TemplateFunction))
-> (FilePath -> IO (Either InterpreterError TemplateFunction))
-> IO (Either InterpreterError TemplateFunction)
forall a b. (a -> b) -> a -> b
$ \tmpDir' :: FilePath
tmpDir' -> do
      let modDir :: FilePath
modDir = (FilePath -> FilePath -> FilePath)
-> FilePath -> [FilePath] -> FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FilePath -> FilePath -> FilePath
(</>) FilePath
tmpDir' ([FilePath] -> [FilePath]
forall a. [a] -> [a]
init [FilePath]
modNames)
      Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
True FilePath
modDir
      FilePath -> Text -> IO ()
Text.writeFile (FilePath
modDir FilePath -> FilePath -> FilePath
</> [FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
modNames FilePath -> FilePath -> FilePath
<.>  "hs") Text
source
      [FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO (Either InterpreterError TemplateFunction)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m (Either InterpreterError a)
loadImportAndInterpret (FilePath
tmpDir'FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
idirs) [FilePath]
iArgs FilePath
topDir FilePath
qualMod FilePath
funcName "TemplateFunction"
    let hsh :: Int
hsh = (FilePath, Text) -> Int
forall a. Hashable a => a -> Int
hash (FilePath
qualMod, Text
source)
    FilePath
-> Text
-> (TemplateFunction -> BlackBox)
-> Either InterpreterError TemplateFunction
-> IO BlackBox
forall (m :: * -> *) t r.
Monad m =>
FilePath -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError (BlackBoxFunctionName -> FilePath
forall a. Show a => a -> FilePath
show BlackBoxFunctionName
bbGenName) Text
pNm (FilePath -> Int -> TemplateFunction -> BlackBox
BBFunction (Text -> FilePath
Data.Text.unpack Text
pNm) Int
hsh) Either InterpreterError TemplateFunction
r
  parseBB ((THaskell,bbGenName :: BlackBoxFunctionName
bbGenName),Nothing) = do
    let BlackBoxFunctionName modNames :: [FilePath]
modNames funcName :: FilePath
funcName = BlackBoxFunctionName
bbGenName
        qualMod :: FilePath
qualMod = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "." [FilePath]
modNames
        hsh :: Int
hsh     = FilePath -> Int
forall a. Hashable a => a -> Int
hash FilePath
qualMod
    Either InterpreterError TemplateFunction
r <- [FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO (Either InterpreterError TemplateFunction)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[FilePath]
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m (Either InterpreterError a)
loadImportAndInterpret [FilePath]
idirs [FilePath]
iArgs FilePath
topDir FilePath
qualMod FilePath
funcName "TemplateFunction"
    FilePath
-> Text
-> (TemplateFunction -> BlackBox)
-> Either InterpreterError TemplateFunction
-> IO BlackBox
forall (m :: * -> *) t r.
Monad m =>
FilePath -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError (BlackBoxFunctionName -> FilePath
forall a. Show a => a -> FilePath
show BlackBoxFunctionName
bbGenName) Text
pNm (FilePath -> Int -> TemplateFunction -> BlackBox
BBFunction (Text -> FilePath
Data.Text.unpack Text
pNm) Int
hsh) Either InterpreterError TemplateFunction
r

compilePrimitive _ _ _ (Primitive pNm :: Text
pNm wf :: WorkInfo
wf typ :: Text
typ) =
  CompiledPrimitive -> IO CompiledPrimitive
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> WorkInfo -> Text -> CompiledPrimitive
forall a b c d. Text -> WorkInfo -> Text -> Primitive a b c d
Primitive Text
pNm WorkInfo
wf Text
typ)

processHintError
  :: Monad m
  => String
  -> Data.Text.Text
  -> (t -> r)
  -> Either Hint.InterpreterError t
  -> m r
processHintError :: FilePath -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError fun :: FilePath
fun bb :: Text
bb go :: t -> r
go r :: Either InterpreterError t
r = case Either InterpreterError t
r of
  Left (Hint.GhcException err :: FilePath
err) ->
    FilePath -> FilePath -> m r
forall a. FilePath -> FilePath -> a
error' "GHC Exception" FilePath
err
  Left (Hint.NotAllowed err :: FilePath
err) ->
    FilePath -> FilePath -> m r
forall a. FilePath -> FilePath -> a
error' "NotAllowed error" FilePath
err
  Left (Hint.UnknownError err :: FilePath
err) ->
    FilePath -> FilePath -> m r
forall a. FilePath -> FilePath -> a
error' "an unknown error" FilePath
err
  Left (Hint.WontCompile ghcErrs :: [GhcError]
ghcErrs) ->
    FilePath -> FilePath -> m r
forall a. FilePath -> FilePath -> a
error' "compilation errors" (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\n\n" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (GhcError -> FilePath) -> [GhcError] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map GhcError -> FilePath
Hint.errMsg [GhcError]
ghcErrs)
  Right f :: t
f ->
    r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> m r) -> r -> m r
forall a b. (a -> b) -> a -> b
$ t -> r
go t
f
 where
  error' :: FilePath -> FilePath -> a
error' errType :: FilePath
errType report :: FilePath
report =
    FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [ "Encountered", FilePath
errType, "while compiling blackbox template"
                    , "function", FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fun, "for function", Text -> FilePath
forall a. Show a => a -> FilePath
show Text
bb FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "."
                    , "Compilation reported: \n\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
report ]

-- | Pretty print Components to HDL Documents
createHDL
  :: Backend backend
  => backend
  -- ^ Backend
  -> Identifier
  -- ^ Module hierarchy root
  -> HashMap Identifier Word
  -- ^ Component names
  -> [([Bool],SrcSpan,HashMap Identifier Word,Component)]
  -- ^ List of components
  -> Component
  -- ^ Top component
  -> (Identifier, Either Manifest Manifest)
  -- ^ Name of the manifest file
  -- + Either:
  --   * Left manifest:  Only write/update the hashes of the @manifest@
  --   * Right manifest: Update all fields of the @manifest@
  -> ([(String,Doc)],Manifest,[(String,FilePath)],[(String,String)])
  -- ^ The pretty-printed HDL documents
  -- + The update manifest file
  -- + The data files that need to be copied
createHDL :: backend
-> Text
-> HashMap Text Word
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Component
-> (Text, Either Manifest Manifest)
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
createHDL backend :: backend
backend modName :: Text
modName seen :: HashMap Text Word
seen components :: [([Bool], SrcSpan, HashMap Text Word, Component)]
components top :: Component
top (topName :: Text
topName,manifestE :: Either Manifest Manifest
manifestE) = (State
   backend
   ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
 -> backend
 -> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
     [(FilePath, FilePath)]))
-> backend
-> State
     backend
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  backend
  ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
   [(FilePath, FilePath)])
-> backend
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
forall s a. State s a -> s -> a
evalState backend
backend (State
   backend
   ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
 -> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
     [(FilePath, FilePath)]))
-> State
     backend
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
-> ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
forall a b. (a -> b) -> a -> b
$ Mon
  (State backend)
  ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
   [(FilePath, FilePath)])
-> State
     backend
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
forall (f :: * -> *) m. Mon f m -> f m
getMon (Mon
   (State backend)
   ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
    [(FilePath, FilePath)])
 -> State
      backend
      ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
       [(FilePath, FilePath)]))
-> Mon
     (State backend)
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
-> State
     backend
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
forall a b. (a -> b) -> a -> b
$ do
  (hdlNmDocs :: [(FilePath, Doc)]
hdlNmDocs,incs :: [[(FilePath, Doc)]]
incs) <- [((FilePath, Doc), [(FilePath, Doc)])]
-> ([(FilePath, Doc)], [[(FilePath, Doc)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((FilePath, Doc), [(FilePath, Doc)])]
 -> ([(FilePath, Doc)], [[(FilePath, Doc)]]))
-> Mon (State backend) [((FilePath, Doc), [(FilePath, Doc)])]
-> Mon (State backend) ([(FilePath, Doc)], [[(FilePath, Doc)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Bool], SrcSpan, HashMap Text Word, Component)
 -> Mon (State backend) ((FilePath, Doc), [(FilePath, Doc)]))
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Mon (State backend) [((FilePath, Doc), [(FilePath, Doc)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(_wereVoids :: [Bool]
_wereVoids,sp :: SrcSpan
sp,ids :: HashMap Text Word
ids,comp :: Component
comp) -> Text
-> SrcSpan
-> HashMap Text Word
-> Component
-> Mon (State backend) ((FilePath, Doc), [(FilePath, Doc)])
forall state.
Backend state =>
Text
-> SrcSpan
-> HashMap Text Word
-> Component
-> Mon (State state) ((FilePath, Doc), [(FilePath, Doc)])
genHDL Text
modName SrcSpan
sp ((Word -> Word -> Word)
-> HashMap Text Word -> HashMap Text Word -> HashMap Text Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max HashMap Text Word
seen HashMap Text Word
ids) Component
comp) [([Bool], SrcSpan, HashMap Text Word, Component)]
components
  [HWType]
hwtys <- HashSet HWType -> [HWType]
forall a. HashSet a -> [a]
HashSet.toList (HashSet HWType -> [HWType])
-> (backend -> HashSet HWType) -> backend -> [HWType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> backend -> HashSet HWType
forall state. Backend state => state -> HashSet HWType
extractTypes (backend -> [HWType])
-> Mon (State backend) backend -> Mon (State backend) [HWType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend backend -> Mon (State backend) backend
forall (f :: * -> *) m. f m -> Mon f m
Mon State backend backend
forall s (m :: * -> *). MonadState s m => m s
get
  [(FilePath, Doc)]
typesPkg <- Text -> [HWType] -> Mon (State backend) [(FilePath, Doc)]
forall state.
Backend state =>
Text -> [HWType] -> Mon (State state) [(FilePath, Doc)]
mkTyPackage Text
modName [HWType]
hwtys
  [(FilePath, FilePath)]
dataFiles <- StateT backend Identity [(FilePath, FilePath)]
-> Mon (State backend) [(FilePath, FilePath)]
forall (f :: * -> *) m. f m -> Mon f m
Mon StateT backend Identity [(FilePath, FilePath)]
forall state. Backend state => State state [(FilePath, FilePath)]
getDataFiles
  [(FilePath, FilePath)]
memFiles  <- StateT backend Identity [(FilePath, FilePath)]
-> Mon (State backend) [(FilePath, FilePath)]
forall (f :: * -> *) m. f m -> Mon f m
Mon StateT backend Identity [(FilePath, FilePath)]
forall state. Backend state => State state [(FilePath, FilePath)]
getMemoryDataFiles
  let hdl :: [(FilePath, Doc)]
hdl   = ((FilePath, Doc) -> (FilePath, Doc))
-> [(FilePath, Doc)] -> [(FilePath, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> FilePath) -> (FilePath, Doc) -> (FilePath, Doc)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (FilePath -> FilePath -> FilePath
<.> backend -> FilePath
forall state. Backend state => state -> FilePath
Clash.Backend.extension backend
backend)) ([(FilePath, Doc)]
typesPkg [(FilePath, Doc)] -> [(FilePath, Doc)] -> [(FilePath, Doc)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Doc)]
hdlNmDocs)
      qincs :: [(FilePath, Doc)]
qincs = [[(FilePath, Doc)]] -> [(FilePath, Doc)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(FilePath, Doc)]]
incs
      topFiles :: [(FilePath, Doc)]
topFiles = [(FilePath, Doc)]
hdl [(FilePath, Doc)] -> [(FilePath, Doc)] -> [(FilePath, Doc)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Doc)]
qincs
  Manifest
manifest <- (Manifest -> Mon (State backend) Manifest)
-> (Manifest -> Mon (State backend) Manifest)
-> Either Manifest Manifest
-> Mon (State backend) Manifest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Manifest -> Mon (State backend) Manifest
forall (m :: * -> *) a. Monad m => a -> m a
return (\m :: Manifest
m -> do
      let topInNames :: [Text]
topInNames = ((Text, HWType) -> Text) -> [(Text, HWType)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, HWType) -> Text
forall a b. (a, b) -> a
fst (Component -> [(Text, HWType)]
inputs Component
top)
      [Text]
topInTypes  <- ((Text, HWType) -> Mon (State backend) Text)
-> [(Text, HWType)] -> Mon (State backend) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Doc -> Text)
-> Mon (State backend) Doc -> Mon (State backend) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Text.toStrict (Text -> Text) -> (Doc -> Text) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
forall ann. Doc ann -> Text
renderOneLine) (Mon (State backend) Doc -> Mon (State backend) Text)
-> ((Text, HWType) -> Mon (State backend) Doc)
-> (Text, HWType)
-> Mon (State backend) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           Usage -> HWType -> Mon (State backend) Doc
forall state.
Backend state =>
Usage -> HWType -> Mon (State state) Doc
hdlType (Text -> Usage
External Text
topName) (HWType -> Mon (State backend) Doc)
-> ((Text, HWType) -> HWType)
-> (Text, HWType)
-> Mon (State backend) Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, HWType) -> HWType
forall a b. (a, b) -> b
snd) (Component -> [(Text, HWType)]
inputs Component
top)
      let topOutNames :: [Text]
topOutNames = ((WireOrReg, (Text, HWType)) -> Text)
-> [(WireOrReg, (Text, HWType))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, HWType) -> Text
forall a b. (a, b) -> a
fst ((Text, HWType) -> Text)
-> ((WireOrReg, (Text, HWType)) -> (Text, HWType))
-> (WireOrReg, (Text, HWType))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WireOrReg, (Text, HWType)) -> (Text, HWType)
forall a b. (a, b) -> b
snd) (Component -> [(WireOrReg, (Text, HWType))]
outputs Component
top)
      [Text]
topOutTypes <- ((WireOrReg, (Text, HWType)) -> Mon (State backend) Text)
-> [(WireOrReg, (Text, HWType))] -> Mon (State backend) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Doc -> Text)
-> Mon (State backend) Doc -> Mon (State backend) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Text.toStrict (Text -> Text) -> (Doc -> Text) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
forall ann. Doc ann -> Text
renderOneLine) (Mon (State backend) Doc -> Mon (State backend) Text)
-> ((WireOrReg, (Text, HWType)) -> Mon (State backend) Doc)
-> (WireOrReg, (Text, HWType))
-> Mon (State backend) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           Usage -> HWType -> Mon (State backend) Doc
forall state.
Backend state =>
Usage -> HWType -> Mon (State state) Doc
hdlType (Text -> Usage
External Text
topName) (HWType -> Mon (State backend) Doc)
-> ((WireOrReg, (Text, HWType)) -> HWType)
-> (WireOrReg, (Text, HWType))
-> Mon (State backend) Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, HWType) -> HWType
forall a b. (a, b) -> b
snd ((Text, HWType) -> HWType)
-> ((WireOrReg, (Text, HWType)) -> (Text, HWType))
-> (WireOrReg, (Text, HWType))
-> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WireOrReg, (Text, HWType)) -> (Text, HWType)
forall a b. (a, b) -> b
snd) (Component -> [(WireOrReg, (Text, HWType))]
outputs Component
top)
      let compNames :: [Text]
compNames = (([Bool], SrcSpan, HashMap Text Word, Component) -> Text)
-> [([Bool], SrcSpan, HashMap Text Word, Component)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Component -> Text
componentName (Component -> Text)
-> (([Bool], SrcSpan, HashMap Text Word, Component) -> Component)
-> ([Bool], SrcSpan, HashMap Text Word, Component)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
-> ([Bool], SrcSpan, HashMap Text Word, Component) -> Component
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
forall s t a b. Field4 s t a b => Lens s t a b
_4) [([Bool], SrcSpan, HashMap Text Word, Component)]
components
      Manifest -> Mon (State backend) Manifest
forall (m :: * -> *) a. Monad m => a -> m a
return (Manifest
m { portInNames :: [Text]
portInNames    = [Text]
topInNames
                , portInTypes :: [Text]
portInTypes    = [Text]
topInTypes
                , portOutNames :: [Text]
portOutNames   = [Text]
topOutNames
                , portOutTypes :: [Text]
portOutTypes   = [Text]
topOutTypes
                , componentNames :: [Text]
componentNames = [Text]
compNames
                })
    ) Either Manifest Manifest
manifestE
  let manDoc :: (FilePath, Doc ann)
manDoc = ( Text -> FilePath
Data.Text.unpack Text
topName FilePath -> FilePath -> FilePath
<.> "manifest"
               , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Text
Text.pack (Manifest -> FilePath
forall a. Show a => a -> FilePath
show Manifest
manifest)))
  ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
 [(FilePath, FilePath)])
-> Mon
     (State backend)
     ([(FilePath, Doc)], Manifest, [(FilePath, FilePath)],
      [(FilePath, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, Doc)
forall ann. (FilePath, Doc ann)
manDoc(FilePath, Doc) -> [(FilePath, Doc)] -> [(FilePath, Doc)]
forall a. a -> [a] -> [a]
:[(FilePath, Doc)]
topFiles,Manifest
manifest,[(FilePath, FilePath)]
dataFiles,[(FilePath, FilePath)]
memFiles)

-- | Prepares the directory for writing HDL files. This means creating the
--   dir if it does not exist and removing all existing .hdl files from it.
prepareDir :: Bool -- ^ Remove existing HDL files
           -> String -- ^ File extension of the HDL files.
           -> String
           -> IO ()
prepareDir :: Bool -> FilePath -> FilePath -> IO ()
prepareDir cleanhdl :: Bool
cleanhdl ext :: FilePath
ext dir :: FilePath
dir = do
  -- Create the dir if needed
  Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
True FilePath
dir
  -- Clean the directory when needed
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cleanhdl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Find all HDL files in the directory
    [FilePath]
files <- FilePath -> IO [FilePath]
Directory.getDirectoryContents FilePath
dir
    let to_remove :: [FilePath]
to_remove = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
ext) (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FilePath.takeExtension) [FilePath]
files
    -- Prepend the dirname to the filenames
    let abs_to_remove :: [FilePath]
abs_to_remove = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
FilePath.combine FilePath
dir) [FilePath]
to_remove
    -- Remove the files
    (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
Directory.removeFile [FilePath]
abs_to_remove

-- | Writes a HDL file to the given directory
writeHDL :: FilePath -> (String, Doc) -> IO ()
writeHDL :: FilePath -> (FilePath, Doc) -> IO ()
writeHDL dir :: FilePath
dir (cname :: FilePath
cname, hdl :: Doc
hdl) = do
  let rendered :: Text
rendered = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine 120 0.4)) Doc
hdl)
      -- remove blank lines to keep things clean
      clean :: Text -> Text
clean = [Text] -> Text
Text.unlines
            ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\t :: Text
t -> if (Char -> Bool) -> Text -> Bool
Text.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ') Text
t then Text
Text.empty else Text
t)
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
  IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
IO.openFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
cname) IOMode
IO.WriteMode) Handle -> IO ()
IO.hClose ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
    Handle -> Text -> IO ()
Text.hPutStr Handle
h (Text -> Text
clean Text
rendered)
    Handle -> Text -> IO ()
Text.hPutStr Handle
h (FilePath -> Text
Text.pack "\n")

-- | Copy given files
writeMemoryDataFiles
    :: FilePath
    -- ^ Directory to copy  files to
    -> [(String, String)]
    -- ^ (filename, content)
    -> IO ()
writeMemoryDataFiles :: FilePath -> [(FilePath, FilePath)] -> IO ()
writeMemoryDataFiles dir :: FilePath
dir files :: [(FilePath, FilePath)]
files =
    ((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      ((FilePath -> FilePath -> IO ()) -> (FilePath, FilePath) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FilePath -> IO ()
writeFile)
      [(FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
fname, FilePath
content) | (fname :: FilePath
fname, content :: FilePath
content) <- [(FilePath, FilePath)]
files]

copyDataFiles
    :: [FilePath]
    -> FilePath
    -> [(String,FilePath)]
    -> IO ()
copyDataFiles :: [FilePath] -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyDataFiles idirs :: [FilePath]
idirs dir :: FilePath
dir = ((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([FilePath] -> (FilePath, FilePath) -> IO ()
copyFile' [FilePath]
idirs)
  where
    copyFile' :: [FilePath] -> (FilePath, FilePath) -> IO ()
copyFile' dirs :: [FilePath]
dirs (nm :: FilePath
nm,old :: FilePath
old) = do
      Bool
oldExists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
old
      if Bool
oldExists
        then FilePath -> FilePath -> IO ()
Directory.copyFile FilePath
old FilePath
new
        else [FilePath] -> IO ()
goImports [FilePath]
dirs
      where
        new :: FilePath
new = FilePath
dir FilePath -> FilePath -> FilePath
FilePath.</> FilePath
nm

        goImports :: [FilePath] -> IO ()
goImports [] = do
          Bool
oldExists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
old
          if Bool
oldExists
            then FilePath -> FilePath -> IO ()
Directory.copyFile FilePath
old FilePath
new
            else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
old) (FilePath -> IO ()
putStrLn ("WARNING: file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
old FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " does not exist"))
        goImports (d :: FilePath
d:ds :: [FilePath]
ds) = do
          let old2 :: FilePath
old2 = FilePath
d FilePath -> FilePath -> FilePath
FilePath.</> FilePath
old
          Bool
old2Exists <- FilePath -> IO Bool
Directory.doesFileExist FilePath
old2
          if Bool
old2Exists
            then FilePath -> FilePath -> IO ()
Directory.copyFile FilePath
old2 FilePath
new
            else [FilePath] -> IO ()
goImports [FilePath]
ds

-- | Get all the terms corresponding to a call graph
callGraphBindings
  :: BindingMap
  -- ^ All bindings
  -> Id
  -- ^ Root of the call graph
  -> [Term]
callGraphBindings :: BindingMap -> Id -> [Term]
callGraphBindings bindingsMap :: BindingMap
bindingsMap tm :: Id
tm =
  (Int -> Term) -> [Int] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (((Id, SrcSpan, InlineSpec, Term)
-> Getting Term (Id, SrcSpan, InlineSpec, Term) Term -> Term
forall s a. s -> Getting a s a -> a
^. Getting Term (Id, SrcSpan, InlineSpec, Term) Term
forall s t a b. Field4 s t a b => Lens s t a b
_4) ((Id, SrcSpan, InlineSpec, Term) -> Term)
-> (Int -> (Id, SrcSpan, InlineSpec, Term)) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BindingMap
bindingsMap BindingMap -> Int -> (Id, SrcSpan, InlineSpec, Term)
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'`)) (UniqMap (VarEnv Word) -> [Int]
forall a. UniqMap a -> [Int]
keysUniqMap UniqMap (VarEnv Word)
cg)
  where
    cg :: UniqMap (VarEnv Word)
cg = BindingMap -> Id -> UniqMap (VarEnv Word)
callGraph BindingMap
bindingsMap Id
tm

-- | Normalize a complete hierarchy
normalizeEntity
  :: CustomReprs
  -> BindingMap
  -- ^ All bindings
  -> CompiledPrimMap
  -- ^ BlackBox HDL templates
  -> TyConMap
  -- ^ TyCon cache
  -> IntMap TyConName
  -- ^ Tuple TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> PrimEvaluator
  -- ^ Hardcoded evaluator (delta-reduction)
  -> [Id]
  -- ^ TopEntities
  -> ClashOpts
  -- ^ Debug information level for the normalization process
  -> Supply.Supply
  -- ^ Unique supply
  -> Id
  -- ^ root of the hierarchy
  -> BindingMap
normalizeEntity :: CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> PrimEvaluator
-> [Id]
-> ClashOpts
-> Supply
-> Id
-> BindingMap
normalizeEntity reprs :: CustomReprs
reprs bindingsMap :: BindingMap
bindingsMap primMap :: CompiledPrimMap
primMap tcm :: TyConMap
tcm tupTcm :: IntMap TyConName
tupTcm typeTrans :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans eval :: PrimEvaluator
eval topEntities :: [Id]
topEntities
  opts :: ClashOpts
opts supply :: Supply
supply tm :: Id
tm = BindingMap
transformedBindings
  where
    doNorm :: RewriteMonad NormalizeState BindingMap
doNorm = do BindingMap
norm <- [Id] -> RewriteMonad NormalizeState BindingMap
normalize [Id
tm]
                let normChecked :: BindingMap
normChecked = BindingMap -> BindingMap
checkNonRecursive BindingMap
norm
                BindingMap
cleaned <- Id -> BindingMap -> RewriteMonad NormalizeState BindingMap
cleanupGraph Id
tm BindingMap
normChecked
                BindingMap -> RewriteMonad NormalizeState BindingMap
forall (m :: * -> *) a. Monad m => a -> m a
return BindingMap
cleaned
    transformedBindings :: BindingMap
transformedBindings = ClashOpts
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> CustomReprs
-> TyConMap
-> IntMap TyConName
-> PrimEvaluator
-> CompiledPrimMap
-> VarEnv Bool
-> [Id]
-> RewriteMonad NormalizeState BindingMap
-> BindingMap
forall a.
ClashOpts
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either FilePath FilteredHWType)))
-> CustomReprs
-> TyConMap
-> IntMap TyConName
-> PrimEvaluator
-> CompiledPrimMap
-> VarEnv Bool
-> [Id]
-> NormalizeSession a
-> a
runNormalization ClashOpts
opts Supply
supply BindingMap
bindingsMap
                            CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either FilePath FilteredHWType))
typeTrans CustomReprs
reprs TyConMap
tcm IntMap TyConName
tupTcm PrimEvaluator
eval CompiledPrimMap
primMap VarEnv Bool
forall a. VarEnv a
emptyVarEnv
                            [Id]
topEntities RewriteMonad NormalizeState BindingMap
doNorm