recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC

Commits:

7 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 
    +   defined_bits     = Nothing -- The number of bits the operation is defined for (if not all bits)
    151 152
    152 153 
     -- Note [When do out-of-line primops go in primops.txt.pp]
    153 154 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1065,8 +1066,10 @@ primop CtzOp "ctz#" GenPrimOp Word# -> Word#
    1065 1066
    1066 1067 
     primop   BSwap16Op   "byteSwap16#"   GenPrimOp   Word# -> Word#
    1067 1068 
         {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }
    1069 
    +    with defined_bits = 16
    1068 1070 
     primop   BSwap32Op   "byteSwap32#"   GenPrimOp   Word# -> Word#
    1069 1071 
         {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }
    1072 
    +    with defined_bits = 32
    1070 1073 
     primop   BSwap64Op   "byteSwap64#"   GenPrimOp   Word64# -> Word64#
    1071 1074 
         {Swap bytes in a 64 bits of a word.}
    1072 1075 
     primop   BSwapOp     "byteSwap#"     GenPrimOp   Word# -> Word#
    ... ... @@ -1074,10 +1077,13 @@ primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word#
    1074 1077
    1075 1078 
     primop   BRev8Op    "bitReverse8#"   GenPrimOp   Word# -> Word#
    1076 1079 
         {Reverse the order of the bits in a 8-bit word.}
    1080 
    +    with defined_bits = 8
    1077 1081 
     primop   BRev16Op   "bitReverse16#"   GenPrimOp   Word# -> Word#
    1078 1082 
         {Reverse the order of the bits in a 16-bit word.}
    1083 
    +    with defined_bits = 16
    1079 1084 
     primop   BRev32Op   "bitReverse32#"   GenPrimOp   Word# -> Word#
    1080 1085 
         {Reverse the order of the bits in a 32-bit word.}
    1086 
    +    with defined_bits = 32
    1081 1087 
     primop   BRev64Op   "bitReverse64#"   GenPrimOp   Word64# -> Word64#
    1082 1088 
         {Reverse the order of the bits in a 64-bit word.}
    1083 1089 
     primop   BRevOp     "bitReverse#"     GenPrimOp   Word# -> Word#

  • testsuite/tests/numeric/should_run/foundation.hs
    ... ... @@ -409,6 +409,33 @@ instance TestPrimop (Word# -> Int# -> Word#) where
    409 409 
       testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2)
    410 410 
       -}
    411 411
    412 
    +-- | A special data-type for representing functions where,
    413 
    +-- since only some number of the lower bits are defined,
    414 
    +-- testing for strict equality in the undefined upper bits is not appropriate!
    415 
    +-- Without using this data-type, false-positive failures will be reported
    416 
    +-- when the undefined bit regions do not match, even though the equality of bits
    417 
    +-- in this undefined region has no bearing on correctness.
    418 
    +data LowerBitsAreDefined =
    419 
    +    LowerBitsAreDefined
    420 
    +    { definedLowerWidth :: Word
    421 
    +    -- ^ The (strictly-non-negative) number of least-significant bits
    422 
    +    -- for which the attached function is defined.
    423 
    +    , undefinedBehavior :: (Word# -> Word#)
    424 
    +    -- ^ Function with undefined behavior for some of its most significant bits.
    425 
    +    }
    426 
    +
    427 
    +instance TestPrimop LowerBitsAreDefined where
    428 
    +  testPrimop s l r = Property s $ \ (uWord#-> x0) ->
    429 
    +    let -- Create a mask to unset all bits in the undefined area,
    430 
    +        -- leaving set bits only in the area of defined behavior.
    431 
    +        -- Since the upper bits are undefined,
    432 
    +        -- if the function defines behavior for the lower N bits,
    433 
    +        -- then /only/ the lower N bits are preserved,
    434 
    +        -- and the upper WORDSIZE - N bits are discarded.
    435 
    +        mask = bit (fromEnum (definedLowerWidth r)) - 1
    436 
    +        valL = wWord# (undefinedBehavior l x0) .&. mask
    437 
    +        valR = wWord# (undefinedBehavior r x0) .&. mask
    438 
    +    in  valL === valR
    412 439
    413 440 
     twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
    414 441 
     twoNonZero f x (NonZero y) = f x y
    ... ... @@ -673,34 +700,6 @@ testPrimops = Group "primop"
    673 700 
       , testPrimop "narrow32Word#" Primop.narrow32Word# Wrapper.narrow32Word#
    674 701 
       ]
    675 702
    676 
    --- | A special data-type for representing functions where,
    677 
    --- since only some number of the lower bits are defined,
    678 
    --- testing for strict equality in the undefined upper bits is not appropriate!
    679 
    --- Without using this data-type, false-positive failures will be reported
    680 
    --- when the undefined bit regions do not match, even though the equality of bits
    681 
    --- in this undefined region has no bearing on correctness.
    682 
    -data LowerBitsAreDefined =
    683 
    -    LowerBitsAreDefined
    684 
    -    { definedLowerWidth :: Word
    685 
    -    -- ^ The (strictly-non-negative) number of least-significant bits
    686 
    -    -- for which the attached function is defined.
    687 
    -    , undefinedBehavior :: (Word# -> Word#)
    688 
    -    -- ^ Function with undefined behavior for some of its most significant bits.
    689 
    -    }
    690 
    -
    691 
    -instance TestPrimop LowerBitsAreDefined where
    692 
    -  testPrimop s l r = Property s $ \ (uWord#-> x0) ->
    693 
    -    let -- Create a mask to unset all bits in the undefined area,
    694 
    -        -- leaving set bits only in the area of defined behavior.
    695 
    -        -- Since the upper bits are undefined,
    696 
    -        -- if the function defines behavior for the lower N bits,
    697 
    -        -- then /only/ the lower N bits are preserved,
    698 
    -        -- and the upper WORDSIZE - N bits are discarded.
    699 
    -        mask = bit (fromEnum (definedLowerWidth r)) - 1
    700 
    -        valL = wWord# (undefinedBehavior l x0) .&. mask
    701 
    -        valR = wWord# (undefinedBehavior r x0) .&. mask
    702 
    -    in  valL === valR
    703 
    -
    704 703 
     instance TestPrimop (Char# -> Char# -> Int#) where
    705 704 
       testPrimop s l r = Property s $ \ (uChar#-> x0) (uChar#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    706 705

  • utils/genprimopcode/Lexer.x
    ... ... @@ -56,6 +56,7 @@ words :-
    56 56 
         <0>         "CanFail"           { mkT TCanFail }
    57 57 
         <0>         "ThrowsException"   { mkT TThrowsException }
    58 58 
         <0>         "ReadWriteEffect"   { mkT TReadWriteEffect }
    59 
    +    <0>         "defined_bits"      { mkT TDefinedBits }
    59 60 
         <0>         "can_fail_warning"  { mkT TCanFailWarnFlag }
    60 61 
         <0>         "DoNotWarnCanFail"  { mkT TDoNotWarnCanFail }
    61 62 
         <0>         "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail }

  • utils/genprimopcode/Main.hs
    ... ... @@ -10,6 +10,7 @@ module Main where
    10 10 
     import Parser
    11 11 
     import Syntax
    12 12
    13 
    +import Control.Applicative (asum)
    13 14 
     import Data.Char
    14 15 
     import Data.List (union, intersperse, intercalate, nub, sort)
    15 16 
     import Data.Maybe ( catMaybes, mapMaybe )
    ... ... @@ -753,7 +754,14 @@ gen_foundation_tests (Info _ entries)
    753 754 
           = let testPrimOpHow = if is_divLikeOp po
    754 755 
                   then "testPrimopDivLike"
    755 756 
                   else "testPrimop"
    756 
    -        in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
    757 
    +            withDefinedBits qName = case mb_defined_bits po of
    758 
    +              Nothing -> qName
    759 
    +              Just bs -> concat ["(", show bs, " `LowerBitsAreDefined` ", qName, ")"]
    760 
    +        in Just $ intercalate " "
    761 
    +             [ testPrimOpHow
    762 
    +             , "\"" ++ poName ++ "\""
    763 
    +             , withDefinedBits $ wrap "Primop" poName
    764 
    +             , withDefinedBits $ wrap "Wrapper" poName]
    757 765 
           | otherwise = Nothing
    758 766
    759 767
    ... ... @@ -771,6 +779,17 @@ gen_foundation_tests (Info _ entries)
    771 779 
         divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
    772 780 
                         ,"Int8#", "Int16#", "Int32#", "Int64#"]
    773 781
    782 
    +
    783 
    +    mb_defined_bits :: Entry -> Maybe Word
    784 
    +    mb_defined_bits op@(PrimOpSpec{}) =
    785 
    +      let opOpts = opts op
    786 
    +          getDefBits :: Option -> Maybe Word
    787 
    +          getDefBits (OptionDefinedBits x) = x
    788 
    +          getDefBits _ = Nothing
    789 
    +      in  asum $ getDefBits <$> opOpts
    790 
    +    mb_defined_bits _ = Nothing
    791 
    +
    792 
    +
    774 793 
     ------------------------------------------------------------------
    775 794 
     -- Create PrimOpInfo text from PrimOpSpecs -----------------------
    776 795 
     ------------------------------------------------------------------

  • utils/genprimopcode/Parser.y
    ... ... @@ -50,6 +50,7 @@ import AccessOps
    50 50 
         CanFail         { TCanFail }
    51 51 
         ThrowsException { TThrowsException }
    52 52 
         ReadWriteEffect { TReadWriteEffect }
    53 
    +    defined_bits     { TDefinedBits }
    53 54 
         can_fail_warning { TCanFailWarnFlag }
    54 55 
         DoNotWarnCanFail { TDoNotWarnCanFail }
    55 56 
         WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail }
    ... ... @@ -81,13 +82,14 @@ pOptions : pOption pOptions { $1 : $2 }
    81 82 
              | {- empty -}      { [] }
    82 83
    83 84 
     pOption :: { Option }
    84 
    -pOption : lowerName '=' false               { OptionFalse  $1 }
    85 
    -        | lowerName '=' true                { OptionTrue   $1 }
    86 
    -        | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
    87 
    -        | lowerName '=' integer             { OptionInteger $1 $3 }
    88 
    -        | vector    '=' pVectorTemplate     { OptionVector $3 }
    89 
    -        | fixity    '=' pInfix              { OptionFixity $3 }
    90 
    -        | effect    '=' pEffect             { OptionEffect $3 }
    85 
    +pOption : lowerName        '=' false                  { OptionFalse   $1     }
    86 
    +        | lowerName        '=' true                   { OptionTrue    $1     }
    87 
    +        | lowerName        '=' pStuffBetweenBraces    { OptionString  $1  $3 }
    88 
    +        | lowerName        '=' integer                { OptionInteger $1  $3 }
    89 
    +        | vector           '=' pVectorTemplate        { OptionVector      $3 }
    90 
    +        | fixity           '=' pInfix                 { OptionFixity      $3 }
    91 
    +        | effect           '=' pEffect                { OptionEffect      $3 }
    92 
    +        | defined_bits     '=' pGoodBits              { OptionDefinedBits $3 }
    91 93 
             | can_fail_warning '=' pPrimOpCanFailWarnFlag { OptionCanFailWarnFlag $3 }
    92 94
    93 95 
     pInfix :: { Maybe Fixity }
    ... ... @@ -102,6 +104,10 @@ pEffect : NoEffect { NoEffect }
    102 104 
             | ThrowsException         { ThrowsException }
    103 105 
             | ReadWriteEffect         { ReadWriteEffect }
    104 106
    107 
    +pGoodBits :: { Maybe Word }
    108 
    +pGoodBits : integer { Just $ toEnum $1 }
    109 
    +          | nothing { Nothing }
    110 
    +
    105 111 
     pPrimOpCanFailWarnFlag :: { PrimOpCanFailWarnFlag }
    106 112 
     pPrimOpCanFailWarnFlag : DoNotWarnCanFail { DoNotWarnCanFail }
    107 113 
                               | WarnIfEffectIsCanFail { WarnIfEffectIsCanFail }

  • utils/genprimopcode/ParserM.hs
    ... ... @@ -116,6 +116,7 @@ data Token = TEOF
    116 116 
                | TCanFail
    117 117 
                | TThrowsException
    118 118 
                | TReadWriteEffect
    119 
    +           | TDefinedBits
    119 120 
                | TCanFailWarnFlag
    120 121 
                | TDoNotWarnCanFail
    121 122 
                | TWarnIfEffectIsCanFail

  • utils/genprimopcode/Syntax.hs
    ... ... @@ -76,6 +76,7 @@ data Option
    76 76 
        | OptionFixity (Maybe Fixity)  -- fixity = infix{,l,r} <int> | Nothing
    77 77 
        | OptionEffect PrimOpEffect    -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect
    78 78 
        | OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail
    79 
    +   | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing
    79 80 
          deriving Show
    80 81
    81 82 
     -- categorises primops
    ... ... @@ -196,6 +197,7 @@ get_attrib_name (OptionVector _) = "vector"
    196 197 
     get_attrib_name (OptionFixity _) = "fixity"
    197 198 
     get_attrib_name (OptionEffect _) = "effect"
    198 199 
     get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning"
    200 
    +get_attrib_name (OptionDefinedBits _) = "defined_bits"
    199 201
    200 202 
     lookup_attrib :: String -> [Option] -> Maybe Option
    201 203 
     lookup_attrib _ [] = Nothing

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