ToInteger.hs

{-|
  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)
#else
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)
#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 = toIntegerBB Verilog (BitVector 0)
bvToIntegerVHDL = toIntegerBB VHDL (BitVector 0)
indexToIntegerVerilog = toIntegerBB Verilog (Index 0)
indexToIntegerVHDL = toIntegerBB VHDL (Index 0)
signedToIntegerVerilog = toIntegerBB Verilog (Signed 0)
signedToIntegerVHDL = toIntegerBB VHDL (Signed 0)
unsignedToIntegerVerilog = toIntegerBB Verilog (Unsigned 0)
unsignedToIntegerVHDL = toIntegerBB VHDL (Unsigned 0)

toIntegerBB :: HDL -> HWType -> BlackBoxFunction
toIntegerBB hdl hty _isD _primName args _ty = do
  case args of
    (Right (LitTy (NumTy i)):_) -> do
      iw <- Lens.view intWidth
      let i1 = width i
      when (fromInteger i1 > iw) $ do
        (_,sp) <- Lens.use curCompNm
        let srcInfo1 | isGoodSrcSpan sp = srcInfo
                     | otherwise        = 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
#else
            opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext
            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
            warnMsg1 = mkPlainMsgEnvelope opts sp diag
            warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1
#endif

        liftIO (hPutStrLn stderr (showSDocUnsafe warnMsg2))
    _ -> return ()
  return ((meta,) <$> bb)
 where
  meta = emptyBlackBoxMeta{bbKind=TExpr}

  bb = BBTemplate <$> case runParse (pack bbText) of
         Success t -> Right t
         _         -> Left "internal error: parse fail"

  bbText = case hdl of
    VHDL -> case hty of
      BitVector {} -> "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      Index {}     -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      Signed {}    -> "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI"
      Unsigned {}  -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
      _            -> error "internal error"
    _ -> case hty of
      BitVector {} -> "~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 {}     -> "~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 {}    -> "~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]]) {~VAR[i][0][~SIZE[~TYP[0]]-1]}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
      Unsigned {}  -> "~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"
      _            -> error "internal error"

  tyName = case hty of
    BitVector {} -> text "BitVector"
    Index {} -> text "Index"
    Signed {} -> text "Signed"
    Unsigned {} -> text "Unsigned"
    _ -> error "internal error"

  width i = case hty of
    Index {} -> maybe 0 toInteger (clogBase 2 i)
    _ -> i

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

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