Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/Builtin/primops.txt.pp
    ... ... @@ -148,6 +148,7 @@ defaults
    148 148 
        vector           = []
    149 149 
        deprecated_msg   = {}      -- A non-empty message indicates deprecation
    150 150 
        div_like         = False   -- Second argument expected to be non zero - used for tests
    151 
    +   shift_like       = False   -- Second argument expected to be atmost first argument's word size -1 - used for tests
    151 152 
        defined_bits     = Nothing -- The number of bits the operation is defined for (if not all bits)
    152 153
    153 154 
     -- Note [When do out-of-line primops go in primops.txt.pp]
    ... ... @@ -312,8 +313,16 @@ primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8#
    312 313 
         div_like = True
    313 314
    314 315 
     primop Int8SllOp "uncheckedShiftLInt8#"  GenPrimOp Int8# -> Int# -> Int8#
    316 
    +  with
    317 
    +    shift_like = True
    318 
    +
    315 319 
     primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#
    320 
    +  with
    321 
    +    shift_like = True
    322 
    +
    316 323 
     primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8#
    324 
    +  with
    325 
    +    shift_like = True
    317 326
    318 327 
     primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8#
    319 328 
        with code_size = 0
    ... ... @@ -372,7 +381,12 @@ primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8#
    372 381 
     primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#
    373 382
    374 383 
     primop Word8SllOp "uncheckedShiftLWord8#"  GenPrimOp Word8# -> Int# -> Word8#
    384 
    +  with
    385 
    +    shift_like = True
    386 
    +
    375 387 
     primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8#
    388 
    +  with
    389 
    +    shift_like = True
    376 390
    377 391 
     primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8#
    378 392 
        with code_size = 0
    ... ... @@ -422,8 +436,16 @@ primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, I
    422 436 
         div_like = True
    423 437
    424 438 
     primop Int16SllOp "uncheckedShiftLInt16#"  GenPrimOp Int16# -> Int# -> Int16#
    439 
    +  with
    440 
    +    shift_like = True
    441 
    +
    425 442 
     primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#
    443 
    +  with
    444 
    +    shift_like = True
    445 
    +
    426 446 
     primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16#
    447 
    +  with
    448 
    +    shift_like = True
    427 449
    428 450 
     primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16#
    429 451 
        with code_size = 0
    ... ... @@ -482,7 +504,12 @@ primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16#
    482 504 
     primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#
    483 505
    484 506 
     primop Word16SllOp "uncheckedShiftLWord16#"  GenPrimOp Word16# -> Int# -> Word16#
    507 
    +  with
    508 
    +    shift_like = True
    509 
    +
    485 510 
     primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16#
    511 
    +  with
    512 
    +    shift_like = True
    486 513
    487 514 
     primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16#
    488 515 
        with code_size = 0
    ... ... @@ -532,8 +559,16 @@ primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, I
    532 559 
         div_like = True
    533 560
    534 561 
     primop Int32SllOp "uncheckedShiftLInt32#"  GenPrimOp Int32# -> Int# -> Int32#
    562 
    +  with
    563 
    +    shift_like = True
    564 
    +
    535 565 
     primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#
    566 
    +  with
    567 
    +    shift_like = True
    568 
    +
    536 569 
     primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32#
    570 
    +  with
    571 
    +    shift_like = True
    537 572
    538 573 
     primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32#
    539 574 
        with code_size = 0
    ... ... @@ -592,7 +627,12 @@ primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32#
    592 627 
     primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32#
    593 628
    594 629 
     primop Word32SllOp "uncheckedShiftLWord32#"  GenPrimOp Word32# -> Int# -> Word32#
    630 
    +  with
    631 
    +    shift_like = True
    632 
    +
    595 633 
     primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32#
    634 
    +  with
    635 
    +    shift_like = True
    596 636
    597 637 
     primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32#
    598 638 
        with code_size = 0
    ... ... @@ -637,8 +677,16 @@ primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#
    637 677 
         div_like = True
    638 678
    639 679 
     primop Int64SllOp "uncheckedIShiftL64#"  GenPrimOp Int64# -> Int# -> Int64#
    680 
    +  with
    681 
    +    shift_like = True
    682 
    +
    640 683 
     primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#
    684 
    +  with
    685 
    +    shift_like = True
    686 
    +
    641 687 
     primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64#
    688 
    +  with
    689 
    +    shift_like = True
    642 690
    643 691 
     primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64#
    644 692 
        with code_size = 0
    ... ... @@ -692,7 +740,12 @@ primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64#
    692 740 
     primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64#
    693 741
    694 742 
     primop Word64SllOp "uncheckedShiftL64#"  GenPrimOp Word64# -> Int# -> Word64#
    743 
    +  with
    744 
    +    shift_like = True
    745 
    +
    695 746 
     primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64#
    747 
    +  with
    748 
    +    shift_like = True
    696 749
    697 750 
     primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64#
    698 751 
        with code_size = 0
    ... ... @@ -865,12 +918,20 @@ primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double#
    865 918 
     primop   IntSllOp   "uncheckedIShiftL#" GenPrimOp  Int# -> Int# -> Int#
    866 919 
              {Shift left.  Result undefined if shift amount is not
    867 920 
               in the range 0 to word size - 1 inclusive.}
    921 
    +  with
    922 
    +    shift_like = True
    923 
    +
    868 924 
     primop   IntSraOp   "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int#
    869 925 
              {Shift right arithmetic.  Result undefined if shift amount is not
    870 926 
               in the range 0 to word size - 1 inclusive.}
    927 
    +  with
    928 
    +    shift_like = True
    929 
    +
    871 930 
     primop   IntSrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#
    872 931 
              {Shift right logical.  Result undefined if shift amount is not
    873 932 
               in the range 0 to word size - 1 inclusive.}
    933 
    +  with
    934 
    +    shift_like = True
    874 935
    875 936 
     ------------------------------------------------------------------------
    876 937 
     section "Word#"
    ... ... @@ -946,9 +1007,14 @@ primop WordNotOp "not#" GenPrimOp Word# -> Word#
    946 1007 
     primop   WordSllOp   "uncheckedShiftL#"   GenPrimOp   Word# -> Int# -> Word#
    947 1008 
              {Shift left logical.   Result undefined if shift amount is not
    948 1009 
               in the range 0 to word size - 1 inclusive.}
    1010 
    +  with
    1011 
    +    shift_like = True
    1012 
    +
    949 1013 
     primop   WordSrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#
    950 1014 
              {Shift right logical.   Result undefined if shift  amount is not
    951 1015 
               in the range 0 to word size - 1 inclusive.}
    1016 
    +  with
    1017 
    +    shift_like = True
    952 1018
    953 1019 
     primop   WordToIntOp   "word2Int#"   GenPrimOp   Word# -> Int#
    954 1020 
        with code_size = 0

  • testsuite/tests/numeric/should_run/foundation.hs
    ... ... @@ -13,6 +13,7 @@
    13 13 
     {-# LANGUAGE FlexibleContexts    #-}
    14 14 
     {-# LANGUAGE OverloadedStrings   #-}
    15 15 
     {-# LANGUAGE ScopedTypeVariables #-}
    16 
    +{-# LANGUAGE TypeAbstractions #-}
    16 17 
     {-# LANGUAGE TypeFamilies        #-}
    17 18 
     {-# LANGUAGE DerivingStrategies #-}
    18 19 
     {-# LANGUAGE MagicHash #-}
    ... ... @@ -24,7 +25,7 @@ module Main
    24 25 
         ( main
    25 26 
         ) where
    26 27
    27 
    -import Data.Bits (Bits((.&.), bit))
    28 
    +import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize)
    28 29 
     import Data.Word
    29 30 
     import Data.Int
    30 31 
     import GHC.Natural
    ... ... @@ -133,6 +134,16 @@ newtype NonZero a = NonZero { getNonZero :: a }
    133 134 
     instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
    134 135 
       arbitrary = nonZero
    135 136
    137 
    +-- | A newtype for shift amounts that are bounded by @wordSize - 1@
    138 
    +newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int}
    139 
    +  deriving (Eq, Ord, Show)
    140 
    +
    141 
    +instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where
    142 
    +  arbitrary = do
    143 
    +    x <- arbitrary
    144 
    +    let widthBits = finiteBitSize (undefined :: a)
    145 
    +    pure $ BoundedShiftAmount (abs x `mod` widthBits)
    146 
    +
    136 147 
     instance Arbitrary Natural where
    137 148 
         arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
    138 149
    ... ... @@ -395,6 +406,10 @@ class TestPrimop f where
    395 406 
       testPrimopDivLike :: String -> f -> f -> Test
    396 407 
       testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
    397 408
    409 
    +  -- | Special test method for shift operations that bounds the shift amount
    410 
    +  testPrimopShift :: String -> f -> f -> Test
    411 
    +  testPrimopShift _ _ _ = error "Shift testing not supported for this type."
    412 
    +
    398 413 
     {-
    399 414 
     instance TestPrimop (Int# -> Int# -> Int#) where
    400 415 
       testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
    ... ... @@ -460,9 +475,9 @@ testPrimops = Group "primop"
    460 475 
       , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
    461 476 
       , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
    462 477 
       , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
    463 
    -  , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
    464 
    -  , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
    465 
    -  , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
    478 
    +  , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
    479 
    +  , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
    480 
    +  , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
    466 481 
       , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8#
    467 482 
       , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8#
    468 483 
       , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8#
    ... ... @@ -482,8 +497,8 @@ testPrimops = Group "primop"
    482 497 
       , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
    483 498 
       , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
    484 499 
       , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8#
    485 
    -  , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
    486 
    -  , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
    500 
    +  , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
    501 
    +  , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
    487 502 
       , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8#
    488 503 
       , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8#
    489 504 
       , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8#
    ... ... @@ -500,9 +515,9 @@ testPrimops = Group "primop"
    500 515 
       , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
    501 516 
       , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
    502 517 
       , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
    503 
    -  , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
    504 
    -  , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
    505 
    -  , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
    518 
    +  , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
    519 
    +  , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
    520 
    +  , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
    506 521 
       , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16#
    507 522 
       , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16#
    508 523 
       , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16#
    ... ... @@ -522,8 +537,8 @@ testPrimops = Group "primop"
    522 537 
       , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
    523 538 
       , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
    524 539 
       , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16#
    525 
    -  , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
    526 
    -  , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
    540 
    +  , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
    541 
    +  , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
    527 542 
       , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16#
    528 543 
       , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16#
    529 544 
       , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16#
    ... ... @@ -540,9 +555,9 @@ testPrimops = Group "primop"
    540 555 
       , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
    541 556 
       , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
    542 557 
       , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
    543 
    -  , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
    544 
    -  , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
    545 
    -  , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
    558 
    +  , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
    559 
    +  , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
    560 
    +  , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
    546 561 
       , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32#
    547 562 
       , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32#
    548 563 
       , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32#
    ... ... @@ -562,8 +577,8 @@ testPrimops = Group "primop"
    562 577 
       , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
    563 578 
       , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
    564 579 
       , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32#
    565 
    -  , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
    566 
    -  , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
    580 
    +  , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
    581 
    +  , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
    567 582 
       , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32#
    568 583 
       , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32#
    569 584 
       , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32#
    ... ... @@ -579,9 +594,9 @@ testPrimops = Group "primop"
    579 594 
       , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
    580 595 
       , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
    581 596 
       , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
    582 
    -  , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
    583 
    -  , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
    584 
    -  , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
    597 
    +  , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
    598 
    +  , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
    599 
    +  , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
    585 600 
       , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64#
    586 601 
       , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64#
    587 602 
       , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64#
    ... ... @@ -600,8 +615,8 @@ testPrimops = Group "primop"
    600 615 
       , testPrimop "or64#" Primop.or64# Wrapper.or64#
    601 616 
       , testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
    602 617 
       , testPrimop "not64#" Primop.not64# Wrapper.not64#
    603 
    -  , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
    604 
    -  , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
    618 
    +  , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
    619 
    +  , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
    605 620 
       , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64#
    606 621 
       , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64#
    607 622 
       , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64#
    ... ... @@ -632,9 +647,9 @@ testPrimops = Group "primop"
    632 647 
       , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#)
    633 648 
       , testPrimop "chr#" Primop.chr# Wrapper.chr#
    634 649 
       , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word#
    635 
    -  , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
    636 
    -  , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
    637 
    -  , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
    650 
    +  , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
    651 
    +  , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
    652 
    +  , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
    638 653 
       , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord#
    639 654 
       , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC#
    640 655 
       , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC#
    ... ... @@ -649,8 +664,8 @@ testPrimops = Group "primop"
    649 664 
       , testPrimop "or#" Primop.or# Wrapper.or#
    650 665 
       , testPrimop "xor#" Primop.xor# Wrapper.xor#
    651 666 
       , testPrimop "not#" Primop.not# Wrapper.not#
    652 
    -  , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
    653 
    -  , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
    667 
    +  , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
    668 
    +  , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
    654 669 
       , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int#
    655 670 
       , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord#
    656 671 
       , testPrimop "geWord#" Primop.geWord# Wrapper.geWord#
    ... ... @@ -709,6 +724,7 @@ instance TestPrimop (Char# -> Int#) where
    709 724 
     instance TestPrimop (Int# -> Int# -> Int#) where
    710 725 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    711 726 
       testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    727 
    +  testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift))
    712 728
    713 729 
     instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
    714 730 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
    ... ... @@ -741,6 +757,7 @@ instance TestPrimop (Int# -> Word#) where
    741 757
    742 758 
     instance TestPrimop (Int16# -> Int# -> Int16#) where
    743 759 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
    760 
    +  testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShiftAmount @Int16 shift) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift))
    744 761
    745 762 
     instance TestPrimop (Int16# -> Int16# -> Int#) where
    746 763 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -765,6 +782,7 @@ instance TestPrimop (Int16# -> Word16#) where
    765 782
    766 783 
     instance TestPrimop (Int32# -> Int# -> Int32#) where
    767 784 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
    785 
    +  testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShiftAmount @Int32 shift) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift))
    768 786
    769 787 
     instance TestPrimop (Int32# -> Int32# -> Int#) where
    770 788 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -789,6 +807,7 @@ instance TestPrimop (Int32# -> Word32#) where
    789 807
    790 808 
     instance TestPrimop (Int64# -> Int# -> Int64#) where
    791 809 
       testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
    810 
    +  testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShiftAmount @Int64 shift) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift))
    792 811
    793 812 
     instance TestPrimop (Int64# -> Int64# -> Int#) where
    794 813 
       testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -809,6 +828,7 @@ instance TestPrimop (Int64# -> Word64#) where
    809 828
    810 829 
     instance TestPrimop (Int8# -> Int# -> Int8#) where
    811 830 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
    831 
    +  testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShiftAmount @Int8 shift) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift))
    812 832
    813 833 
     instance TestPrimop (Int8# -> Int8# -> Int#) where
    814 834 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -833,6 +853,7 @@ instance TestPrimop (Int8# -> Word8#) where
    833 853
    834 854 
     instance TestPrimop (Word# -> Int# -> Word#) where
    835 855 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
    856 
    +  testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShiftAmount @Word shift) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift))
    836 857
    837 858 
     instance TestPrimop (Word# -> Word# -> Int#) where
    838 859 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -870,6 +891,7 @@ instance TestPrimop (Word# -> Word8#) where
    870 891
    871 892 
     instance TestPrimop (Word16# -> Int# -> Word16#) where
    872 893 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
    894 
    +  testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShiftAmount @Word16 shift) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift))
    873 895
    874 896 
     instance TestPrimop (Word16# -> Word16# -> Int#) where
    875 897 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -894,6 +916,7 @@ instance TestPrimop (Word16# -> Word16#) where
    894 916
    895 917 
     instance TestPrimop (Word32# -> Int# -> Word32#) where
    896 918 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
    919 
    +  testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShiftAmount @Word32 shift) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift))
    897 920
    898 921 
     instance TestPrimop (Word32# -> Word32# -> Int#) where
    899 922 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -918,6 +941,7 @@ instance TestPrimop (Word32# -> Word32#) where
    918 941
    919 942 
     instance TestPrimop (Word64# -> Int# -> Word64#) where
    920 943 
       testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
    944 
    +  testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShiftAmount @Word64 shift) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift))
    921 945
    922 946 
     instance TestPrimop (Word64# -> Word64# -> Int#) where
    923 947 
       testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    ... ... @@ -938,6 +962,7 @@ instance TestPrimop (Word64# -> Word64#) where
    938 962
    939 963 
     instance TestPrimop (Word8# -> Int# -> Word8#) where
    940 964 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
    965 
    +  testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShiftAmount @Word8 shift) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift))
    941 966
    942 967 
     instance TestPrimop (Word8# -> Word8# -> Int#) where
    943 968 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)

  • utils/genprimopcode/Main.hs
    ... ... @@ -696,7 +696,7 @@ gen_wired_in_deprecations (Info _ entries)
    696 696
    697 697 
     gen_foundation_tests :: Info -> String
    698 698 
     gen_foundation_tests (Info _ entries)
    699 
    -  = "tests =\n  [ "
    699 
    +  = "testPrimops = Group \"primop\"\n  [ "
    700 700 
         ++ intercalate "\n  , " (catMaybes $ map mkTest entries)
    701 701 
         ++ "\n  ]\n"
    702 702 
         ++ "\n" ++ intercalate "\n" (map mkInstances testable_tys)
    ... ... @@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries)
    705 705
    706 706 
         mkInstances inst_ty =
    707 707 
           let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
    708 
    +          shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShiftAmount @" ++ dropMagicHash (head arg_tys) ++ " shift) -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r"
    708 709 
           in  unlines $
    709 710 
           [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
    710 711 
           , "  testPrimop s l r = Property s $ " ++ test_lambda ]
    711 712 
           ++ (if mb_divable_tys
    712 713 
               then ["  testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
    713 714 
               else [])
    715 
    +      ++ (if mb_shiftable_tys
    716 
    +          then ["  testPrimopShift s l r = Property s $ " ++ shift_lambda]
    717 
    +          else [])
    714 718 
           where
    715 719 
             arg_tys = args inst_ty
    716 720 
             -- eg Int -> Int -> a
    ... ... @@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries)
    718 722 
                 [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
    719 723 
                 _         -> False
    720 724
    725 
    +        -- eg SomeType# -> Int# -> SomeType#
    726 
    +        mb_shiftable_tys = case arg_tys of
    727 
    +            [ty1,"Int#"] -> let res_type = getResultType inst_ty
    728 
    +                            in ty1 == res_type && ty1 `elem` shiftableTyCons
    729 
    +            _            -> False
    730 
    +
    721 731 
             mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
    732 
    +        mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))")
    722 733
    723 734 
             vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
    724 735
    ... ... @@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries)
    761 772 
           , (testable (ty po))
    762 773 
           = let testPrimOpHow = if is_divLikeOp po
    763 774 
                   then "testPrimopDivLike"
    775 
    +              else if is_shiftLikeOp po
    776 
    +              then "testPrimopShift"
    764 777 
                   else "testPrimop"
    765 778 
                 qualOp qualification =
    766 779 
                   let qName = wrap qualification poName
    ... ... @@ -784,6 +797,17 @@ gen_foundation_tests (Info _ entries)
    784 797 
         testableTyCon _ = False
    785 798 
         divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
    786 799 
                         ,"Int8#", "Int16#", "Int32#", "Int64#"]
    800 
    +    shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
    801 
    +                      ,"Int8#", "Int16#", "Int32#", "Int64#"]
    802 
    +
    803 
    +    dropMagicHash :: String -> String
    804 
    +    dropMagicHash = takeWhile (not . (== '#'))
    805 
    +
    806 
    +    getResultType :: Ty -> String
    807 
    +    getResultType (TyF _ t2) = getResultType t2
    808 
    +    getResultType (TyApp (TyCon c) []) = c
    809 
    +    getResultType (TyUTup _) = ""  -- Unboxed tuples can't be shift operations
    810 
    +    getResultType t = error $ "getResultType: unexpected type " ++ pprTy t
    787 811
    788 812 
         mb_defined_bits :: Entry -> Maybe Word
    789 813 
         mb_defined_bits op@(PrimOpSpec{}) =

  • utils/genprimopcode/Syntax.hs
    ... ... @@ -54,17 +54,23 @@ is_primtype (PrimTypeSpec {}) = True
    54 54 
     is_primtype _ = False
    55 55
    56 56 
     is_divLikeOp :: Entry -> Bool
    57 
    -is_divLikeOp entry = case entry of
    58 
    -   PrimOpSpec{} -> has_div_like
    59 
    -   PseudoOpSpec{} -> has_div_like
    60 
    -   PrimVecOpSpec{} -> has_div_like
    61 
    -   PrimTypeSpec{} -> False
    62 
    -   PrimVecTypeSpec{} -> False
    63 
    -   Section{} -> False
    64 
    -   where
    65 
    -      has_div_like = case lookup_attrib "div_like" (opts entry) of
    66 
    -         Just (OptionTrue{}) -> True
    67 
    -         _ -> False
    57 
    +is_divLikeOp = is_likeOp "div_like"
    58 
    +
    59 
    +is_shiftLikeOp :: Entry -> Bool
    60 
    +is_shiftLikeOp = is_likeOp "shift_like"
    61 
    +
    62 
    +is_likeOp :: String -> Entry -> Bool
    63 
    +is_likeOp attrName entry = case entry of
    64 
    +  PrimOpSpec {} -> has_attr
    65 
    +  PseudoOpSpec {} -> has_attr
    66 
    +  PrimVecOpSpec {} -> has_attr
    67 
    +  PrimTypeSpec {} -> False
    68 
    +  PrimVecTypeSpec {} -> False
    69 
    +  Section {} -> False
    70 
    +  where
    71 
    +    has_attr = case lookup_attrib attrName (opts entry) of
    72 
    +      Just (OptionTrue {}) -> True
    73 
    +      _ -> False
    68 74
    69 75 
     -- a binding of property to value
    70 76 
     data Option

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help