content: {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, CPP #-}
  module TopUtils where
  
  -- Haskell libs
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  import Text.Printf(printf)
  import System.IO(hFlush, stdout)
  import System.CPUTime(getCPUTime)
  import Control.Monad(when, unless)
  import Control.Monad.Trans(MonadIO(..))
  import System.Time -- XXX: from old-time package
  -- hbc libs
  import PFPrint
  -- utility libs
  import Util(itos)
  import FileNameUtil(baseName, dropSuf)
  import FileIOUtil(writeFileCatch)
  
  -- compiler libs
  import Flags( Flags(..), verbose, quiet,
               DumpFlag(..), dumpInfo)
  -- import CSyntax
  import CVPrint
  import IdPrint
  import ISyntax(IPackage(..), IModule(..),
                 IStateVar(..), IRules(..))
  import ASyntax(APackage(..), ASPackage(..), ARule(..),
                 aIfaceName)
  import SystemVerilogTokens(SV_Token(..))
  import Version(bluespec, bscVersionStr)
  
  import Error(ErrorHandle, exitOK)
  
  import Eval
  --import Debug.Trace
  
  dfltBluespecDir, dfltVSim, dfltMACRODEF :: String
  dfltBluespecDir = "/usr/local/lib/" ++ bluespec
  dfltVSim = "iverilog"
  dfltMACRODEF = "-D"
  
  dfltCCompile, dfltCxxCompile :: String
  dfltCCompile = "cc"
  dfltCxxCompile = "c++"
  dfltCFLAGS, dfltBSC_CFLAGS, dfltCXXFLAGS,dfltBSC_CXXFLAGS :: String
  dfltCFLAGS = "-O3"
  dfltBSC_CFLAGS = "-Wall -Wno-unused -D_FILE_OFFSET_BITS=64"
  dfltCXXFLAGS = "-O3"
  dfltBSC_CXXFLAGS = "-Wall -Wno-unused -D_FILE_OFFSET_BITS=64"
  
  dfltMake, dfltBSC_MAKEFLAGS :: String
  dfltMake = "make"
  -- MAKEFLAGS is a reserved variable that make uses for recursive calls;
  -- it should not be explicitly added to calls to 'make'
  --dfltMAKEFLAGS = ""
  dfltBSC_MAKEFLAGS = ""
  
  fmtDouble :: Double -> String
  fmtDouble = printf "%.2f"
  
  start :: Flags -> DumpFlag -> IO ()
  start flags d = when (verbose flags) (putStrLnF ("starting " ++ drop 2 (show d)) >> hFlush stdout)
  
  type DumpNames = (String {- file name (last path component) -}, String {- package name -}, String {- module name or empty -})
  
  dump :: (PPrint a, Hyper a) =>
          ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a
       -> IO TimeInfo
  dump errh flags t d names a =
          hyper a $        -- force evaluation
          dumpStr errh flags t d names (ppReadable a)
  
  ddump :: (PPrint a, Hyper a) =>
          ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a
       -> IO TimeInfo
  ddump errh flags t d names a =
          hyper a $        -- force evaluation
          dumpStr errh flags t d names (ppDebug a)
  
  vdump :: (PVPrint a, Hyper a) =>
          ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a
       -> IO TimeInfo
  vdump errh flags t d names a =
          hyper a $        -- force evaluation
          dumpStr errh flags t d names (pvpReadable a)
  
  
  sdump :: (Show a, Hyper a) =>
          ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> a
       -> IO TimeInfo
  sdump errh flags t d names a =
          hyper a $        -- force evaluation
          dumpStr errh flags t d names (show a)
  
  
  dumpStr :: ErrorHandle -> Flags -> TimeInfo -> DumpFlag -> DumpNames -> String
          -> IO TimeInfo
  dumpStr errh flags t d names@(file, pkg, mod) a = do
      -- the name of this stage
      let sname = drop 2 (show d)
      -- first, dump the info appropriately
      case (dumpInfo flags d) of
          Just (Just file) -> do
              writeFileCatch errh (substNames names file) a
              when (verbose flags) $ putStrLnF (sname ++ " done")
          Just Nothing -> do
              unless (quiet flags) $ putStrLnF ("=== " ++ sname ++ ":\n" ++ a ++ "\n-----\n")
          Nothing -> do
              when (verbose flags) $ putStrLnF (sname ++ " done")
      -- second, dump the timestamp (and get the new time)
      t' <- timestamp flags t
      -- finally, decide whether to exit here
      case (kill flags) of
          (Just (pass, Nothing))
            | pass == d -> do
               putStrLnF ("\ncompilation stopped because of -KILL" ++
                          sname ++ " flag")
               exitOK errh
          (Just (pass, Just pkg_or_mod))
            | pass == d && (pkg_or_mod == pkg || pkg_or_mod == mod) -> do
               putStrLnF ("\ncompilation stopped because of -KILL" ++
                          sname ++ "=" ++ pkg_or_mod ++ " flag")
               exitOK errh
          _ -> -- don't exit here, return the new time
               return t'
  
  substNames :: (String,String, String) -> String -> String
  substNames _ "" = ""
  substNames names@(file,pkg,mod) ('%':c:cs) = subst ++ substNames names cs
      where subst = case c of
                    '%' -> "%"
                    'f' -> file
                    'p' -> pkg
                    'm' -> mod
                    c'  -> [c']
  substNames names (c:cs) = c : substNames names cs
  
  timestamp :: Flags -> TimeInfo -> IO TimeInfo
  timestamp flags t = do
          t' <- getNow
          when (verbose flags) $
              printElapsed t t'
          return t'
  
  -- a simplfiied "dumpStr" which only prints a title and the timestamp
  timestampStr :: Flags -> String -> TimeInfo -> IO TimeInfo
  timestampStr flags title t = do
          t' <- getNow
          when (verbose flags) $ do
              putStrLnF title
              printElapsed t t'
          return t'
  
  withElapsed :: MonadIO m => m a -> m a
  withElapsed m = do
    t   <- liftIO getNow
    res <- m
    t'  <- liftIO getNow
    liftIO $ printElapsed t t'
    return res
  
  printElapsed :: TimeInfo -> TimeInfo -> IO ()
  printElapsed t t' = do
          let (dc, dr) = diffTimeInfo t t'
          putStrLnF (" elapsed time: CPU " ++ fmtDouble dc ++ "s, real " ++ fmtDouble dr ++ "s\n")
  
  
  stats :: (Stats a) => Flags -> DumpFlag -> a -> IO ()
  stats flags df a =
      if not (showStats flags) then
          return ()
      else do
          putStrLn (pretty 78 78 (text ("stats " ++ drop 2 (show df) ++ ":") $+$ (text "  " <> pStats (verbose flags) a)))
  
  --hyperEval x = hyper x (return ())
  
  
  -----------------------------------------------------------------------------------------------------
  putInDir :: Maybe String -> String -> String -> String
  putInDir Nothing name suf = dropSuf name ++ "." ++ suf
  putInDir (Just d) name suf = d ++ "/" ++ baseName (dropSuf name) ++ "." ++ suf
  
  -----
  
  commentC, commentV :: [String] -> String
  commentC ls = unlines (["/*"] ++ map (" * " ++) ls ++ [" */"])
  commentV ls = unlines (["//"] ++ map ("// " ++) ls ++ ["//"])
  
  -----
  
  getCPUTimeDoublePortable :: IO Double
  getCPUTimeDoublePortable = do
          t <- getCPUTime
          return (fromInteger t * 1.0e-12)
  
  data TimeInfo = TimeInfo Double ClockTime
          deriving (Show)
  
  getNow :: IO TimeInfo
  getNow = do
          t <- getCPUTimeDoublePortable
          ct <- getClockTime
          return (TimeInfo t ct)
  
  diffTimeInfo :: TimeInfo -> TimeInfo -> (Double, Double)
  diffTimeInfo (TimeInfo t ct) (TimeInfo t' ct') = (t'-t, tdToDouble (diffClockTimes ct' ct))
    where tdToDouble d = fromIntegral ((tdHour d * 60 + tdMin d) * 60 + tdSec d) + fromInteger (tdPicosec d) * 1.0e-12
  
  putStrLnF :: String -> IO ()
  putStrLnF s = do putStrLn s; hFlush stdout
  
  -----
  
  class Stats a where
      pStats :: Bool -> a -> Doc
  
  instance Stats CPackage where
      pStats _ (CPackage _ _ _ _ ds _) =
          showLen ds "definitions:" $+$
          (text "  " <> showLen [ () | CValueSign _ <- ds ] "values")
  
  instance Stats (IPackage a) where
      pStats _ (IPackage _ _ _ ds) =
          showLen ds "definitions"
  
  instance Stats (IModule a) where
      pStats _ (IModule { imod_name        = i,
                          imod_wire_args   = as,
                          imod_state_insts = vs,
                          imod_local_defs  = ds,
                          imod_rules       = rs,
                          imod_interface   = ifc }) =
          (text "module" <+> ppId PDReadable i) $+$
          (text "  " <> (
          showLen as "arguments" $+$
          showLen vs "state elements" $+$
          (text "  " <> showLen [ () | (_, IStateVar { isv_is_arg = False }) <- vs ] "interface arguments") $+$
          showLen ds "local definitions" $+$
          showCnt (countRules rs) "rules" $+$
          showLen ifc "interface methods"
          ))
            where countRules (IRules _ rs) = length rs
  
  instance Stats APackage where
      pStats v apkg =
          (text "module" <+> ppId PDReadable (apkg_name apkg)) $+$
          (text "  " <> (
          showLen (apkg_size_params apkg) "arguments" $+$
          showLen (apkg_state_instances apkg) "state elements" $+$
          showLen (apkg_local_defs apkg) "local definitions" $+$
          (showLen (apkg_rules apkg) "rules" <>
           if v then text "" <+>pPrint PDReadable 0 [ i | ARule { arule_id = i } <- apkg_rules apkg ] else text "") $+$
          (showLen (apkg_interface apkg) "interface methods" <>
           if v then text "" <+> pPrint PDReadable 0 (map aIfaceName (apkg_interface apkg)) else text "")
          ))
  
  instance Stats ASPackage where
      pStats _ (ASPackage i _ _ os is ios vs sos ds _ fs _ _ _) =
          (text "module" <+> ppId PDReadable i) $+$
          (text "  " <> (
          showLen os "outputs" $+$
          showLen is "inputs" $+$
          showLen ios "inouts" $+$
          showLen vs "state elements" $+$
          showLen sos "state elements outputs" $+$
          showLen ds "local definitions" $+$
          showLen fs "foreign function calls"))
  
  instance Stats [SV_Token] where
      pStats _ toks = showLen toks "tokens"
  
  -- verilog preprocessor output
  newtype VPPOut = VPPOut (String, [String])
    deriving(Hyper)
  
  instance PPrint VPPOut where
    pPrint d p (VPPOut (source,includes)) = text source
  
  instance Stats VPPOut where
      pStats _ (VPPOut (source,includes)) =
        showLen (lines source) "post-preprocessing source lines" $+$
        showLen includes "included files"
  
  showLen :: [a] -> String -> Doc
  showLen xs s = showCnt (length xs) s
  
  showCnt :: Int -> String -> Doc
  showCnt cnt s = text $ itos cnt ++ " " ++ s
  
  -- ------------
  
  -- | Makes a timestamp string for generated code, respecting the timeStamps flag
  mkTimestampComment :: Flags -> IO String
  mkTimestampComment flags
    | timeStamps flags = getClockTime >>= return . ("On " ++) . show
    | otherwise        = return ""
  
  mkGenFileHeader :: Flags -> IO [String]
  mkGenFileHeader flags = do
    ts <- mkTimestampComment flags
    let compiler = bscVersionStr (showVersion flags)
        -- Take a list of comment lines. If empty, delete them, else
        -- put a newline after the comment to separate them.
        addBlanks = concatMap (\x -> if x == "" then [] else [x, ""])
    return $ addBlanks ["Generated by " ++ compiler, ts]
  