Commit b0b80e90 authored by Iavor S. Diatchki's avatar Iavor S. Diatchki Committed by Ben Gamari

Implement the basics of hex floating point literals

Implement hexadecmial floating point literals.

The digits of the mantissa are hexadecimal.
The exponent is written in base 10, and the base for the exponentiation is 2.
Hexadecimal literals look a lot like ordinary decimal literals, except that
they use hexadecmial digits, and the exponent is written using `p` rather than `e`.

The specification of the feature is available here:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0004-hexFloats.rst

For a discussion of the various choices:
https://github.com/ghc-proposals/ghc-proposals/pull/37

Reviewers: mpickering, goldfire, austin, bgamari, hvr

Reviewed By: bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D3066
parent 1130c67b
......@@ -3969,6 +3969,7 @@ xFlagsDeps = [
flagSpec "NamedFieldPuns" LangExt.RecordPuns,
flagSpec "NamedWildCards" LangExt.NamedWildCards,
flagSpec "NegativeLiterals" LangExt.NegativeLiterals,
flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals,
flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation,
depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses
(deprecatedForExtension "MultiParamTypeClasses"),
......
......@@ -105,7 +105,7 @@ import Outputable
import StringBuffer
import FastString
import UniqFM
import Util ( readRational )
import Util ( readRational, readHexRational )
-- compiler/main
import ErrUtils
......@@ -182,6 +182,7 @@ $docsym = [\| \^ \* \$]
@octal = $octit+
@hexadecimal = $hexit+
@exponent = [eE] [\-\+]? @decimal
@bin_exponent = [pP] [\-\+]? @decimal
@qual = (@conid \.)+
@qvarid = @qual @varid
......@@ -190,6 +191,7 @@ $docsym = [\| \^ \* \$]
@qconsym = @qual @consym
@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
@hex_floating_point = @hexadecimal \. @hexadecimal @bin_exponent? | @hexadecimal @bin_exponent
-- normal signed numerical literals can only be explicitly negative,
-- not explicitly positive (contrast @exponent)
......@@ -498,6 +500,9 @@ $tab { warnTab }
-- Normal rational literals (:: Fractional a => a, from Rational)
@floating_point { strtoken tok_float }
@negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float }
0[xX] @hex_floating_point / { ifExtension hexFloatLiteralsEnabled } { strtoken tok_hex_float }
@negative 0[xX]@hex_floating_point / { ifExtension hexFloatLiteralsEnabled `alexAndPred`
ifExtension negativeLiteralsEnabled } { strtoken tok_hex_float }
}
<0> {
......@@ -1306,14 +1311,23 @@ hexadecimal = (16,hexDigit)
-- readRational can understand negative rationals, exponents, everything.
tok_float, tok_primfloat, tok_primdouble :: String -> Token
tok_float str = ITrational $! readFractionalLit str
tok_primfloat str = ITprimfloat $! readFractionalLit str
tok_primdouble str = ITprimdouble $! readFractionalLit str
tok_float str = ITrational $! readFractionalLit str
tok_hex_float str = ITrational $! readHexFractionalLit str
tok_primfloat str = ITprimfloat $! readFractionalLit str
tok_primdouble str = ITprimdouble $! readFractionalLit str
readFractionalLit :: String -> FractionalLit
readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
where is_neg = case str of ('-':_) -> True
_ -> False
readHexFractionalLit :: String -> FractionalLit
readHexFractionalLit str =
FL { fl_text = SourceText str
, fl_neg = case str of
'-' : _ -> True
_ -> False
, fl_value = readHexRational str
}
-- -----------------------------------------------------------------------------
-- Layout processing
......@@ -2204,6 +2218,7 @@ data ExtBits
| LambdaCaseBit
| BinaryLiteralsBit
| NegativeLiteralsBit
| HexFloatLiteralsBit
| TypeApplicationsBit
| StaticPointersBit
deriving Enum
......@@ -2266,6 +2281,8 @@ binaryLiteralsEnabled :: ExtsBitmap -> Bool
binaryLiteralsEnabled = xtest BinaryLiteralsBit
negativeLiteralsEnabled :: ExtsBitmap -> Bool
negativeLiteralsEnabled = xtest NegativeLiteralsBit
hexFloatLiteralsEnabled :: ExtsBitmap -> Bool
hexFloatLiteralsEnabled = xtest HexFloatLiteralsBit
patternSynonymsEnabled :: ExtsBitmap -> Bool
patternSynonymsEnabled = xtest PatternSynonymsBit
typeApplicationEnabled :: ExtsBitmap -> Bool
......@@ -2323,6 +2340,7 @@ mkParserFlags flags =
.|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags
.|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags
.|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags
.|. HexFloatLiteralsBit `setBitIf` xopt LangExt.HexFloatLiterals flags
.|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags
.|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags
.|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags
......
......@@ -89,6 +89,7 @@ module Util (
-- * Floating point
readRational,
readHexRational,
-- * read helpers
maybeRead, maybeReadFuzzy,
......@@ -143,7 +144,7 @@ import GHC.Exts
import GHC.Stack (HasCallStack)
import Control.Applicative ( liftA2 )
import Control.Monad ( liftM )
import Control.Monad ( liftM, guard )
import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
import GHC.Conc.Sync ( sharedCAF )
import System.IO (Handle, hGetEncoding, hSetEncoding)
......@@ -151,7 +152,8 @@ import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
import System.FilePath
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper
, isHexDigit, digitToInt )
import Data.Int
import Data.Ratio ( (%) )
import Data.Ord ( comparing )
......@@ -1159,6 +1161,59 @@ readRational top_s
_ -> error ("readRational: ambiguous parse:" ++ top_s)
readHexRational :: String -> Rational
readHexRational str =
case str of
'-' : xs -> - (readMe xs)
xs -> readMe xs
where
readMe as =
case readHexRational__ as of
Just n -> n
_ -> error ("readHexRational: no parse:" ++ str)
readHexRational__ :: String -> Maybe Rational
readHexRational__ ('0' : x : rest)
| x == 'X' || x == 'x' =
do let (front,rest2) = span isHexDigit rest
guard (not (null front))
let frontNum = steps 16 0 front
case rest2 of
'.' : rest3 ->
do let (back,rest4) = span isHexDigit rest3
guard (not (null back))
let backNum = steps 16 frontNum back
exp1 = -4 * length back
case rest4 of
p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)
_ -> return (mk backNum exp1)
p : ps | isExp p -> fmap (mk frontNum) (getExp ps)
_ -> Nothing
where
isExp p = p == 'p' || p == 'P'
getExp ('+' : ds) = dec ds
getExp ('-' : ds) = fmap negate (dec ds)
getExp ds = dec ds
mk :: Integer -> Int -> Rational
mk n e = fromInteger n * 2^^e
dec cs = case span isDigit cs of
(ds,"") | not (null ds) -> Just (steps 10 0 ds)
_ -> Nothing
steps base n ds = foldl' (step base) n ds
step base n d = base * n + fromIntegral (digitToInt d)
readHexRational__ _ = Nothing
-----------------------------------------------------------------------------
-- read helpers
......
......@@ -100,6 +100,11 @@ Language
:ghc-flag:`-XEmptyDataDeriving` to do so. This also goes for other classes
which require extensions to derive, such as :ghc-flag:`-XDeriveFunctor`.
- Hexadecimal floating point literals (e.g. ``0x0.1p4``), enabled with
:ghc-flag:`HexFloatLiterals`. See
:ref:`Hexadecimal floating point literals <hex-float-literals>`
for the full details.
Compiler
~~~~~~~~
......
......@@ -509,6 +509,50 @@ integer literals in binary notation with the prefix ``0b`` or ``0B``. For
instance, the binary integer literal ``0b11001001`` will be desugared into
``fromInteger 201`` when :extension:`BinaryLiterals` is enabled.
.. _hex-float-literals:
Hexadecimal floating point literals
-----------------------------------
.. ghc-flag:: -XHexFloatLiterals
:shortdesc: Enable support for :ref:`hexadecimal floating point literals <heax-float-literals>`.
:type: dynamic
:reverse: -XNoHexFloatLIterals
:category:
:since: 8.4.1
Allow writing floating point literals using hexadecimal notation.
The hexadecimal notation for floating point literals is useful when you
need to specify floating point constants precisely, as the literal notation
corresponds closely to the underlying bit-encoding of the number.
In this notation floating point numbers are written using hexadecimal digits,
and so the digits are interpreted using base 16, rather then the usual 10.
This means that digits left of the decimal point correspond to positive
powers of 16, while the ones to the right correspond to negaitve ones.
You may also write an explicit exponent, which is similar to the exponent
in decimal notation with the following differences:
- the exponent begins with ``p`` instead of ``e``
- the exponent is written in base ``10`` (**not** 16)
- the base of the exponent is ``2`` (**not** 16).
In terms of the underlying bit encoding, each hexadecimal digit corresponds
to 4 bits, and you may think of the exponent as "moving" the floating point
by one bit left (negative) or right (positive). Here are some examples:
- ``0x0.1`` is the same as ``1/16``
- ``0x0.01`` is the same as ``1/256``
- ``0xF.FF`` is the same as ``15 + 15/16 + 15/256``
- ``0x0.1p4`` is the same as ``1``
- ``0x0.1p-4`` is the same as ``1/256``
- ``0x0.1p12`` is the same as ``256``
.. _pattern-guards:
Pattern guards
......
......@@ -33,6 +33,7 @@ module Numeric (
showFFloatAlt,
showGFloatAlt,
showFloat,
showHFloat,
floatToDigits,
......@@ -69,6 +70,7 @@ import GHC.Show
import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )
import qualified Text.Read.Lex as L
-- -----------------------------------------------------------------------------
-- Reading
......@@ -213,6 +215,52 @@ showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS
showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x)
showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x)
{- | Show a floating-point value in the hexadecimal format,
similar to the @%a@ specifier in C's printf.
>>> showHFloat (212.21 :: Double) ""
"0x1.a86b851eb851fp7"
>>> showHFloat (-12.76 :: Float) ""
"-0x1.9851ecp3"
>>> showHFloat (-0 :: Double) ""
"-0x0p+0"
-}
showHFloat :: RealFloat a => a -> ShowS
showHFloat = showString . fmt
where
fmt x
| isNaN x = "NaN"
| isInfinite x = (if x < 0 then "-" else "") ++ "Infinity"
| x < 0 || isNegativeZero x = '-' : cvt (-x)
| otherwise = cvt x
cvt x
| x == 0 = "0x0p+0"
| otherwise =
case floatToDigits 2 x of
r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r
(d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1)
-- Given binary digits, convert them to hex in blocks of 4
-- Special case: If all 0's, just drop it.
frac digits
| allZ digits = ""
| otherwise = "." ++ hex digits
where
hex ds =
case ds of
[] -> ""
[a] -> hexDigit a 0 0 0 ""
[a,b] -> hexDigit a b 0 0 ""
[a,b,c] -> hexDigit a b c 0 ""
a : b : c : d : r -> hexDigit a b c d (hex r)
hexDigit a b c d = showHex (8*a + 4*b + 2*c + d)
allZ xs = case xs of
x : more -> x == 0 && allZ more
[] -> True
-- ---------------------------------------------------------------------------
-- Integer printing functions
......
......@@ -3,6 +3,8 @@
## 4.11.0.0 *TBA*
* Bundled with GHC 8.4.1
* Add `showHFloat` to `Numeric`
* Add `Div`, `Mod`, and `Log2` functions on type-level naturals
in `GHC.TypeLits`.
......
......@@ -120,6 +120,7 @@ data Extension
| MultiWayIf
| BinaryLiterals
| NegativeLiterals
| HexFloatLiterals
| DuplicateRecordFields
| OverloadedLabels
| EmptyCase
......
......@@ -41,7 +41,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRuleTransitional",
"UnboxedSums",
"DerivingStrategies",
"EmptyDataDeriving"]
"EmptyDataDeriving",
"HexFloatLiterals"]
expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics",
......
{-# Language HexFloatLiterals #-}
import Numeric(showHFloat)
main :: IO ()
main =
do print [ 0xF.0
, 0xF.1, 0xF.01
, 0xF1p-4, 0xF01p-8
, 0x0.F1p4, 0x0.00F01p12
]
mapM_ putStrLn [ showHFloat (212.21 :: Double) ""
, showHFloat (-12.76 :: Float) ""
, showHFloat (-0 :: Double) ""
]
[15.0,15.0625,15.00390625,15.0625,15.00390625,15.0625,15.00390625]
0x1.a86b851eb851fp7
-0x1.9851ecp3
-0x0p+0
......@@ -11,3 +11,4 @@ test('BinaryLiterals1', [], compile_and_run, [''])
test('BinaryLiterals2', [], compile_and_run, [''])
test('T10807', normal, compile_and_run, [''])
test('NegativeZero', normal, compile_and_run, [''])
test('HexFloatLiterals', normal, compile_and_run, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment