ToInteger.hs

{-# 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))

import DynFlags (unsafeGlobalDynFlags)
import ErrUtils (mkPlainWarnMsg, pprLocErrMsg)
import Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
import qualified Outputable
import SrcLoc (isGoodSrcSpan)

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.use intWidth
      let i1 = width i
      when (fromInteger i1 > iw) $ do
        (_,sp) <- Lens.use curCompNm
        let srcInfo1 | isGoodSrcSpan sp = srcInfo
                     | otherwise        = empty

            warnMsg1 = mkPlainWarnMsg unsafeGlobalDynFlags sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)

        liftIO (hPutStrLn stderr (showSDocUnsafe (pprLocErrMsg warnMsg1)))
    _ -> 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]]) {1'b0}},~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."