From c1c15170614c74acdb125d28cd9c0e6fa15433c8 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Mon, 13 Jan 2025 14:16:04 +0100 Subject: [PATCH] Avoid warnings instead of hiding them --- clash-prelude/src/Clash/Examples/Internal.hs | 35 +++++++++---- clash-prelude/src/Clash/Sized/Index.hs | 6 +-- clash-prelude/src/Clash/Sized/Vector.hs | 54 ++++++++++++++++---- 3 files changed, 69 insertions(+), 26 deletions(-) diff --git a/clash-prelude/src/Clash/Examples/Internal.hs b/clash-prelude/src/Clash/Examples/Internal.hs index d773280458..80d1de0c15 100644 --- a/clash-prelude/src/Clash/Examples/Internal.hs +++ b/clash-prelude/src/Clash/Examples/Internal.hs @@ -2,6 +2,7 @@ Copyright : © 2015-2016, Christiaan Baaij, 2017 , Google Inc. 2019 , Myrtle Software Ltd + 2025 , QBayLogic B.V. Licence : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/) -} @@ -13,16 +14,10 @@ Licence : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licens {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - module Clash.Examples.Internal where import Clash.Prelude hiding (feedback) -import Control.Lens +import Control.Lens hiding ((:>)) import Control.Monad import Control.Monad.Trans.State @@ -45,6 +40,7 @@ decoderCase enable binaryIn | enable = 0xD -> 0x2000 0xE -> 0x4000 0xF -> 0x8000 + _ -> 0 decoderCase _ _ = 0 decoderShift :: Bool -> BitVector 4 -> BitVector 16 @@ -72,6 +68,7 @@ encoderCase enable binaryIn | enable = 0x2000 -> 0xD 0x4000 -> 0xE 0x8000 -> 0xF + _ -> 0 encoderCase _ _ = 0 upCounter @@ -107,7 +104,8 @@ upDownCounter upDown = s lfsrF' :: BitVector 16 -> BitVector 16 lfsrF' s = pack feedback ++# slice (SNat @15) d1 s where - feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0 + feedback = foldr1 xor + $ (s !) <$> (5 :: Int) :> 3 :> 2 :> 0 :> Nil lfsrF :: HiddenClockResetEnable dom @@ -153,9 +151,9 @@ crcT => a -> Bit -> a -crcT bv dIn = replaceBit 0 dInXor - $ replaceBit 5 (bv!4 `xor` dInXor) - $ replaceBit 12 (bv!11 `xor` dInXor) +crcT bv dIn = replaceBit ( 0 :: Int) dInXor + $ replaceBit ( 5 :: Int) (bv ! ( 4 :: Int) `xor` dInXor) + $ replaceBit (12 :: Int) (bv ! (11 :: Int) `xor` dInXor) rotated where dInXor = dIn `xor` fb @@ -200,6 +198,7 @@ data TxReg makeLenses ''TxReg +uartTX :: TxReg -> Bool -> BitVector 8 -> Bool -> TxReg uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do when ld_tx_data $ do if not _tx_empty then @@ -220,6 +219,7 @@ uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do unless tx_enable $ tx_cnt .= 0 +uartRX :: RxReg -> Bit -> Bool -> Bool -> RxReg uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do -- Synchronize the async signal rx_d1 .= rx_in @@ -260,6 +260,19 @@ uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do else do rx_busy .= False +uart :: + HiddenClockResetEnable dom => + Signal dom Bool -> + Signal dom (BitVector 8) -> + Signal dom Bool -> + Signal dom Bit -> + Signal dom Bool -> + Signal dom Bool -> + ( Signal dom Bit + , Signal dom Bool + , Signal dom (BitVector 8) + , Signal dom Bool + ) uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable = ( _tx_out <$> txReg , _tx_empty <$> txReg diff --git a/clash-prelude/src/Clash/Sized/Index.hs b/clash-prelude/src/Clash/Sized/Index.hs index ac33459cd3..e7a6a732f3 100644 --- a/clash-prelude/src/Clash/Sized/Index.hs +++ b/clash-prelude/src/Clash/Sized/Index.hs @@ -1,5 +1,6 @@ {-| Copyright : (C) 2013-2016, University of Twente + 2025 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} @@ -8,7 +9,6 @@ Maintainer : Christiaan Baaij {-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Sized.Index @@ -16,9 +16,7 @@ module Clash.Sized.Index where import GHC.TypeLits (KnownNat, type (^)) -import GHC.TypeLits.Extra (CLog) -- documentation only -import Clash.Promoted.Nat (SNat (..), pow2SNat) import Clash.Sized.Internal.BitVector (BitVector) import Clash.Sized.Internal.Index @@ -29,7 +27,7 @@ import Clash.Sized.Internal.Index -- That is, the type of 'Clash.Class.BitPack.unpack' is: -- -- @ --- __unpack__ :: 'BitVector' ('CLog' 2 n) -> 'Index' n +-- __unpack__ :: 'BitVector' ('GHC.TypeLits.Extra.CLog' 2 n) -> 'Index' n -- @ -- -- And is useful when you know the size of the 'Index', and want to get a value diff --git a/clash-prelude/src/Clash/Sized/Vector.hs b/clash-prelude/src/Clash/Sized/Vector.hs index 3ebd8a2c70..a310430969 100644 --- a/clash-prelude/src/Clash/Sized/Vector.hs +++ b/clash-prelude/src/Clash/Sized/Vector.hs @@ -8,6 +8,7 @@ Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -23,8 +24,6 @@ Maintainer : QBayLogic B.V. {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-} - {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Sized.Vector @@ -184,6 +183,9 @@ data Vec :: Nat -> Type -> Type where {-# COMPLETE Nil, (:>) #-} +-- | Tag for K1: @n ~ 0@ proof +data N + -- | In many cases, this Generic instance only allows generic -- functions/instances over vectors of at least size 1, due to the -- /n-1/ in the /Rep (Vec n a)/ definition. @@ -194,7 +196,7 @@ data Vec :: Nat -> Type -> Type where instance KnownNat n => Generic (Vec n a) where type Rep (Vec n a) = D1 ('MetaData "Vec" "Clash.Data.Vector" "clash-prelude" 'False) - (C1 ('MetaCons "Nil" 'PrefixI 'False) U1 :+: + (C1 ('MetaCons "Nil" 'PrefixI 'False) (K1 N (Dict (n ~ 0))) :+: C1 ('MetaCons "Cons" 'PrefixI 'False) (S1 ('MetaSel 'Nothing 'NoSourceUnpackedness @@ -206,13 +208,14 @@ instance KnownNat n => Generic (Vec n a) where 'NoSourceStrictness 'DecidedLazy) (Rec0 (Vec (n-1) a)))) - from Nil = M1 (L1 (M1 U1)) + from Nil = M1 (L1 (M1 (K1 Dict))) from (Cons x xs) = M1 (R1 (M1 (M1 (K1 x) :*: M1 (K1 xs)))) to (M1 g) = case compareSNat (SNat @n) (SNat @0) of SNatLE -> case leZero @n of Sub Dict -> Nil SNatGT -> case g of R1 (M1 (M1 (K1 p) :*: M1 (K1 q))) -> Cons p q + L1 (M1 (K1 eqZero)) -> case eqZero of {} instance (KnownNat n, Typeable a, Data a) => Data (Vec n a) where gunfold k z _ = case compareSNat (SNat @n) (SNat @0) of @@ -449,6 +452,12 @@ singleton = (`Cons` Nil) -} head :: Vec (n + 1) a -> a head (x `Cons` _) = x +#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +head xs = unreachable xs + where + unreachable :: forall n a. 1 <= n => Vec n a -> a + unreachable (x `Cons` _) = x +#endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 {-# CLASH_OPAQUE tail #-} @@ -494,7 +503,13 @@ head (x `Cons` _) = x #endif -} tail :: Vec (n + 1) a -> Vec n a -tail (_ `Cons` xs) = xs +tail (_ `Cons` xr) = xr +#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +tail xs = unreachable xs + where + unreachable :: forall n a. 1 <= n => Vec n a -> Vec (n - 1) a + unreachable (_ `Cons` xr) = xr +#endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 {-# CLASH_OPAQUE last #-} @@ -541,7 +556,13 @@ tail (_ `Cons` xs) = xs -} last :: Vec (n + 1) a -> a last (x `Cons` Nil) = x -last (_ `Cons` y `Cons` ys) = last (y `Cons` ys) +last (_ `Cons` y `Cons` xr) = last (y `Cons` xr) +#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +last xs = unreachable xs + where + unreachable :: 1 <= n => Vec n a -> a + unreachable ys@(Cons _ _) = last ys +#endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 {-# CLASH_OPAQUE init #-} @@ -588,7 +609,13 @@ last (_ `Cons` y `Cons` ys) = last (y `Cons` ys) -} init :: Vec (n + 1) a -> Vec n a init (_ `Cons` Nil) = Nil -init (x `Cons` y `Cons` ys) = x `Cons` init (y `Cons` ys) +init (x `Cons` y `Cons` xr) = x `Cons` init (y `Cons` xr) +#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +init xs = unreachable xs + where + unreachable :: 1 <= n => Vec n a -> Vec (n - 1) a + unreachable ys@(Cons _ _) = init ys +#endif {-# INLINE shiftInAt0 #-} -- | Shift in elements to the head of a vector, bumping out elements at the @@ -740,9 +767,9 @@ splitAt n xs = splitAtU (toUNat n) xs {-# ANN splitAt hasBlackBox #-} splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -splitAtU UZero ys = (Nil,ys) -splitAtU (USucc s) (y `Cons` ys) = let (as,bs) = splitAtU s ys - in (y `Cons` as, bs) +splitAtU UZero ys = (Nil, ys) +splitAtU (USucc s) ys = let (as, bs) = splitAtU s $ tail ys + in (head ys `Cons` as, bs) -- | Split a vector into two vectors where the length of the two is determined -- by the context. @@ -1237,7 +1264,7 @@ scanl f z xs = ws -- >>> scanl1 (-) (1 :> 2 :> 3 :> 4 :> Nil) -- 1 :> -1 :> -4 :> -8 :> Nil scanl1 :: KnownNat n => (a -> a -> a) -> Vec (n+1) a -> Vec (n+1) a -scanl1 op (v:>vs) = scanl op v vs +scanl1 op vs = scanl op (head vs) (tail vs) {-# INLINE scanl1 #-} -- | 'scanr' with no seed value @@ -2587,6 +2614,11 @@ dtfold _ f g = go (SNat :: SNat k) sn' = sn `subSNat` d1 (xsL,xsR) = splitAt (pow2SNat sn') xs in g sn' (go sn' xsL) (go sn' xsR) +#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) + go _ Nil = + case (const Dict :: forall m. Proxy m -> Dict (1 <= 2 ^ m)) (Proxy @n) of + {} +#endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 {-# CLASH_OPAQUE dtfold #-} {-# ANN dtfold hasBlackBox #-}