{-|
  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 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 Data.Text.Lazy (pack)
import Text.Trifecta.Result (Result(Success))

import GHC.Utils.Outputable
  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc (isGoodSrcSpan)

import Clash.Annotations.Primitive (HDL (Verilog,VHDL))
import Clash.Core.Type (Type (LitTy), LitTy (NumTy))
import Clash.Driver.Warning (warnAboutM)
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)
import Clash.Warning (ClashWarning(WarnIntegerNarrowing))

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

bvToIntegerVerilog :: BlackBoxFunction
bvToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Int -> HWType
BitVector Int
0)
bvToIntegerVHDL :: BlackBoxFunction
bvToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Int -> HWType
BitVector Int
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 (Int -> HWType
Signed Int
0)
signedToIntegerVHDL :: BlackBoxFunction
signedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Int -> HWType
Signed Int
0)
unsignedToIntegerVerilog :: BlackBoxFunction
unsignedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
Verilog (Int -> HWType
Unsigned Int
0)
unsignedToIntegerVHDL :: BlackBoxFunction
unsignedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
toIntegerBB HDL
VHDL (Int -> HWType
Unsigned Int
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
      Int
iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
      let i1 :: Integer
i1 = Integer -> Integer
width Integer
i
      Bool -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
forall doc. IsOutput doc => doc
empty
            msg :: SDoc
msg = Integer -> Int -> SDoc
warnMsg Integer
i1 Int
iw SDoc -> SDoc -> SDoc
$+$ SDoc
blankLine SDoc -> SDoc -> SDoc
$+$ SDoc
srcInfo1

        ClashWarning -> SrcSpan -> String -> NetlistMonad ()
forall (m :: Type -> Type).
CanWarn m =>
ClashWarning -> SrcSpan -> String -> m ()
warnAboutM ClashWarning
WarnIntegerNarrowing SrcSpan
sp (SDoc -> String
showSDocUnsafe SDoc
msg)
    [Either Term Type]
_ -> () -> NetlistMonad ()
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall a. a -> NetlistMonad a
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=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]]) {~VAR[i][0][~SIZE[~TYP[0]]-1]}},~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
forall doc. IsLine doc => String -> doc
text String
"BitVector"
    Index {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Index"
    Signed {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signed"
    Unsigned {} -> String -> SDoc
forall doc. IsLine doc => String -> doc
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 -> (Int -> Integer) -> Maybe Int -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Integer -> Integer -> Maybe Int
clogBase Integer
2 Integer
i)
    HWType
_ -> Integer
i

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

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