{-# 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 :: BlackBoxFunction
bvToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
BitVector 0)
bvToIntegerVHDL :: BlackBoxFunction
bvToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
BitVector 0)
indexToIntegerVerilog :: BlackBoxFunction
indexToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Integer -> HWType
Index 0)
indexToIntegerVHDL :: BlackBoxFunction
indexToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Integer -> HWType
Index 0)
signedToIntegerVerilog :: BlackBoxFunction
signedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
Signed 0)
signedToIntegerVHDL :: BlackBoxFunction
signedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
Signed 0)
unsignedToIntegerVerilog :: BlackBoxFunction
unsignedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Size -> HWType
Unsigned 0)
unsignedToIntegerVHDL :: BlackBoxFunction
unsignedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Size -> HWType
Unsigned 0)

toIntegerBB :: HDL -> HWType -> BlackBoxFunction
toIntegerBB :: HDL -> HWType -> BlackBoxFunction
toIntegerBB hdl :: HDL
hdl hty :: HWType
hty _isD :: Bool
_isD _primName :: Text
_primName args :: [Either Term Type]
args _ty :: Type
_ty = do
  case [Either Term Type]
args of
    (Right (LitTy (NumTy i :: Integer
i)):_) -> do
      Size
iw <- Getting Size NetlistState Size -> NetlistMonad Size
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Size NetlistState Size
Lens' NetlistState 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
        (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
        let srcInfo1 :: SDoc
srcInfo1 | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp = SDoc
srcInfo
                     | Bool
otherwise        = SDoc
empty

            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)

        IO () -> NetlistMonad ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr (SDoc -> String
showSDocUnsafe (ErrMsg -> SDoc
pprLocErrMsg ErrMsg
warnMsg1)))
    _ -> () -> 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 t :: BlackBoxTemplate
t -> BlackBoxTemplate -> Either String BlackBoxTemplate
forall a b. b -> Either a b
Right BlackBoxTemplate
t
         _         -> String -> Either String BlackBoxTemplate
forall a b. a -> Either a b
Left "internal error: parse fail"

  bbText :: String
bbText = case HDL
hdl of
    VHDL -> case HWType
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"
      _            -> String -> String
forall a. HasCallStack => String -> a
error "internal error"
    _ -> case HWType
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"
      _            -> String -> String
forall a. HasCallStack => String -> a
error "internal error"

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

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

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

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