Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • compiler/GHC/Builtin/primops.txt.pp
    ... ... @@ -147,6 +147,7 @@ defaults
    147 147 
        fixity           = Nothing
    148 148 
        vector           = []
    149 149 
        deprecated_msg   = {}      -- A non-empty message indicates deprecation
    150 
    +   div_like         = False   -- Second argument expected to be non zero - used for tests
    150 151
    151 152 
     -- Note [When do out-of-line primops go in primops.txt.pp]
    152 153 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -296,14 +297,18 @@ primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#
    296 297 
     primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#
    297 298 
       with
    298 299 
         effect = CanFail
    300 
    +    div_like = True
    299 301
    300 302 
     primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#
    301 303 
       with
    302 304 
         effect = CanFail
    305 
    +    div_like = True
    306 
    +
    303 307
    304 308 
     primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)
    305 309 
       with
    306 310 
         effect = CanFail
    311 
    +    div_like = True
    307 312
    308 313 
     primop Int8SllOp "uncheckedShiftLInt8#"  GenPrimOp Int8# -> Int# -> Int8#
    309 314 
     primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#
    ... ... @@ -342,14 +347,17 @@ primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#
    342 347 
     primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#
    343 348 
       with
    344 349 
         effect = CanFail
    350 
    +    div_like = True
    345 351
    346 352 
     primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#
    347 353 
       with
    348 354 
         effect = CanFail
    355 
    +    div_like = True
    349 356
    350 357 
     primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)
    351 358 
       with
    352 359 
         effect = CanFail
    360 
    +    div_like = True
    353 361
    354 362 
     primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#
    355 363 
        with commutable = True
    ... ... @@ -400,14 +408,17 @@ primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#
    400 408 
     primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#
    401 409 
       with
    402 410 
         effect = CanFail
    411 
    +    div_like = True
    403 412
    404 413 
     primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#
    405 414 
       with
    406 415 
         effect = CanFail
    416 
    +    div_like = True
    407 417
    408 418 
     primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)
    409 419 
       with
    410 420 
         effect = CanFail
    421 
    +    div_like = True
    411 422
    412 423 
     primop Int16SllOp "uncheckedShiftLInt16#"  GenPrimOp Int16# -> Int# -> Int16#
    413 424 
     primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#
    ... ... @@ -446,14 +457,17 @@ primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#
    446 457 
     primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#
    447 458 
       with
    448 459 
         effect = CanFail
    460 
    +    div_like = True
    449 461
    450 462 
     primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#
    451 463 
       with
    452 464 
         effect = CanFail
    465 
    +    div_like = True
    453 466
    454 467 
     primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)
    455 468 
       with
    456 469 
         effect = CanFail
    470 
    +    div_like = True
    457 471
    458 472 
     primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#
    459 473 
        with commutable = True
    ... ... @@ -504,14 +518,17 @@ primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#
    504 518 
     primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#
    505 519 
       with
    506 520 
         effect = CanFail
    521 
    +    div_like = True
    507 522
    508 523 
     primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#
    509 524 
       with
    510 525 
         effect = CanFail
    526 
    +    div_like = True
    511 527
    512 528 
     primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)
    513 529 
       with
    514 530 
         effect = CanFail
    531 
    +    div_like = True
    515 532
    516 533 
     primop Int32SllOp "uncheckedShiftLInt32#"  GenPrimOp Int32# -> Int# -> Int32#
    517 534 
     primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#
    ... ... @@ -550,14 +567,17 @@ primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#
    550 567 
     primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#
    551 568 
       with
    552 569 
         effect = CanFail
    570 
    +    div_like = True
    553 571
    554 572 
     primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#
    555 573 
       with
    556 574 
         effect = CanFail
    575 
    +    div_like = True
    557 576
    558 577 
     primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)
    559 578 
       with
    560 579 
         effect = CanFail
    580 
    +    div_like = True
    561 581
    562 582 
     primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#
    563 583 
        with commutable = True
    ... ... @@ -608,10 +628,12 @@ primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#
    608 628 
     primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#
    609 629 
       with
    610 630 
         effect = CanFail
    631 
    +    div_like = True
    611 632
    612 633 
     primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#
    613 634 
       with
    614 635 
         effect = CanFail
    636 
    +    div_like = True
    615 637
    616 638 
     primop Int64SllOp "uncheckedIShiftL64#"  GenPrimOp Int64# -> Int# -> Int64#
    617 639 
     primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#
    ... ... @@ -650,10 +672,12 @@ primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#
    650 672 
     primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#
    651 673 
       with
    652 674 
         effect = CanFail
    675 
    +    div_like = True
    653 676
    654 677 
     primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#
    655 678 
       with
    656 679 
         effect = CanFail
    680 
    +    div_like = True
    657 681
    658 682 
     primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#
    659 683 
        with commutable = True
    ... ... @@ -737,6 +761,7 @@ primop IntQuotOp "quotInt#" GenPrimOp
    737 761 
         zero.
    738 762 
        }
    739 763 
        with effect = CanFail
    764 
    +        div_like = True
    740 765
    741 766 
     primop   IntRemOp    "remInt#"    GenPrimOp
    742 767 
        Int# -> Int# -> Int#
    ... ... @@ -744,11 +769,13 @@ primop IntRemOp "remInt#" GenPrimOp
    744 769 
         behavior is undefined if the second argument is zero.
    745 770 
        }
    746 771 
        with effect = CanFail
    772 
    +        div_like = True
    747 773
    748 774 
     primop   IntQuotRemOp "quotRemInt#"    GenPrimOp
    749 775 
        Int# -> Int# -> (# Int#, Int# #)
    750 776 
        {Rounds towards zero.}
    751 777 
        with effect = CanFail
    778 
    +        div_like = True
    752 779
    753 780 
     primop   IntAndOp   "andI#"   GenPrimOp    Int# -> Int# -> Int#
    754 781 
        {Bitwise "and".}
    ... ... @@ -886,19 +913,23 @@ primop WordMul2Op "timesWord2#" GenPrimOp
    886 913
    887 914 
     primop   WordQuotOp   "quotWord#"   GenPrimOp   Word# -> Word# -> Word#
    888 915 
        with effect = CanFail
    916 
    +        div_like = True
    889 917
    890 918 
     primop   WordRemOp   "remWord#"   GenPrimOp   Word# -> Word# -> Word#
    891 919 
        with effect = CanFail
    920 
    +        div_like = True
    892 921
    893 922 
     primop   WordQuotRemOp "quotRemWord#" GenPrimOp
    894 923 
        Word# -> Word# -> (# Word#, Word# #)
    895 924 
        with effect = CanFail
    925 
    +        div_like = True
    896 926
    897 927 
     primop   WordQuotRem2Op "quotRemWord2#" GenPrimOp
    898 928 
        Word# -> Word# -> Word# -> (# Word#, Word# #)
    899 929 
              { Takes high word of dividend, then low word of dividend, then divisor.
    900 930 
                Requires that high word < divisor.}
    901 931 
        with effect = CanFail
    932 
    +        div_like = True
    902 933
    903 934 
     primop   WordAndOp   "and#"   GenPrimOp   Word# -> Word# -> Word#
    904 935 
        with commutable = True
    ... ... @@ -4166,6 +4197,7 @@ primop VecQuotOp "quot#" GenPrimOp
    4166 4197 
          Do not expect high performance. }
    4167 4198 
        with effect = CanFail
    4168 4199 
             vector = INT_VECTOR_TYPES
    4200 
    +        div_like = True
    4169 4201
    4170 4202 
     primop VecRemOp "rem#" GenPrimOp
    4171 4203 
        VECTOR -> VECTOR -> VECTOR
    ... ... @@ -4175,6 +4207,8 @@ primop VecRemOp "rem#" GenPrimOp
    4175 4207 
          Do not expect high performance. }
    4176 4208 
        with effect = CanFail
    4177 4209 
             vector = INT_VECTOR_TYPES
    4210 
    +        div_like = True
    4211 
    +
    4178 4212
    4179 4213 
     primop VecNegOp "negate#" GenPrimOp
    4180 4214 
        VECTOR -> VECTOR

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -857,6 +857,17 @@ doPrimOp platform op init_d s p args =
    857 857 
         Word8AddOp -> sizedPrimOp OP_ADD
    858 858 
         AddrAddOp -> sizedPrimOp OP_ADD
    859 859
    860 
    +    IntMulOp -> sizedPrimOp OP_MUL
    861 
    +    Int64MulOp -> sizedPrimOp OP_MUL
    862 
    +    Int32MulOp -> sizedPrimOp OP_MUL
    863 
    +    Int16MulOp -> sizedPrimOp OP_MUL
    864 
    +    Int8MulOp -> sizedPrimOp OP_MUL
    865 
    +    WordMulOp -> sizedPrimOp OP_MUL
    866 
    +    Word64MulOp -> sizedPrimOp OP_MUL
    867 
    +    Word32MulOp -> sizedPrimOp OP_MUL
    868 
    +    Word16MulOp -> sizedPrimOp OP_MUL
    869 
    +    Word8MulOp -> sizedPrimOp OP_MUL
    870 
    +
    860 871 
         IntSubOp -> sizedPrimOp OP_SUB
    861 872 
         WordSubOp -> sizedPrimOp OP_SUB
    862 873 
         Int64SubOp -> sizedPrimOp OP_SUB
    ... ... @@ -1009,20 +1020,20 @@ doPrimOp platform op init_d s p args =
    1009 1020 
         Int16NegOp -> sizedPrimOp OP_NEG
    1010 1021 
         Int8NegOp -> sizedPrimOp OP_NEG
    1011 1022
    1012 
    -    IntToWordOp     -> no_op
    1013 
    -    WordToIntOp     -> no_op
    1014 
    -    Int8ToWord8Op   -> no_op
    1015 
    -    Word8ToInt8Op   -> no_op
    1016 
    -    Int16ToWord16Op -> no_op
    1017 
    -    Word16ToInt16Op -> no_op
    1018 
    -    Int32ToWord32Op -> no_op
    1019 
    -    Word32ToInt32Op -> no_op
    1020 
    -    Int64ToWord64Op -> no_op
    1021 
    -    Word64ToInt64Op -> no_op
    1022 
    -    IntToAddrOp     -> no_op
    1023 
    -    AddrToIntOp     -> no_op
    1024 
    -    ChrOp           -> no_op   -- Int# and Char# are rep'd the same
    1025 
    -    OrdOp           -> no_op
    1023 
    +    IntToWordOp     -> mk_conv (platformWordWidth platform)
    1024 
    +    WordToIntOp     -> mk_conv (platformWordWidth platform)
    1025 
    +    Int8ToWord8Op   -> mk_conv W8
    1026 
    +    Word8ToInt8Op   -> mk_conv W8
    1027 
    +    Int16ToWord16Op -> mk_conv W16
    1028 
    +    Word16ToInt16Op -> mk_conv W16
    1029 
    +    Int32ToWord32Op -> mk_conv W32
    1030 
    +    Word32ToInt32Op -> mk_conv W32
    1031 
    +    Int64ToWord64Op -> mk_conv W64
    1032 
    +    Word64ToInt64Op -> mk_conv W64
    1033 
    +    IntToAddrOp     -> mk_conv (platformWordWidth platform)
    1034 
    +    AddrToIntOp     -> mk_conv (platformWordWidth platform)
    1035 
    +    ChrOp           -> mk_conv (platformWordWidth platform)   -- Int# and Char# are rep'd the same
    1036 
    +    OrdOp           -> mk_conv (platformWordWidth platform)
    1026 1037
    1027 1038 
         IndexOffAddrOp_Word8 ->  primOpWithRep (OP_INDEX_ADDR W8) W8
    1028 1039 
         IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16
    ... ... @@ -1031,6 +1042,7 @@ doPrimOp platform op init_d s p args =
    1031 1042
    1032 1043 
         _ -> Nothing
    1033 1044 
       where
    1045 
    +    primArg1Width :: StgArg -> Width
    1034 1046 
         primArg1Width arg
    1035 1047 
           | rep <- (stgArgRepU arg)
    1036 1048 
           = case rep of
    ... ... @@ -1080,43 +1092,12 @@ doPrimOp platform op init_d s p args =
    1080 1092 
           let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
    1081 1093 
           return $ prim_code `appOL` slide
    1082 1094
    1083 
    -    no_op = Just $ do
    1095 
    +    mk_conv :: Width -> Maybe (BcM (OrdList BCInstr))
    1096 
    +    mk_conv target_width = Just $ do
    1084 1097 
           let width = primArg1Width (head args)
    1085 
    -      prim_code <- terribleNoOp init_d s p undefined args
    1086 
    -      let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
    1087 
    -      return $ prim_code `appOL` slide
    1088 
    -
    1089 
    --- It's horrible, but still better than calling intToWord ...
    1090 
    -terribleNoOp
    1091 
    -    :: StackDepth
    1092 
    -    -> Sequel
    1093 
    -    -> BCEnv
    1094 
    -    -> BCInstr                  -- The operator
    1095 
    -    -> [StgArg]                 -- Args, in *reverse* order (must be fully applied)
    1096 
    -    -> BcM BCInstrList
    1097 
    -terribleNoOp orig_d _ p _ args = app_code
    1098 
    -  where
    1099 
    -    app_code = do
    1100 
    -        profile <- getProfile
    1101 
    -        let --platform = profilePlatform profile
    1102 
    -
    1103 
    -            non_voids =
    1104 
    -                addArgReps (assertNonVoidStgArgs args)
    1105 
    -            (_, _, args_offsets) =
    1106 
    -                mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
    1107 
    -
    1108 
    -            do_pushery !d (arg : args) = do
    1109 
    -                (push, arg_bytes) <- case arg of
    1110 
    -                    (Padding l _) -> return $! pushPadding (ByteOff l)
    1111 
    -                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
    1112 
    -                more_push_code <- do_pushery (d + arg_bytes) args
    1113 
    -                return (push `appOL` more_push_code)
    1114 
    -            do_pushery !_d [] = do
    1115 
    -                -- let !n_arg_words = bytesToWords platform (d - orig_d)
    1116 
    -                return (nilOL)
    1117 
    -
    1118 
    -        -- Push on the stack in the reverse order.
    1119 
    -        do_pushery orig_d (reverse args_offsets)
    1098 
    +      (push_code, _bytes) <- pushAtom init_d p (head args)
    1099 
    +      let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width
    1100 
    +      return $ push_code `appOL` slide
    1120 1101
    1121 1102 
     -- Push the arguments on the stack and emit the given instruction
    1122 1103 
     -- Pushes one word per non void arg.

  • rts/Interpreter.c
    ... ... @@ -249,9 +249,9 @@ See ticket #25750
    249 249 
     #define SafeSpWP(n)      \
    250 250 
       ((StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)))
    251 251 
     #define SafeSpBP(off_w)      \
    252 
    -  ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W(1+off_w/sizeof(StgWord))) ? \
    252 
    +  ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
    253 253 
             Sp_plusB(off_w) : \
    254 
    -        (StgWord*) ((ptrdiff_t)(off_w % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, off_w/sizeof(StgWord))))
    254 
    +        (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))))
    255 255
    256 256
    257 257
    ... ... @@ -2270,10 +2270,10 @@ run_BCO:
    2270 2270 
     #define UN_SIZED_OP(op,ty)                                          \
    2271 2271 
         {                                                               \
    2272 2272 
             if(sizeof(ty) == 8) {                                       \
    2273 
    -            ty r = op (*(ty*) ReadSpW64(0));                        \
    2273 
    +            ty r = op ((ty) ReadSpW64(0));                        \
    2274 2274 
                 SpW64(0) = (StgWord64) r;                               \
    2275 2275 
             } else {                                                    \
    2276 
    -            ty r = op (*(ty*) ReadSpW(0));                          \
    2276 
    +            ty r = op ((ty) ReadSpW(0));                          \
    2277 2277 
                 SpW(0) = (StgWord) r;                                   \
    2278 2278 
             }                                                           \
    2279 2279 
             goto nextInsn;                                              \
    ... ... @@ -2293,15 +2293,30 @@ run_BCO:
    2293 2293 
                 goto nextInsn;                                                      \
    2294 2294 
             }
    2295 2295
    2296 
    +// op :: ty -> Int -> ty
    2297 
    +#define SIZED_BIN_OP_TY_INT(op,ty)                                      \
    2298 
    +{                                                                       \
    2299 
    +    if(sizeof(ty) > sizeof(StgWord)) {                                  \
    2300 
    +        ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW(2));                \
    2301 
    +        Sp_addW(1);                                                     \
    2302 
    +        SpW64(0) = (StgWord64) r;                                       \
    2303 
    +    } else {                                                            \
    2304 
    +        ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1));                  \
    2305 
    +        Sp_addW(1);                                                     \
    2306 
    +        SpW(0) = (StgWord) r;                                           \
    2307 
    +    };                                                                  \
    2308 
    +    goto nextInsn;                                                      \
    2309 
    +}
    2310 
    +
    2296 2311 
             case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
    2297 2312 
             case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
    2298 2313 
             case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
    2299 2314 
             case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
    2300 2315 
             case bci_OP_OR_64:  SIZED_BIN_OP(|, StgInt64)
    2301 2316 
             case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
    2302 
    -        case bci_OP_SHL_64: SIZED_BIN_OP(<<, StgWord64)
    2303 
    -        case bci_OP_LSR_64: SIZED_BIN_OP(>>, StgWord64)
    2304 
    -        case bci_OP_ASR_64: SIZED_BIN_OP(>>, StgInt64)
    2317 
    +        case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
    2318 
    +        case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
    2319 
    +        case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
    2305 2320
    2306 2321 
             case bci_OP_NEQ_64:  SIZED_BIN_OP(!=, StgWord64)
    2307 2322 
             case bci_OP_EQ_64:   SIZED_BIN_OP(==, StgWord64)
    ... ... @@ -2325,9 +2340,9 @@ run_BCO:
    2325 2340 
             case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
    2326 2341 
             case bci_OP_OR_32:  SIZED_BIN_OP(|, StgInt32)
    2327 2342 
             case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
    2328 
    -        case bci_OP_SHL_32: SIZED_BIN_OP(<<, StgWord32)
    2329 
    -        case bci_OP_LSR_32: SIZED_BIN_OP(>>, StgWord32)
    2330 
    -        case bci_OP_ASR_32: SIZED_BIN_OP(>>, StgInt32)
    2343 
    +        case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
    2344 
    +        case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
    2345 
    +        case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
    2331 2346
    2332 2347 
             case bci_OP_NEQ_32:  SIZED_BIN_OP(!=, StgWord32)
    2333 2348 
             case bci_OP_EQ_32:   SIZED_BIN_OP(==, StgWord32)
    ... ... @@ -2351,9 +2366,9 @@ run_BCO:
    2351 2366 
             case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
    2352 2367 
             case bci_OP_OR_16:  SIZED_BIN_OP(|, StgInt16)
    2353 2368 
             case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
    2354 
    -        case bci_OP_SHL_16: SIZED_BIN_OP(<<, StgWord16)
    2355 
    -        case bci_OP_LSR_16: SIZED_BIN_OP(>>, StgWord16)
    2356 
    -        case bci_OP_ASR_16: SIZED_BIN_OP(>>, StgInt16)
    2369 
    +        case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
    2370 
    +        case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
    2371 
    +        case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
    2357 2372
    2358 2373 
             case bci_OP_NEQ_16:  SIZED_BIN_OP(!=, StgWord16)
    2359 2374 
             case bci_OP_EQ_16:   SIZED_BIN_OP(==, StgWord16)
    ... ... @@ -2377,9 +2392,9 @@ run_BCO:
    2377 2392 
             case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
    2378 2393 
             case bci_OP_OR_08:  SIZED_BIN_OP(|, StgInt8)
    2379 2394 
             case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
    2380 
    -        case bci_OP_SHL_08: SIZED_BIN_OP(<<, StgWord8)
    2381 
    -        case bci_OP_LSR_08: SIZED_BIN_OP(>>, StgWord8)
    2382 
    -        case bci_OP_ASR_08: SIZED_BIN_OP(>>, StgInt8)
    2395 
    +        case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
    2396 
    +        case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
    2397 
    +        case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
    2383 2398
    2384 2399 
             case bci_OP_NEQ_08:  SIZED_BIN_OP(!=, StgWord8)
    2385 2400 
             case bci_OP_EQ_08:   SIZED_BIN_OP(==, StgWord8)

  • testsuite/tests/numeric/should_run/foundation.hs
    1 
    +{- PARTS OF THIS FILE ARE SEMI-AUTOGENERATED.
    2 
    +   You can re-generate them by invoking the genprimops utility with --foundation-tests
    3 
    +   and then integrating the output in this file.
    4 
    +-}
    5 
    +
    1 6 
     {-# LANGUAGE FlexibleContexts    #-}
    2 7 
     {-# LANGUAGE OverloadedStrings   #-}
    3 8 
     {-# LANGUAGE ScopedTypeVariables #-}
    ... ... @@ -19,6 +24,7 @@ import Data.Typeable
    19 24 
     import Data.Proxy
    20 25 
     import GHC.Int
    21 26 
     import GHC.Word
    27 
    +import GHC.Word
    22 28 
     import Data.Function
    23 29 
     import GHC.Prim
    24 30 
     import Control.Monad.Reader
    ... ... @@ -108,6 +114,17 @@ arbitraryWord64 = Gen $ do
    108 114 
         h <- ask
    109 115 
         liftIO (randomWord64 h)
    110 116
    117 
    +nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
    118 
    +nonZero = do
    119 
    +  x <- arbitrary
    120 
    +  if x == 0 then nonZero else pure $ NonZero x
    121 
    +
    122 
    +newtype NonZero a = NonZero { getNonZero :: a }
    123 
    +  deriving (Eq,Ord,Bounded,Show)
    124 
    +
    125 
    +instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
    126 
    +  arbitrary = nonZero
    127 
    +
    111 128 
     instance Arbitrary Natural where
    112 129 
         arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
    113 130
    ... ... @@ -138,10 +155,10 @@ instance Arbitrary Int8 where
    138 155
    139 156 
     instance Arbitrary Char where
    140 157 
         arbitrary = do
    141 
    -      let low = fromEnum (minBound :: Char)
    142 
    -          high = fromEnum (maxBound :: Char)
    143 
    -      x <- arbitrary
    144 
    -      if x >= low && x <= high then return (chr x) else arbitrary
    158 
    +      let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
    159 
    +      (x::Word) <- arbitrary
    160 
    +      let x' = mod x high
    161 
    +      return (chr $ fromIntegral x')
    145 162
    146 163 
     int64ToInt :: Int64 -> Int
    147 164 
     int64ToInt (I64# i) = I# (int64ToInt# i)
    ... ... @@ -277,9 +294,8 @@ testMultiplicative _ = Group "Multiplicative"
    277 294 
     testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
    278 295 
                   => Proxy a -> Test
    279 296 
     testDividible _ = Group "Divisible"
    280 
    -    [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b ->
    281 
    -            if b == 0 then True === True
    282 
    -                      else a === (a `div` b) * b + (a `mod` b)
    297 
    +    [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
    298 
    +            a === (a `div` b) * b + (a `mod` b)
    283 299 
         ]
    284 300
    285 301 
     testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a,  Arbitrary a, Typeable a)
    ... ... @@ -368,6 +384,9 @@ wInt64# = I64#
    368 384 
     class TestPrimop f where
    369 385 
       testPrimop :: String -> f -> f -> Test
    370 386
    387 
    +  testPrimopDivLike :: String -> f -> f -> Test
    388 
    +  testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
    389 
    +
    371 390 
     {-
    372 391 
     instance TestPrimop (Int# -> Int# -> Int#) where
    373 392 
       testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
    ... ... @@ -383,6 +402,9 @@ instance TestPrimop (Word# -> Int# -> Word#) where
    383 402 
       -}
    384 403
    385 404
    405 
    +twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
    406 
    +twoNonZero f x (NonZero y) = f x y
    407 
    +
    386 408 
     main = runTests (Group "ALL" [testNumberRefs, testPrimops])
    387 409
    388 410 
     -- Test an interpreted primop vs a compiled primop
    ... ... @@ -400,9 +422,9 @@ testPrimops = Group "primop"
    400 422 
       , testPrimop "plusInt8#" Primop.plusInt8# Wrapper.plusInt8#
    401 423 
       , testPrimop "subInt8#" Primop.subInt8# Wrapper.subInt8#
    402 424 
       , testPrimop "timesInt8#" Primop.timesInt8# Wrapper.timesInt8#
    403 
    -  , testPrimop "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
    404 
    -  , testPrimop "remInt8#" Primop.remInt8# Wrapper.remInt8#
    405 
    -  , testPrimop "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
    425 
    +  , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
    426 
    +  , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
    427 
    +  , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
    406 428 
       , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
    407 429 
       , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
    408 430 
       , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
    ... ... @@ -418,9 +440,9 @@ testPrimops = Group "primop"
    418 440 
       , testPrimop "plusWord8#" Primop.plusWord8# Wrapper.plusWord8#
    419 441 
       , testPrimop "subWord8#" Primop.subWord8# Wrapper.subWord8#
    420 442 
       , testPrimop "timesWord8#" Primop.timesWord8# Wrapper.timesWord8#
    421 
    -  , testPrimop "quotWord8#" Primop.quotWord8# Wrapper.quotWord8#
    422 
    -  , testPrimop "remWord8#" Primop.remWord8# Wrapper.remWord8#
    423 
    -  , testPrimop "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8#
    443 
    +  , testPrimopDivLike "quotWord8#" Primop.quotWord8# Wrapper.quotWord8#
    444 
    +  , testPrimopDivLike "remWord8#" Primop.remWord8# Wrapper.remWord8#
    445 
    +  , testPrimopDivLike "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8#
    424 446 
       , testPrimop "andWord8#" Primop.andWord8# Wrapper.andWord8#
    425 447 
       , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
    426 448 
       , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
    ... ... @@ -440,9 +462,9 @@ testPrimops = Group "primop"
    440 462 
       , testPrimop "plusInt16#" Primop.plusInt16# Wrapper.plusInt16#
    441 463 
       , testPrimop "subInt16#" Primop.subInt16# Wrapper.subInt16#
    442 464 
       , testPrimop "timesInt16#" Primop.timesInt16# Wrapper.timesInt16#
    443 
    -  , testPrimop "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
    444 
    -  , testPrimop "remInt16#" Primop.remInt16# Wrapper.remInt16#
    445 
    -  , testPrimop "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
    465 
    +  , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
    466 
    +  , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
    467 
    +  , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
    446 468 
       , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
    447 469 
       , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
    448 470 
       , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
    ... ... @@ -458,9 +480,9 @@ testPrimops = Group "primop"
    458 480 
       , testPrimop "plusWord16#" Primop.plusWord16# Wrapper.plusWord16#
    459 481 
       , testPrimop "subWord16#" Primop.subWord16# Wrapper.subWord16#
    460 482 
       , testPrimop "timesWord16#" Primop.timesWord16# Wrapper.timesWord16#
    461 
    -  , testPrimop "quotWord16#" Primop.quotWord16# Wrapper.quotWord16#
    462 
    -  , testPrimop "remWord16#" Primop.remWord16# Wrapper.remWord16#
    463 
    -  , testPrimop "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16#
    483 
    +  , testPrimopDivLike "quotWord16#" Primop.quotWord16# Wrapper.quotWord16#
    484 
    +  , testPrimopDivLike "remWord16#" Primop.remWord16# Wrapper.remWord16#
    485 
    +  , testPrimopDivLike "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16#
    464 486 
       , testPrimop "andWord16#" Primop.andWord16# Wrapper.andWord16#
    465 487 
       , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
    466 488 
       , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
    ... ... @@ -480,9 +502,9 @@ testPrimops = Group "primop"
    480 502 
       , testPrimop "plusInt32#" Primop.plusInt32# Wrapper.plusInt32#
    481 503 
       , testPrimop "subInt32#" Primop.subInt32# Wrapper.subInt32#
    482 504 
       , testPrimop "timesInt32#" Primop.timesInt32# Wrapper.timesInt32#
    483 
    -  , testPrimop "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
    484 
    -  , testPrimop "remInt32#" Primop.remInt32# Wrapper.remInt32#
    485 
    -  , testPrimop "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
    505 
    +  , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
    506 
    +  , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
    507 
    +  , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
    486 508 
       , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
    487 509 
       , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
    488 510 
       , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
    ... ... @@ -498,9 +520,9 @@ testPrimops = Group "primop"
    498 520 
       , testPrimop "plusWord32#" Primop.plusWord32# Wrapper.plusWord32#
    499 521 
       , testPrimop "subWord32#" Primop.subWord32# Wrapper.subWord32#
    500 522 
       , testPrimop "timesWord32#" Primop.timesWord32# Wrapper.timesWord32#
    501 
    -  , testPrimop "quotWord32#" Primop.quotWord32# Wrapper.quotWord32#
    502 
    -  , testPrimop "remWord32#" Primop.remWord32# Wrapper.remWord32#
    503 
    -  , testPrimop "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32#
    523 
    +  , testPrimopDivLike "quotWord32#" Primop.quotWord32# Wrapper.quotWord32#
    524 
    +  , testPrimopDivLike "remWord32#" Primop.remWord32# Wrapper.remWord32#
    525 
    +  , testPrimopDivLike "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32#
    504 526 
       , testPrimop "andWord32#" Primop.andWord32# Wrapper.andWord32#
    505 527 
       , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
    506 528 
       , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
    ... ... @@ -520,8 +542,8 @@ testPrimops = Group "primop"
    520 542 
       , testPrimop "plusInt64#" Primop.plusInt64# Wrapper.plusInt64#
    521 543 
       , testPrimop "subInt64#" Primop.subInt64# Wrapper.subInt64#
    522 544 
       , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
    523 
    -  , testPrimop "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
    524 
    -  , testPrimop "remInt64#" Primop.remInt64# Wrapper.remInt64#
    545 
    +  , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
    546 
    +  , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
    525 547 
       , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
    526 548 
       , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
    527 549 
       , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
    ... ... @@ -537,8 +559,8 @@ testPrimops = Group "primop"
    537 559 
       , testPrimop "plusWord64#" Primop.plusWord64# Wrapper.plusWord64#
    538 560 
       , testPrimop "subWord64#" Primop.subWord64# Wrapper.subWord64#
    539 561 
       , testPrimop "timesWord64#" Primop.timesWord64# Wrapper.timesWord64#
    540 
    -  , testPrimop "quotWord64#" Primop.quotWord64# Wrapper.quotWord64#
    541 
    -  , testPrimop "remWord64#" Primop.remWord64# Wrapper.remWord64#
    562 
    +  , testPrimopDivLike "quotWord64#" Primop.quotWord64# Wrapper.quotWord64#
    563 
    +  , testPrimopDivLike "remWord64#" Primop.remWord64# Wrapper.remWord64#
    542 564 
       , testPrimop "and64#" Primop.and64# Wrapper.and64#
    543 565 
       , testPrimop "or64#" Primop.or64# Wrapper.or64#
    544 566 
       , testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
    ... ... @@ -557,9 +579,9 @@ testPrimops = Group "primop"
    557 579 
       , testPrimop "*#" (Primop.*#) (Wrapper.*#)
    558 580 
       , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2#
    559 581 
       , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
    560 
    -  , testPrimop "quotInt#" Primop.quotInt# Wrapper.quotInt#
    561 
    -  , testPrimop "remInt#" Primop.remInt# Wrapper.remInt#
    562 
    -  , testPrimop "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
    582 
    +  , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt#
    583 
    +  , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt#
    584 
    +  , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
    563 585 
       , testPrimop "andI#" Primop.andI# Wrapper.andI#
    564 586 
       , testPrimop "orI#" Primop.orI# Wrapper.orI#
    565 587 
       , testPrimop "xorI#" Primop.xorI# Wrapper.xorI#
    ... ... @@ -585,10 +607,9 @@ testPrimops = Group "primop"
    585 607 
       , testPrimop "minusWord#" Primop.minusWord# Wrapper.minusWord#
    586 608 
       , testPrimop "timesWord#" Primop.timesWord# Wrapper.timesWord#
    587 609 
       , testPrimop "timesWord2#" Primop.timesWord2# Wrapper.timesWord2#
    588 
    -  , testPrimop "quotWord#" Primop.quotWord# Wrapper.quotWord#
    589 
    -  , testPrimop "remWord#" Primop.remWord# Wrapper.remWord#
    590 
    -  , testPrimop "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord#
    591 
    ---  , testPrimop "quotRemWord2#" Primop.quotRemWord2# Wrapper.quotRemWord2#
    610 
    +  , testPrimopDivLike "quotWord#" Primop.quotWord# Wrapper.quotWord#
    611 
    +  , testPrimopDivLike "remWord#" Primop.remWord# Wrapper.remWord#
    612 
    +  , testPrimopDivLike "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord#
    592 613 
       , testPrimop "and#" Primop.and# Wrapper.and#
    593 614 
       , testPrimop "or#" Primop.or# Wrapper.or#
    594 615 
       , testPrimop "xor#" Primop.xor# Wrapper.xor#
    ... ... @@ -652,12 +673,15 @@ instance TestPrimop (Char# -> Int#) where
    652 673
    653 674 
     instance TestPrimop (Int# -> Int# -> Int#) where
    654 675 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    676 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    655 677
    656 678 
     instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
    657 679 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
    680 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
    658 681
    659 682 
     instance TestPrimop (Int# -> Int# -> (# Int#,Int#,Int# #)) where
    660 683 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
    684 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
    661 685
    662 686 
     instance TestPrimop (Int# -> Char#) where
    663 687 
       testPrimop s l r = Property s $ \ (uInt#-> x0) -> wChar# (l x0) === wChar# (r x0)
    ... ... @@ -685,12 +709,15 @@ instance TestPrimop (Int16# -> Int# -> Int16#) where
    685 709
    686 710 
     instance TestPrimop (Int16# -> Int16# -> Int#) where
    687 711 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    712 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    688 713
    689 714 
     instance TestPrimop (Int16# -> Int16# -> Int16#) where
    690 715 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
    716 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
    691 717
    692 718 
     instance TestPrimop (Int16# -> Int16# -> (# Int16#,Int16# #)) where
    693 719 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
    720 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
    694 721
    695 722 
     instance TestPrimop (Int16# -> Int#) where
    696 723 
       testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt# (l x0) === wInt# (r x0)
    ... ... @@ -706,12 +733,15 @@ instance TestPrimop (Int32# -> Int# -> Int32#) where
    706 733
    707 734 
     instance TestPrimop (Int32# -> Int32# -> Int#) where
    708 735 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    736 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    709 737
    710 738 
     instance TestPrimop (Int32# -> Int32# -> Int32#) where
    711 739 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
    740 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
    712 741
    713 742 
     instance TestPrimop (Int32# -> Int32# -> (# Int32#,Int32# #)) where
    714 743 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
    744 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
    715 745
    716 746 
     instance TestPrimop (Int32# -> Int#) where
    717 747 
       testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt# (l x0) === wInt# (r x0)
    ... ... @@ -727,9 +757,11 @@ instance TestPrimop (Int64# -> Int# -> Int64#) where
    727 757
    728 758 
     instance TestPrimop (Int64# -> Int64# -> Int#) where
    729 759 
       testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    760 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    730 761
    731 762 
     instance TestPrimop (Int64# -> Int64# -> Int64#) where
    732 763 
       testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
    764 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
    733 765
    734 766 
     instance TestPrimop (Int64# -> Int#) where
    735 767 
       testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt# (l x0) === wInt# (r x0)
    ... ... @@ -745,12 +777,15 @@ instance TestPrimop (Int8# -> Int# -> Int8#) where
    745 777
    746 778 
     instance TestPrimop (Int8# -> Int8# -> Int#) where
    747 779 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    780 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    748 781
    749 782 
     instance TestPrimop (Int8# -> Int8# -> Int8#) where
    750 783 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
    784 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
    751 785
    752 786 
     instance TestPrimop (Int8# -> Int8# -> (# Int8#,Int8# #)) where
    753 787 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
    788 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
    754 789
    755 790 
     instance TestPrimop (Int8# -> Int#) where
    756 791 
       testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt# (l x0) === wInt# (r x0)
    ... ... @@ -764,20 +799,21 @@ instance TestPrimop (Int8# -> Word8#) where
    764 799 
     instance TestPrimop (Word# -> Int# -> Word#) where
    765 800 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
    766 801
    767 
    -instance TestPrimop (Word# -> Word# -> Word# -> (# Word#,Word# #)) where
    768 
    -  testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) (uWord#-> x2) -> WTUP2(wWord#,wWord#, (l x0 x1 x2)) === WTUP2(wWord#,wWord#, (r x0 x1 x2))
    769 
    -
    770 802 
     instance TestPrimop (Word# -> Word# -> Int#) where
    771 803 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    804 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    772 805
    773 806 
     instance TestPrimop (Word# -> Word# -> Word#) where
    774 807 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
    808 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
    775 809
    776 810 
     instance TestPrimop (Word# -> Word# -> (# Word#,Int# #)) where
    777 811 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
    812 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
    778 813
    779 814 
     instance TestPrimop (Word# -> Word# -> (# Word#,Word# #)) where
    780 815 
       testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
    816 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
    781 817
    782 818 
     instance TestPrimop (Word# -> Int#) where
    783 819 
       testPrimop s l r = Property s $ \ (uWord#-> x0) -> wInt# (l x0) === wInt# (r x0)
    ... ... @@ -802,12 +838,15 @@ instance TestPrimop (Word16# -> Int# -> Word16#) where
    802 838
    803 839 
     instance TestPrimop (Word16# -> Word16# -> Int#) where
    804 840 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    841 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    805 842
    806 843 
     instance TestPrimop (Word16# -> Word16# -> Word16#) where
    807 844 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
    845 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
    808 846
    809 847 
     instance TestPrimop (Word16# -> Word16# -> (# Word16#,Word16# #)) where
    810 848 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
    849 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
    811 850
    812 851 
     instance TestPrimop (Word16# -> Int16#) where
    813 852 
       testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
    ... ... @@ -823,12 +862,15 @@ instance TestPrimop (Word32# -> Int# -> Word32#) where
    823 862
    824 863 
     instance TestPrimop (Word32# -> Word32# -> Int#) where
    825 864 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    865 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    826 866
    827 867 
     instance TestPrimop (Word32# -> Word32# -> Word32#) where
    828 868 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
    869 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
    829 870
    830 871 
     instance TestPrimop (Word32# -> Word32# -> (# Word32#,Word32# #)) where
    831 872 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
    873 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
    832 874
    833 875 
     instance TestPrimop (Word32# -> Int32#) where
    834 876 
       testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
    ... ... @@ -844,9 +886,11 @@ instance TestPrimop (Word64# -> Int# -> Word64#) where
    844 886
    845 887 
     instance TestPrimop (Word64# -> Word64# -> Int#) where
    846 888 
       testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    889 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    847 890
    848 891 
     instance TestPrimop (Word64# -> Word64# -> Word64#) where
    849 892 
       testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
    893 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
    850 894
    851 895 
     instance TestPrimop (Word64# -> Int64#) where
    852 896 
       testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
    ... ... @@ -862,12 +906,15 @@ instance TestPrimop (Word8# -> Int# -> Word8#) where
    862 906
    863 907 
     instance TestPrimop (Word8# -> Word8# -> Int#) where
    864 908 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    909 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    865 910
    866 911 
     instance TestPrimop (Word8# -> Word8# -> Word8#) where
    867 912 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
    913 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
    868 914
    869 915 
     instance TestPrimop (Word8# -> Word8# -> (# Word8#,Word8# #)) where
    870 916 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
    917 
    +  testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
    871 918
    872 919 
     instance TestPrimop (Word8# -> Int8#) where
    873 920 
       testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wInt8# (l x0) === wInt8# (r x0)

  • utils/genprimopcode/Main.hs
    1 
    +{-# OPTIONS_GHC -Wno-x-partial #-}
    1 2 
     ------------------------------------------------------------------
    2 3 
     -- A primop-table mangling program                              --
    3 4 
     --
    ... ... @@ -693,16 +694,24 @@ gen_foundation_tests (Info _ entries)
    693 694 
       where
    694 695 
         testable_tys = nub (sort (mapMaybe (\po -> ty po <$ mkTest po) entries))
    695 696
    696 
    -    mkInstances ty = unlines $
    697 
    -      [ "instance TestPrimop (" ++ pprTy ty ++ ") where"
    698 
    -      , "  testPrimop s l r = Property s $ \\ " ++ intercalate " " (zipWith mkArg [0..] (args ty)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" ]
    699 
    -
    697 
    +    mkInstances inst_ty =
    698 
    +      let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
    699 
    +      in  unlines $
    700 
    +      [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
    701 
    +      , "  testPrimop s l r = Property s $ " ++ test_lambda ]
    702 
    +      ++ (if mb_divable_tys
    703 
    +          then ["  testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
    704 
    +          else [])
    700 705 
           where
    701 
    -        n_args = length (args ty)
    706 
    +        arg_tys = args inst_ty
    707 
    +        -- eg Int -> Int -> a
    708 
    +        mb_divable_tys = case arg_tys of
    709 
    +            [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
    710 
    +            _         -> False
    702 711
    703 
    -        mk_body s = res_ty ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
    712 
    +        mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
    704 713
    705 
    -        vs = zipWith (\n _ -> "x" ++ show n) [0..] (args ty)
    714 
    +        vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
    706 715
    707 716 
         mkArg n t = "(" ++ unwrapper t  ++ "-> x" ++ show n ++ ")"
    708 717
    ... ... @@ -714,15 +723,22 @@ gen_foundation_tests (Info _ entries)
    714 723 
         args (TyF (TyApp (TyCon c) []) t2) = c : args t2
    715 724 
         args (TyApp {}) = []
    716 725 
         args (TyUTup {}) = []
    726 
    +    -- If you hit this you will need to handle the foundation tests to handle the
    727 
    +    -- type it failed on.
    728 
    +    args arg_ty = error ("Unexpected primop type:" ++ pprTy arg_ty)
    717 729
    718 730 
         res_ty (TyF _ t2) x = res_ty t2 x
    719 731 
         res_ty (TyApp (TyCon c) []) x = wrapper c ++ x
    720 
    -    res_ty (TyUTup args) x =
    721 
    -      let wtup = case length args of
    732 
    +    res_ty (TyUTup tup_tys) x =
    733 
    +      let wtup = case length tup_tys of
    722 734 
                        2 -> "WTUP2"
    723 735 
                        3 -> "WTUP3"
    724 
    -      in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") args ++ [x]) ++ ")"
    725 
    -
    736 
    +                   -- Only handles primops returning unboxed tuples up to 3 args currently
    737 
    +                   _ -> error "Unexpected primop result type"
    738 
    +      in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") tup_tys ++ [x]) ++ ")"
    739 
    +    -- If you hit this you will need to handle the foundation tests to handle the
    740 
    +    -- type it failed on.
    741 
    +    res_ty unexpected_ty x = error ("Unexpected primop result type:" ++ pprTy unexpected_ty ++ "," ++ x)
    726 742
    727 743
    728 744 
         wrap qual nm | isLower (head nm) = qual ++ "." ++ nm
    ... ... @@ -734,7 +750,10 @@ gen_foundation_tests (Info _ entries)
    734 750 
           , poName /= "tagToEnum#"
    735 751 
           , poName /= "quotRemWord2#"
    736 752 
           , (testable (ty po))
    737 
    -      = Just $ intercalate " " ["testPrimop", "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
    753 
    +      = let testPrimOpHow = if is_divLikeOp po
    754 
    +              then "testPrimopDivLike"
    755 
    +              else "testPrimop"
    756 
    +        in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
    738 757 
           | otherwise = Nothing
    739 758
    740 759
    ... ... @@ -742,13 +761,15 @@ gen_foundation_tests (Info _ entries)
    742 761 
         testable (TyF t1 t2) = testable t1 && testable t2
    743 762 
         testable (TyC _  t2) = testable t2
    744 763 
         testable (TyApp tc tys) = testableTyCon tc && all testable tys
    745 
    -    testable (TyVar a)   = False
    764 
    +    testable (TyVar _a)   = False
    746 765 
         testable (TyUTup tys)  = all testable tys
    747 766
    748 767 
         testableTyCon (TyCon c) =
    749 768 
           c `elem` ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
    750 769 
                    , "Int8#", "Int16#", "Int32#", "Int64#", "Char#"]
    751 770 
         testableTyCon _ = False
    771 
    +    divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
    772 
    +                    ,"Int8#", "Int16#", "Int32#", "Int64#"]
    752 773
    753 774 
     ------------------------------------------------------------------
    754 775 
     -- Create PrimOpInfo text from PrimOpSpecs -----------------------

  • utils/genprimopcode/Syntax.hs
    ... ... @@ -53,6 +53,19 @@ is_primtype :: Entry -> Bool
    53 53 
     is_primtype (PrimTypeSpec {}) = True
    54 54 
     is_primtype _ = False
    55 55
    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
    68 
    +
    56 69 
     -- a binding of property to value
    57 70 
     data Option
    58 71 
        = OptionFalse  String          -- name = False

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