fu2 = fu (-)
fu3 = fu (*)
-data Opcode = Shift | Xor | Equal
+data Opcode = ShiftL | Xor | Equal
-multiop Shift = shift
+multiop ShiftL = shiftL
multiop Xor = xor
multiop Equal = \a b -> if a == b then 1 else 0
(fu3 inputs (addrs!3)) +> empty)))
out = last s
-
-
-
-
-
-
--- Some minor details
cpuState :: Vector D4 (Signed D16)
cpuState = copy 0
-
-const a b = a
-xor = const
-shift = const
module CLasH.HardwareTypes
( module Types
+ , module Data.Param.Integer
, module Data.Param.Vector
, module Data.Param.Index
, module Data.Param.Signed
, module Data.Param.Unsigned
, module Prelude
+ , module Data.Bits
, Bit(..)
, State(..)
, hwand
import qualified Prelude as P
import Prelude (Bool(..),Num(..),Eq(..),Ord(..),snd,fst,otherwise,(&&),(||),not)
import Types
+import Data.Param.Integer (HWBits(..))
import Data.Param.Vector
import Data.Param.Index
import Data.Param.Signed
import Data.Param.Unsigned
+import Data.Bits hiding (shiftL,shiftR)
import Language.Haskell.TH.Lift
import Data.Typeable
-- circular dependencie.
builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId
, selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId
- , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId
+ , foldrId, zipId, unzipId, shiftIntoLId, shiftIntoRId, rotlId, rotrId
, concatId, reverseId, iteratenId, iterateId, generatenId, generateId
, emptyId, singletonId, copynId, copyId, lengthTId, nullId
, hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId
, lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId
, negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId
, resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId
- , splitId, minimumId, fromRangedWordId
+ , splitId, minimumId, fromRangedWordId, xorId, shiftLId , shiftRId
]
--------------
-- Identifiers
dropId = "drop"
-- | shiftl function identifier
-shiftlId :: String
-shiftlId = "shiftIntoL"
+shiftIntoLId :: String
+shiftIntoLId = "shiftIntoL"
-- | shiftr function identifier
-shiftrId :: String
-shiftrId = "shiftIntoR"
+shiftIntoRId :: String
+shiftIntoRId = "shiftIntoR"
-- | rotl function identifier
rotlId :: String
hwandId :: String
hwandId = "hwand"
+xorId :: String
+xorId = "xor"
+
+shiftLId :: String
+shiftLId = "shiftL"
+
+shiftRId :: String
+shiftRId = "shiftR"
+
lengthTId :: String
lengthTId = "lengthT"
where
vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
(AST.ToRange init last))
+
+genSll :: BuiltinBuilder
+genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
+genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
+genSll' res f [(arg1,_),(arg2,_)] = do {
+ ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
+ }
+
+genSra :: BuiltinBuilder
+genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
+genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
+genSra' res f [(arg1,_),(arg2,_)] = do {
+ ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
+ }
+
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-----------------------------------------------------------------------------
, (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
, (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
, (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
- , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
- , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+ , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+ , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
, (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
, (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
, (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
- shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+ shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftlVar =
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+ shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftrVar =
, (foldrId , (3, genFoldr ) )
, (zipId , (2, genZip ) )
, (unzipId , (1, genUnzip ) )
- , (shiftlId , (2, genFCall False ) )
- , (shiftrId , (2, genFCall False ) )
+ , (shiftIntoLId , (2, genFCall False ) )
+ , (shiftIntoRId , (2, genFCall False ) )
, (rotlId , (1, genFCall False ) )
, (rotrId , (1, genFCall False ) )
, (concatId , (1, genConcat ) )
, (sndId , (1, genSnd ) )
, (blockRAMId , (5, genBlockRAM ) )
, (splitId , (1, genSplit ) )
+ , (xorId , (2, genOperator2 AST.Xor ) )
+ , (shiftLId , (2, genSll ) )
+ , (shiftRId , (2, genSra ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
]
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
+import qualified Data.Bits as B
import Types
import Types.Data.Num.Decimal.Literals.TH
( Signed(..)
, Unsigned(..)
, Index (..)
+ , HWBits(..)
) where
import Types
+import qualified Data.Bits as B
newtype (NaturalT nT) => Signed nT = Signed Integer
newtype (NaturalT nT) => Unsigned nT = Unsigned Integer
-newtype (PositiveT upper) => Index upper = Index Integer
\ No newline at end of file
+newtype (PositiveT upper) => Index upper = Index Integer
+
+class (B.Bits a) => HWBits a where
+ shiftL :: a -> a -> a
+ shiftR :: a -> a -> a
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
+import qualified Data.Bits as B
import Types
import Types.Data.Num.Decimal.Literals.TH
mask :: forall nT . NaturalT nT
=> nT
-> Integer
-mask _ = bit (fromIntegerT (undefined :: nT)) - 1
+mask _ = B.bit (fromIntegerT (undefined :: nT)) - 1
signBit :: forall nT . NaturalT nT
=> nT
=> Signed nT
-> Bool
isNegative (Signed x) =
- testBit x $ signBit (undefined :: nT)
+ B.testBit x $ signBit (undefined :: nT)
instance NaturalT nT => Eq (Signed nT) where
(Signed x) == (Signed y) = x == y
a `compare` b = toInteger a `compare` toInteger b
instance NaturalT nT => Bounded (Signed nT) where
- minBound = Signed $ negate $ 1 `shiftL` (fromIntegerT (undefined :: nT) - 1)
- maxBound = Signed $ (1 `shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1
+ minBound = Signed $ negate $ 1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)
+ maxBound = Signed $ (1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1
instance NaturalT nT => Enum (Signed nT) where
succ x
(Signed a) * (Signed b) =
fromInteger $ a * b
negate (Signed n) =
- fromInteger $ (n `xor` mask (undefined :: nT)) + 1
+ fromInteger $ (n `B.xor` mask (undefined :: nT)) + 1
a - b =
a + (negate b)
fromInteger n
| n > 0 =
- Signed $ n .&. mask (undefined :: nT)
+ Signed $ n B..&. mask (undefined :: nT)
fromInteger n
| n < 0 =
negate $ fromInteger $ negate n
then let Signed x' = negate s in negate x'
else x
-instance NaturalT nT => Bits (Signed nT) where
- (Signed a) .&. (Signed b) = Signed $ a .&. b
- (Signed a) .|. (Signed b) = Signed $ a .|. b
- (Signed a) `xor` Signed b = Signed $ a `xor` b
- complement (Signed x) = Signed $ x `xor` mask (undefined :: nT)
+instance NaturalT nT => B.Bits (Signed nT) where
+ (Signed a) .&. (Signed b) = Signed $ a B..&. b
+ (Signed a) .|. (Signed b) = Signed $ a B..|. b
+ (Signed a) `xor` Signed b = Signed $ a `B.xor` b
+ complement (Signed x) = Signed $ x `B.xor` mask (undefined :: nT)
(Signed x) `shiftL` b
| b < 0 = error $ "Bits.shiftL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
| otherwise =
- Signed $ mask (undefined :: nT) .&. (x `shiftL` b)
+ Signed $ mask (undefined :: nT) B..&. (x `B.shiftL` b)
s@(Signed x) `shiftR` b
| b < 0 = error $ "Bits.shiftR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
| isNegative s =
- Signed $ mask (undefined :: nT) .&.
- ((x `shiftR` b) .|. (mask (undefined :: nT) `shiftL` (fromIntegerT (undefined :: nT) - b)))
+ Signed $ mask (undefined :: nT) B..&.
+ ((x `B.shiftR` b) B..|. (mask (undefined :: nT) `B.shiftL` (fromIntegerT (undefined :: nT) - b)))
| otherwise =
- Signed $ (mask (undefined :: nT)) .&. (x `shiftR` b)
+ Signed $ (mask (undefined :: nT)) B..&. (x `B.shiftR` b)
(Signed a) `rotateL` b
| b < 0 =
error $ "Bits.rotateL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
| otherwise =
- Signed $ mask (undefined :: nT) .&.
- ((a `shiftL` b) .|. (a `shiftR` (fromIntegerT (undefined :: nT) - b)))
+ Signed $ mask (undefined :: nT) B..&.
+ ((a `B.shiftL` b) B..|. (a `B.shiftR` (fromIntegerT (undefined :: nT) - b)))
(Signed a) `rotateR` b
| b < 0 =
error $ "Bits.rotateR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
| otherwise =
- Signed $ mask (undefined :: nT) .&.
- ((a `shiftR` b) .|. (a `shiftL` (fromIntegerT (undefined :: nT) - b)))
+ Signed $ mask (undefined :: nT) B..&.
+ ((a `B.shiftR` b) B..|. (a `B.shiftL` (fromIntegerT (undefined :: nT) - b)))
bitSize _ = fromIntegerT (undefined :: nT)
isSigned _ = True
+
+instance NaturalT nT => HWBits (Signed nT) where
+ a `shiftL` b = a `B.shiftL` (fromInteger (toInteger b))
+ a `shiftR` b = a `B.shiftR` (fromInteger (toInteger b))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
+import qualified Data.Bits as B
import Types
import Types.Data.Num.Decimal.Literals.TH
mask :: forall nT . NaturalT nT
=> nT
-> Integer
-mask _ = bit (fromIntegerT (undefined :: nT)) - 1
+mask _ = B.bit (fromIntegerT (undefined :: nT)) - 1
instance NaturalT nT => Eq (Unsigned nT) where
(Unsigned x) == (Unsigned y) = x == y
instance NaturalT nT => Bounded (Unsigned nT) where
minBound = 0
- maxBound = Unsigned $ (1 `shiftL` (fromIntegerT (undefined :: nT))) - 1
+ maxBound = Unsigned $ (1 `B.shiftL` (fromIntegerT (undefined :: nT))) - 1
instance NaturalT nT => Enum (Unsigned nT) where
succ x
(Unsigned a) * (Unsigned b) =
fromInteger $ a * b
negate s@(Unsigned n) =
- fromInteger $ (n `xor` mask (sizeT s)) + 1
+ fromInteger $ (n `B.xor` mask (sizeT s)) + 1
a - b =
a + (negate b)
fromInteger n
| n > 0 =
- Unsigned $ n .&. mask (undefined :: nT)
+ Unsigned $ n B..&. mask (undefined :: nT)
fromInteger n
| n < 0 =
negate $ fromInteger $ negate n
in (fromInteger div, fromInteger mod)
toInteger s@(Unsigned x) = x
-instance NaturalT nT => Bits (Unsigned nT) where
- (Unsigned a) .&. (Unsigned b) = Unsigned $ a .&. b
- (Unsigned a) .|. (Unsigned b) = Unsigned $ a .|. b
- (Unsigned a) `xor` Unsigned b = Unsigned $ a `xor` b
- complement (Unsigned x) = Unsigned $ x `xor` mask (undefined :: nT)
+instance NaturalT nT => B.Bits (Unsigned nT) where
+ (Unsigned a) .&. (Unsigned b) = Unsigned $ a B..&. b
+ (Unsigned a) .|. (Unsigned b) = Unsigned $ a B..|. b
+ (Unsigned a) `xor` Unsigned b = Unsigned $ a `B.xor` b
+ complement (Unsigned x) = Unsigned $ x `B.xor` mask (undefined :: nT)
s@(Unsigned x) `shiftL` b
- | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
+ | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (B.bitSize s) ++ "}: tried to shift by negative amount"
| otherwise =
- Unsigned $ mask (undefined :: nT) .&. (x `shiftL` b)
+ Unsigned $ mask (undefined :: nT) B..&. (x `B.shiftL` b)
s@(Unsigned x) `shiftR` b
- | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
+ | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (B.bitSize s) ++ "}: tried to shift by negative amount"
| otherwise =
- Unsigned $ (x `shiftR` b)
+ Unsigned $ (x `B.shiftR` b)
s@(Unsigned x) `rotateL` b
| b < 0 =
- error $ "Bits.rotateL{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
+ error $ "Bits.rotateL{Unsigned " ++ show (B.bitSize s) ++ "}: tried to rotate by negative amount"
| otherwise =
- Unsigned $ mask (undefined :: nT) .&.
- ((x `shiftL` b) .|. (x `shiftR` (bitSize s - b)))
+ Unsigned $ mask (undefined :: nT) B..&.
+ ((x `B.shiftL` b) B..|. (x `B.shiftR` (B.bitSize s - b)))
s@(Unsigned x) `rotateR` b
| b < 0 =
- error $ "Bits.rotateR{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
+ error $ "Bits.rotateR{Unsigned " ++ show (B.bitSize s) ++ "}: tried to rotate by negative amount"
| otherwise =
- Unsigned $ mask (undefined :: nT) .&.
- ((x `shiftR` b) .|. (x `shiftL` (bitSize s - b)))
+ Unsigned $ mask (undefined :: nT) B..&.
+ ((x `B.shiftR` b) B..|. (x `B.shiftL` (B.bitSize s - b)))
bitSize _ = fromIntegerT (undefined :: nT)
isSigned _ = False
+
+instance NaturalT nT => HWBits (Unsigned nT) where
+ a `shiftL` b = a `B.shiftL` (fromInteger (toInteger b))
+ a `shiftR` b = a `B.shiftR` (fromInteger (toInteger b))