From 8d96fd2a541a2602544ced741552ebd17714c67d Mon Sep 17 00:00:00 2001
From: Yann Herklotz <git@yannherklotz.com>
Date: Wed, 18 Sep 2019 19:06:32 +0200
Subject: Rename main modules

---
 src/Verismith/Verilog/Eval.hs | 119 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 119 insertions(+)
 create mode 100644 src/Verismith/Verilog/Eval.hs

(limited to 'src/Verismith/Verilog/Eval.hs')

diff --git a/src/Verismith/Verilog/Eval.hs b/src/Verismith/Verilog/Eval.hs
new file mode 100644
index 0000000..cbc2563
--- /dev/null
+++ b/src/Verismith/Verilog/Eval.hs
@@ -0,0 +1,119 @@
+{-|
+Module      : Verismith.Verilog.Eval
+Description : Evaluation of Verilog expressions and statements.
+Copyright   : (c) 2019, Yann Herklotz Grave
+License     : GPL-3
+Maintainer  : yann [at] yannherklotz [dot] com
+Stability   : experimental
+Portability : POSIX
+
+Evaluation of Verilog expressions and statements.
+-}
+
+module Verismith.Verilog.Eval
+    ( evaluateConst
+    , resize
+    )
+where
+
+import           Data.Bits
+import           Data.Foldable            (fold)
+import           Data.Functor.Foldable    hiding (fold)
+import           Data.Maybe               (listToMaybe)
+import           Verismith.Verilog.AST
+import           Verismith.Verilog.BitVec
+
+type Bindings = [Parameter]
+
+paramIdent_ :: Parameter -> Identifier
+paramIdent_ (Parameter i _) = i
+
+paramValue_ :: Parameter -> ConstExpr
+paramValue_ (Parameter _ v) = v
+
+applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a
+applyUnary UnPlus  a = a
+applyUnary UnMinus a = negate a
+applyUnary UnLNot a | a == 0    = 0
+                    | otherwise = 1
+applyUnary UnNot a = complement a
+applyUnary UnAnd a | finiteBitSize a == popCount a = 1
+                   | otherwise                     = 0
+applyUnary UnNand a | finiteBitSize a == popCount a = 0
+                    | otherwise                     = 1
+applyUnary UnOr a | popCount a == 0 = 0
+                  | otherwise       = 1
+applyUnary UnNor a | popCount a == 0 = 1
+                   | otherwise       = 0
+applyUnary UnXor a | popCount a `mod` 2 == 0 = 0
+                   | otherwise               = 1
+applyUnary UnNxor a | popCount a `mod` 2 == 0 = 1
+                    | otherwise               = 0
+applyUnary UnNxorInv a | popCount a `mod` 2 == 0 = 1
+                       | otherwise               = 0
+
+compXor :: Bits c => c -> c -> c
+compXor a = complement . xor a
+
+toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p
+toIntegral a b c = if a b c then 1 else 0
+
+toInt :: (Integral a, Num t1) => (t2 -> t1 -> t3) -> t2 -> a -> t3
+toInt a b c = a b $ fromIntegral c
+
+applyBinary :: (Integral a, Bits a) => BinaryOperator -> a -> a -> a
+applyBinary BinPlus    = (+)
+applyBinary BinMinus   = (-)
+applyBinary BinTimes   = (*)
+applyBinary BinDiv     = quot
+applyBinary BinMod     = rem
+applyBinary BinEq      = toIntegral (==)
+applyBinary BinNEq     = toIntegral (/=)
+applyBinary BinCEq     = toIntegral (==)
+applyBinary BinCNEq    = toIntegral (/=)
+applyBinary BinLAnd    = undefined
+applyBinary BinLOr     = undefined
+applyBinary BinLT      = toIntegral (<)
+applyBinary BinLEq     = toIntegral (<=)
+applyBinary BinGT      = toIntegral (>)
+applyBinary BinGEq     = toIntegral (>=)
+applyBinary BinAnd     = (.&.)
+applyBinary BinOr      = (.|.)
+applyBinary BinXor     = xor
+applyBinary BinXNor    = compXor
+applyBinary BinXNorInv = compXor
+applyBinary BinPower   = undefined
+applyBinary BinLSL     = toInt shiftL
+applyBinary BinLSR     = toInt shiftR
+applyBinary BinASL     = toInt shiftL
+applyBinary BinASR     = toInt shiftR
+
+-- | Evaluates a 'ConstExpr' using a context of 'Bindings' as input.
+evaluateConst :: Bindings -> ConstExprF BitVec -> BitVec
+evaluateConst _ (ConstNumF b) = b
+evaluateConst p (ParamIdF i) =
+    cata (evaluateConst p) . maybe 0 paramValue_ . listToMaybe $ filter
+        ((== i) . paramIdent_)
+        p
+evaluateConst _ (ConstConcatF c       ) = fold c
+evaluateConst _ (ConstUnOpF unop c    ) = applyUnary unop c
+evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b
+evaluateConst _ (ConstCondF  a b     c) = if a > 0 then b else c
+evaluateConst _ (ConstStrF _          ) = 0
+
+-- | Apply a function to all the bitvectors. Would be fixed by having a
+-- 'Functor' instance for a polymorphic 'ConstExpr'.
+applyBitVec :: (BitVec -> BitVec) -> ConstExpr -> ConstExpr
+applyBitVec f (ConstNum    b   ) = ConstNum $ f b
+applyBitVec f (ConstConcat c   ) = ConstConcat $ fmap (applyBitVec f) c
+applyBitVec f (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c
+applyBitVec f (ConstBinOp a binop b) =
+    ConstBinOp (applyBitVec f a) binop (applyBitVec f b)
+applyBitVec f (ConstCond a b c) = ConstCond (abv a) (abv b) (abv c)
+    where abv = applyBitVec f
+applyBitVec _ a = a
+
+-- | This probably could be implemented using some recursion scheme in the
+-- future. It would also be fixed by having a polymorphic expression type.
+resize :: Int -> ConstExpr -> ConstExpr
+resize n = applyBitVec (resize' n) where resize' n' (BitVec _ a) = BitVec n' a
-- 
cgit