{-|
  Copyright   :  (C) 2020,2022 QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Blackbox implementations for "Clash.Sized.Internal.*.toInteger#".
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Clash.Primitives.Sized.ToInteger
  ( bvToIntegerVerilog
  , bvToIntegerVHDL
  , indexToIntegerVerilog
  , indexToIntegerVHDL
  , signedToIntegerVerilog
  , signedToIntegerVHDL
  , unsignedToIntegerVerilog
  , unsignedToIntegerVHDL
  )
where

import qualified Control.Lens as Lens
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Text.Lazy (pack)
import System.IO (hPutStrLn, stderr)
import Text.Trifecta.Result (Result(Success))

#if MIN_VERSION_ghc(9,8,0)
import GHC.Unit.Module.Warnings (emptyWarningCategorySet)
import GHC.Utils.Error
  (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)
import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
   defaultSDocContext )
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
import GHC.Types.SrcLoc (isGoodSrcSpan)
#elif MIN_VERSION_ghc(9,6,0)
import GHC.Utils.Error
  (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)
import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
   defaultSDocContext )
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
import GHC.Types.SrcLoc (isGoodSrcSpan)
#elif MIN_VERSION_ghc(9,4,0)
import GHC.Utils.Error
  (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelope)
import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
   defaultSDocContext )
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
import GHC.Types.SrcLoc (isGoodSrcSpan)
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Error (mkPlainWarnMsg, pprLocMsgEnvelope)
import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc (isGoodSrcSpan)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Driver.Session (unsafeGlobalDynFlags)
import GHC.Utils.Error (mkPlainWarnMsg, pprLocErrMsg)
import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc (isGoodSrcSpan)
#else
import DynFlags (unsafeGlobalDynFlags)
import ErrUtils (mkPlainWarnMsg, pprLocErrMsg)
import Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
import qualified Outputable
import SrcLoc (isGoodSrcSpan)
#endif

import Clash.Annotations.Primitive (HDL (Verilog,VHDL))
import Clash.Core.Type (Type (LitTy), LitTy (NumTy))
import Clash.Netlist.BlackBox.Parser (runParse)
import Clash.Netlist.BlackBox.Types
  (BlackBoxFunction, BlackBoxMeta (bbKind), TemplateKind (TExpr),
   emptyBlackBoxMeta)
import Clash.Netlist.Types
  (BlackBox (BBTemplate), HWType (..), curCompNm, intWidth)
import Clash.Util (clogBase)

bvToIntegerVerilog, bvToIntegerVHDL, indexToIntegerVerilog,
  indexToIntegerVHDL,  signedToIntegerVerilog, signedToIntegerVHDL,
  unsignedToIntegerVerilog, unsignedToIntegerVHDL :: BlackBoxFunction

bvToIntegerVerilog :: BlackBoxFunction
bvToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
BitVector Size
0)
bvToIntegerVHDL :: BlackBoxFunction
bvToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
BitVector Size
0)
indexToIntegerVerilog :: BlackBoxFunction
indexToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Integer -> HWType
Index Integer
0)
indexToIntegerVHDL :: BlackBoxFunction
indexToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Integer -> HWType
Index Integer
0)
signedToIntegerVerilog :: BlackBoxFunction
signedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
Signed Size
0)
signedToIntegerVHDL :: BlackBoxFunction
signedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
Signed Size
0)
unsignedToIntegerVerilog :: BlackBoxFunction
unsignedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
Unsigned Size
0)
unsignedToIntegerVHDL :: BlackBoxFunction
unsignedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
Unsigned Size
0)

toIntegerBB :: HDL -> HWType -> BlackBoxFunction
toIntegerBB :: HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
hdl HWType
hty Bool
_isD Text
_primName [Either Term Type]
args [Type]
_ty = do
  case [Either Term Type]
args of
    (Right (LitTy (NumTy Integer
i)):[Either Term Type]
_) -> do
      Size
iw <- Getting Size NetlistEnv Size -> NetlistMonad Size
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Size NetlistEnv Size
Getter NetlistEnv Size
intWidth
      let i1 :: Integer
i1 = Integer -> Integer
width Integer
i
      Bool -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer -> Size
forall a. Num a => Integer -> a
fromInteger Integer
i1 Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
iw) (NetlistMonad () -> NetlistMonad ())
-> NetlistMonad () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ do
        (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
        let srcInfo1 :: SDoc
srcInfo1 | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp = SDoc
srcInfo
                     | Bool
otherwise        = SDoc
empty
#if MIN_VERSION_ghc(9,8,0)
            opts     = DiagOpts mempty mempty emptyWarningCategorySet emptyWarningCategorySet False False Nothing defaultSDocContext
            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
            warnMsg1 = mkPlainMsgEnvelope opts sp diag
            warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1
#elif MIN_VERSION_ghc(9,6,0)
            opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext
            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
            warnMsg1 = mkPlainMsgEnvelope opts sp diag
            warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1
#elif MIN_VERSION_ghc(9,4,0)
            opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext
            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
            warnMsg1 = mkPlainMsgEnvelope opts sp diag
            warnMsg2 = pprLocMsgEnvelope warnMsg1
#elif MIN_VERSION_ghc(9,2,0)
            warnMsg1 = mkPlainWarnMsg sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
            warnMsg2 = pprLocMsgEnvelope warnMsg1
#else
            warnMsg1 :: ErrMsg
warnMsg1 = DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
unsafeGlobalDynFlags SrcSpan
sp (Integer -> Size -> SDoc
warnMsg Integer
i1 Size
iw SDoc -> SDoc -> SDoc
$+$ SDoc
blankLine SDoc -> SDoc -> SDoc
$+$ SDoc
srcInfo1)
            warnMsg2 :: SDoc
warnMsg2 = ErrMsg -> SDoc
pprLocErrMsg ErrMsg
warnMsg1
#endif

        IO () -> NetlistMonad ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr (SDoc -> String
showSDocUnsafe SDoc
warnMsg2))
    [Either Term Type]
_ -> () -> NetlistMonad ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBoxMeta
meta,) (BlackBox -> (BlackBoxMeta, BlackBox))
-> Either String BlackBox -> Either String (BlackBoxMeta, BlackBox)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String BlackBox
bb)
 where
  meta :: BlackBoxMeta
meta = BlackBoxMeta
emptyBlackBoxMeta{bbKind :: TemplateKind
bbKind=TemplateKind
TExpr}

  bb :: Either String BlackBox
bb = BlackBoxTemplate -> BlackBox
BBTemplate (BlackBoxTemplate -> BlackBox)
-> Either String BlackBoxTemplate -> Either String BlackBox
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text -> Result BlackBoxTemplate
runParse (String -> Text
pack String
bbText) of
         Success BlackBoxTemplate
t -> BlackBoxTemplate -> Either String BlackBoxTemplate
forall a b. b -> Either a b
Right BlackBoxTemplate
t
         Result BlackBoxTemplate
_         -> String -> Either String BlackBoxTemplate
forall a b. a -> Either a b
Left String
"internal error: parse fail"

  bbText :: String
bbText = case HDL
hdl of
    HDL
VHDL -> case HWType
hty of
      BitVector {} -> String
"~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      Index {}     -> String
"~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      Signed {}    -> String
"~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI"
      Unsigned {}  -> String
"~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      HWType
_            -> String -> String
forall a. HasCallStack => String -> a
error String
"internal error"
    HDL
_ -> case HWType
hty of
      BitVector {} -> String
"~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
      Index {}     -> String
"~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
      Signed {}    -> String
"~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
      Unsigned {}  -> String
"~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
      HWType
_            -> String -> String
forall a. HasCallStack => String -> a
error String
"internal error"

  tyName :: SDoc
tyName = case HWType
hty of
    BitVector {} -> String -> SDoc
text String
"BitVector"
    Index {} -> String -> SDoc
text String
"Index"
    Signed {} -> String -> SDoc
text String
"Signed"
    Unsigned {} -> String -> SDoc
text String
"Unsigned"
    HWType
_ -> String -> SDoc
forall a. HasCallStack => String -> a
error String
"internal error"

  width :: Integer -> Integer
width Integer
i = case HWType
hty of
    Index {} -> Integer -> (Size -> Integer) -> Maybe Size -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Size -> Integer
forall a. Integral a => a -> Integer
toInteger (Integer -> Integer -> Maybe Size
clogBase Integer
2 Integer
i)
    HWType
_ -> Integer
i

  warnMsg :: Integer -> Size -> SDoc
warnMsg Integer
i Size
iw =
   SDoc
tyName SDoc -> SDoc -> SDoc
Outputable.<> String -> SDoc
text String
".toInteger: Integer width," SDoc -> SDoc -> SDoc
<+> Size -> SDoc
int Size
iw SDoc -> SDoc -> SDoc
Outputable.<>
   String -> SDoc
text String
", is smaller than" SDoc -> SDoc -> SDoc
<+> SDoc
tyName SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"width," SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
i SDoc -> SDoc -> SDoc
Outputable.<>
   String -> SDoc
text String
". Dropping MSBs." SDoc -> SDoc -> SDoc
$+$
   String -> SDoc
text String
"Are you using 'fromIntegral' to convert between types?" SDoc -> SDoc -> SDoc
<+>
   String -> SDoc
text String
"Use 'bitCoerce' instead."

  srcInfo :: SDoc
srcInfo =
   String -> SDoc
text String
"NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." SDoc -> SDoc -> SDoc
$$
   String -> SDoc
text String
"The actual location of the error can be in a function that is inlined." SDoc -> SDoc -> SDoc
$$
   String -> SDoc
text String
"To prevent inlining of those functions, annotate them with a NOINLINE pragma."