<commit_before>{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
module CLaSH.Driver where

import           Control.Monad.State          (evalState)
import           Data.Maybe                   (catMaybes,listToMaybe)
import qualified Control.Concurrent.Supply    as Supply
import qualified Data.HashMap.Lazy            as HashMap
import           Data.List                    (isSuffixOf)
import qualified Data.Text.Lazy               as Text
import qualified System.Directory             as Directory
import qualified System.FilePath              as FilePath
import qualified System.IO                    as IO
import           Text.PrettyPrint.Leijen.Text (Doc,hPutDoc)
import           Unbound.LocallyNameless      (name2String)

import           CLaSH.Core.Term              (TmName)
import           CLaSH.Core.Type              (Type)
import           CLaSH.Driver.TestbenchGen
import           CLaSH.Driver.Types
import           CLaSH.Netlist                (genNetlist)
import           CLaSH.Netlist.VHDL           (genVHDL,mkTyPackage)
import           CLaSH.Netlist.Types          (Component(..),HWType)
import           CLaSH.Normalize              (runNormalization, normalize, checkNonRecursive, cleanupGraph)
import           CLaSH.Primitives.Types
import           CLaSH.Rewrite.Types          (DebugLevel(..))
import           CLaSH.Util

import qualified Data.Time.Clock as Clock

generateVHDL :: BindingMap
             -> ClassOpMap
             -> DFunMap
             -> PrimMap
             -> (Type -> Maybe (Either String HWType))
             -> DebugLevel
             -> IO ()
generateVHDL bindingsMap clsOpMap dfunMap primMap typeTrans dbgLevel = do
  start <- Clock.getCurrentTime

  let topEntities = HashMap.toList
                  $ HashMap.filterWithKey isTopEntity bindingsMap

      testInputs  = HashMap.toList
                  $ HashMap.filterWithKey isTestInput bindingsMap

      expectedOutputs = HashMap.toList
                      $ HashMap.filterWithKey isExpectedOutput bindingsMap

  case topEntities of
    [topEntity] -> do
      (supplyN,supplyTB) <- fmap (Supply.splitSupply . snd .  Supply.freshId) Supply.newSupply

      prepTime <- dfunMap `seq` Clock.getCurrentTime
      traceIf True ("Loading dependencies took " ++ show (Clock.diffUTCTime prepTime start)) $ return ()

      let transformedBindings
            = runNormalization dbgLevel supplyN bindingsMap dfunMap clsOpMap typeTrans
            $ (normalize [fst topEntity]) >>= checkNonRecursive (fst topEntity) >>= cleanupGraph [fst topEntity]

      normTime <- transformedBindings `seq` Clock.getCurrentTime
      traceIf True ("Normalisation took " ++ show (Clock.diffUTCTime normTime prepTime)) $ return ()

      (netlist,vhdlState) <- genNetlist Nothing (HashMap.fromList $ transformedBindings)
                              primMap
                              typeTrans
                              Nothing
                              (fst topEntity)

      netlistTime <- netlist `seq` Clock.getCurrentTime
      traceIf True ("Netlist generation took " ++ show (Clock.diffUTCTime netlistTime normTime)) $ return ()

      (testBench,vhdlState') <- genTestBench DebugNone supplyTB dfunMap clsOpMap primMap typeTrans vhdlState
                                  bindingsMap
                                  (listToMaybe $ map fst testInputs)
                                  (listToMaybe $ map fst expectedOutputs)
                                  (head $ filter (\(Component cName _ _ _ _) -> Text.isSuffixOf (Text.pack "topEntity_0") cName) netlist)

      testBenchTime <- testBench `seq` Clock.getCurrentTime
      traceIf True ("Testbench generation took " ++ show (Clock.diffUTCTime testBenchTime netlistTime)) $ return ()

      let (vhdlNms,vhdlDocs,typesPkgM) = flip evalState vhdlState' $ do
            { (vhdlNms',typeDocsM,vhdlDocs') <- fmap unzip3 $ mapM genVHDL (netlist ++ testBench)
            ; let (typeDecDocs,typeBodyDocs) = ((catMaybes >< catMaybes) . unzip) typeDocsM
            ; typesPkgM'  <- case typeDecDocs of
                              [] -> return Nothing
                              _  -> Just <$> mkTyPackage (typeDecDocs,typeBodyDocs)
            ; return (vhdlNms',vhdlDocs',typesPkgM')
            }<commit_msg>Also show debug messages for testbench generation<commit_after>{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
module CLaSH.Driver where

import           Control.Monad.State          (evalState)
import           Data.Maybe                   (catMaybes,listToMaybe)
import qualified Control.Concurrent.Supply    as Supply
import qualified Data.HashMap.Lazy            as HashMap
import           Data.List                    (isSuffixOf)
import qualified Data.Text.Lazy               as Text
import qualified System.Directory             as Directory
import qualified System.FilePath              as FilePath
import qualified System.IO                    as IO
import           Text.PrettyPrint.Leijen.Text (Doc,hPutDoc)
import           Unbound.LocallyNameless      (name2String)

import           CLaSH.Core.Term              (TmName)
import           CLaSH.Core.Type              (Type)
import           CLaSH.Driver.TestbenchGen
import           CLaSH.Driver.Types
import           CLaSH.Netlist                (genNetlist)
import           CLaSH.Netlist.VHDL           (genVHDL,mkTyPackage)
import           CLaSH.Netlist.Types          (Component(..),HWType)
import           CLaSH.Normalize              (runNormalization, normalize, checkNonRecursive, cleanupGraph)
import           CLaSH.Primitives.Types
import           CLaSH.Rewrite.Types          (DebugLevel(..))
import           CLaSH.Util

import qualified Data.Time.Clock as Clock

generateVHDL :: BindingMap
             -> ClassOpMap
             -> DFunMap
             -> PrimMap
             -> (Type -> Maybe (Either String HWType))
             -> DebugLevel
             -> IO ()
generateVHDL bindingsMap clsOpMap dfunMap primMap typeTrans dbgLevel = do
  start <- Clock.getCurrentTime

  let topEntities = HashMap.toList
                  $ HashMap.filterWithKey isTopEntity bindingsMap

      testInputs  = HashMap.toList
                  $ HashMap.filterWithKey isTestInput bindingsMap

      expectedOutputs = HashMap.toList
                      $ HashMap.filterWithKey isExpectedOutput bindingsMap

  case topEntities of
    [topEntity] -> do
      (supplyN,supplyTB) <- fmap (Supply.splitSupply . snd .  Supply.freshId) Supply.newSupply

      prepTime <- dfunMap `seq` Clock.getCurrentTime
      traceIf True ("Loading dependencies took " ++ show (Clock.diffUTCTime prepTime start)) $ return ()

      let transformedBindings
            = runNormalization dbgLevel supplyN bindingsMap dfunMap clsOpMap typeTrans
            $ (normalize [fst topEntity]) >>= checkNonRecursive (fst topEntity) >>= cleanupGraph [fst topEntity]

      normTime <- transformedBindings `seq` Clock.getCurrentTime
      traceIf True ("Normalisation took " ++ show (Clock.diffUTCTime normTime prepTime)) $ return ()

      (netlist,vhdlState) <- genNetlist Nothing (HashMap.fromList $ transformedBindings)
                              primMap
                              typeTrans
                              Nothing
                              (fst topEntity)

      netlistTime <- netlist `seq` Clock.getCurrentTime
      traceIf True ("Netlist generation took " ++ show (Clock.diffUTCTime netlistTime normTime)) $ return ()

      (testBench,vhdlState') <- genTestBench dbgLevel supplyTB dfunMap clsOpMap primMap typeTrans vhdlState
                                  bindingsMap
                                  (listToMaybe $ map fst testInputs)
                                  (listToMaybe $ map fst expectedOutputs)
                                  (head $ filter (\(Component cName _ _ _ _) -> Text.isSuffixOf (Text.pack "topEntity_0") cName) netlist)

      testBenchTime <- testBench `seq` Clock.getCurrentTime
      traceIf True ("Testbench generation took " ++ show (Clock.diffUTCTime testBenchTime netlistTime)) $ return ()

      let (vhdlNms,vhdlDocs,typesPkgM) = flip evalState vhdlState' $ do
            { (vhdlNms',typeDocsM,vhdlDocs') <- fmap unzip3 $ mapM genVHDL (netlist ++ testBench)
            ; let (typeDecDocs,typeBodyDocs) = ((catMaybes >< catMaybes) . unzip) typeDocsM
            ; typesPkgM'  <- case typeDecDocs of
                              [] -> return Nothing
                              _  -> Just <$> mkTyPackage (typeDecDocs,typeBodyDocs)
            ; return (vhdlNms',vhdlDocs',typesPkgM')
            }
{'fraction_non_alphanumeric': 0.07721130918587488, 'fraction_numerical': 0.0006812762575224253, 'mean_word_length': 1.9213930348258705, 'pattern_counts': {'":': 0, '<': 27, '<?xml version=': 0, '>': 37, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1314088', 'n_tokens_mistral': 2482, 'n_tokens_neox': 2361, 'n_words': 572}