diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,9 +1,19 @@ * Hackage: * GitHub: -* Latest Hackage released version: 2.3, 2020-09-05 +* Latest Hackage released version: 3.0, 2021-03-29 +### Version 3.0, 2021-03-29 + + * A complete rewrite, much simplified, and supporting + arbitrary precision floats. Some of the old features + and the library are dropped; so if you rely on the library + nature of CrackNum, do not upgrade. For other users who + merely use crackNum as an executable, the new version is + strongly recommended. + ### Version 2.4, 2020-09-05 + * Changes required to compile cleanly with GHC 8.10.2 ### Version 2.3, 2018-11-17 diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,5 +1,5 @@ -Copyright (c) 2015-2016, Levent Erkok (erkokl@gmail.com) +Copyright (c) 2015-2021, Levent Erkok (erkokl@gmail.com) All rights reserved. -The crackIEEE754 library is distributed with the BSD3 license. See the LICENSE file +The crackNum executable is distributed with the BSD3 license. See the LICENSE file for details. diff --git a/Data/Numbers/CrackNum.hs b/Data/Numbers/CrackNum.hs deleted file mode 100644 --- a/Data/Numbers/CrackNum.hs +++ /dev/null @@ -1,273 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : Data.Numbers.CrackNum --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- A library for formatting/analyzing FP and Integer values ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Numbers.CrackNum - ( -- * Internal representation of a Floating-point numbers - FP(..), Precision(..), IPrecision(..), Kind(..) - -- * Creating FP values - , floatToFP, doubleToFP, stringToFP, integerToFP - -- * Displaying FP and Int/Word values - , displayFP, displayWord - -- * Converting between floats and bit-representations - , floatToWord, wordToFloat, doubleToWord, wordToDouble - ) - where - -import Data.Bits (testBit, setBit, Bits) -import Data.Char (toLower) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.List (intercalate) -import Data.Maybe (isJust, fromJust, fromMaybe, catMaybes) - -import Numeric -import Data.Numbers.CrackNum.Data -import Data.Numbers.CrackNum.Utils - -import qualified Data.Numbers.FloatingHex as FH - -import Data.Word (Word32, Word64) -import Data.Array.ST (newArray, readArray, MArray, STUArray) -import Data.Array.Unsafe (castSTUArray) -import GHC.ST (runST, ST) - --- | Crack a Haskell Integer value as the given precision floating value. The Integer should --- be the value corresponding to the bit-pattern as the float is laid out in memory according --- to the IEEE rules. -integerToFP :: Precision -> Integer -> FP -integerToFP HP = crack HP 15 15 [14, 13 .. 10] [9, 8 .. 0] -integerToFP SP = crack SP 127 31 [30, 29 .. 23] [22, 21 .. 0] -integerToFP DP = crack DP 1023 63 [62, 61 .. 52] [51, 50 .. 0] - --- | Use Haskell Float to represent SP -spVal :: Bool -> Int -> [Bool] -> Float -spVal dn expVal fracBits = ((2::Float) ** fromIntegral expVal) * add1 frac - where frac = sum $ zipWith (\b i -> if b then (2::Float)**(-(fromIntegral (i::Int))) else 0) fracBits [1..] - add1 | dn = id - | True = (1+) - --- | Use Haskell Double to represent DP -dpVal :: Bool -> Int -> [Bool] -> Double -dpVal dn expVal fracBits = ((2::Double) ** fromIntegral expVal) * add1 frac - where frac = sum $ zipWith (\b i -> if b then (2::Double)**(-(fromIntegral (i::Int))) else 0) fracBits [1..] - add1 | dn = id - | True = (1+) - --- | Assemble a FP from the given bits and pieces. -crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP -crack vPrec vBias signPos expPos fracPos val - = FP { intVal = val - , prec = vPrec - , sign = vSign - , stExpt = vStoredExp - , expt = vStoredExp - curBias - , bias = curBias - , fracBits = vFracBits - , bitLayOut = layOut [[vSign], vExpBits, vFracBits] - , kind = vKind - } - where bit i = val `testBit` i - vSign = bit signPos - vExpBits = map bit expPos - vStoredExp = bv vExpBits - vFracBits = map bit fracPos - isZero = all0 vExpBits && all0 vFracBits - isDenormal = all0 vExpBits && any1 vFracBits - isInfinity = all1 vExpBits && all0 vFracBits - isNAN = all1 vExpBits && any1 vFracBits - vKind | isZero = Zero vSign - | isInfinity = Infty vSign - | isNAN = if head vFracBits then QNaN else SNaN - | isDenormal = Denormal - | True = Normal - curBias = case vKind of - Denormal -> vBias - 1 - _ -> vBias - --- | Display a Floating-point number in a nicely formatted way. (This function is also available --- through the 'Show' instance for 'FP', but is provided here for symmetry with 'displayWord'.) -displayFP :: FP -> String -displayFP FP{intVal, prec, sign, stExpt, bias, expt, fracBits, bitLayOut, kind} = intercalate "\n" ls - where ls = [ " " ++ inds1 - , " " ++ inds2 - , " " ++ inds3 - , " Binary: " ++ bitLayOut - , " Hex: " ++ hexDisp allBits - , " Precision: " ++ show prec - , " Sign: " ++ if sign then "Negative" else "Positive" - , " Exponent: " ++ show expt ++ " (Stored: " ++ show stExpt ++ ", Bias: " ++ show bias ++ ")" - , " Hex-float: " ++ hexVal - , " Value: " ++ val - ] - ++ [ " Note: Representation for NaN's is not unique." | isNaNKind kind] - - (inds1, inds2, inds3) = case prec of - HP -> (hpInds1, hpInds2, hpInds3) - SP -> (spInds1, spInds2, spInds3) - DP -> (dpInds1, dpInds2, dpInds3) - allBits = case prec of - HP -> [intVal `testBit` i | i <- startsAt 15] - SP -> [intVal `testBit` i | i <- startsAt 31] - DP -> [intVal `testBit` i | i <- startsAt 63] - where startsAt n = [n, n-1 .. 0] - - dup x = (x, x) - - (val, hexVal) = case kind of - Zero False -> ("+0.0", "0x0p+0") - Zero True -> ("-0.0", "-0x0p+0") - Infty False -> dup "+Infinity" - Infty True -> dup "-Infinity" - SNaN -> dup "NaN (Signaling)" - QNaN -> dup "NaN (Quietized)" - Denormal -> nval True " (DENORMAL)" - Normal -> nval False " (NORMAL)" - - nval dn tag = (s ++ vd ++ tag, s ++ vh) - where s = if sign then "-" else "+" - vd = case prec of - HP -> showGFloat Nothing (spVal dn expt fracBits) "" - SP -> showGFloat Nothing (spVal dn expt fracBits) "" - DP -> showGFloat Nothing (dpVal dn expt fracBits) "" - vh = case prec of - HP -> FH.showHFloat (spVal dn expt fracBits) "" - SP -> FH.showHFloat (spVal dn expt fracBits) "" - DP -> FH.showHFloat (dpVal dn expt fracBits) "" - --- | Show instance for FP -instance Show FP where - show = displayFP - --- | Display a Integer (signed/unsigned) number in a nicely formatted way -displayWord :: IPrecision -> Integer -> String -displayWord iprec intVal = intercalate "\n" ls - where (sg, sz) = sgSz iprec - ls = [ " " ++ fromJust inds1 | isJust inds1] - ++ [ " " ++ inds2 - , " Binary: " ++ binDisp allBits - , " Hex: " ++ hexDisp allBits - , " Type: " ++ show iprec - ] - ++ [ " Sign: " ++ if signBit then "Negative" else "Positive" | sg] - ++ [ " Value: " ++ val - ] - (inds1, inds2) = case sz of - 8 -> (Nothing, bInds2) - 16 -> (Just wInds1, wInds2) - 32 -> (Just dInds1, dInds2) - 64 -> (Just qInds1, qInds2) - _ -> error $ "displayWord: Unexpected size: " ++ show sz - allBits = [intVal `testBit` i | i <- [sz-1, sz-2 .. 0]] - signBit = head allBits - val | not sg = show intVal - | True = case iprec of - I8 -> show $ adjust (0::Int8) - I16 -> show $ adjust (0::Int16) - I32 -> show $ adjust (0::Int32) - I64 -> show $ adjust (0::Int64) - _ -> error $ "displayWord: Unexpected type: " ++ show iprec - adjust :: Bits a => a -> a - adjust v = foldr (flip setBit) v [i | (i, True) <- zip [0..] (reverse allBits)] - --- | Convert the given string to a IEEE number with the required precision -stringToFP :: Precision -> String -> FP -stringToFP precision input - = case precision of - SP -> fromMaybe (error $ "*** stringToFP: Cannot read a valid SP number from: " ++ show input) mbF - DP -> fromMaybe (error $ "*** stringToFP: Cannot read a valid DP number from: " ++ show input) mbD - _ -> error $ "*** stringToFP: Unsupported precision: " ++ show precision - where i = map toLower (dropWhile (== '+') input) - specials :: [(String, (FP, FP))] - specials = [ (s, (floatToFP f, doubleToFP d)) - | (s, (f, d)) <- [ ("infinity", ( infinityF, infinityD)) - , ("-infinity", (-infinityF, - infinityD)) - , ("0", ( 0, 0)) - , ("-0", (-0, - 0)) - , ("max", ( maxFiniteF, maxFiniteD)) - , ("-max", (-maxFiniteF, - maxFiniteD)) - , ("min", ( minNormalF, minNormalD)) - , ("-min", (-minNormalF, - minNormalD)) - , ("epsilon", ( epsilonF, epsilonD))] ] - ++ [ ("ulp", (integerToFP SP 1, integerToFP DP 1)) - , ("nan", (integerToFP SP 0x7f800001, integerToFP DP 0x7ff0000000000001)) - , ("snan", (integerToFP SP 0x7f800001, integerToFP DP 0x7ff0000000000001)) - , ("qnan", (integerToFP SP 0x7fc00000, integerToFP DP 0x7ff8000000000000)) - ] - - infinityF, maxFiniteF, minNormalF, epsilonF :: Float - infinityF = 1/0 - maxFiniteF = 3.40282347e+38 - minNormalF = 1.17549435e-38 - epsilonF = 1.19209290e-07 - - infinityD, maxFiniteD, minNormalD, epsilonD :: Double - infinityD = 1/0 - maxFiniteD = 1.7976931348623157e+308 - minNormalD = 2.2250738585072014e-308 - epsilonD = 2.2204460492503131e-16 - - mbF, mbD :: Maybe FP - (mbF, mbD) = case (i `lookup` specials, rd i :: Maybe Float, rd i :: Maybe Double) of - (Just (f, d), _ , _ ) -> (Just f, Just d) - (Nothing, Just f, Just d) -> (Just (floatToFP f), Just (doubleToFP d)) - (Nothing, Just f, _ ) -> (Just (floatToFP f), Nothing) - (Nothing, _, Just d) -> (Nothing, Just (doubleToFP d)) - _ -> (Nothing, Nothing) - - rd :: (Read a, FH.FloatingHexReader a) => String -> Maybe a - rd s = case [v | (v, "") <- reads s] ++ catMaybes [FH.readHFloat s] of - [v] -> Just v - _ -> Nothing - --- | Turn a Haskell float to the internal detailed FP representation -floatToFP :: Float -> FP -floatToFP = integerToFP SP . toInteger . floatToWord - --- | Turn a Haskell double to the internal detailed FP representation -doubleToFP :: Double -> FP -doubleToFP = integerToFP DP . toInteger . doubleToWord - -------------------------------------------------------------------------- --- Reinterpreting float/double as word32/64 and back. Here, we use the --- definitions from the reinterpret-cast package: --- --- http://hackage.haskell.org/package/reinterpret-cast --- --- The reason we steal these definitions is to make sure we keep minimal --- dependencies and no FFI requirements anywhere. -------------------------------------------------------------------------- --- | Reinterpret-casts a `Float` to a `Word32`. -floatToWord :: Float -> Word32 -floatToWord x = runST (cast x) -{-# INLINEABLE floatToWord #-} - --- | Reinterpret-casts a `Word32` to a `Float`. -wordToFloat :: Word32 -> Float -wordToFloat x = runST (cast x) -{-# INLINEABLE wordToFloat #-} - --- | Reinterpret-casts a `Double` to a `Word64`. -doubleToWord :: Double -> Word64 -doubleToWord x = runST (cast x) -{-# INLINEABLE doubleToWord #-} - --- | Reinterpret-casts a `Word64` to a `Double`. -wordToDouble :: Word64 -> Double -wordToDouble x = runST (cast x) -{-# INLINEABLE wordToDouble #-} - -{-# INLINE cast #-} -cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b -cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 diff --git a/Data/Numbers/CrackNum/Data.hs b/Data/Numbers/CrackNum/Data.hs deleted file mode 100644 --- a/Data/Numbers/CrackNum/Data.hs +++ /dev/null @@ -1,66 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : Data.Numbers.CrackNum.Data --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Internal representation of FP values ------------------------------------------------------------------------------ - -module Data.Numbers.CrackNum.Data where - --- | Floating point precision -data Precision = HP -- ^ Half precision; 16 bits = 1 sign + 5 exponent + 10 mantissa - | SP -- ^ Single precision; 32 bits = 1 sign + 8 exponent + 23 mantissa - | DP -- ^ Double precision; 64 bits = 1 sign + 11 exponent + 52 mantissa - deriving (Eq, Show) - --- | Integer/Word precision -data IPrecision = W8 -- ^ 8-bit unsigned (byte) - | I8 -- ^ 8-bit signed - | W16 -- ^ 16-bit unsigned (word) - | I16 -- ^ 16-bit signed - | W32 -- ^ 32-bit unsigned (double-word) - | I32 -- ^ 32-bit signed - | W64 -- ^ 64-bit unsigned (quad-word) - | I64 -- ^ 64-bit signed - deriving Eq - --- | Kinds of floating point values -data Kind = Zero Bool -- ^ Zero: 0. If Bool is true, then this is -0; otherwise +0. - | Infty Bool -- ^ Infinity: oo. If Bool is true, then this is -oo, otherwie +oo. - | SNaN -- ^ The signaling-NaN. - | QNaN -- ^ The quiet-NaN. - | Denormal -- ^ Denormalized number, i.e., leading bit is not 1 - | Normal -- ^ Normal value. - --- | Determine if we have a NaN value -isNaNKind :: Kind -> Bool -isNaNKind SNaN = True -isNaNKind QNaN = True -isNaNKind _ = False - --- | Show instance for integer-precisions -instance Show IPrecision where - show W8 = "Unsigned Byte" - show I8 = "Signed Byte" - show W16 = "Unsigned Word" - show I16 = "Signed Word" - show W32 = "Unsigned Double" - show I32 = "Signed Double" - show W64 = "Unsigned Quad" - show I64 = "Signed Quad" - --- | Complete internal representation for a floating-point number -data FP = FP { intVal :: Integer -- ^ The value as represented as a full Integer. Storage purposes only. - , prec :: Precision -- ^ FP precision. - , sign :: Bool -- ^ Sign. If True then negative, otherwise positive. - , stExpt :: Int -- ^ The exponent as it is stored. - , bias :: Int -- ^ The implicit bias of the exponent. - , expt :: Int -- ^ The actual exponent. - , fracBits :: [Bool] -- ^ Bits in the fractional part - , bitLayOut :: String -- ^ Layout representation - , kind :: Kind -- ^ Floating-point kind (i.e., value) - } diff --git a/Data/Numbers/CrackNum/Main.hs b/Data/Numbers/CrackNum/Main.hs deleted file mode 100644 --- a/Data/Numbers/CrackNum/Main.hs +++ /dev/null @@ -1,288 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : Main --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Main entry point for the crackNum executable ------------------------------------------------------------------------------ - -{-# LANGUAGE PatternGuards #-} - -module Main(main) where - -import Control.Monad (zipWithM_) -import Data.Char (isHexDigit, isDigit) -import Data.Maybe (fromMaybe, listToMaybe, isNothing) -import System.Console.GetOpt (ArgOrder(Permute), getOpt, ArgDescr(..), OptDescr(..), usageInfo) -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) - -import Data.Numbers.CrackNum -import Data.Numbers.CrackNum.Utils - -import Data.Version (showVersion) -import Paths_crackNum (version) - -copyRight :: String -copyRight = "(c) Levent Erkok. Released with a BSD3 license." - --- | Options accepted by the executable -data Flag = FPType Precision -- ^ Crack as a Floating Point with given precision - | IType IPrecision -- ^ Crack as an Integer with the given number of bits - | ToIEEE String -- ^ Convert to IEEE SP/DP value - | Lanes String -- ^ Number of lanes present in the input, crackNum can guess but it can also be specified. - | Help -- ^ Help - | VIM -- ^ Are we being called from VIM? - | Version -- ^ Version - deriving Eq - -options :: [OptDescr Flag] -options = [ - Option "" ["hp"] (NoArg (FPType HP)) "16 bit half precision" - , Option "" ["sp"] (NoArg (FPType SP)) "32 bit single precision" - , Option "" ["dp"] (NoArg (FPType DP)) "64 bit double precision" - , Option "" ["sb"] (NoArg (IType I8)) " 8 bit signed byte" - , Option "" ["sw"] (NoArg (IType I16)) "16 bit signed word" - , Option "" ["sd"] (NoArg (IType I32)) "32 bit signed double" - , Option "" ["sq"] (NoArg (IType I64)) "64 bit signed quad" - , Option "" ["ub"] (NoArg (IType W8)) " 8 bit unsigned byte" - , Option "" ["uw"] (NoArg (IType W16)) "16 bit unsigned word" - , Option "" ["ud"] (NoArg (IType W32)) "32 bit unsigned double" - , Option "" ["uq"] (NoArg (IType W64)) "64 bit unsigned quad" - , Option "" ["toIEEE"] (ReqArg ToIEEE "n") "Convert from decimal to IEEE SP/DP formats." - , Option "l" ["lanes"] (ReqArg Lanes "n") "number of lanes" - , Option "" ["vim"] (NoArg VIM) "output in vim friendly format" - , Option "h?" ["help"] (NoArg Help) "print help, with examples" - , Option "v" ["version"] (NoArg Version) "print version info" - ] - -helpStr :: String -> String -helpStr pn = usageInfo ("Usage: " ++ pn ++ " precision bit/hex-pattern") options - -usage :: String -> IO () -usage pn = do putStrLn $ helpStr pn - putStrLn "Examples:" - putStrLn "" - putStrLn $ " " ++ pn ++ " --hp fc00" - putStrLn $ " " ++ pn ++ " --sp fc00 abcd" - putStrLn $ " " ++ pn ++ " --dp fc00 abc1 2345 6789" - putStrLn $ " " ++ pn ++ " --sp 01111111110000000000000000000000" - putStrLn $ " " ++ pn ++ " -l2 --hp 01111111110000000000000000000000" - putStrLn $ " " ++ pn ++ " --sb 7f" - putStrLn $ " " ++ pn ++ " --sp --toIEEE=-2.3e6" - putStrLn $ " " ++ pn ++ " --dp --toIEEE=max" - putStrLn $ " " ++ pn ++ " --dp --toIEEE=ulp" - putStrLn "" - putStrLn "Notes:" - putStrLn " - You can use hexadecimal or binary as input." - putStrLn " - You can use _,- or space as a digit to improve readability." - putStrLn " - You can give input for multiple lanes, we will guess the #of lanes for you." - putStrLn " Or, you can specify number of lanes with the -l option." - putStrLn " - For \"toIEEE\" option (case doesn't matter):" - putStrLn " - You can enter a number in decimal notation (like 2.3)" - putStrLn " - You can enter a number in hexadecimal notation (like 0x1.abcp+3)" - putStrLn " - OR, enter one of the following:" - putStrLn " * infinity, -infinity: Positive/Negative infinities" - putStrLn " * nan, snan, qnan: Not-A-Number; signaling/quiet" - putStrLn " * 0, -0: Both kinds of zeros" - putStrLn " * max : The maximum finite positive value" - putStrLn " * -max: The minimum finite negative value" - putStrLn " * min : The minimum normal positive value" - putStrLn " * -min: The maximum normal negative value" - putStrLn " * epsilon: The smallest possible value x s.t. 1+x /= 1." - putStrLn " * ulp: The minimum subnormal value" - exitFailure - --- instead of dealing with vimscript, munge our args here.. heh -vimpret :: [String] -> [String] -vimpret args = case break (== "--bv") args of - ([p], "--bv":rest) -> case mkArgs p of - Nothing -> ["--help"] - Just pr -> ("--" ++ pr) : rest - _ -> ["--help"] - where bad = (`elem` ["lanes", "vim", "help"]) - validPrecs = filter (not . bad) $ concat [xs | Option _ xs _ _ <- options] - dvalidPrecs = map ('-':) validPrecs - ddvalidPrecs = map ('-':) dvalidPrecs - mkArgs p - | p `elem` validPrecs = Just p - | p `elem` dvalidPrecs = Just (drop 1 p) - | p `elem` ddvalidPrecs = Just (drop 2 p) - | True = Nothing - -main :: IO () -main = do origArgs <- getArgs - origPN <- getProgName - - let -- bugger.. make the args a bit more friendly - friendly :: String -> String - friendly ('-':ns) -- -2/-3 etc become lane stuff - | all isDigit ns - = "-l" ++ ns - friendly ('-':c:cs) - | c `notElem` "-l" = "--" ++ (c:cs) - friendly s = s - - cleanArgs = map friendly origArgs - - - (argv, pn) | "--vim" `elem` cleanArgs = ("--vim" : vimpret (filter (/= "--vim") cleanArgs), "CrackNum") - | True = (cleanArgs, origPN) - - case getOpt Permute options argv of - (os, rs, []) -> if Version `elem` os - then putStrLn $ pn ++ " v" ++ showVersion version ++ ", " ++ copyRight - else process pn os rs - (_, _, errs) -> do mapM_ putStrLn errs - putStr $ helpStr pn - where getChosenPrec os = case [p | p@FPType{} <- os] ++ [p | p@IType{} <- os] of - [p] -> Just p - _ -> Nothing - process pn os rs - | Help `elem` os - = do putStrLn $ pn ++ " v" ++ showVersion version ++ ", " ++ copyRight - usage pn - | Just v <- listToMaybe [s | ToIEEE s <- os], null rs, Just (FPType p) <- mbPrec - = putStrLn $ displayFP $ stringToFP p v - | all isDigit lcs && lc > 0, Just p <- mbPrec - = lane pn (VIM `elem` os) lc p rs - | True - = putStr $ helpStr pn - where mbPrec = getChosenPrec os - lcs = fromMaybe (show (guessLaneCount mbPrec (cleanUp (concat rs)))) (listToMaybe (reverse [n | Lanes n <- os])) - lc = read lcs - --- Try to guess the lane count if not given; if we can't we'll just return 1 -guessLaneCount :: Maybe Flag -> String -> Int -guessLaneCount mbp s - | not (allHex || allBin) = 1 - | isNothing mbp = 1 - | Just (FPType p) <- mbp = guessFP ls p - | Just (IType p) <- mbp = guessIP ls p - | True = 1 - where allHex = all isHexDigit s - allBin = all isBinDigit s - ls | allBin = length s - | True = 4 * length s - --- | Guess lane count for floating-point -guessFP :: Int -> Precision -> Int -guessFP 0 _ = 1 -guessFP l p - | r == 0 = q - | True = 1 - where sz = fpSz p - (q, r) = l `quotRem` sz - --- | Guess lane count for integer -guessIP :: Int -> IPrecision -> Int -guessIP 0 _ = 1 -guessIP l p - | r == 0 = q - | True = 1 - where (_, sz) = sgSz p - (q, r) = l `quotRem` sz - --- | Do the lane.. -lane :: String -> Bool -> Int -> Flag -> [String] -> IO () -lane pn _ 1 f rs = dispatch pn f rs -lane pn vim n f rs - | ls `mod` n /= 0 - = help $ "Input length " ++ show ls ++ " is not a multiple of lane count: " ++ show n - | True - = zipWithM_ cvt [n-1, n-2 .. 0] (cluster n s) - where s = cleanUp (concat rs) - ls = length s - help m = do putStrLn $ pn ++ ": " ++ m - usage pn - cvt i r = do putStrLn $ vimMarker vim ++ mkHeader (Just i) f - dispatch pn f [r] - -vimMarker :: Bool -> String -vimMarker False = "" -vimMarker True = "VIM " - --- | Display the ruler.. -mkHeader :: Maybe Int -> Flag -> String -mkHeader mbl f = take (fit len) divider - where divider - | Just l <- mbl = "== Lane: " ++ show l ++ ' ' : repeat '=' - | True = repeat '=' - fit n = 30 `max` (n + 19) - len = case f of - FPType p -> fpLen p - IType p -> ipLen p - _ -> 80 - get p xs = fromMaybe 78 (lookup p xs) - fpLen p = get p [ (HP, 8 + length hpInds3) - , (SP, length spInds3) - , (DP, length dpInds3) - ] - ipLen p = get p [ (W8, length bInds2), (I8, length bInds2) - , (W16, length wInds2), (I16, length wInds2) - , (W32, length dInds2), (I32, length dInds2) - , (W64, length qInds2), (I32, length qInds2) - ] - -dispatch :: String -> Flag -> [String] -> IO () -dispatch pn p@FPType{} rs = unpack pn p (unwords rs) -dispatch pn p@IType{} rs = unpack pn p (unwords rs) -dispatch pn _ _ = usage pn - -unpack :: String -> Flag -> String -> IO () -unpack pn precFlag orig = - case (precFlag, length s, allHex, allBin) of - (FPType HP, 4, True, _ ) -> putStrLn $ displayFP $ integerToFP HP hexVal - (FPType HP, 16, _ , True) -> putStrLn $ displayFP $ integerToFP HP binVal - (FPType SP, 8, True, _ ) -> putStrLn $ displayFP $ integerToFP SP hexVal - (FPType SP, 32, _ , True) -> putStrLn $ displayFP $ integerToFP SP binVal - (FPType DP, 16, True, _ ) -> putStrLn $ displayFP $ integerToFP DP hexVal - (FPType DP, 64, _ , True) -> putStrLn $ displayFP $ integerToFP DP binVal - (IType I8, 2, True, _ ) -> putStrLn $ displayWord I8 hexVal - (IType I8, 8, _ , True) -> putStrLn $ displayWord I8 binVal - (IType W8, 2, True, _ ) -> putStrLn $ displayWord W8 hexVal - (IType W8, 8, _ , True) -> putStrLn $ displayWord W8 binVal - (IType I16, 4, True, _ ) -> putStrLn $ displayWord I16 hexVal - (IType I16, 16, _ , True) -> putStrLn $ displayWord I16 binVal - (IType W16, 4, True, _ ) -> putStrLn $ displayWord W16 hexVal - (IType W16, 16, _ , True) -> putStrLn $ displayWord W16 binVal - (IType I32, 8, True, _ ) -> putStrLn $ displayWord I32 hexVal - (IType I32, 32, _ , True) -> putStrLn $ displayWord I32 binVal - (IType W32, 8, True, _ ) -> putStrLn $ displayWord W32 hexVal - (IType W32, 32, _ , True) -> putStrLn $ displayWord W32 binVal - (IType I64, 16, True, _ ) -> putStrLn $ displayWord I64 hexVal - (IType I64, 64, _ , True) -> putStrLn $ displayWord I64 binVal - (IType W64, 16, True, _ ) -> putStrLn $ displayWord W64 hexVal - (IType W64, 64, _ , True) -> putStrLn $ displayWord W64 binVal - _ -> if not (null orig) - then do case precFlag of - FPType HP -> putStrLn $ "ERROR: HP format requires 4 hex or 16 bin digits, received: " ++ what - FPType SP -> putStrLn $ "ERROR: SP format requires 8 hex or 32 bin digits, received: " ++ what - FPType DP -> putStrLn $ "ERROR: DP format requires 16 hex or 64 bin digits, received: " ++ what - IType I8 -> putStrLn $ "ERROR: Signed byte format requires 2 hex or 8 bin digits, received: " ++ what - IType I16 -> putStrLn $ "ERROR: Signed word format requires 4 hex or 16 bin digits, received: " ++ what - IType I32 -> putStrLn $ "ERROR: Signed double format requires 8 hex or 32 bin digits, received: " ++ what - IType I64 -> putStrLn $ "ERROR: Signed quad format requires 16 hex or 64 bin digits, received: " ++ what - IType W8 -> putStrLn $ "ERROR: Unsigned byte format requires 2 hex or 8 bin digits, received: " ++ what - IType W16 -> putStrLn $ "ERROR: Unsigned word format requires 4 hex or 16 bin digits, received: " ++ what - IType W32 -> putStrLn $ "ERROR: Unsigned double format requires 8 hex or 32 bin digits, received: " ++ what - IType W64 -> putStrLn $ "ERROR: Unsigned quad format requires 16 hex or 64 bin digits, received: " ++ what - _ -> putStrLn $ "ERROR: Illegal input received: " ++ what - putStrLn $ "\nUse '" ++ pn ++ " --help' for detailed help." - exitFailure - else usage pn - where s = cleanUp orig - ls = length s - allHex = all isHexDigit s - allBin = all isBinDigit s - hexVal = readB16 s - binVal = readB2 s - what | allHex && allBin = show ls ++ " bin/hex digit" ++ plural - | allHex = show ls ++ " hex digit" ++ plural - | allBin = show ls ++ " bin digit" ++ plural - | True = show ls ++ " bogus digit" ++ plural - where plural | ls == 1 = "" - | True = "s" diff --git a/Data/Numbers/CrackNum/Utils.hs b/Data/Numbers/CrackNum/Utils.hs deleted file mode 100644 --- a/Data/Numbers/CrackNum/Utils.hs +++ /dev/null @@ -1,176 +0,0 @@ ---------------------------------------------------------------------------- --- | --- Module : Data.Numbers.CrackNum.Utils --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Various utils and sundry ------------------------------------------------------------------------------ - -module Data.Numbers.CrackNum.Utils where - -import Data.Char (toLower) -import Data.List (genericIndex) -import Numeric - -import Data.Numbers.CrackNum.Data (Precision(..), IPrecision(..)) - --- | Returns True if all bits are False -all0 :: [Bool] -> Bool -all0 = all not - --- | Returns True if all bits are True -all1 :: [Bool] -> Bool -all1 = and - --- | Returns True if any bit is True -any1 :: [Bool] -> Bool -any1 = (True `elem`) - --- | Lay out a sequence of separated bools as a nicely formatted binary number -layOut :: [[Bool]] -> String -layOut = unwords . map b2s - --- | Binary to String conversion -b2s :: [Bool] -> String -b2s bs = concat [if b then "1" else "0" | b <- bs] - --- | Test whether a digit is binary -isBinDigit :: Char -> Bool -isBinDigit = (`elem` "01") - --- | Convert from binary char digit to value -binDigit :: Char -> Int -binDigit '0' = 0 -binDigit '1' = 1 -binDigit c = error $ "binDigit: recevied: " ++ show c - --- | Read a number in base 16 -readB16 :: String -> Integer -readB16 s = case readHex s of - [(v, "")] -> v - _ -> error $ "Invalid hex input: " ++ show s - --- | Read a number in base 2 -readB2 :: String -> Integer -readB2 s = case readInt 2 isBinDigit binDigit s of - [(v, "")] -> v - _ -> error $ "Invalid binary input: " ++ show s - --- | Display a binary number in groups of 4 -binDisp :: [Bool] -> String -binDisp = grpBy4 . b2s - --- | Group in chunks of 44 -grpBy4 :: String -> String -grpBy4 = grp False - where grp _ [] = [] - grp sep xs = let (f, r) = splitAt 4 xs in (if sep then " " else "") ++ f ++ grp True r - --- | Display a binary number in groups of 4, in hexadecimal format -hexDisp :: [Bool] -> String -hexDisp = grpBy4 . chunkHex - where chunkHex [] = [] - chunkHex xs = let (f, r) = splitAt 4 xs in (letters `genericIndex` (bv f :: Int)) : chunkHex r - letters = ['0' .. '9'] ++ ['A' .. 'F'] - --- | Cluster a list into given size chunks -cluster :: Int -> [a] -> [[a]] -cluster n is = go is - where s = length is `div` n - go [] = [] - go xs = let (f, r) = splitAt s xs in f : go r - --- | Big-endian num converter -bv :: Num a => [Bool] -> a -bv = foldr (\b a -> 2 * a + b2i b) 0 . reverse - where b2i b = if b then 1 else 0 - --- | Drop unnecessary parts from input. This enables the user to be able to give data more easily -cleanUp :: String -> String -cleanUp = map toLower . filter (not . ignorable) - where ignorable = (`elem` " _-") - ----------------------------------------------------------------------------------------------------- --- Rulers ----------------------------------------------------------------------------------------------------- - --- | Half-precision ruler, line 1 -hpInds1 :: String --- | Half-precision ruler, line 2 -hpInds2 :: String --- | Half-precision ruler, line 3 -hpInds3 :: String - -hpInds1 = "1 0" -hpInds2 = "5 43210 9876543210" -hpInds3 = "S -E5-- ---F10----" - --- | Single-precision ruler, line 1 -spInds1 :: String --- | Single-precision ruler, line 2 -spInds2 :: String --- | Single-precision ruler, line 3 -spInds3 :: String - -spInds1 = "3 2 1 0" -spInds2 = "1 09876543 21098765432109876543210" -spInds3 = "S ---E8--- ----------F23----------" - --- | Double-precision ruler, line 1 -dpInds1 :: String --- | Double-precision ruler, line 2 -dpInds2 :: String --- | Double-precision ruler, line 3 -dpInds3 :: String - -dpInds1 = "6 5 4 3 2 1 0" -dpInds2 = "3 21098765432 1098765432109876543210987654321098765432109876543210" -dpInds3 = "S ----E11---- ------------------------F52-------------------------" - --- | Byte-precision ruler, line 2 (note that no line 1 is needed!) -bInds2 :: String -bInds2 = "7654 3210" - --- | Word-precision ruler, line 1 -wInds1 :: String --- | Word-precision ruler, line 2 -wInds2 :: String - -wInds1 = "1 0" -wInds2 = "5432 1098 7654 3210" - --- | Double-word-precision ruler, line 1 -dInds1 :: String --- | Double-word-precision ruler, line 2 -dInds2 :: String - -dInds1 = "3 2 1 0" -dInds2 = "1098 7654 3210 9876 5432 1098 7654 3210" - --- | Quad-word-precision ruler, line 1 -qInds1 :: String --- | QuadDouble-word-precision ruler, line 2 -qInds2 :: String - -qInds1 = "6 5 4 3 2 1 0" -qInds2 = "3210 9876 5432 1098 7654 3210 9876 5432 1098 7654 3210 9876 5432 1098 7654 3210" - --- | Convert Floating point precision to corresponding number of bits -fpSz :: Precision -> Int -fpSz HP = 16 -fpSz SP = 32 -fpSz DP = 64 - --- | Convert Integer precision to whether it's signed and how many bits -sgSz :: IPrecision -> (Bool, Int) -sgSz W8 = (False, 8) -sgSz I8 = (True, 8) -sgSz W16 = (False, 16) -sgSz I16 = (True, 16) -sgSz W32 = (False, 32) -sgSz I32 = (True, 32) -sgSz W64 = (False, 64) -sgSz I64 = (True, 64) diff --git a/INSTALL b/INSTALL deleted file mode 100644 --- a/INSTALL +++ /dev/null @@ -1,3 +0,0 @@ -The crackNum library can be installed simply by issuing cabal install like this: - - cabal install crackNum diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ -crackIEEE754: Cracking various Floating/Integer values +crackNum: Cracking various Floating/Integer values -Copyright (c) 2015-2016, Levent Erkok (erkokl@gmail.com) +Copyright (c) 2015-2021, Levent Erkok (erkokl@gmail.com) All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,99 +1,99 @@ -## CrackNum: Decode/Encode IEE754 Numbers +## Decode/Encode Integers, Words, and IEE754 Floats [![Hackage version](http://img.shields.io/hackage/v/crackNum.svg?label=Hackage)](http://hackage.haskell.org/package/crackNum) [![Build Status](http://img.shields.io/travis/LeventErkok/crackNum.svg?label=Build)](http://travis-ci.org/LeventErkok/crackNum) -CrackNum now comes with vim bindings, see http://github.com/LeventErkok/crackNum/blob/master/crackNum.vim - -### Command line options: +``` +Usage: crackNum value OR binary/hex-pattern + -i N Signed integer of N-bits + -w N Unsigned integer of N-bits + -f fp Floating point format fp + -r rm Rounding mode to use. If not given, Nearest-ties-to-Even. + -h, -? --help print help, with examples + -v --version print version info - crackNum v2.3, (c) Levent Erkok. Released with a BSD3 license. - Usage: crackNum precision bit/hex-pattern - --hp 16 bit half precision - --sp 32 bit single precision - --dp 64 bit double precision - --sb 8 bit signed byte - --sw 16 bit signed word - --sd 32 bit signed double - --sq 64 bit signed quad - --ub 8 bit unsigned byte - --uw 16 bit unsigned word - --ud 32 bit unsigned double - --uq 64 bit unsigned quad - --toIEEE=n Convert from decimal to IEEE SP/DP formats. - -l n --lanes=n number of lanes - --vim output in vim friendly format - -h, -? --help print help, with examples - -v --version print version info - - Examples: - - crackNum --hp fc00 - crackNum --sp fc00 abcd - crackNum --dp fc00 abc1 2345 6789 - crackNum --sp 01111111110000000000000000000000 - crackNum -l2 --hp 01111111110000000000000000000000 - crackNum --sb 7f - crackNum --sp --toIEEE=-2.3e6 - crackNum --dp --toIEEE=max - crackNum --dp --toIEEE=ulp - - Notes: - - You can use hexadecimal or binary as input. - - You can use _,- or space as a digit to improve readability. - - You can give input for multiple lanes, we will guess the #of lanes for you. - Or, you can specify number of lanes with the -l option. - - For "toIEEE" option (case doesn't matter): - - You can enter a number in decimal notation (like 2.3) - - You can enter a number in hexadecimal notation (like 0x1.abcp+3) - - OR, enter one of the following: - * infinity, -infinity: Positive/Negative infinities - * nan, snan, qnan: Not-A-Number; signaling/quiet - * 0, -0: Both kinds of zeros - * max : The maximum finite positive value - * -max: The minimum finite negative value - * min : The minimum normal positive value - * -min: The maximum normal negative value - * epsilon: The smallest possible value x s.t. 1+x /= 1. - * ulp: The minimum subnormal value +Examples: + Encoding: + crackNum -i4 -- -2 -- encode as 4-bit signed integer + crackNum -w4 2 -- encode as 4-bit unsigned integer + crackNum -f3+4 2.5 -- encode as float with 3 bits exponent, 4 bits significand + crackNum -f3+4 2.5 -rRTZ -- encode as above, but use RTZ rounding mode. + crackNum -fbp 2.5 -- encode as a brain-precision float + crackNum -fdp 2.5 -- encode as a double-precision float -### Example: Decoding single-precision numbers on two lanes + Decoding: + crackNum -i4 0b0110 -- decode as 4-bit signed integer, from binary + crackNum -w4 0xE -- decode as 4-bit unsigned integer, from hex + crackNum -f3+4 0b0111001 -- decode as float with 3 bits exponent, 4 bits significand + crackNum -fbp 0x000F -- decode as a brain-precision float + crackNum -fdp 0x8000000000000000 -- decode as a double-precision float - $ crackNum --sp fc00 abc1 7F80 0001 - == Lane: 1 ========================================== - 3 2 1 0 - 1 09876543 21098765432109876543210 - S ---E8--- ----------F23---------- - Binary: 1 11111000 00000001010101111000001 - Hex: FC00 ABC1 - Precision: SP - Sign: Negative - Exponent: 121 (Stored: 248, Bias: 127) - Hex-float: -0x1.015782p121 - Value: -2.6723903e36 (NORMAL) - == Lane: 0 ========================================== - 3 2 1 0 - 1 09876543 21098765432109876543210 - S ---E8--- ----------F23---------- - Binary: 0 11111111 00000000000000000000001 - Hex: 7F80 0001 - Precision: SP - Sign: Positive - Exponent: 128 (Stored: 255, Bias: 127) - Hex-float: NaN (Signaling) - Value: NaN (Signaling) - Note: Representation for NaN's is not unique. + Notes: + - For encoding: + - Use -- to separate your argument if it's a negative number. + - For floats: You can pass in NaN, Inf, -0, -Inf etc as the argument, along with a decimal float. + - For decoding: + - Use hexadecimal (0x) or binary (0b) as input. Input must have one of these prefixes. + - You can use _,- or space as a digit to improve readability for the pattern to be decoded +``` -### Example: Encoding a float as a IEEE754 single-precision bit-pattern +VIM users: You can use the https://github.com/LeventErkok/crackNum/blob/master/crackNum.vim file to +use CrackNum directly from VIM. Simply locate your cursor on the text to crack, and use the +command `:CrackNum options`. - $ crackNum --sp --toIEEE=-2.3e6 +### Example: Encode a decimal numer as a single-precision IEEE754 number +``` +$ crackNum -fsp -- -2.3e6 +Satisfiable. Model: + ENCODED = -2300000.0 :: Float 3 2 1 0 1 09876543 21098765432109876543210 - S ---E8--- ----------F23---------- - Binary: 1 10010100 00011000110000110000000 - Hex: CA0C 6180 - Precision: SP + S ---E8--- ----------S23---------- + Binary layout: 1 10010100 00011000110000110000000 + Hex layout: CA0C 6180 + Precision: Single Sign: Negative Exponent: 21 (Stored: 148, Bias: 127) - Hex-float: -0x1.18c3p21 - Value: -2300000.0 (NORMAL) + Classification: FP_NORMAL + Binary: -0b1.0001100011000011p+21 + Octal: -0o1.061414p+21 + Decimal: -2300000.0 + Hex: -0x2.3186p+20 + Rounding mode: RNE: Round nearest ties to even. +``` + +### Example: Decode a double-precision IEEE754 number from memory-layout +``` +$ crackNum -fdp 0xfc00 abc1 7F80 0001 +Satisfiable. Model: + DECODED = -2.0307920360962302e289 :: Double + 6 5 4 3 2 1 0 + 3 21098765432 1098765432109876543210987654321098765432109876543210 + S ----E11---- ------------------------S52------------------------- + Binary layout: 1 11111000000 0000101010111100000101111111100000000000000000000001 + Hex layout: FC00 ABC1 7F80 0001 + Precision: Double + Sign: Negative + Exponent: 961 (Stored: 1984, Bias: 1023) + Classification: FP_NORMAL + Binary: -0b1.0000101010111100000101111111100000000000000000000001p+961 + Octal: -0o2.05274057740000001p+960 + Decimal: -2.0307920360962302e289 + Hex: -0x2.15782FF000002p+960 +``` + +### Example: Encode an integer as a 7-bit signed word +``` +$ crackNum -i7 12 +Satisfiable. Model: + ENCODED = 12 :: IntN 7 + 654 3210 + Binary layout: 000 1100 + Hex layout: 0C + Type: Signed 7-bit 2's complement integer + Sign: Positive + Binary: 0b1100 + Octal: 0o14 + Decimal: 12 + Hex: 0xc +``` diff --git a/crackNum.cabal b/crackNum.cabal --- a/crackNum.cabal +++ b/crackNum.cabal @@ -1,40 +1,32 @@ -Name: crackNum -Version: 2.4 -Synopsis: Crack various integer, floating-point data formats -Description: Crack HP, SP and DP floats and 8, 16, 32, 64 bit words and integers. +Cabal-version : 2.2 +Name : crackNum +Version : 3.0 +Synopsis : Crack various integer and floating-point data formats +Description : Crack IEEE-754 float formats and arbitrary sized words and integers, showing the layout. . For details, please see: -License: BSD3 -License-file: LICENSE -Author: Levent Erkok -Homepage: http://github.com/LeventErkok/CrackNum -Maintainer: erkokl@gmail.com -Copyright: Levent Erkok -Category: Tools -Build-type: Simple -Cabal-version: 1.14 -Extra-Source-Files: INSTALL, README.md, COPYRIGHT, CHANGES.md, crackNum.vim +License : BSD-3-Clause +License-file : LICENSE +Author : Levent Erkok +Homepage : http://github.com/LeventErkok/CrackNum +Maintainer : erkokl@gmail.com +Copyright : Levent Erkok +Category : Tools +Build-type : Simple +Extra-Source-Files : README.md, COPYRIGHT, CHANGES.md -Tested-With : GHC==8.10.2 +Tested-With : GHC==9.0.1 source-repository head type: git location: git://github.com/LeventErkok/crackNum.git Executable crackNum - main-is : Data/Numbers/CrackNum/Main.hs - ghc-options : -Wall + main-is : CrackNum/Main.hs default-language: Haskell2010 - build-depends: base >= 4.11 && < 5, array, FloatingHex - other-modules: Data.Numbers.CrackNum - , Data.Numbers.CrackNum.Utils - , Data.Numbers.CrackNum.Data - , Paths_crackNum - -Library - ghc-options : -Wall - default-language: Haskell2010 - Build-Depends : base >= 4 && < 5, array >= 0.4.0.1, FloatingHex >= 0.4 - Exposed-modules : Data.Numbers.CrackNum - other-modules : Data.Numbers.CrackNum.Utils - , Data.Numbers.CrackNum.Data + hs-source-dirs : src + ghc-options : -Wall -Wunused-packages + build-depends : base >= 4.11 && < 5, libBF, sbv >= 8.14 + , tasty, tasty-golden, filepath, directory, process + other-modules : Paths_crackNum, CrackNum.TestSuite + autogen-modules : Paths_crackNum diff --git a/crackNum.vim b/crackNum.vim deleted file mode 100644 --- a/crackNum.vim +++ /dev/null @@ -1,80 +0,0 @@ -"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" -" VI interface to crackNum -" -" Copyright : (c) Levent Erkok -" License : BSD3 -" Maintainer : erkokl@gmail.com -" -" INSTALLATION: Put this file in a convenient location (typically your .vim directory), -" and put "so crackNum.vim" in your .vimrc file. (With the appropriate path.) -" -" Once you restart vim, locate your cursor over a stream of binary/hex digits, and -" enter the command :CrackNum to see further options. -" -" See https://github.com/LeventErkok/CrackNum for details. - -let g:crackNumPrecisions = ["hp","sp","dp","sb","sw","sd","sq","ub","uw","ud","uq"] -function! CrackNumComplete(A, L, P) - if empty(a:A) - return g:crackNumPrecisions - else - let out = filter(copy(g:crackNumPrecisions), 'v:val =~ "^' . a:A . '.*"') - if empty(out) - return g:crackNumPrecisions - else - return out - endif -endfunction -function! CrackNum(...) - redraw - let curWord = expand("") - if empty(curWord) - echoerr "Place the cursor on a bin/hex number to crack!" - return - endif - if empty(a:000) - echo "Cracking \"" . curWord . "\".. Use TAB to see precisions supported." - call inputsave() - let prec = input("Precision> ", "", "customlist,CrackNumComplete") - call inputrestore() - let args = [prec] + copy(a:000) - else - echo "Cracking \"" . curWord . "\".." - let prec = a:1 - let args = copy(a:000) - endif - - if index(g:crackNumPrecisions, prec) < 0 - echoerr "Unknown precision: \"" . prec . "\"" . ". Must be one of: " . join(g:crackNumPrecisions, ' ') - return - endif - - let l:grepargs = join(['--vim'] + copy(args) + ['--bv', curWord], ' ') - let grepprg_bak=&grepprg - let grepformat_bak=&grepformat - try - let &grepprg="crackNum" - let &grepformat="VIM %m" - silent execute "grep" . " " . l:grepargs - finally - let &grepprg=grepprg_bak - let &grepformat=grepformat_bak - endtry - - botright copen - - redraw! -endfunction -command! -nargs=* -complete=customlist,CrackNumComplete CrackNum call CrackNum() -map @nhp :silent call CrackNum('hp') -map @nsp :silent call CrackNum('sp') -map @ndp :silent call CrackNum('dp') -map @nsb :silent call CrackNum('sb') -map @nsw :silent call CrackNum('sw') -map @nsd :silent call CrackNum('sd') -map @nsq :silent call CrackNum('sq') -map @nub :silent call CrackNum('ub') -map @nuw :silent call CrackNum('uw') -map @nud :silent call CrackNum('ud') -map @nuq :silent call CrackNum('uq') -" end crackNum interface diff --git a/src/CrackNum/Main.hs b/src/CrackNum/Main.hs new file mode 100644 --- /dev/null +++ b/src/CrackNum/Main.hs @@ -0,0 +1,382 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Main entry point for the crackNum executable +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main(main) where + +import System.Environment (getArgs, getProgName, withArgs) +import Data.Char (isDigit, isSpace, toLower) +import Data.List (isPrefixOf, isSuffixOf, unfoldr) + +import System.Console.GetOpt (ArgOrder(Permute), getOpt, ArgDescr(..), OptDescr(..), usageInfo) +import System.Exit (exitFailure) +import Text.Read (readMaybe) + +import System.IO (hPutStr, stderr) + +import LibBF +import Numeric + +import Data.SBV hiding (crack) +import Data.SBV.Float hiding (FP) +import Data.SBV.Dynamic hiding (satWith) +import Data.SBV.Internals hiding (free) + +import Data.Version (showVersion) +import Paths_crackNum (version) + +import CrackNum.TestSuite + +-- | Copyright info +copyRight :: String +copyRight = "(c) Levent Erkok. Released with a BSD3 license." + +-- | Various precisions we support +data FP = SP -- Single precision + | DP -- Double precision + | FP Int Int -- Arbitrary precision with given exponent and significand sizes + deriving (Show, Eq) + +-- | How many bits does this float occupy +fpSize :: FP -> Int +fpSize SP = 32 +fpSize DP = 64 +fpSize (FP i j) = i+j + +-- | Rounding modes we support +data RM = RNE -- ^ Round nearest ties to even + | RNA -- ^ Round nearest ties to away + | RTP -- ^ Round towards positive infinity + | RTN -- ^ Round towards negative infinity + | RTZ -- ^ Round towards zero + deriving (Eq, Enum, Bounded) + +-- | Show instance for RM, for descriptive purposes +instance Show RM where + show RNE = "RNE: Round nearest ties to even." + show RNA = "RNA: Round nearest ties to away." + show RTP = "RTP: Round towards positive infinity." + show RTN = "RTN: Round towards negative infinity." + show RTZ = "RTZ: Round towards zero." + +-- Covert to LibBF rounding mode +toLibBFRM :: RM -> RoundMode +toLibBFRM RNE = NearEven +toLibBFRM RNA = NearAway +toLibBFRM RTP = ToPosInf +toLibBFRM RTN = ToNegInf +toLibBFRM RTZ = ToZero + +-- | Options accepted by the executable +data Flag = Signed Int -- ^ Crack as a signed word with the given number of bits + | Unsigned Int -- ^ Crack as an unsigned word with the given number of bits + | Floating FP -- ^ Crack as the corresponding floating-point type + | RMode RM -- ^ Rounding mode to use + | BadFlag [String] -- ^ Bad input + | Version -- ^ Version + | Help -- ^ Show help + deriving (Show, Eq) + +-- | Is this a rounding flag? +isRMode :: Flag -> Bool +isRMode RMode{} = True +isRMode _ = False + +-- | Given an integer flag value, turn it into a flag +getSize :: String -> (Int -> Flag) -> String -> Flag +getSize flg f n = case readMaybe n of + Just i | i > 0 -> f i + | True -> BadFlag ["Option " ++ show flg ++ " requires an integer >= 1. Received: " ++ show n] + Nothing -> BadFlag ["Option " ++ show flg ++ " requires an integer argument. Received: " ++ show n] + +#include "MachDeps.h" + +#define FP_MIN_EB 2 +#define FP_MIN_SB 2 +#if WORD_SIZE_IN_BITS == 64 +#define FP_MAX_EB 61 +#define FP_MAX_SB 4611686018427387902 +#else +#define FP_MAX_EB 29 +#define FP_MAX_SB 1073741822 +#endif + +-- | Given a float flag value, turn it into a flag +getFP :: String -> Flag +getFP "hp" = Floating $ FP 5 11 +getFP "bp" = Floating $ FP 8 8 +getFP "sp" = Floating SP +getFP "dp" = Floating DP +getFP "qp" = Floating $ FP 15 113 +getFP ab = case span isDigit ab of + (eb@(_:_), '+':r) -> case span isDigit r of + (sp@(_:_), "") -> mkEBSB (read eb) (read sp) + _ -> bad + _ -> bad + where bad = BadFlag [ "Option " ++ show "-f" ++ " requires one of:" + , "" + , " hp: Half float ( 5 + 11)" + , " bp: Brain float ( 8 + 8)" + , " sp: Single precision ( 8 + 24)" + , " dp: Single precision (11 + 53)" + , " qp: Quad precision (15 + 113)" + , " a+b: Arbitrary precision ( a + b)" + , "" + , "where first number is the number of bits in the exponent" + , "and the second number is the number of bits in the significand, including the implicit bit." + ] + mkEBSB :: Int -> Int -> Flag + mkEBSB eb sb + | eb >= FP_MIN_EB && eb <= FP_MAX_EB + && sb >= FP_MIN_SB && sb <= FP_MAX_SB + = Floating $ FP eb sb + | True + = BadFlag [ "Invalid floating-point precision." + , "" + , " Exponent size must be between " ++ show (FP_MIN_EB :: Int) ++ " to " ++ show (FP_MAX_EB :: Int) + , " Significant size must be between " ++ show (FP_MIN_SB :: Int) ++ " to " ++ show (FP_MAX_SB :: Int) + , "" + , "Received: " ++ show eb ++ " " ++ show sb + ] + +getRM :: String -> Flag +getRM "rne" = RMode RNE +getRM "rna" = RMode RNA +getRM "rtp" = RMode RTP +getRM "rtn" = RMode RTN +getRM "rtz" = RMode RTZ +getRM m = BadFlag $ [ "Invalid rounding mode." + , "" + , " Must be one of:" + ] + ++ [ " " ++ show r | r <- [minBound .. maxBound::RM]] + ++ [ "" + , "Received: " ++ m + ] + +-- | Options we accept +pgmOptions :: [OptDescr Flag] +pgmOptions = [ + Option "i" [] (ReqArg (getSize "-i" Signed) "N" ) "Signed integer of N-bits" + , Option "w" [] (ReqArg (getSize "-w" Unsigned) "N" ) "Unsigned integer of N-bits" + , Option "f" [] (ReqArg getFP "fp") "Floating point format fp" + , Option "r" [] (ReqArg (getRM . map toLower) "rm") "Rounding mode to use. If not given, Nearest-ties-to-Even." + , Option "h?" ["help"] (NoArg Help) "print help, with examples" + , Option "v" ["version"] (NoArg Version) "print version info" + ] + +-- | Help info +helpStr :: String -> String +helpStr pn = usageInfo ("Usage: " ++ pn ++ " value OR binary/hex-pattern") pgmOptions + +-- | Print usage info and examples. +usage :: String -> IO () +usage pn = putStr $ unlines [ helpStr pn + , "Examples:" + , " Encoding:" + , " " ++ pn ++ " -i4 -- -2 -- encode as 4-bit signed integer" + , " " ++ pn ++ " -w4 2 -- encode as 4-bit unsigned integer" + , " " ++ pn ++ " -f3+4 2.5 -- encode as float with 3 bits exponent, 4 bits significand" + , " " ++ pn ++ " -f3+4 2.5 -rRTZ -- encode as above, but use RTZ rounding mode." + , " " ++ pn ++ " -fbp 2.5 -- encode as a brain-precision float" + , " " ++ pn ++ " -fdp 2.5 -- encode as a double-precision float" + , "" + , " Decoding:" + , " " ++ pn ++ " -i4 0b0110 -- decode as 4-bit signed integer, from binary" + , " " ++ pn ++ " -w4 0xE -- decode as 4-bit unsigned integer, from hex" + , " " ++ pn ++ " -f3+4 0b0111001 -- decode as float with 3 bits exponent, 4 bits significand" + , " " ++ pn ++ " -fbp 0x000F -- decode as a brain-precision float" + , " " ++ pn ++ " -fdp 0x8000000000000000 -- decode as a double-precision float" + , "" + , " Notes:" + , " - For encoding:" + , " - Use -- to separate your argument if it's a negative number." + , " - For floats: You can pass in NaN, Inf, -0, -Inf etc as the argument, along with a decimal float." + , " - For decoding:" + , " - Use hexadecimal (0x) or binary (0b) as input. Input must have one of these prefixes." + , " - You can use _,- or space as a digit to improve readability for the pattern to be decoded" + ] + +-- | Terminate early +die :: [String] -> IO a +die xs = do hPutStr stderr $ unlines $ "ERROR:" : map (" " ++) xs + exitFailure + +-- | main entry point to crackNum +crack :: String -> [String] -> IO () +crack pn argv = case getOpt Permute pgmOptions argv of + (_, _, errs@(_:_)) -> die $ errs ++ lines (helpStr pn) + (os, rs, []) + | Version `elem` os -> putStrLn $ pn ++ " v" ++ showVersion version ++ ", " ++ copyRight + | Help `elem` os -> usage pn + | True -> do let rm = case reverse [r | RMode r <- os] of + (r:_) -> r + _ -> RNE + + arg = dropWhile isSpace $ unwords rs + + case ([b | BadFlag b <- os], filter (not . isRMode) os) of + (e:_, _) -> die e + (_, [Signed n]) -> process (SInt n) rm arg + (_, [Unsigned n]) -> process (SWord n) rm arg + (_, [Floating s]) -> process (SFloat s) rm arg + _ -> usage pn + +-- | Kinds of numbers we understand +data NKind = SInt Int -- ^ Signed integer of n bits + | SWord Int -- ^ Unsigned integer of n bits + | SFloat FP -- ^ Floating point with precision + +-- | main entry point to crackNum +main :: IO () +main = do argv <- getArgs + pn <- getProgName + + let rt = "--runTests" + + if rt `elem` argv + then withArgs (filter (`notElem` [rt, "--"]) argv) runTests + else crack pn argv + +-- | Perform the encoding/decoding +process :: NKind -> RM -> String -> IO () +process num rm inp = case num of + SInt n -> print =<< (if decode then di else ei) True n + SWord n -> print =<< (if decode then di else ei) False n + SFloat s -> (if decode then df else ef) s + where decode = any (`isPrefixOf` inp) ["0x", "0b"] + + bitString n = do let isSkippable c = c `elem` "_-" || isSpace c + + (isHex, stream) <- case map toLower (filter (not . isSkippable) inp) of + '0':'x':rest -> pure (True, rest) + '0':'b':rest -> pure (False, rest) + _ -> die [ "Input string must start with 0b or 0x for decoding." + , "Received prefix: " ++ show (take 2 inp) + ] + + let cvtBin '1' = pure [True] + cvtBin '0' = pure [False] + cvtBin c = die ["Input has a non-binary digit: " ++ show c] + + cvtHex c = case readHex [c] of + [(v, "")] -> pure $ pad + $ map (== (1::Int)) + $ reverse + $ unfoldr (\x -> if x == 0 then Nothing else Just (x `rem` 2, x `div` 2)) v + _ -> die ["Input has a non-hexadecimal digit: " ++ show c] + where pad p = replicate (4 - length p) False ++ p + + cvt i | isHex = concat <$> mapM cvtHex i + | True = concat <$> mapM cvtBin i + + encoded <- cvt stream + + let bits 1 = "one bit" + bits b = show b ++ " bits" + + case length encoded `compare` n of + EQ -> pure encoded + LT -> die ["Input needs to be " ++ show n ++ " bits wide, it's too short by " ++ bits (n - length encoded)] + GT -> die ["Input needs to be " ++ show n ++ " bits wide, it's too long by " ++ bits (length encoded - n)] + + di :: Bool -> Int -> IO SatResult + di sgn n = do bs <- bitString n + satWith z3{crackNum=True} $ p bs + where p :: [Bool] -> Goal + p bs = do x <- (if sgn then sIntN else sWordN) n "DECODED" + mapM_ constrain $ zipWith (.==) (map SBV (svBlastBE x)) (map literal bs) + + ei :: Bool -> Int -> IO SatResult + ei sgn n = case reads inp of + [(v :: Integer, "")] -> satWith z3{crackNum=True} $ p v + _ -> die ["Expected an integer value to decode, received: " ++ show inp] + where p :: Integer -> Predicate + p iv = do let k = KBounded sgn n + v = SBV $ SVal k $ Left $ mkConstCV k iv + x <- (if sgn then sIntN else sWordN) n "ENCODED" + pure $ SBV x .== v + + df :: FP -> IO () + df fp = do bs <- map literal <$> bitString (fpSize fp) + case fp of + SP -> print =<< satWith z3{crackNum=True} (dFloat bs) + DP -> print =<< satWith z3{crackNum=True} (dDouble bs) + FP i j -> print =<< satWith z3{crackNum=True} (dFP i j bs) + + dFloat :: [SBool] -> Goal + dFloat bs = do x <- sFloat "DECODED" + let (s, e, m) = blastSFloat x + mapM_ constrain $ zipWith (.==) (s : e ++ m) bs + + dDouble :: [SBool] -> Goal + dDouble bs = do x <- sDouble "DECODED" + let (s, e, m) = blastSDouble x + mapM_ constrain $ zipWith (.==) (s : e ++ m) bs + + dFP :: Int -> Int -> [SBool] -> Goal + dFP i j bs = do sx <- svNewVar (KFP i j) "DECODED" + let bits = svBlastBE sx + mapM_ constrain $ zipWith (.==) (map SBV bits) bs + + convert :: Int -> Int -> (BigFloat, Maybe String) + convert i j = case s of + Ok -> (v, Nothing) + _ -> (v, Just (trim (show s))) + where bfOpts = allowSubnormal <> rnd (toLibBFRM rm) <> expBits (fromIntegral i) <> precBits (fromIntegral j) + (v, s) = bfFromString 10 bfOpts inp + trim xs | "[" `isPrefixOf` xs && "]" `isSuffixOf` xs = init (tail xs) + | True = xs + + note :: Maybe String -> IO () + note mbs = do putStrLn $ " Rounding mode: " ++ show rm + case mbs of + Nothing -> pure () + Just s -> putStrLn $ " Note: Conversion from " ++ show inp ++ " was not faithful. Status: " ++ s ++ "." + + ef :: FP -> IO () + ef SP = case reads (fixup inp) of + [(v :: Float, "")] -> do print =<< satWith z3{crackNum=True} (p v) + note $ snd $ convert 8 24 + _ -> ef (FP 8 24) + where p :: Float -> Predicate + p f = do x <- sFloat "ENCODED" + pure $ x .=== literal f + + ef DP = case reads (fixup inp) of + [(v :: Double, "")] -> do print =<< satWith z3{crackNum=True} (p v) + note $ snd $ convert 11 53 + _ -> ef (FP 11 53) + where p :: Double -> Predicate + p d = do x <- sDouble"ENCODED" + pure $ x .=== literal d + + ef (FP i j) = do let (v, mbS) = convert i j + print =<< satWith z3{crackNum=True} (p v) + note mbS + where p :: BigFloat -> Predicate + p bf = do let k = KFP i j + sx <- svNewVar k "ENCODED" + pure $ SBV $ sx `svStrongEqual` SVal k (Left (CV k (CFP (fpFromBigFloat i j bf)))) + +-- | Convert certain strings to more understandable format by read +fixup :: String -> String +fixup inp + | linp `elem` ["inf", "infinity"] = "Infinity" + | linp `elem` ["-inf", "-infinity"] = "-Infinity" + | linp == "nan" = "NaN" + | linp == "-nan" = "-NaN" + | True = inp + where linp = map toLower inp diff --git a/src/CrackNum/TestSuite.hs b/src/CrackNum/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/CrackNum/TestSuite.hs @@ -0,0 +1,71 @@ +--------------------------------------------------------------------------- +-- | +-- Module : TestSuite +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Test-suite for crackNum +----------------------------------------------------------------------------- + +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wall -Werror #-} + +module CrackNum.TestSuite(runTests) where + +import Control.Exception as C + +import Test.Tasty +import Test.Tasty.Golden (goldenVsFileDiff) +import System.FilePath + +import System.Directory (removeFile) +import System.Process (readProcessWithExitCode) + +import Data.List (intercalate) + +gold :: TestName -> [String] -> TestTree +gold n args = goldenVsFileDiff n diff gf gfTmp (rm gfTmp >> run) + where gf = "Golds" n <.> "gold" + gfTmp = gf ++ "_temp" + + rm f = removeFile f `C.catch` (\(_ :: C.SomeException) -> return ()) + + as = unwords args + run = do (ec, so, se) <- readProcessWithExitCode "crackNum" args "" + writeFile gfTmp $ intercalate "\n" $ [ "Arguments: " ++ as + , "Exit code: " ++ show ec + , so + ] + ++ concat [["STDERR:", se] | not (null se)] + + diff ref new = ["diff", "-w", "-u", ref, new] + +-- | run the test suite +runTests :: IO () +runTests = defaultMain tests + +tests :: TestTree +tests = testGroup "CrackNum" [ + testGroup "Encode" [ + gold "encode0" ["-i4", "--", "-2"] + , gold "encode1" ["-w4", "2"] + , gold "encode2" ["-f3+4", "2.5"] + , gold "encode3" ["-f3+4", "2.5", "-rRTZ"] + , gold "encode4" ["-fbp", "2.5"] + , gold "encode5" ["-fdp", "2.5"] + ] + , testGroup "Decode" [ + gold "decode0" ["-i4", "0b0110"] + , gold "decode1" ["-w4", "0xE"] + , gold "decode2" ["-f3+4", "0b0111001"] + , gold "decode3" ["-fbp", "0x000F"] + , gold "decode4" ["-fdp", "0x8000000000000000"] + ] + , testGroup "Bad" [ + gold "badInvocation0" ["-f3+4", "0b01"] + , gold "badInvocation1" ["-f3+4", "0xFFFF"] + ] + ]