1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
{-|
Module : VeriFuzz.Reduce
Description : Test case reducer implementation.
Copyright : (c) 2019, Yann Herklotz
License : GPL-3
Maintainer : ymherklotz [at] gmail [dot] com
Stability : experimental
Portability : POSIX
Test case reducer implementation.
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module VeriFuzz.Reduce
( reduce
)
where
import Control.Lens
import VeriFuzz.Verilog.AST
import VeriFuzz.Verilog.CodeGen
import VeriFuzz.Verilog.Mutate
-- | Replacement type that supports returning different kinds of reduced
-- replacements that could be tried.
data Replacement a = Dual a a
| Single a
| None
deriving (Eq, Show)
instance Functor Replacement where
fmap f (Dual a b) = Dual (f a) $ f b
fmap f (Single a) = Single $ f a
fmap _ None = None
instance Applicative Replacement where
pure = Single
(Dual a b) <*> (Dual c d) = Dual (a c) $ b d
(Dual a b) <*> (Single c) = Dual (a c) $ b c
(Single a) <*> (Dual b c) = Dual (a b) $ a c
(Single a) <*> (Single b) = Single $ a b
None <*> _ = None
_ <*> None = None
instance Foldable Replacement where
foldMap _ None = mempty
foldMap f (Single a) = f a
foldMap f (Dual a b) = f a <> f b
instance Traversable Replacement where
traverse _ None = pure None
traverse f (Single a) = Single <$> f a
traverse f (Dual a b) = Dual <$> f a <*> f b
-- | Split a list in two halves.
halve :: [a] -> Replacement [a]
halve [] = None
halve [a] = Single [a]
halve l = Dual a b where (a, b) = splitAt (length l `div` 2) l
-- | When given a Lens and a function that works on a lower replacement, it will
-- go down, apply the replacement, and return a replacement of the original
-- module.
combine :: Lens' a b -> (b -> Replacement b) -> a -> Replacement a
combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res
-- | Deletes Id 'Expr' if they are not part of the current scope, and replaces
-- these by 0.
filterExpr :: [Identifier] -> Expr -> Expr
filterExpr ids (Id i) = if i `notElem` ids then Number 0 else Id i
filterExpr _ e = e
-- | Checks if a declaration is part of the current scope. If not, it returns
-- 'False', otherwise 'True', as it should be kept.
filterDecl :: [Identifier] -> ModItem -> Bool
filterDecl ids (Decl Nothing (Port _ _ _ i) _) = i `elem` ids
filterDecl _ _ = True
-- | Checks if a continuous assignment is in the current scope, if not, it
-- returns 'False'.
filterAssigns :: [Port] -> ModItem -> Bool
filterAssigns out (ModCA (ContAssign i _)) =
elem i $ out ^.. traverse . portName
filterAssigns _ _ = True
cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem]
cleanUndefined ids mis =
filter (filterDecl usedWires) mis
& traverse
. modContAssign
. contAssignExpr
%~ transform (filterExpr usedWires)
where
usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids
halveModAssign :: ModDecl -> Replacement ModDecl
halveModAssign m = cleanMod m $ modify <$> assigns (m ^. modItems)
where
assigns = halve . filter (filterAssigns $ m ^. modOutPorts)
modify l = m & modItems .~ l
cleanMod :: ModDecl -> Replacement ModDecl -> Replacement ModDecl
cleanMod m newm = modify . change <$> newm
where
mis = m ^. modItems
modify l = m & modItems .~ l
change l =
cleanUndefined (m ^.. modInPorts . traverse . portName)
. combineAssigns (head $ m ^. modOutPorts)
. (filter (not . filterAssigns []) mis <>)
$ l
^. modItems
-- halveStatements :: Statement -> Replacement Statement
-- halveStatements (SeqBlock l ) = SeqBlock <$> halve l
-- halveStatements (CondStmnt _ (Just a) b) = maybe (Single a) (Dual a) b
-- halveStatements (CondStmnt _ Nothing b) = maybe None Single b
-- halveStatements (ForLoop _ _ _ s ) = Single s
-- halveStatements _ = None
-- | Split a module declaration in half by trying to remove assign statements.
halveAssigns :: SourceInfo -> Replacement SourceInfo
halveAssigns = combine mainModule halveModAssign
halveIndExpr :: Expr -> Replacement Expr
halveIndExpr (Concat l ) = Concat <$> halve l
halveIndExpr (BinOp e1 _ e2) = Dual e1 e2
halveIndExpr (Cond _ e1 e2) = Dual e1 e2
halveIndExpr (UnOp _ e ) = Single e
halveIndExpr (Appl _ e ) = Single e
halveIndExpr e = Single e
halveModExpr :: ModItem -> Replacement ModItem
halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca
halveModExpr a = Single a
halveExpr :: SourceInfo -> Replacement SourceInfo
halveExpr = combine contexpr $ traverse halveModExpr
where
contexpr :: Lens' SourceInfo [ModItem]
contexpr = mainModule . modItems
reduce_
:: (SourceInfo -> Replacement SourceInfo)
-> (SourceInfo -> IO Bool)
-> SourceInfo
-> IO SourceInfo
reduce_ repl eval src = do
replAnswer <- sequenceA $ evalIfNotEmpty <$> replacement
case (replacement, replAnswer) of
(Single s, Single False ) -> runIf s
(Dual _ l, Dual True False ) -> runIf l
(Dual r _, Dual False True ) -> runIf r
(Dual r l, Dual False False) -> do
lreduced <- runIf l
rreduced <- runIf r
if runSource lreduced < runSource rreduced
then return lreduced
else return rreduced
(None, None) -> return src
_ -> return src
where
replacement = repl src
runIf s = if s /= src then reduce_ repl eval s else return s
evalIfNotEmpty m = do
print
$ GenVerilog
<$> m
^.. mainModule
. modItems
. traverse
. modContAssign
eval m
-- | Reduce an input to a minimal representation. It first reduces the always
-- blocks, then reduces
reduce
:: (SourceInfo -> IO Bool) -- ^ Failed or not.
-> SourceInfo -- ^ Input verilog source to be reduced.
-> IO SourceInfo -- ^ Reduced output.
reduce eval src = red halveAssigns src >>= red halveExpr
where red a = reduce_ a eval
|
