1-- PSL - Small QM reduction 2-- Copyright (C) 2002-2016 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with Ada.Text_IO; 18with Types; use Types; 19with PSL.Types; use PSL.Types; 20with PSL.Errors; use PSL.Errors; 21with PSL.Prints; 22with PSL.CSE; 23 24package body PSL.QM is 25 procedure Reset is 26 begin 27 for I in 1 .. Nbr_Terms loop 28 Set_HDL_Index (Term_Assoc (I), 0); 29 end loop; 30 Nbr_Terms := 0; 31 Term_Assoc := (others => Null_Node); 32 end Reset; 33 34 function Term (P : Natural) return Vector_Type is 35 begin 36 return Shift_Left (1, P - 1); 37 end Term; 38 39 procedure Disp_Primes_Set (Ps : Primes_Set) 40 is 41 use Ada.Text_IO; 42 use PSL.Prints; 43 Prime : Prime_Type; 44 T : Vector_Type; 45 First_Term : Boolean; 46 begin 47 if Ps.Nbr = 0 then 48 Put ("FALSE"); 49 return; 50 end if; 51 for I in 1 .. Ps.Nbr loop 52 Prime := Ps.Set (I); 53 if I /= 1 then 54 Put (" | "); 55 end if; 56 if Prime.Set = 0 then 57 Put ("TRUE"); 58 else 59 First_Term := True; 60 for J in 1 .. Max_Terms loop 61 T := Term (J); 62 if (Prime.Set and T) /= 0 then 63 if First_Term then 64 First_Term := False; 65 else 66 Put ('.'); 67 end if; 68 if (Prime.Val and T) = 0 then 69 Put ('!'); 70 end if; 71 Print_Expr (Term_Assoc (J)); 72 end if; 73 end loop; 74 end if; 75 end loop; 76 end Disp_Primes_Set; 77 78 -- Return TRUE iff L includes R, ie 79 -- for all x, x in L => x in R. 80 function Included (L, R : Prime_Type) return Boolean is 81 begin 82 return ((L.Set or R.Set) = L.Set) 83 and then ((L.Val and R.Set) = (R.Val and R.Set)); 84 end Included; 85 86 -- Return TRUE iff L and R have the same don't care set 87 -- and L and R can be merged into a new prime with a new don't care. 88 function Is_One_Change_Same (L, R : Prime_Type) return Boolean 89 is 90 V : Vector_Type; 91 begin 92 if L.Set /= R.Set then 93 return False; 94 end if; 95 V := L.Val xor R.Val; 96 return (V and -V) = V; 97 end Is_One_Change_Same; 98 99 -- Return true iff L can add a new DC in R. 100 function Is_One_Change (L, R : Prime_Type) return Boolean 101 is 102 V : Vector_Type; 103 begin 104 if (L.Set or R.Set) /= R.Set then 105 return False; 106 end if; 107 V := (L.Val xor R.Val) and L.Set; 108 return (V and -V) = V; 109 end Is_One_Change; 110 111 procedure Merge (Ps : in out Primes_Set; P : Prime_Type) 112 is 113 Do_Append : Boolean := True; 114 T : Prime_Type; 115 begin 116 for I in 1 .. Ps.Nbr loop 117 T := Ps.Set (I); 118 if Included (P, T) then 119 -- Already in the set. 120 return; 121 end if; 122 if Included (T, P) then 123 Ps.Set (I) := P; 124 Do_Append := False; 125 else 126 if Is_One_Change_Same (P, T) then 127 declare 128 V : constant Vector_Type := T.Val xor P.Val; 129 begin 130 Ps.Set (I).Set := T.Set and not V; 131 Ps.Set (I).Val := T.Val and not V; 132 end; 133 Do_Append := False; 134 end if; 135 if Is_One_Change (P, T) then 136 declare 137 V : constant Vector_Type := (T.Val xor P.Val) and P.Set; 138 begin 139 Ps.Set (I).Set := T.Set and not V; 140 Ps.Set (I).Val := T.Val and not V; 141 end; 142 -- continue. 143 end if; 144 end if; 145 end loop; 146 if Do_Append then 147 Ps.Nbr := Ps.Nbr + 1; 148 Ps.Set (Ps.Nbr) := P; 149 end if; 150 end Merge; 151 152 function Build_Primes_And (L, R : Primes_Set) return Primes_Set 153 is 154 Res : Primes_Set (L.Nbr * R.Nbr); 155 L_P, R_P : Prime_Type; 156 P : Prime_Type; 157 begin 158 for I in 1 .. L.Nbr loop 159 L_P := L.Set (I); 160 for J in 1 .. R.Nbr loop 161 R_P := R.Set (J); 162 -- In case of conflict, discard. 163 if ((L_P.Val xor R_P.Val) and (L_P.Set and R_P.Set)) /= 0 then 164 null; 165 else 166 P.Set := L_P.Set or R_P.Set; 167 P.Val := (R_P.Set and R_P.Val) 168 or ((L_P.Set and not R_P.Set) and L_P.Val); 169 Merge (Res, P); 170 end if; 171 end loop; 172 end loop; 173 174 return Res; 175 end Build_Primes_And; 176 177 178 function Build_Primes_Or (L, R : Primes_Set) return Primes_Set 179 is 180 Res : Primes_Set (L.Nbr + R.Nbr); 181 L_P, R_P : Prime_Type; 182 begin 183 for I in 1 .. L.Nbr loop 184 L_P := L.Set (I); 185 Merge (Res, L_P); 186 end loop; 187 for J in 1 .. R.Nbr loop 188 R_P := R.Set (J); 189 Merge (Res, R_P); 190 end loop; 191 192 return Res; 193 end Build_Primes_Or; 194 195 function Build_Primes (N : Node; Negate : Boolean) return Primes_Set is 196 begin 197 case Get_Kind (N) is 198 when N_HDL_Bool 199 | N_EOS => 200 declare 201 Res : Primes_Set (1); 202 Index : Int32; 203 T : Vector_Type; 204 begin 205 Index := Get_HDL_Index (N); 206 if Index = 0 then 207 Nbr_Terms := Nbr_Terms + 1; 208 if Nbr_Terms > Max_Terms then 209 raise Program_Error; 210 end if; 211 Term_Assoc (Nbr_Terms) := N; 212 Index := Int32 (Nbr_Terms); 213 Set_HDL_Index (N, Index); 214 else 215 if Index not in 1 .. Int32 (Nbr_Terms) 216 or else Term_Assoc (Natural (Index)) /= N 217 then 218 raise Internal_Error; 219 end if; 220 end if; 221 T := Term (Natural (Index)); 222 Res.Nbr := 1; 223 Res.Set (1).Set := T; 224 if Negate then 225 Res.Set (1).Val := 0; 226 else 227 Res.Set (1).Val := T; 228 end if; 229 return Res; 230 end; 231 when N_False => 232 declare 233 Res : Primes_Set (0); 234 begin 235 return Res; 236 end; 237 when N_True => 238 declare 239 Res : Primes_Set (1); 240 begin 241 Res.Nbr := 1; 242 Res.Set (1).Set := 0; 243 Res.Set (1).Val := 0; 244 return Res; 245 end; 246 when N_Not_Bool => 247 return Build_Primes (Get_Boolean (N), not Negate); 248 when N_And_Bool => 249 if Negate then 250 -- !(a & b) <-> !a || !b 251 return Build_Primes_Or (Build_Primes (Get_Left (N), True), 252 Build_Primes (Get_Right (N), True)); 253 else 254 return Build_Primes_And (Build_Primes (Get_Left (N), False), 255 Build_Primes (Get_Right (N), False)); 256 end if; 257 when N_Or_Bool => 258 if Negate then 259 -- !(a || b) <-> !a && !b 260 return Build_Primes_And (Build_Primes (Get_Left (N), True), 261 Build_Primes (Get_Right (N), True)); 262 else 263 return Build_Primes_Or (Build_Primes (Get_Left (N), False), 264 Build_Primes (Get_Right (N), False)); 265 end if; 266 when N_Imp_Bool => 267 if not Negate then 268 -- a -> b <-> !a || b 269 return Build_Primes_Or (Build_Primes (Get_Left (N), True), 270 Build_Primes (Get_Right (N), False)); 271 else 272 -- !(a -> b) <-> a && !b 273 return Build_Primes_And (Build_Primes (Get_Left (N), False), 274 Build_Primes (Get_Right (N), True)); 275 end if; 276 when N_Equiv_Bool => 277 if not Negate then 278 -- a <-> b <-> (a && b) || (!a && !b) 279 return Build_Primes_Or 280 (Build_Primes_And (Build_Primes (Get_Left (N), False), 281 Build_Primes (Get_Right (N), False)), 282 Build_Primes_And (Build_Primes (Get_Left (N), True), 283 Build_Primes (Get_Right (N), True))); 284 else 285 -- !(a <-> b) <-> (!a && b) || (a && !b) 286 return Build_Primes_Or 287 (Build_Primes_And (Build_Primes (Get_Left (N), True), 288 Build_Primes (Get_Right (N), False)), 289 Build_Primes_And (Build_Primes (Get_Left (N), False), 290 Build_Primes (Get_Right (N), True))); 291 end if; 292 when others => 293 Error_Kind ("build_primes", N); 294 end case; 295 end Build_Primes; 296 297 function Build_Primes (N : Node) return Primes_Set is 298 begin 299 return Build_Primes (N, False); 300 end Build_Primes; 301 302 function Build_Node (P : Prime_Type) return Node 303 is 304 Res : Node := Null_Node; 305 N : Node; 306 S : Vector_Type := P.Set; 307 T : Vector_Type; 308 begin 309 if S = 0 then 310 return True_Node; 311 end if; 312 for I in Natural range 1 .. Vector_Type'Modulus loop 313 T := Term (I); 314 if (S and T) /= 0 then 315 N := Term_Assoc (I); 316 if (P.Val and T) = 0 then 317 N := PSL.CSE.Build_Bool_Not (N); 318 end if; 319 if Res = Null_Node then 320 Res := N; 321 else 322 Res := PSL.CSE.Build_Bool_And (Res, N); 323 end if; 324 S := S and not T; 325 exit when S = 0; 326 end if; 327 end loop; 328 return Res; 329 end Build_Node; 330 331 function Build_Node (Ps : Primes_Set) return Node 332 is 333 Res : Node; 334 begin 335 if Ps.Nbr = 0 then 336 return False_Node; 337 else 338 Res := Build_Node (Ps.Set (1)); 339 for I in 2 .. Ps.Nbr loop 340 Res := PSL.CSE.Build_Bool_Or (Res, Build_Node (Ps.Set (I))); 341 end loop; 342 return Res; 343 end if; 344 end Build_Node; 345 346 -- FIXME: finish the work: do a real Quine-McKluskey minimization. 347 function Reduce (N : Node) return Node is 348 begin 349 return Build_Node (Build_Primes (N)); 350 end Reduce; 351end PSL.QM; 352