{-# 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 (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
#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
opts = EnumSet WarningFlag
-> EnumSet WarningFlag
-> Bool
-> Bool
-> Maybe Int
-> SDocContext
-> DiagOpts
DiagOpts EnumSet WarningFlag
forall a. Monoid a => a
mempty EnumSet WarningFlag
forall a. Monoid a => a
mempty Bool
False Bool
False Maybe Int
forall a. Maybe a
Nothing SDocContext
defaultSDocContext
diag :: DiagnosticMessage
diag = DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [] (Integer -> Int -> SDoc
warnMsg Integer
i1 Int
iw SDoc -> SDoc -> SDoc
$+$ SDoc
blankLine SDoc -> SDoc -> SDoc
$+$ SDoc
srcInfo1)
warnMsg1 :: MsgEnvelope DiagnosticMessage
warnMsg1 = DiagOpts
-> SrcSpan -> DiagnosticMessage -> MsgEnvelope DiagnosticMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
opts SrcSpan
sp DiagnosticMessage
diag
warnMsg2 :: SDoc
warnMsg2 = MsgEnvelope DiagnosticMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope DiagnosticMessage
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 = mkPlainWarnMsg unsafeGlobalDynFlags sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
warnMsg2 = pprLocErrMsg warnMsg1
#endif
IO () -> NetlistMonad ()
forall a. IO a -> NetlistMonad a
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 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]]) {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
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."