1{-# LANGUAGE UnicodeSyntax #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE TemplateHaskell #-} 4 5-- | Template Haskell utilities for generating double words declarations 6module Data.DoubleWord.TH 7 ( mkDoubleWord 8 , mkUnpackedDoubleWord 9 ) where 10 11import GHC.Arr (Ix(..)) 12import Data.Ratio ((%)) 13import Data.Bits (Bits(..)) 14#if MIN_VERSION_base(4,7,0) 15import Data.Bits (FiniteBits(..)) 16#endif 17import Data.Word (Word8, Word16, Word32, Word64) 18import Data.Int (Int8, Int16, Int32, Int64) 19#if MIN_VERSION_hashable(1,2,0) 20import Data.Hashable (Hashable(..), hashWithSalt) 21#else 22import Data.Hashable (Hashable(..), combine) 23#endif 24#if !MIN_VERSION_base(4,12,0) 25import Control.Applicative ((<$>), (<*>)) 26#endif 27import Language.Haskell.TH hiding (unpacked, match) 28import Data.BinaryWord (BinaryWord(..)) 29import Data.DoubleWord.Base 30 31tup ∷ [Exp] → Exp 32#if MIN_VERSION_template_haskell(2,16,0) 33tup = TupE . fmap Just 34#else 35tup = TupE 36#endif 37 38-- | Declare signed and unsigned binary word types built from 39-- the specified low and high halves. The high halves /must/ have 40-- less or equal bit-length than the lover half. For each data type 41-- the following instances are declared: 'DoubleWord', 'Eq', 'Ord', 42-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Read', 43-- 'Hashable', 'Ix', 'Bits', 'BinaryWord'. 44mkDoubleWord ∷ String -- ^ Unsigned variant type name 45 → String -- ^ Unsigned variant constructor name 46#if MIN_VERSION_template_haskell(2,11,0) 47 → Bang -- ^ Unsigned variant higher half strictness 48#else 49 → Strict -- ^ Unsigned variant higher half strictness 50#endif 51 → Name -- ^ Unsigned variant higher half type 52 → String -- ^ Signed variant type name 53 → String -- ^ Signed variant constructor name 54#if MIN_VERSION_template_haskell(2,11,0) 55 → Bang -- ^ Signed variant higher half strictness 56#else 57 → Strict -- ^ Signed variant higher half strictness 58#endif 59 → Name -- ^ Signed variant higher half type 60#if MIN_VERSION_template_haskell(2,11,0) 61 → Bang -- ^ Lower half strictness 62#else 63 → Strict -- ^ Lower half strictness 64#endif 65 → Name -- ^ Lower half type 66 → [Name] -- ^ List of instances for automatic derivation 67 → Q [Dec] 68mkDoubleWord un uc uhs uhn sn sc shs shn ls ln ad = 69 (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls lt ad 70 <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls lt ad 71 where un' = mkName un 72 uc' = mkName uc 73 sn' = mkName sn 74 sc' = mkName sc 75 lt = ConT ln 76 77-- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for 78-- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@ 79mkUnpackedDoubleWord ∷ String -- ^ Unsigned variant type name 80 → Name -- ^ Unsigned variant higher half type 81 → String -- ^ Signed variant type name 82 → Name -- ^ Signed variant higher half type 83 → Name -- ^ Lower half type 84 → [Name] -- ^ List of instances for automatic derivation 85 → Q [Dec] 86mkUnpackedDoubleWord un uhn sn shn ln ad = 87 mkDoubleWord un un unpacked uhn sn sn unpacked shn unpacked ln ad 88 where unpacked = 89#if MIN_VERSION_template_haskell(2,11,0) 90 Bang SourceUnpack SourceStrict 91#else 92 Unpacked 93#endif 94 95mkDoubleWord' ∷ Bool 96 → Name → Name 97 → Name → Name 98#if MIN_VERSION_template_haskell(2,11,0) 99 → Bang 100#else 101 → Strict 102#endif 103 → Type 104#if MIN_VERSION_template_haskell(2,11,0) 105 → Bang 106#else 107 → Strict 108#endif 109 → Type 110 → [Name] 111 → Q [Dec] 112mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT ad = (<$> mkRules) $ (++) $ 113 [ DataD [] tp [] 114#if MIN_VERSION_template_haskell(2,11,0) 115 Nothing 116#endif 117 [NormalC cn [(hiS, hiT), (loS, loT)]] 118#if MIN_VERSION_template_haskell(2,12,0) 119 [DerivClause Nothing (map ConT ad)] 120#elif MIN_VERSION_template_haskell(2,11,0) 121 (ConT <$> ad) 122#else 123 ad 124#endif 125 , inst ''DoubleWord [tp] 126 [ tySynInst ''LoWord [tpT] loT 127 , tySynInst ''HiWord [tpT] hiT 128 , funLo 'loWord (VarE lo) 129 , inline 'loWord 130 , funHi 'hiWord (VarE hi) 131 , inline 'hiWord 132 , fun 'fromHiAndLo (ConE cn) 133 , inline 'fromHiAndLo 134 {- extendLo x = W allZeroes x -} 135 , funX 'extendLo $ appWN ['allZeroes, x] 136 , inline 'extendLo 137 {- 138 signExtendLo x = W (if x < 0 then allOnes else allZeroes) 139 (unsignedWord x) 140 -} 141 , funX 'signExtendLo $ 142 appW [ CondE (appVN 'testMsb [x]) 143 (VarE 'allOnes) (VarE 'allZeroes) 144 , appVN 'unsignedWord [x] ] 145 , inlinable 'signExtendLo 146 ] 147 , inst ''Eq [tp] $ 148 {- (W hi lo) == (W hi' lo') = hi == hi' && lo == lo' -} 149 [ funHiLo2 '(==) $ 150 appV '(&&) [appVN '(==) [hi, hi'], appVN '(==) [lo, lo']] 151 , inline '(==) ] 152 , inst ''Ord [tp] 153 {- 154 compare (W hi lo) (W hi' lo') = case hi `compare` hi' of 155 EQ → lo `compare` lo' 156 x → x 157 -} 158 [ funHiLo2 'compare $ 159 CaseE (appVN 'compare [hi, hi']) 160 [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] 161 , Match (VarP x) (NormalB (VarE x)) [] ] 162 , inlinable 'compare ] 163 , inst ''Bounded [tp] 164 {- minBound = W minBound minBound -} 165 [ fun 'minBound $ appWN ['minBound, 'minBound] 166 , inline 'minBound 167 {- maxBound = W maxBound maxBound -} 168 , fun 'maxBound $ appWN ['maxBound, 'maxBound] 169 , inline 'maxBound ] 170 , inst ''Enum [tp] 171 {- 172 succ (W hi lo) = if lo == maxBound then W (succ hi) minBound 173 else W hi (succ lo) 174 -} 175 [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound]) 176 (appW [appVN 'succ [hi], VarE 'minBound]) 177 (appW [VarE hi, appVN 'succ [lo]]) 178 , inlinable 'succ 179 {- 180 pred (W hi lo) = if lo == minBound then W (pred hi) maxBound 181 else W hi (pred lo) 182 -} 183 , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound]) 184 (appW [appVN 'pred [hi], VarE 'maxBound]) 185 (appW [VarE hi, appVN 'pred [lo]]) 186 , inlinable 'pred 187 {- 188 toEnum x 189 | x < 0 = if signed 190 then W (-1) (negate $ 1 + toEnum (negate (x + 1))) 191 else ERROR 192 | otherwise = W 0 (toEnum x) 193 -} 194 , funX 'toEnum $ 195 CondE (appV '(<) [VarE x, litI 0]) 196 (if signed 197 then appW [ VarE 'allOnes 198 , appV 'negate 199 [ appV '(+) 200 [ oneE 201 , appV 'toEnum 202 [ appV 'negate 203 [appV '(+) [VarE x, litI 1]] ] 204 ] 205 ] 206 ] 207 else appV 'error [litS "toEnum: nagative value"]) 208 (appW [VarE 'allZeroes, appVN 'toEnum [x]]) 209 {- 210 fromEnum (W 0 lo) = fromEnum lo 211 fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo 212 else ERROR 213 fromEnum _ = ERROR 214 -} 215 , FunD 'fromEnum $ 216 Clause [ConP cn [LitP $ IntegerL 0, VarP lo]] 217 (NormalB $ appVN 'fromEnum [lo]) [] : 218 if signed 219 then [ Clause [ConP cn [LitP $ IntegerL (-1), VarP lo]] 220 (NormalB $ 221 appV 'negate 222 [appV 'fromEnum [appV 'negate [VarE lo]]]) 223 [] 224 , Clause [WildP] 225 (NormalB $ 226 appV 'error [litS "fromEnum: out of bounds"]) 227 [] 228 ] 229 else [ Clause [WildP] 230 (NormalB $ 231 appV 'error [litS "fromEnum: out of bounds"]) 232 [] ] 233 {- enumFrom x = enumFromTo x maxBound -} 234 , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] 235 , inline 'enumFrom 236 {- 237 enumFromThen x y = 238 enumFromThenTo x y $ if y >= x then maxBound else minBound 239 -} 240 , funXY 'enumFromThen $ 241 appV 'enumFromThenTo 242 [ VarE x 243 , VarE y 244 , CondE (appVN '(>=) [y, x]) (VarE 'maxBound) (VarE 'minBound) 245 ] 246 , inlinable 'enumFromThen 247 {- 248 enumFromTo x y = case y `compare` x of 249 LT → [] 250 EQ → [x] 251 GT → x : up y x 252 where up to c = next : if next == to then [] else up to next 253 where next = c + 1 254 -} 255 , FunD 'enumFromTo $ return $ 256 Clause 257 [VarP x, VarP y] 258 (NormalB $ 259 CaseE (appVN 'compare [y, x]) 260 [ match (ConP 'LT []) (ConE '[]) 261 , match (ConP 'EQ []) (singE $ VarE x) 262 , match (ConP 'GT []) $ appC '(:) [VarE x, appVN up [y, x]] 263 ]) 264 [ FunD up $ return $ 265 Clause [VarP to, VarP c] 266 (NormalB $ 267 appC '(:) 268 [ VarE next 269 , CondE (appVN '(==) [next, to]) 270 (ConE '[]) (appVN up [to, next]) 271 ]) 272 [val next $ appVN '(+) [c, 'lsb]] 273 ] 274 {- 275 enumFromThenTo x y z = case y `compare` x of 276 LT → if z > y then (if z > x then [] else [x]) 277 else x : down step (z + step) y 278 where step = x - y 279 to = z + step 280 down c | c < to = [c] 281 | otherwise = c : down (c - step) 282 EQ → if z < x then [] else repeat x 283 GT → if z < y then (if z < x then [] else [x]) 284 else x : up step (z - step) y 285 where step = y - x 286 to = z - step 287 up c | c > to = [c] 288 | otherwise = c : up (c + step) 289 -} 290 , FunD 'enumFromThenTo $ return $ 291 Clause [VarP x, VarP y, VarP z] 292 (NormalB $ 293 CaseE (appVN 'compare [y, x]) 294 [ match' 295 (ConP 'LT []) 296 (CondE (appVN '(>) [z, y]) 297 (CondE (appVN '(>) [z, x]) 298 (ConE '[]) (singE $ VarE x)) 299 (appC '(:) [VarE x, appVN down [y]])) 300 [ val step $ appVN '(-) [x, y] 301 , val to $ appVN '(+) [z, step] 302 , fun1 down c $ 303 CondE (appVN '(<) [c, to]) 304 (singE $ VarE c) 305 (appC '(:) 306 [ VarE c 307 , appV down [appVN '(-) [c, step]] 308 ]) 309 ] 310 , match 311 (ConP 'EQ []) 312 (CondE (appVN '(<) [z, x]) 313 (ConE '[]) (appVN 'repeat [x])) 314 , match' 315 (ConP 'GT []) 316 (CondE (appVN '(<) [z, y]) 317 (CondE (appVN '(<) [z, x]) 318 (ConE '[]) (singE $ VarE x)) 319 (appC '(:) [VarE x, appVN up [y]])) 320 [ val step $ appVN '(-) [y, x] 321 , val to $ appVN '(-) [z, step] 322 , fun1 up c $ 323 CondE (appVN '(>) [c, to]) 324 (singE $ VarE c) 325 (appC '(:) 326 [ VarE c 327 , appV up [appVN '(+) [c, step]] 328 ]) 329 ] 330 ]) 331 [] 332 ] 333 , inst ''Num [tp] 334 {- 335 negate (W hi lo) = if lo == 0 then W (negate hi) 0 336 else W (negate $ hi + 1) (negate lo) 337 -} 338 [ funHiLo 'negate $ 339 CondE (appVN '(==) [lo, 'allZeroes]) 340 (appW [appVN 'negate [hi], zeroE]) 341 (appW [ appV 'negate [appVN '(+) ['lsb, hi]] 342 , appVN 'negate [lo] ]) 343 , inlinable 'negate 344 {- 345 abs x = if SIGNED 346 then if x < 0 then negate x else x 347 else x 348 -} 349 , funX 'abs $ 350 if signed 351 then CondE (appVN '(<) [x, 'allZeroes]) 352 (appVN 'negate [x]) (VarE x) 353 else VarE x 354 , if signed then inlinable 'abs else inline 'abs 355 {- 356 signum (W hi lo) = if SIGNED 357 then case hi `compare` 0 of 358 LT → W (-1) maxBound 359 EQ → if lo == 0 then 0 else 1 360 GT → W 0 1 361 else if hi == 0 && lo == 0 then 0 else 1 362 -} 363 , funHiLo 'signum $ 364 if signed 365 then CaseE (appVN 'compare [hi, 'allZeroes]) 366 [ Match (ConP 'LT []) 367 (NormalB $ appWN ['allOnes, 'maxBound]) [] 368 , Match (ConP 'EQ []) 369 (NormalB $ CondE (appVN '(==) [lo, 'allZeroes]) 370 zeroE oneE) 371 [] 372 , Match (ConP 'GT []) (NormalB oneE) [] 373 ] 374 else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] 375 , appVN '(==) [lo, 'allZeroes] ]) 376 zeroE oneE 377 , inlinable 'signum 378 {- 379 (W hi lo) + (W hi' lo') = W y x 380 where x = lo + lo' 381 y = hi + hi' + if x < lo then 1 else 0 382 -} 383 , funHiLo2' '(+) (appWN [y, x]) 384 [ val x $ appVN '(+) [lo, lo'] 385 , val y $ appV '(+) 386 [ appVN '(+) [hi, hi'] 387 , CondE (appVN '(<) [x, lo]) oneE zeroE ] 388 ] 389 , inlinable '(+) 390 {- 391 UNSIGNED: 392 (W hi lo) * (W hi' lo') = 393 W (hi * fromIntegral lo' + hi' * fromIntegral lo + 394 fromIntegral x) y 395 where (x, y) = unwrappedMul lo lo' 396 397 SIGNED: 398 x * y = signedWord $ unsignedWord x * unsignedWord y 399 -} 400 , if signed 401 then 402 funXY '(*) $ 403 appV 'signedWord 404 [appV '(*) [ appVN 'unsignedWord [x] 405 , appVN 'unsignedWord [y] ]] 406 else 407 funHiLo2' '(*) 408 (appW [ appV '(+) 409 [ appV '(+) 410 [ appV '(*) [VarE hi, appVN 'fromIntegral [lo']] 411 , appV '(*) [VarE hi', appVN 'fromIntegral [lo]] ] 412 , appVN 'fromIntegral [x] ] 413 , VarE y ]) 414 [vals [x, y] (appVN 'unwrappedMul [lo, lo'])] 415 , inlinable '(*) 416 {- 417 fromInteger x = W (fromInteger y) (fromInteger z) 418 where (y, z) = x `divMod` (toInteger (maxBound ∷ L) + 1) 419 -} 420 , funX' 'fromInteger 421 (appW [appVN 'fromInteger [y], appVN 'fromInteger [z]]) 422 [vals [y, z] 423 (appV 'divMod 424 [ VarE x 425 , appV '(+) 426 [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] 427 ])] 428 ] 429 , inst ''Real [tp] 430 {- toRational x = toInteger x % 1 -} 431 [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1] 432 , inline 'toRational ] 433 , inst ''Integral [tp] $ 434 {- 435 toInteger (W hi lo) = 436 toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo 437 -} 438 [ funHiLo 'toInteger $ 439 appV '(+) 440 [ appV '(*) 441 [ appVN 'toInteger [hi] 442 , appV '(+) 443 [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ] 444 , appVN 'toInteger [lo] ] 445 {- 446 UNSIGNED: 447 quotRem x@(W hi lo) y@(W hi' lo') = 448 if hi' == 0 && lo' == 0 449 then error "divide by zero" 450 else case compare hi hi' of 451 LT → (0, x) 452 EQ → compare lo lo' of 453 LT → (0, x) 454 EQ → (1, 0) 455 GT | hi' == 0 → (W 0 t2, W 0 t1) 456 where (t2, t1) = quotRem lo lo' 457 GT → (1, lo - lo') 458 GT | lo' == 0 → (W 0 (fromIntegral t2), 459 W (fromIntegral t1) lo) 460 where (t2, t1) = quotRem hi hi' 461 GT | hi' == 0 && lo' == maxBound → 462 if t2 == 0 463 then if t1 == maxBound 464 then (W 0 z + 1, 0) 465 else (W 0 z, t1) 466 else if t1 == maxBound 467 then (W 0 z + 2, 1) 468 else if t1 == xor maxBound 1 469 then (W 0 z + 2, 0) 470 else (W 0 z + 1, W 0 (t1 + 1)) 471 where z = fromIntegral hi 472 (t2, t1) = unwrappedAdd z lo 473 GT | hi' == 0 → (t2, W 0 t1) 474 where (t2, t1) = div1 hi lo lo' 475 GT → if t1 == t2 476 then (1, x - y) 477 else (W 0 (fromIntegral q2), shiftR r2 t2) 478 where t1 = leadingZeroes hi 479 t2 = leadingZeroes hi' 480 z = shiftR hi (bitSize (undefined ∷ H) - t2) 481 W hhh hll = shiftL x t2 482 v@(W lhh lll) = shiftL y t2 483 -- z hhh hll / lhh lll 484 ((0, q1), r1) = div2 z hhh lhh 485 (t4, t3) = unwrappedMul (fromIntegral q1) lll 486 t5 = W (fromIntegral t4) t3 487 t6 = W r1 hll 488 (t8, t7) = unwrappedAdd t6 v 489 (t10, t9) = unwrappedAdd t7 v 490 (q2, r2) = 491 if t5 > t6 492 then 493 if loWord t8 == 0 494 then 495 if t7 >= t5 496 then (q1 - 1, t7 - t5) 497 else 498 if loWord t10 == 0 499 then (q1 - 2, t9 - t5) 500 else (q1 - 2, (maxBound - t5) + t9 + 1) 501 else 502 (q1 - 1, (maxBound - t5) + t7 + 1) 503 else 504 (q1, t6 - t5) 505 where div1 hhh hll by = go hhh hll 0 506 where (t2, t1) = quotRem maxBound by 507 go h l c = 508 if z == 0 509 then (c + W (fromIntegral t8) t7 + W 0 t10, t9) 510 else go (fromIntegral z) t5 511 (c + (W (fromIntegral t8) t7)) 512 where h1 = fromIntegral h 513 (t4, t3) = unwrappedMul h1 (t1 + 1) 514 (t6, t5) = unwrappedAdd t3 l 515 z = t4 + t6 516 (t8, t7) = unwrappedMul h1 t2 517 (t10, t9) = quotRem t5 by 518 div2 hhh hll by = go hhh hll (0, 0) 519 where (t2, t1) = quotRem maxBound by 520 go h l c = 521 if z == 0 522 then (addT (addT c (t8, t7)) (0, t10), t9) 523 else go z t5 (addT c (t8, t7)) 524 where (t4, t3) = unwrappedMul h (t1 + 1) 525 (t6, t5) = unwrappedAdd t3 l 526 z = t4 + t6 527 (t8, t7) = unwrappedMul h t2 528 (t10, t9) = quotRem t5 by 529 addT (lhh, lhl) (llh, lll) = (lhh + llh + t4, t3) 530 where (t4, t3) = unwrappedAdd lhl lll 531 532 SIGNED: 533 quotRem x y = 534 if x < 0 535 then 536 if y < 0 537 then let (q, r) = quotRem (negate $ unsignedWord x) 538 (negate $ unsignedWord y) in 539 (signedWord q, signedWord $ negate r) 540 else let (q, r) = quotRem (negate $ unsignedWord x) 541 (unsignedWord y) in 542 (signedWord $ negate q, signedWord $ negate r) 543 else 544 if y < 0 545 then let (q, r) = quotRem (unsignedWord x) 546 (negate $ unsignedWord y) in 547 (signedWord $ negate q, signedWord r) 548 else let (q, r) = quotRem (unsignedWord x) 549 (unsignedWord y) in 550 (signedWord q, signedWord r) 551 -} 552 , if signed 553 then 554 funXY 'quotRem $ 555 CondE (appVN 'testMsb [x]) 556 (CondE (appVN 'testMsb [y]) 557 (LetE [vals [q, r] $ 558 appV 'quotRem 559 [ appV 'unsignedWord [appVN 'negate [x]] 560 , appV 'unsignedWord [appVN 'negate [y]] ]] 561 (tup [ appVN 'signedWord [q] 562 , appV 'signedWord [appVN 'negate [r]] ])) 563 (LetE [vals [q, r] $ 564 appV 'quotRem 565 [ appV 'unsignedWord [appVN 'negate [x]] 566 , appVN 'unsignedWord [y] ]] 567 (tup [ appV 'signedWord [appVN 'negate [q]] 568 , appV 'signedWord [appVN 'negate [r]] ]))) 569 (CondE (appVN 'testMsb [y]) 570 (LetE [vals [q, r] $ 571 appV 'quotRem 572 [ appVN 'unsignedWord [x] 573 , appV 'unsignedWord [appVN 'negate [y]] ]] 574 (tup [ appV 'signedWord [appVN 'negate [q]] 575 , appVN 'signedWord [r] ])) 576 (LetE [vals [q, r] $ 577 appV 'quotRem 578 [ appVN 'unsignedWord [x] 579 , appVN 'unsignedWord [y] ]] 580 (tup [ appVN 'signedWord [q] 581 , appVN 'signedWord [r] ]))) 582 else 583 funHiLo2XY' 'quotRem 584 (CondE (appV '(&&) [ appVN '(==) [hi', 'allZeroes] 585 , appVN '(==) [lo', 'allZeroes] ]) 586 (appV 'error [litS "divide by zero"]) 587 (CaseE (appVN 'compare [hi, hi']) 588 [ match (ConP 'LT []) (tup [zeroE, VarE x]) 589 , match (ConP 'EQ []) 590 (CaseE (appVN 'compare [lo, lo']) 591 [ match (ConP 'LT []) (tup [zeroE, VarE x]) 592 , match (ConP 'EQ []) (tup [oneE, zeroE]) 593 , Match (ConP 'GT []) 594 (GuardedB $ return 595 ( NormalG (appVN '(==) [hi', 'allZeroes]) 596 , tup [ appWN ['allZeroes, t2] 597 , appWN ['allZeroes, t1] ])) 598 [vals [t2, t1] $ appVN 'quotRem [lo, lo']] 599 , match (ConP 'GT []) $ 600 tup [ oneE 601 , appW [zeroE, appVN '(-) [lo, lo']] ] 602 ]) 603 , Match (ConP 'GT []) 604 (GuardedB $ return 605 ( NormalG (appVN '(==) [lo', 'allZeroes]) 606 , tup 607 [ appW [zeroE, appVN 'fromIntegral [t2]] 608 , appW [appVN 'fromIntegral [t1], VarE lo] 609 ] )) 610 [vals [t2, t1] $ appVN 'quotRem [hi, hi']] 611 , Match (ConP 'GT []) 612 (GuardedB $ return 613 ( NormalG (appV '(&&) 614 [ appVN '(==) [hi', 'allZeroes] 615 , appVN '(==) [lo', 'maxBound] ]) 616 , CondE (appVN '(==) [t2, 'allZeroes]) 617 (CondE (appVN '(==) [t1, 'maxBound]) 618 (tup 619 [ appV '(+) 620 [ appWN ['allZeroes, z] 621 , oneE ] 622 , zeroE ]) 623 (tup 624 [ appWN ['allZeroes, z] 625 , appWN ['allZeroes, t1] ])) 626 (CondE (appVN '(==) [t1, 'maxBound]) 627 (tup 628 [ appV '(+) 629 [appWN ['allZeroes, z], litI 2] 630 , oneE ]) 631 (CondE 632 (appV '(==) 633 [ VarE t1 634 , appVN 'xor ['maxBound, 'lsb] 635 ]) 636 (tup 637 [ appV '(+) 638 [appWN ['allZeroes, z], litI 2] 639 , zeroE ]) 640 (tup 641 [ appV '(+) 642 [appWN ['allZeroes, z], oneE] 643 , appW [ zeroE 644 , appVN '(+) [t1, 'lsb] ] 645 ]))) 646 )) 647 [ val z $ appVN 'fromIntegral [hi] 648 , vals [t2, t1] $ appVN 'unwrappedAdd [z, lo] ] 649 , Match (ConP 'GT []) 650 (GuardedB $ return 651 ( NormalG (appVN '(==) [hi', 'allZeroes]) 652 , tup [VarE t2, appWN ['allZeroes, t1]] )) 653 [vals [t2, t1] $ appVN div1 [hi, lo, lo']] 654 , match' (ConP 'GT []) 655 (CondE (appVN '(==) [t1, t2]) 656 (tup [oneE, appVN '(-) [x, y]]) 657 (tup [ appW [zeroE, appVN 'fromIntegral [q2]] 658 , appVN 'shiftR [r2, t2] ])) 659 [ val t1 $ appVN 'leadingZeroes [hi] 660 , val t2 $ appVN 'leadingZeroes [hi'] 661 , val z $ appV 'shiftR 662 [ VarE hi 663 , appV '(-) [hiSizeE, VarE t2] 664 ] 665 , ValD (ConP cn [VarP hhh, VarP hll]) 666 (NormalB $ appVN 'shiftL [x, t2]) [] 667 , ValD (AsP v $ ConP cn [VarP lhh, VarP lll]) 668 (NormalB $ appVN 'shiftL [y, t2]) [] 669 , ValD (TupP [ TupP [LitP (IntegerL 0), VarP q1] 670 , VarP r1 ]) 671 (NormalB $ appVN div2 [z, hhh, lhh]) [] 672 , vals [t4, t3] $ 673 appV 'unwrappedMul 674 [appVN 'fromIntegral [q1], VarE lll] 675 , val t5 $ appW [appVN 'fromIntegral [t4], VarE t3] 676 , val t6 $ appWN [r1, hll] 677 , vals [t8, t7] $ appVN 'unwrappedAdd [t6, v] 678 , vals [t10, t9] $ appVN 'unwrappedAdd [t7, v] 679 , vals [q2, r2] $ 680 CondE (appVN '(>) [t5, t6]) 681 (CondE (appV '(==) [appVN 'loWord [t8], zeroE]) 682 (CondE (appVN '(>=) [t7, t5]) 683 (tup [ appVN '(-) [q1, 'lsb] 684 , appVN '(-) [t7, t5] ]) 685 (CondE (appV '(==) [ appVN 'loWord [t10] 686 , zeroE ]) 687 (tup [ appV '(-) [VarE q1, litI 2] 688 , appVN '(-) [t9, t5] ]) 689 (tup [ appV '(-) [VarE q1, litI 2] 690 , appV '(+) 691 [ appVN '(-) ['maxBound, t5] 692 , appVN '(+) [t9, 'lsb] 693 ] 694 ]))) 695 (tup [ appVN '(-) [q1, 'lsb] 696 , appV '(+) 697 [ appVN '(-) ['maxBound, t5] 698 , appVN '(+) [t7, 'lsb] ] 699 ])) 700 (tup [VarE q1, appVN '(-) [t6, t5]]) 701 ] 702 ])) 703 [ FunD div1 $ return $ 704 Clause [VarP hhh, VarP hll, VarP by] 705 (NormalB (appVN go [hhh, hll, 'allZeroes])) 706 [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] 707 , FunD go $ return $ 708 Clause [VarP h, VarP l, VarP c] 709 (NormalB 710 (CondE (appVN '(==) [z, 'allZeroes]) 711 (tup [ appV '(+) 712 [ VarE c 713 , appV '(+) 714 [ appW [ appVN 'fromIntegral [t8] 715 , VarE t7 ] 716 , appWN ['allZeroes, t10] ] 717 ] 718 , VarE t9 ]) 719 (appV go 720 [ appVN 'fromIntegral [z] 721 , VarE t5 722 , appV '(+) 723 [ VarE c 724 , appW [ appVN 'fromIntegral [t8] 725 , VarE t7 ] 726 ] 727 ]))) 728 [ val h1 $ appVN 'fromIntegral [h] 729 , vals [t4, t3] $ 730 appV 'unwrappedMul 731 [VarE h1, appVN '(+) [t1, 'lsb]] 732 , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] 733 , val z $ appVN '(+) [t4, t6] 734 , vals [t8, t7] $ appVN 'unwrappedMul [h1, t2] 735 , vals [t10, t9] $ appVN 'quotRem [t5, by] ] 736 ] 737 , FunD div2 $ return $ 738 Clause [VarP hhh, VarP hll, VarP by] 739 (NormalB (appV go [ VarE hhh 740 , VarE hll 741 , tup [zeroE, zeroE]])) 742 [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] 743 , FunD go $ return $ 744 Clause [VarP h, VarP l, VarP c] 745 (NormalB 746 (CondE (appVN '(==) [z, 'allZeroes]) 747 (tup [ appV addT 748 [ VarE c 749 , appV addT 750 [ tup [VarE t8 , VarE t7] 751 , tup [zeroE, VarE t10] ] 752 ] 753 , VarE t9 ]) 754 (appV go 755 [ VarE z 756 , VarE t5 757 , appV addT 758 [ VarE c 759 , tup [VarE t8, VarE t7] 760 ] 761 ]))) 762 [ vals [t4, t3] $ 763 appV 'unwrappedMul 764 [VarE h, appVN '(+) [t1, 'lsb]] 765 , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] 766 , val z $ appVN '(+) [t4, t6] 767 , vals [t8, t7] $ appVN 'unwrappedMul [h, t2] 768 , vals [t10, t9] $ appVN 'quotRem [t5, by] ] 769 , FunD addT $ return $ 770 Clause [ TupP [VarP lhh, VarP lhl] 771 , TupP [VarP llh, VarP lll] 772 ] 773 (NormalB (tup [ appV '(+) 774 [ VarE t4 775 , appVN '(+) [lhh, llh] 776 ] 777 , VarE t3 778 ])) 779 [vals [t4, t3] $ appVN 'unwrappedAdd [lhl, lll]] 780 ] 781 ] 782 {- 783 UNSIGNED: 784 divMod = quotRem 785 786 SIGNED: 787 divMod x y = 788 if x < 0 789 then 790 if y < 0 791 then let (q, r) = quotRem (negate $ unsignedWord x) 792 (negate $ unsignedWord y) in 793 (signedWord q, signedWord $ negate r) 794 else let (q, r) = quotRem (negate $ unsignedWord x) 795 (unsignedWord y) 796 q1 = signedWord (negate q) 797 r1 = signedWord (negate r) in 798 if r == 0 799 then (q1, r1) 800 else (q1 - 1, r1 + y) 801 else 802 if y < 0 803 then let (q, r) = quotRem (unsignedWord x) 804 (negate $ unsignedWord y) 805 q1 = signedWord (negate q) 806 r1 = signedWord r in 807 if r == 0 808 then (q1, r1) 809 else (q1 - 1, r1 + y) 810 else let (q, r) = quotRem (unsignedWord x) 811 (unsignedWord y) in 812 (signedWord q, signedWord r) 813 -} 814 , if signed 815 then 816 funXY 'divMod $ 817 CondE (appVN 'testMsb [x]) 818 (CondE (appVN 'testMsb [y]) 819 (LetE [vals [q, r] $ 820 appV 'quotRem 821 [ appV 'unsignedWord [appVN 'negate [x]] 822 , appV 'unsignedWord [appVN 'negate [y]] ]] 823 (tup [ appVN 'signedWord [q] 824 , appV 'signedWord [appVN 'negate [r]] ])) 825 (LetE [ vals [q, r] $ 826 appV 'quotRem 827 [ appV 'unsignedWord [appVN 'negate [x]] 828 , appVN 'unsignedWord [y] ] 829 , val q1 $ appV 'signedWord [appVN 'negate [q]] 830 , val r1 $ appV 'signedWord [appVN 'negate [r]] 831 ] 832 (CondE (appVN '(==) [r, 'allZeroes]) 833 (tup [VarE q1, VarE r1]) 834 (tup [ appVN '(-) [q1, 'lsb] 835 , appVN '(+) [r1, y] ])))) 836 (CondE (appVN 'testMsb [y]) 837 (LetE [ vals [q, r] $ 838 appV 'quotRem 839 [ appVN 'unsignedWord [x] 840 , appV 'unsignedWord [appVN 'negate [y]] ] 841 , val q1 $ appV 'signedWord [appVN 'negate [q]] 842 , val r1 $ appVN 'signedWord [r] 843 ] 844 (CondE (appVN '(==) [r, 'allZeroes]) 845 (tup [VarE q1, VarE r1]) 846 (tup [ appVN '(-) [q1, 'lsb] 847 , appVN '(+) [r1, y] ]))) 848 (LetE [vals [q, r] $ 849 appV 'quotRem 850 [ appVN 'unsignedWord [x] 851 , appVN 'unsignedWord [y] ]] 852 (tup [ appVN 'signedWord [q] 853 , appVN 'signedWord [r] ]))) 854 else 855 fun 'divMod $ VarE 'quotRem 856 ] ++ 857 if signed then [] else [inline 'divMod] 858 , inst ''Show [tp] 859 [ fun 'show $ appVN '(.) ['show, 'toInteger] 860 , inline 'show ] 861 , inst ''Read [tp] 862 {- 863 readsPrec x y = fmap (\(q, r) → (fromInteger q, r)) 864 $ readsPrec x y 865 -} 866 [ funXY 'readsPrec $ 867 appV 'fmap [ LamE [TupP [VarP q, VarP r]] 868 (tup [appVN 'fromInteger [q], VarE r]) 869 , appVN 'readsPrec [x, y] ] 870 ] 871 , inst ''Hashable [tp] 872#if MIN_VERSION_hashable(1,2,0) 873 {- 874 hashWithSalt x (W hi lo) = 875 x `hashWithSalt` hi `hashWithSalt` lo 876 -} 877 [ funXHiLo 'hashWithSalt $ 878 appV 'hashWithSalt [appVN 'hashWithSalt [x, hi], VarE lo] 879#else 880 {- hash (W hi lo) = hash hi `combine` hash lo -} 881 [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]] 882 , inline 'hash 883#endif 884 , inline 'hashWithSalt ] 885 , inst ''Ix [tp] 886 {- range (x, y) = enumFromTo x y -} 887 [ funTup 'range $ appVN 'enumFromTo [x, y] 888 , inline 'range 889 {- unsafeIndex (x, _) z = fromIntegral z - fromIntegral x -} 890 , funTupLZ 'unsafeIndex $ 891 appV '(-) [appVN 'fromIntegral [z], appVN 'fromIntegral [x]] 892 , inline 'unsafeIndex 893 {- inRange (x, y) z = z >= x && z <= y -} 894 , funTupZ 'inRange $ 895 appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]] 896 , inline 'inRange ] 897 , inst ''Bits [tp] $ 898 {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -} 899 [ fun_ 'bitSize $ appV '(+) [hiSizeE, loSizeE] 900 , inline 'bitSize 901#if MIN_VERSION_base(4,7,0) 902 {- bitSizeMaybe = Just . finiteBitSize -} 903 , fun 'bitSizeMaybe $ appV '(.) [ConE 'Just, VarE 'finiteBitSize] 904 , inline 'bitSizeMaybe 905#endif 906 {- isSigned _ = SIGNED -} 907 , fun_ 'isSigned $ ConE $ if signed then 'True else 'False 908 , inline 'isSigned 909 {- complement (W hi lo) = W (complement hi) (complement lo) -} 910 , funHiLo 'complement $ 911 appW [appVN 'complement [hi], appVN 'complement [lo]] 912 , inline 'complement 913 {- xor (W hi lo) (W hi' lo') = W (xor hi hi') (xor lo lo') -} 914 , funHiLo2 'xor $ appW [appVN 'xor [hi, hi'], appVN 'xor [lo, lo']] 915 , inline 'xor 916 {- (W hi lo) .&. (W hi' lo') = W (hi .&. hi') (lo .&. lo') -} 917 , funHiLo2 '(.&.) $ 918 appW [appVN '(.&.) [hi, hi'], appVN '(.&.) [lo, lo']] 919 , inline '(.&.) 920 {- (W hi lo) .|. (W hi' lo') = W (hi .|. hi') (lo .|. lo') -} 921 , funHiLo2 '(.|.) $ 922 appW [appVN '(.|.) [hi, hi'], appVN '(.|.) [lo, lo']] 923 , inline '(.|.) 924 {- 925 shiftL (W hi lo) x = 926 if y > 0 927 then W (shiftL hi x .|. fromIntegral (shiftR lo y)) 928 (shiftL lo x) 929 else W (fromIntegral $ shiftL lo $ negate y) 0 930 where y = bitSize (undefined ∷ L) - x 931 -} 932 , funHiLoX' 'shiftL 933 (CondE (appV '(>) [VarE y, litI 0]) 934 (appW 935 [ appV '(.|.) 936 [ appVN 'shiftL [hi, x] 937 , appV 'fromIntegral [appVN 'shiftR [lo, y]] ] 938 , appVN 'shiftL [lo, x] ]) 939 (appW [ appV 'fromIntegral 940 [appV 'shiftL [VarE lo, appVN 'negate [y]]] 941 , zeroE ])) 942 [val y $ appV '(-) [loSizeE, VarE x]] 943 {- 944 shiftR (W hi lo) x = 945 W (shiftR hi x) 946 (if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x 947 else z) 948 where y = bitSize (undefined ∷ L) - x 949 z = if SIGNED 950 then fromIntegral $ 951 shiftR (fromIntegral hi ∷ SignedWord L) $ 952 negate y 953 else shiftR (fromIntegral hi) $ negate y 954 -} 955 , funHiLoX' 'shiftR 956 (appW [ appVN 'shiftR [hi, x] 957 , CondE (appV '(>=) [VarE y, litI 0]) 958 (appV '(.|.) 959 [ appV 'shiftL 960 [appVN 'fromIntegral [hi], VarE y] 961 , appVN 'shiftR [lo, x] ]) 962 (VarE z) ]) 963 [ val y $ appV '(-) [loSizeE, VarE x] 964 , val z $ 965 if signed 966 then appV 'fromIntegral 967 [appV 'shiftR 968 [ SigE (appVN 'fromIntegral [hi]) 969 (AppT (ConT ''SignedWord) loT) 970 , appVN 'negate [y] ]] 971 else appV 'shiftR [ appVN 'fromIntegral [hi] 972 , appVN 'negate [y] ] 973 ] 974 {- 975 UNSIGNED: 976 rotateL (W hi lo) x = 977 if y >= 0 978 then W (fromIntegral (shiftL lo y) .|. shiftR hi z) 979 W (shiftL (fromIntegral hi) (bitSize (undefined ∷ L) - z) 980 .|. shiftR lo z) 981 else W (fromIntegral (shiftR lo $ negate y) .|. shiftL hi x) 982 (shift (fromIntegral hi) (bitSize (undefined ∷ L) - z) 983 .|. shiftL lo x 984 .|. shiftR lo z) 985 where y = x - bitSize (undefined ∷ L) 986 z = bitSize (undefined ∷ W) - x 987 SIGNED: 988 rotateL x y = signedWord $ rotateL (unsignedWord x) y 989 -} 990 , if signed 991 then 992 funXY 'rotateL $ 993 appV 'signedWord 994 [appV 'rotateL [appVN 'unsignedWord [x], VarE y]] 995 else 996 funHiLoX' 'rotateL 997 (CondE (appV '(>=) [VarE y, litI 0]) 998 (appW 999 [ appV '(.|.) 1000 [ appV 'fromIntegral [appVN 'shiftL [lo, y]] 1001 , appVN 'shiftR [hi, z] ] 1002 , appV '(.|.) 1003 [ appV 'shiftL 1004 [ appVN 'fromIntegral [hi] 1005 , appV '(-) [loSizeE, VarE z] 1006 ] 1007 , appVN 'shiftR [lo, z] ] 1008 ]) 1009 (appW 1010 [ appV '(.|.) 1011 [ appV 'fromIntegral 1012 [appV 'shiftR [VarE lo, appVN 'negate [y]]] 1013 , appVN 'shiftL [hi, x] ] 1014 , appV '(.|.) 1015 [ appV 'shift 1016 [ appVN 'fromIntegral [hi] 1017 , appV '(-) [loSizeE, VarE z] ] 1018 , appV '(.|.) 1019 [appVN 'shiftL [lo, x], appVN 'shiftR [lo, z]] ] 1020 ])) 1021 [ val y $ appV '(-) [VarE x, loSizeE] 1022 , val z $ appV '(-) [sizeE, VarE x] 1023 ] 1024 {- rotateR x y = rotateL x $ bitSize (undefined ∷ W) - y -} 1025 , funXY 'rotateR $ appV 'rotateL [VarE x, appV '(-) [sizeE, VarE y]] 1026 , inline 'rotateR 1027 {- 1028 bit x = if y >= 0 then W (bit y) 0 else W 0 (bit x) 1029 where y = x - bitSize (undefined ∷ LoWord W) 1030 -} 1031 , funX' 'bit (CondE (appV '(>=) [VarE y, litI 0]) 1032 (appW [appVN 'bit [y], zeroE]) 1033 (appW [zeroE, appVN 'bit [x]])) 1034 [val y $ appV '(-) [VarE x, loSizeE]] 1035 , inlinable 'bit 1036 {- 1037 setBit (W hi lo) x = 1038 if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x) 1039 where y = x - bitSize (undefined ∷ L) 1040 -} 1041 , funHiLoX' 'setBit 1042 (CondE (appV '(>=) [VarE y, litI 0]) 1043 (appW [appVN 'setBit [hi, y], VarE lo]) 1044 (appW [VarE hi, appVN 'setBit [lo, x]])) 1045 [val y $ 1046 appV '(-) [ VarE x 1047 , appV 'bitSize [SigE (VarE 'undefined) loT] ]] 1048 , inlinable 'setBit 1049 {- 1050 clearBit (W hi lo) x = 1051 if y >= 0 then W (clearBit hi y) lo 1052 else W hi (clearBit lo x) 1053 where y = x - bitSize (undefined ∷ L) 1054 -} 1055 , funHiLoX' 'clearBit 1056 (CondE (appV '(>=) [VarE y, litI 0]) 1057 (appW [appVN 'clearBit [hi, y], VarE lo]) 1058 (appW [VarE hi, appVN 'clearBit [lo, x]])) 1059 [val y $ appV '(-) [VarE x, loSizeE]] 1060 , inlinable 'clearBit 1061 {- 1062 complementBit (W hi lo) x = 1063 if y >= 0 then W (complementBit hi y) lo 1064 else W hi (complementBit lo x) 1065 where y = x - bitSize (undefined ∷ L) 1066 -} 1067 , funHiLoX' 'complementBit 1068 (CondE (appV '(>=) [VarE y, litI 0]) 1069 (appW [appVN 'complementBit [hi, y], VarE lo]) 1070 (appW [VarE hi, appVN 'complementBit [lo, x]])) 1071 [val y $ appV '(-) [VarE x, loSizeE]] 1072 , inlinable 'complementBit 1073 {- 1074 testBit (W hi lo) x = 1075 if y >= 0 then testBit hi y else testBit lo x 1076 where y = x - bitSize (undefined ∷ L) 1077 -} 1078 , funHiLoX' 'testBit 1079 (CondE (appV '(>=) [VarE y, litI 0]) 1080 (appVN 'testBit [hi, y]) 1081 (appVN 'testBit [lo, x])) 1082 [val y $ appV '(-) [VarE x, loSizeE]] 1083 , inlinable 'testBit 1084 {- popCount (W hi lo) = popCount hi + popCount lo -} 1085 , funHiLo 'popCount 1086 (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]]) 1087 , inline 'popCount 1088 ] ++ 1089 if signed then [inline 'rotateL] else [] 1090#if MIN_VERSION_base(4,7,0) 1091 , inst ''FiniteBits [tp] 1092 {- 1093 finiteBitSize = finiteBitSize (undefined ∷ H) + 1094 finiteBitSize (undefined ∷ L) 1095 -} 1096 [ fun_ 'finiteBitSize $ appV '(+) [hiSizeE, loSizeE] 1097 , inline 'finiteBitSize 1098# if MIN_VERSION_base(4,8,0) 1099 {- countLeadingZeros = leadingZeroes -} 1100 , fun 'countLeadingZeros $ VarE 'leadingZeroes 1101 , inline 'countLeadingZeros 1102 {- countTrailingZeros = trailingZeroes -} 1103 , fun 'countTrailingZeros $ VarE 'trailingZeroes 1104 , inline 'countTrailingZeros 1105# endif 1106 ] 1107#endif 1108 , inst ''BinaryWord [tp] 1109 [ tySynInst ''UnsignedWord [tpT] $ 1110 ConT $ if signed then otp else tp 1111 , tySynInst ''SignedWord [tpT] $ 1112 ConT $ if signed then tp else otp 1113 {- 1114 UNSIGNED: 1115 unsignedWord = id 1116 1117 SIGNED: 1118 unsignedWord (W hi lo) = U (unsignedWord hi) lo 1119 -} 1120 , if signed 1121 then 1122 funHiLo 'unsignedWord $ 1123 appC ocn [appVN 'unsignedWord [hi], VarE lo] 1124 else 1125 fun 'unsignedWord $ VarE 'id 1126 , inline 'unsignedWord 1127 {- 1128 UNSIGNED: 1129 signedWord (W hi lo) = S (signedWord hi) lo 1130 1131 SIGNED: 1132 signedWord = id 1133 -} 1134 , if signed 1135 then 1136 fun 'signedWord $ VarE 'id 1137 else 1138 funHiLo 'signedWord $ 1139 appC ocn [appVN 'signedWord [hi], VarE lo] 1140 , inline 'signedWord 1141 {- 1142 UNSIGNED: 1143 unwrappedAdd (W hi lo) (W hi' lo') = (W 0 z, W y x) 1144 where (t1, x) = unwrappedAdd lo lo' 1145 (t3, t2) = unwrappedAdd hi (fromIntegral t1) 1146 (t4, y) = unwrappedAdd t2 hi' 1147 z = fromIntegral $ t3 + t4 1148 SIGNED: 1149 unwrappedAdd x y = (z, t4) 1150 where t1 = if x < 0 then maxBound else minBound 1151 t2 = if y < 0 then maxBound else minBound 1152 (t3, t4) = unwrappedAdd (unsignedWord x) (unsignedWord y) 1153 z = signedWord $ t1 + t2 + t3 1154 -} 1155 , if signed 1156 then 1157 funXY' 'unwrappedAdd (tup [VarE z, VarE t4]) 1158 [ val t1 $ CondE (appVN 'testMsb [x]) 1159 (VarE 'maxBound) (VarE 'minBound) 1160 , val t2 $ CondE (appVN 'testMsb [y]) 1161 (VarE 'maxBound) (VarE 'minBound) 1162 , vals [t3, t4] $ 1163 appV 'unwrappedAdd [ appVN 'unsignedWord [x] 1164 , appVN 'unsignedWord [y] ] 1165 , val z $ 1166 appV 'signedWord [appV '(+) [VarE t1, appVN '(+) [t2, t3]]] 1167 ] 1168 else 1169 funHiLo2' 'unwrappedAdd 1170 (tup [appWN ['allZeroes, z], appWN [y, x]]) 1171 [ vals [t1, x] $ appVN 'unwrappedAdd [lo, lo'] 1172 , vals [t3, t2] $ 1173 appV 'unwrappedAdd [VarE hi, appVN 'fromIntegral [t1]] 1174 , vals [t4, y] $ appVN 'unwrappedAdd [t2, hi'] 1175 , val z $ appV 'fromIntegral [appVN '(+) [t3, t4]] 1176 ] 1177 {- 1178 UNSIGNED: 1179 unwrappedMul (W hi lo) (W hi' lo') = 1180 (W (hhh + fromIntegral (shiftR t9 y) + shiftL x z) 1181 (shiftL t9 z .|. shiftR t3 y), 1182 W (fromIntegral t3) lll) 1183 where (llh, lll) = unwrappedMul lo lo' 1184 (hlh, hll) = unwrappedMul (fromIntegral hi) lo' 1185 (lhh, lhl) = unwrappedMul lo (fromIntegral hi') 1186 (hhh, hhl) = unwrappedMul hi hi' 1187 (t2, t1) = unwrappedAdd llh hll 1188 (t4, t3) = unwrappedAdd t1 lhl 1189 (t6, t5) = unwrappedAdd (fromIntegral hhl) (t2 + t4) 1190 (t8, t7) = unwrappedAdd t5 lhh 1191 (t10, t9) = unwrappedAdd t7 hlh 1192 x = fromIntegral $ t6 + t8 + t10 1193 y = bitSize (undefined ∷ H) 1194 z = bitSize (undefined ∷ L) - y 1195 SIGNED: 1196 unwrappedMul (W hi lo) (W hi' lo') = (x, y) 1197 where t1 = W (complement hi') (complement lo') + 1 1198 t2 = W (complement hi) (complement lo) + 1 1199 (t3, y) = unwrappedMul (U (unsignedWord hi) lo) 1200 (U (unsignedWord hi') lo') 1201 z = signedWord t3 1202 x = if hi < 0 1203 then if hi' < 0 1204 then z + t1 + t2 1205 else z + t1 1206 else if hi' < 0 1207 then z + t2 1208 else z 1209 -} 1210 , if signed 1211 then 1212 funHiLo2' 'unwrappedMul (tup [VarE x, VarE y]) 1213 [ val t1 $ 1214 appV '(+) [ appW [ appVN 'complement [hi'] 1215 , appVN 'complement [lo'] ] 1216 , oneE ] 1217 , val t2 $ 1218 appV '(+) [ appW [ appVN 'complement [hi] 1219 , appVN 'complement [lo] ] 1220 , oneE ] 1221 , vals [t3, y] $ 1222 appV 'unwrappedMul 1223 [ appC ocn [appVN 'unsignedWord [hi], VarE lo] 1224 , appC ocn [appVN 'unsignedWord [hi'], VarE lo'] ] 1225 , val z $ appVN 'signedWord [t3] 1226 , val x $ 1227 CondE (appVN 'testMsb [hi]) 1228 (CondE (appVN 'testMsb [hi']) 1229 (appV '(+) [VarE z, appVN '(+) [t1, t2]]) 1230 (appVN '(+) [z, t1])) 1231 (CondE (appVN 'testMsb [hi']) 1232 (appVN '(+) [z, t2]) (VarE z)) 1233 ] 1234 else 1235 funHiLo2' 'unwrappedMul 1236 (tup [ appW 1237 [ appV '(+) 1238 [ VarE hhh 1239 , appV '(+) 1240 [ appV 'fromIntegral [appVN 'shiftR [t9, y]] 1241 , appVN 'shiftL [x, z] ] 1242 ] 1243 , appV '(.|.) [ appVN 'shiftL [t9, z] 1244 , appVN 'shiftR [t3, y] ] 1245 ] 1246 , appW [appVN 'fromIntegral [t3], VarE lll] 1247 ]) 1248 [ vals [llh, lll] $ appVN 'unwrappedMul [lo, lo'] 1249 , vals [hlh, hll] $ 1250 appV 'unwrappedMul [appVN 'fromIntegral [hi], VarE lo'] 1251 , vals [lhh, lhl] $ 1252 appV 'unwrappedMul [VarE lo, appVN 'fromIntegral [hi']] 1253 , vals [hhh, hhl] $ appVN 'unwrappedMul [hi, hi'] 1254 , vals [t2, t1] $ appVN 'unwrappedAdd [llh, hll] 1255 , vals [t4, t3] $ appVN 'unwrappedAdd [t1, lhl] 1256 , vals [t6, t5] $ 1257 appV 'unwrappedAdd [ appVN 'fromIntegral [hhl] 1258 , appVN '(+) [t2, t4] ] 1259 , vals [t8, t7] $ appVN 'unwrappedAdd [t5, lhh] 1260 , vals [t10, t9] $ appVN 'unwrappedAdd [t7, hlh] 1261 , val x $ 1262 appV 'fromIntegral 1263 [appV '(+) [VarE t6, appVN '(+) [t8, t10]]] 1264 , val y $ hiSizeE 1265 , val z $ appV '(-) [loSizeE, VarE y] 1266 ] 1267 {- 1268 UNSIGNED: 1269 leadingZeroes (W hi lo) = 1270 if x == y then y + leadingZeroes lo else x 1271 where x = leadingZeroes hi 1272 y = bitSize (undefined ∷ H) 1273 SIGNED: 1274 leadingZeroes = leadingZeroes . unsignedWord 1275 -} 1276 , if signed 1277 then 1278 fun 'leadingZeroes $ appVN '(.) ['leadingZeroes, 'unsignedWord] 1279 else 1280 funHiLo' 'leadingZeroes 1281 (CondE (appVN '(==) [x, y]) 1282 (appV '(+) [VarE y, appVN 'leadingZeroes [lo]]) 1283 (VarE x)) 1284 [ val x $ appVN 'leadingZeroes [hi] 1285 , val y $ hiSizeE 1286 ] 1287 , if signed then inlinable 'leadingZeroes 1288 else inline 'leadingZeroes 1289 {- 1290 UNSIGNED: 1291 trailingZeroes (W hi lo) = 1292 if x == y then y + trailingZeroes hi else x 1293 where x = trailingZeroes lo 1294 y = bitSize (undefined ∷ L) 1295 SIGNED: 1296 trailingZeroes = trailingZeroes . unsignedWord 1297 -} 1298 , if signed 1299 then 1300 fun 'trailingZeroes $ appVN '(.) ['trailingZeroes, 'unsignedWord] 1301 else 1302 funHiLo' 'trailingZeroes 1303 (CondE (appVN '(==) [x, y]) 1304 (appV '(+) [VarE y, appVN 'trailingZeroes [hi]]) 1305 (VarE x)) 1306 [ val x $ appVN 'trailingZeroes [lo] 1307 , val y $ loSizeE ] 1308 , if signed then inlinable 'trailingZeroes 1309 else inline 'trailingZeroes 1310 {- allZeroes = W allZeroes allZeroes -} 1311 , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes] 1312 , inline 'allZeroes 1313 {- allOnes = W allOnes allOnes -} 1314 , fun 'allOnes $ appWN ['allOnes, 'allOnes] 1315 , inline 'allOnes 1316 {- msb = W msb allZeroes -} 1317 , fun 'msb $ appWN ['msb, 'allZeroes] 1318 , inline 'msb 1319 {- lsb = W allZeroes lsb -} 1320 , fun 'lsb $ appWN ['allZeroes, 'lsb] 1321 , inline 'lsb 1322 {- testMsb (W hi _) = testMsb hi -} 1323 , funHi 'testMsb $ appVN 'testMsb [hi] 1324 , inline 'testMsb 1325 {- testLsb (W _ lo) = testLsb lo -} 1326 , funLo 'testLsb $ appVN 'testLsb [lo] 1327 , inline 'testLsb 1328 {- setMsb (W hi lo) = W (setMsb hi) lo -} 1329 , funHiLo 'setMsb $ appW [appVN 'setMsb [hi], VarE lo] 1330 , inline 'setMsb 1331 {- setLsb (W hi lo) = W hi (setLsb lo) -} 1332 , funHiLo 'setLsb $ appW [VarE hi, appVN 'setLsb [lo]] 1333 , inline 'setLsb 1334 {- clearMsb (W hi lo) = W (clearMsb hi) lo -} 1335 , funHiLo 'clearMsb $ appW [appVN 'clearMsb [hi], VarE lo] 1336 , inline 'clearMsb 1337 {- clearLsb (W hi lo) = W hi (clearLsb lo) -} 1338 , funHiLo 'clearLsb $ appW [VarE hi, appVN 'clearLsb [lo]] 1339 , inline 'clearLsb 1340 ] 1341 ] 1342 where 1343 x = mkName "x" 1344 y = mkName "y" 1345 z = mkName "z" 1346 t1 = mkName "t1" 1347 t2 = mkName "t2" 1348 t3 = mkName "t3" 1349 t4 = mkName "t4" 1350 t5 = mkName "t5" 1351 t6 = mkName "t6" 1352 t7 = mkName "t7" 1353 t8 = mkName "t8" 1354 t9 = mkName "t9" 1355 t10 = mkName "t10" 1356 v = mkName "v" 1357 q = mkName "q" 1358 q1 = mkName "q1" 1359 q2 = mkName "q2" 1360 r = mkName "r" 1361 r1 = mkName "r1" 1362 r2 = mkName "r2" 1363 lll = mkName "lll" 1364 llh = mkName "llh" 1365 lhl = mkName "lhl" 1366 lhh = mkName "lhh" 1367 hll = mkName "hll" 1368 hlh = mkName "hlh" 1369 hhl = mkName "hhl" 1370 hhh = mkName "hhh" 1371 h = mkName "h" 1372 h1 = mkName "h1" 1373 l = mkName "l" 1374 div1 = mkName "div1" 1375 div2 = mkName "div2" 1376 addT = mkName "addT" 1377 by = mkName "by_" 1378 go = mkName "go_" 1379 c = mkName "c" 1380 next = mkName "next_" 1381 step = mkName "step_" 1382 to = mkName "to_" 1383 down = mkName "down_" 1384 up = mkName "up_" 1385 hi = mkName "hi_" 1386 lo = mkName "lo_" 1387 hi' = mkName "hi'" 1388 lo' = mkName "lo'" 1389 tpT = ConT tp 1390 tySynInst n ps t = 1391#if MIN_VERSION_template_haskell(2,15,0) 1392 TySynInstD (TySynEqn Nothing (foldl AppT (ConT n) ps) t) 1393#elif MIN_VERSION_template_haskell(2,9,0) 1394 TySynInstD n (TySynEqn ps t) 1395#else 1396 TySynInstD n ps t 1397#endif 1398 inst cls params = InstanceD 1399#if MIN_VERSION_template_haskell(2,11,0) 1400 Nothing 1401#endif 1402 [] (foldl AppT (ConT cls) (ConT <$> params)) 1403 fun n e = FunD n [Clause [] (NormalB e) []] 1404 fun1 n a e = FunD n [Clause [VarP a] (NormalB e) []] 1405 fun_ n e = FunD n [Clause [WildP] (NormalB e) []] 1406 funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds] 1407 funX n e = funX' n e [] 1408 funXY' n e ds = FunD n [Clause [VarP x, VarP y] (NormalB e) ds] 1409 funXY n e = funXY' n e [] 1410 funTup n e = FunD n [Clause [TupP [VarP x, VarP y]] (NormalB e) []] 1411 funTupZ n e = 1412 FunD n [Clause [TupP [VarP x, VarP y], VarP z] (NormalB e) []] 1413 funTupLZ n e = 1414 FunD n [Clause [TupP [VarP x, WildP], VarP z] (NormalB e) []] 1415 funLo n e = FunD n [Clause [ConP cn [WildP, VarP lo]] (NormalB e) []] 1416 funHi n e = FunD n [Clause [ConP cn [VarP hi, WildP]] (NormalB e) []] 1417 funHiLo n e = funHiLo' n e [] 1418 funHiLo' n e ds = 1419 FunD n [Clause [ConP cn [VarP hi, VarP lo]] (NormalB e) ds] 1420 funHiLoX' n e ds = 1421 FunD n [Clause [ConP cn [VarP hi, VarP lo], VarP x] (NormalB e) ds] 1422 funHiLo2 n e = funHiLo2' n e [] 1423 funHiLo2' n e ds = 1424 FunD n [Clause [ ConP cn [VarP hi, VarP lo] 1425 , ConP cn [VarP hi', VarP lo'] ] 1426 (NormalB e) ds] 1427 funHiLo2XY' n e ds = 1428 FunD n [Clause [ AsP x (ConP cn [VarP hi, VarP lo]) 1429 , AsP y (ConP cn [VarP hi', VarP lo']) ] 1430 (NormalB e) ds] 1431 funXHiLo n e = FunD n [Clause [VarP x, ConP cn [VarP hi, VarP lo]] 1432 (NormalB e) []] 1433 match' p e ds = Match p (NormalB e) ds 1434 match p e = match' p e [] 1435 inline n = PragmaD $ InlineP n Inline FunLike AllPhases 1436 inlinable n = PragmaD $ InlineP n Inlinable FunLike AllPhases 1437 val n e = ValD (VarP n) (NormalB e) [] 1438 vals ns e = ValD (TupP (VarP <$> ns)) (NormalB e) [] 1439 app f = foldl AppE f 1440 appN f = app f . fmap VarE 1441 appV f = app (VarE f) 1442 appC f = app (ConE f) 1443 appW = appC cn 1444 appVN f = appN (VarE f) 1445 appCN f = appN (ConE f) 1446 appWN = appCN cn 1447 litI = LitE . IntegerL 1448 litS = LitE . StringL 1449 zeroE = VarE 'allZeroes 1450 oneE = VarE 'lsb 1451#if MIN_VERSION_base(4,7,0) 1452 loSizeE = appV 'finiteBitSize [SigE (VarE 'undefined) loT] 1453 hiSizeE = appV 'finiteBitSize [SigE (VarE 'undefined) hiT] 1454 sizeE = appV 'finiteBitSize [SigE (VarE 'undefined) tpT] 1455#else 1456 loSizeE = appV 'bitSize [SigE (VarE 'undefined) loT] 1457 hiSizeE = appV 'bitSize [SigE (VarE 'undefined) hiT] 1458 sizeE = appV 'bitSize [SigE (VarE 'undefined) tpT] 1459#endif 1460 singE e = appC '(:) [e, ConE '[]] 1461 ruleP name lhs rhs phases = 1462 RuleP name 1463#if MIN_VERSION_template_haskell(2,15,0) 1464 Nothing 1465#endif 1466 [] lhs rhs phases 1467 mkRules = do 1468 let idRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) 1469 (VarE 'fromIntegral) 1470 (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT)) 1471 AllPhases 1472 signRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show otp) 1473 (VarE 'fromIntegral) 1474 (SigE (VarE (if signed then 'unsignedWord 1475 else 'signedWord)) 1476 (AppT (AppT ArrowT tpT) (ConT otp))) 1477 AllPhases 1478 mkRules' [idRule, signRule] loT 1479 (VarE 'loWord) 1480 (VarE 'extendLo) 1481 (VarE 'signExtendLo) 1482 mkRules' rules t narrowE extE signExtE = do 1483 let narrowRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ showT t) 1484 (VarE 'fromIntegral) 1485 (SigE narrowE (AppT (AppT ArrowT tpT) t)) 1486 AllPhases 1487 extRule = ruleP ("fromIntegral/" ++ showT t ++ "->" ++ show tp) 1488 (VarE 'fromIntegral) 1489 (SigE extE (AppT (AppT ArrowT t) tpT)) 1490 AllPhases 1491 signedRules ← do 1492 insts ← reifyInstances ''SignedWord [t] 1493 case insts of 1494#if MIN_VERSION_template_haskell(2,15,0) 1495 [TySynInstD (TySynEqn _ _ signT)] → return $ 1496#elif MIN_VERSION_template_haskell(2,9,0) 1497 [TySynInstD _ (TySynEqn _ signT)] → return $ 1498#else 1499 [TySynInstD _ _ signT] → return $ 1500#endif 1501 [ ruleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT) 1502 (VarE 'fromIntegral) 1503 (SigE (AppE (appVN '(.) ['signedWord]) narrowE) 1504 (AppT (AppT ArrowT tpT) signT)) 1505 AllPhases 1506 , ruleP ("fromIntegral/" ++ showT signT ++ "->" ++ show tp) 1507 (VarE 'fromIntegral) 1508 (SigE signExtE (AppT (AppT ArrowT signT) tpT)) 1509 AllPhases ] 1510 _ → return [] 1511 let rules' = narrowRule : extRule : signedRules ++ rules 1512 case smallerStdTypes t of 1513 Just ts → do 1514 let smallRules = ts >>= \(uSmallName, sSmallName) → 1515 let uSmallT = ConT uSmallName 1516 sSmallT = ConT sSmallName in 1517 [ ruleP ("fromIntegral/" ++ 1518 show tp ++ "->" ++ show uSmallName) 1519 (VarE 'fromIntegral) 1520 (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) 1521 (AppT (AppT ArrowT tpT) uSmallT)) 1522 AllPhases 1523 , ruleP ("fromIntegral/" ++ 1524 show uSmallName ++ "->" ++ show tp) 1525 (VarE 'fromIntegral) 1526 (SigE (appV '(.) [extE, VarE 'fromIntegral]) 1527 (AppT (AppT ArrowT uSmallT) tpT)) 1528 AllPhases 1529 , ruleP ("fromIntegral/" ++ 1530 show tp ++ "->" ++ show sSmallName) 1531 (VarE 'fromIntegral) 1532 (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) 1533 (AppT (AppT ArrowT tpT) sSmallT)) 1534 AllPhases 1535 , ruleP ("fromIntegral/" ++ 1536 show sSmallName ++ "->" ++ show tp) 1537 (VarE 'fromIntegral) 1538 (SigE (appV '(.) [signExtE, VarE 'fromIntegral]) 1539 (AppT (AppT ArrowT sSmallT) tpT)) 1540 AllPhases 1541 ] 1542 return $ PragmaD <$> rules' ++ smallRules 1543 _ → do 1544 insts ← reifyInstances ''LoWord [t] 1545 case insts of 1546#if MIN_VERSION_template_haskell(2,15,0) 1547 [TySynInstD (TySynEqn _ _ t')] → 1548#elif MIN_VERSION_template_haskell(2,9,0) 1549 [TySynInstD _ (TySynEqn _ t')] → 1550#else 1551 [TySynInstD _ _ t'] → 1552#endif 1553 mkRules' rules' t' 1554 (appV '(.) [VarE 'loWord, narrowE]) 1555 (appV '(.) [VarE 'extendLo, extE]) 1556 (appV '(.) [VarE 'signExtendLo, signExtE]) 1557 _ → return $ PragmaD <$> rules' 1558 showT (ConT n) = show n 1559 showT t = show t 1560 stdTypes = [(''Word64, ''Int64), (''Word32, ''Int32), 1561 (''Word16, ''Int16), (''Word8, ''Int8)] 1562 smallerStdTypes t = smallerStdTypes' t stdTypes 1563 smallerStdTypes' _ [] = Nothing 1564 smallerStdTypes' t ((ut, _) : ts) 1565 | ConT ut == t = Just ts 1566 | otherwise = smallerStdTypes' t ts 1567 1568