const-math-ghc-plugin 0.1.0.0 → 0.2.0.0
raw patch · 36 files changed
+1220/−21 lines, 36 filesdep +directorydep +process
Dependencies added: directory, process
Files
- ConstMath/Pass.hs +55/−17
- ConstMath/Types.hs +1/−1
- const-math-ghc-plugin.cabal +15/−3
- tests/1603.hs +7/−0
- tests/3676.hs +32/−0
- tests/4381.hs +5/−0
- tests/4383.hs +1/−0
- tests/Make.hs +11/−0
- tests/Makefile +52/−0
- tests/Sqrt.hs +3/−0
- tests/arith001.hs +28/−0
- tests/arith002.hs +52/−0
- tests/arith003.hs +84/−0
- tests/arith004.hs +86/−0
- tests/arith005.hs +60/−0
- tests/arith006.hs +4/−0
- tests/arith007.hs +23/−0
- tests/arith008.hs +24/−0
- tests/arith009.hs +6/−0
- tests/arith010.hs +11/−0
- tests/arith011.hs +174/−0
- tests/arith012.hs +90/−0
- tests/arith013.hs +13/−0
- tests/arith014.hs +11/−0
- tests/arith015.hs +5/−0
- tests/arith016.hs +33/−0
- tests/arith017.hs +10/−0
- tests/arith018.hs +12/−0
- tests/arith019.hs +10/−0
- tests/expfloat.hs +7/−0
- tests/numrun009.hs +17/−0
- tests/numrun010.hs +13/−0
- tests/numrun011.hs +2/−0
- tests/numrun012.hs +35/−0
- tests/numrun013.hs +17/−0
- tests/numrun014.hs +211/−0
ConstMath/Pass.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}@@ -24,20 +25,21 @@ subBind :: Opts -> String -> CoreBind -> CoreM CoreBind subBind opts tab (NonRec b rhs) = do- traceMsg opts $ tab ++ "Non-recursive binding named " ++ showSDoc (ppr b)+ tracePretty opts (tab ++ "Non-recursive binding named ") b rhs' <- subExpr opts tab rhs return (NonRec b rhs') subBind opts _tab bndr@(Rec pairs) = do _ <- mapM (uncurry $ printRecBind opts) pairs return bndr +printRecBind :: Opts -> CoreBndr -> Expr CoreBndr -> CoreM () printRecBind opts b _e = do- traceMsg opts $ "Recursive binding " ++ showSDoc (ppr b)+ tracePretty opts "Recursive binding " b subExpr :: Opts -> String -> CoreExpr -> CoreM CoreExpr subExpr opts tab expr@(Type t) = do- traceMsg opts $ tab ++ "Type " ++ showSDoc (ppr t)+ tracePretty opts (tab ++ "Type ") t return expr subExpr opts tab expr@(Coercion _co) = do@@ -45,15 +47,15 @@ return expr subExpr opts tab expr@(Lit lit) = do- traceMsg opts $ tab ++ "Lit " ++ showSDoc (ppr lit)+ tracePretty opts (tab ++ "Lit ") lit return expr subExpr opts tab expr@(Var v) = do- traceMsg opts $ tab ++ "Var " ++ showSDoc (ppr v)+ tracePretty opts (tab ++ "Var ") v return expr subExpr opts tab (App f a) = do- traceMsg opts $ tab ++ "App " ++ showSDoc (ppr f)+ tracePretty opts (tab ++ "App ") f f' <- subExpr opts (tab ++ "< ") f a' <- subExpr opts (tab ++ "> ") a collapse opts (App f' a')@@ -99,25 +101,36 @@ -> CoreExpr -> CoreM CoreExpr mkUnaryCollapseIEEE fnE opts expr@(App f1 (App f2 (Lit lit)))- | isDHash f2, MachDouble d <- lit = evalUnaryIEEE d mkDoubleLitDouble- | isFHash f2, MachFloat d <- lit = evalUnaryIEEE d mkFloatLitFloat+ | isDHash f2, MachDouble d <- lit = e d mkDoubleLitDouble+ | isFHash f2, MachFloat d <- lit = e d mkFloatLitFloat where- evalUnaryIEEE d mkLit = do- let sub = fnE (fromRational d)- maybe (return expr)- (return . App f2 . mkLit)- =<< maybeIEEE opts (fromJust $ funcName f1) sub+ e d = evalUnaryIEEE opts fnE f1 f2 d expr mkUnaryCollapseIEEE _ _ expr = return expr +evalUnaryIEEE :: (Fractional a, RealFloat b)+ => Opts+ -> (a -> b)+ -> CoreExpr+ -> CoreExpr+ -> Rational+ -> CoreExpr+ -> (b -> Arg Var)+ -> CoreM (CoreExpr)+evalUnaryIEEE opts fnE f1 f2 d expr mkLit = do+ let sub = fnE (fromRational d)+ maybe (return expr)+ (return . App f2 . mkLit)+ =<< maybeIEEE opts (fromJust $ funcName f1) sub+ mkUnaryCollapseNum :: (forall a . Num a => (a -> a)) -> Opts -> CoreExpr -> CoreM CoreExpr-mkUnaryCollapseNum fnE _opts (App _f1 (App f2 (Lit lit)))+mkUnaryCollapseNum fnE opts expr@(App f1 (App f2 (Lit lit))) | isDHash f2, MachDouble d <- lit =- evalUnaryNum fromRational d mkDoubleLitDouble+ evalUnaryIEEE opts fnE f1 f2 d expr mkDoubleLitDouble | isFHash f2, MachFloat d <- lit =- evalUnaryNum fromRational d mkFloatLitFloat+ evalUnaryIEEE opts fnE f1 f2 d expr mkFloatLitFloat | isIHash f2, MachInt d <- lit = evalUnaryNum fromIntegral d mkIntLitInt | isWHash f2, MachWord d <- lit =@@ -198,7 +211,7 @@ binarySub nm fn = CMSub nm (mkBinaryCollapse fn) funcName :: CoreExpr -> Maybe String-funcName = listToMaybe . words . showSDoc . ppr+funcName = listToMaybe . words . prettyExpr isFHash :: CoreExpr -> Bool isFHash = maybe False ((==) "GHC.Types.F#") . funcName@@ -258,3 +271,28 @@ traceMsg opts s | traced opts = putMsgS s | otherwise = return ()++tracePretty :: Outputable a => Opts -> String -> a -> CoreM ()+tracePretty opts s x = do+ p <- pretty x+ traceMsg opts (s ++ p)++----------------------------------------------------------------------++pretty :: Outputable a => a -> CoreM String+#if __GLASGOW_HASKELL__ >= 706+pretty x = do+ dflags <- getDynFlags+ return $ showSDoc dflags (ppr x)+#else+pretty = return . showSDoc . ppr+#endif++prettyExpr :: CoreExpr -> String+prettyExpr (Var var) = m ++ (unpackFS . occNameFS . nameOccName $ n)+ where+ n = varName var+ m | isExternalName n = (moduleNameString . moduleName . nameModule $ n) ++ "."+ | otherwise = ""+prettyExpr (App f _) = prettyExpr f+prettyExpr _ = "<unknown>"
ConstMath/Types.hs view
@@ -18,7 +18,7 @@ deriving (Eq, Show) setVerbosity :: Verbosity -> Opts -> Opts-setVerbosity cmVerbosity opts = Opts{cmVerbosity}+setVerbosity cmVerbosity opts = opts{cmVerbosity} defaultOpts :: Opts defaultOpts = Opts None
const-math-ghc-plugin.cabal view
@@ -1,5 +1,5 @@ name: const-math-ghc-plugin-version: 0.1.0.0+version: 0.2.0.0 synopsis: Compiler plugin for constant math elimination description: This library implements elimination of constant math expressions.@@ -12,6 +12,12 @@ build-type: Simple cabal-version: >=1.8 +-- tests/*.hs shouldn't have to go here, but the source files+-- for the test-suite stanzas don't get picked up by 'cabal sdist'.+Extra-source-files:+ tests/*.hs+ tests/Makefile+ library exposed-modules: ConstMath.Plugin ConstMath.Rules@@ -21,11 +27,17 @@ containers, ghc >= 7.4 +Test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Make.hs+ build-depends: base < 5,+ directory,+ process+ ------------------------------------------------------------------------ -- Git repo -- source-repository head type: git location: git://github.com/kfish/const-math-ghc-plugin.git--
+ tests/1603.hs view
@@ -0,0 +1,7 @@+module Main where++main = print (syn [-1])++syn :: [Int] -> [Int]+syn (d:ds) = rem d 0x40000000 : syn ds+syn [] = []
+ tests/3676.hs view
@@ -0,0 +1,32 @@+-- test conversion of funny numbers through Rational (#3676)++main = mapM_ putStrLn $ concat $+ [map (show.d2d) doubles1,+ map (show.d2f) doubles1,+ map (show.d2r) doubles1,+ map (show.f2d) floats1,+ map (show.f2f) floats1,+ map (show.f2r) floats1,+ map (show.d2d) doubles2,+ map (show.d2f) doubles2,+ map (show.d2r) doubles2,+ map (show.f2d) floats2,+ map (show.f2f) floats2,+ map (show.f2r) floats2+ ]++d2d = realToFrac :: Double -> Double+d2f = realToFrac :: Double -> Float+d2r = realToFrac :: Double -> Rational+f2d = realToFrac :: Float -> Double+f2f = realToFrac :: Float -> Float+f2r = realToFrac :: Float -> Rational++doubles1 = [0/0, 1/0, -1/0, 0/(-1)] :: [Double]+floats1 = [0/0, 1/0, -1/0, 0/(-1)] :: [Float]++doubles2 = names :: [Double]+floats2 = names :: [Float]++names :: Read a => [a]+names = map read ["NaN", "Infinity", "-Infinity", "-0"]
+ tests/4381.hs view
@@ -0,0 +1,5 @@+module Main where++main = do+ print (scaleFloat 30000 1)+ print (scaleFloat (maxBound :: Int) 1)
+ tests/4383.hs view
@@ -0,0 +1,1 @@+main = print (0.5 ^ 1030)
+ tests/Make.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Cmd+import System.Directory++import Paths_const_math_ghc_plugin++main = do+ testdir <- getDataFileName "tests"+ setCurrentDirectory testdir+ system "make && make clean"
+ tests/Makefile view
@@ -0,0 +1,52 @@+GHC=ghc++NOPLUGIN_OPTS=-O2 -fforce-recomp+#WITHPLUGIN_OPTS=$(NOPLUGIN_OPTS) -fplugin ConstMath.Plugin -fplugin-opt=ConstMath.Plugin:--trace+WITHPLUGIN_OPTS=$(NOPLUGIN_OPTS) -fplugin ConstMath.Plugin++ERROR_TESTS= \+ 1603.hs \+ 3676.hs \+ 4381.hs \+ 4383.hs \+ arith001.hs \+ arith002.hs \+ arith003.hs \+ arith004.hs \+ arith005.hs \+ arith006.hs \+ arith007.hs \+ arith008.hs \+ arith009.hs \+ arith010.hs \+ arith011.hs \+ arith012.hs \+ arith013.hs \+ arith014.hs \+ arith015.hs \+ arith016.hs \+ arith017.hs \+ arith018.hs \+ arith019.hs \+ expfloat.hs \+ numrun009.hs \+ numrun010.hs \+ numrun011.hs \+ numrun012.hs \+ numrun013.hs \+ numrun014.hs++check.%.hs: %.hs+ @echo "Checking $< ..."+ $(GHC) $(NOPLUGIN_OPTS) $< -o $*.noplugin.exe+ ./$*.noplugin.exe 1>$*.noplugin.stdout 2>$*.noplugin.stderr+ $(GHC) $(WITHPLUGIN_OPTS) $< -o $*.withplugin.exe+ ./$*.withplugin.exe 1>$*.withplugin.stdout 2>$*.withplugin.stderr+ @diff -u $*.noplugin.stdout $*.withplugin.stdout+ @diff -u $*.noplugin.stderr $*.withplugin.stderr+ -rm -f $*.noplugin.exe $*.withplugin.exe $*.noplugin.stdout $*.noplugin.stderr $*.withplugin.stdout $*.withplugin.stderr++all :: $(patsubst %, check.%, $(ERROR_TESTS))++clean:+ rm -f *.o *.hi *.exe *.stdout *.stderr
+ tests/Sqrt.hs view
@@ -0,0 +1,3 @@+module Sqrt where++main = print (1.0 / sqrt 2.0)
+ tests/arith001.hs view
@@ -0,0 +1,28 @@+-- !!! conversions: Double <=> Rational/Integer things+--+import Data.Ratio++main = putStr (show r42 ++ "\n" +++ show nu42 ++ ", " +++ show de42 ++ "\n" +++ show nu42d ++ ", " +++ show de42d ++ "\n" +++ show s2 ++ ", " +++ show e2 ++ "\n" +++ show s ++ ", " +++ show e ++ "\n" )+ where + d42 :: Double+ r42 :: Rational+ nu42, de42 :: Integer+ nu42d, de42d :: Double++ d42 = 42+ r42 = toRational d42+ nu42 = numerator r42+ de42 = denominator r42+ nu42d= fromInteger nu42+ de42d= fromInteger de42++ (s,e)= decodeFloat (nu42d / de42d ) + (s2,e2) = decodeFloat d42
+ tests/arith002.hs view
@@ -0,0 +1,52 @@+-- !!! basic Rational operations+--+import Data.Ratio++main+ = putStr+ (-- Ratio Ints+ show [i0a, i0b, i0c, i2a, i2b, im2a, im2b, i_pi, i_misc]+ ++ "\n"+ -- the Ints+ ++ show ((map numerator [i0a, i0b, i0c, i2a, i2b, im2a, im2b, i_pi, i_misc])+ ++(map denominator [i0a, i0b, i0c, i2a, i2b, im2a, im2b, i_pi, i_misc]))+ ++ "\n"+ -- Booleans+-- ++ show []+-- ++ "\n"++ -- Rationals (Ratio Integers)+ ++ show [r0a, r0b, r0c, r2a, r2b, rm2a, rm2b, r_pi, r_misc]+ ++ "\n"+ -- the Integers+ ++ show ((map numerator [r0a, r0b, r0c, r2a, r2b, rm2a, rm2b, r_pi, r_misc])+ ++(map denominator [r0a, r0b, r0c, r2a, r2b, rm2a, rm2b, r_pi, r_misc]))+ ++ "\n"+ -- Booleans+-- ++ show []+-- ++ "\n"+ )+ where + i0a, i0b, i0c, i2a, i2b, im2a, im2b, i_pi, i_misc :: Ratio Int++ i0a = 0 % 1+ i0b = (-0) % 1+ i0c = 0 % (-1)+ i2a = 4 % 2+ i2b = (-4) % (-2)+ im2a = (-4) % 2+ im2b = 4 % (-2)+ i_pi = 22 % 7+ i_misc = 2 % 10000++ r0a, r0b, r0c, r2a, r2b, rm2a, rm2b, r_pi, r_misc :: Rational++ r0a = 0 % 1+ r0b = (-0) % 1+ r0c = 0 % (-1)+ r2a = 4 % 2+ r2b = (-4) % (-2)+ rm2a = (-4) % 2+ rm2b = 4 % (-2)+ r_pi = 22 % 7+ r_misc = 2 % 10000
+ tests/arith003.hs view
@@ -0,0 +1,84 @@+-- $Id: arith003.hs,v 1.2 2002/01/25 13:40:39 simonmar Exp $+--+-- !!! test Int/Integer arithmetic operations from the Prelude.+--++main+ = putStr+ (+ showit (do_ops int_ops) +++ showit (do_ops integer_ops)+ )++showit :: (Show a, Integral a) => [(String, a, a, a)] -> String+showit stuff = concat+ [ str ++ " " ++ show l ++ " " ++ show r ++ " = " ++ show result ++ "\n"+ | (str, l, r, result) <- stuff+ ]++do_ops :: Integral a => [((a -> a -> a), String, [(a,a)])]+ -> [(String, a, a, a)]+do_ops ops = [ (str, l, r, l `op` r) | (op,str,args) <- ops, (l,r) <- args ]++small_operands, non_min_operands, operands, non_max_operands+ :: Integral a => [a]+small_operands = [ 0, 1, -1, 2, -2 ]+operands = small_operands ++ [ fromIntegral minInt, fromIntegral maxInt ]+non_min_operands = small_operands ++ [ fromIntegral maxInt ]+non_max_operands = small_operands ++ [ fromIntegral minInt ]++large_operands :: [ Integer ]+large_operands = operands ++ + [ fromIntegral minInt - 1,+ fromIntegral maxInt + 1,+ fromIntegral minInt * 2,+ fromIntegral maxInt * 2,+ fromIntegral minInt ^ 2, + fromIntegral maxInt ^ 2+ ]++integer_ops :: [((Integer -> Integer -> Integer), String, [(Integer,Integer)])]+integer_ops = [ + ((+), "(+)", both_large),+ ((-), "(-)", both_large),+ (div, "div", large_non_zero_r),+ (mod, "mod", large_non_zero_r),+ (quot, "quot", large_non_zero_r),+ (rem, "rem", large_non_zero_r),+ (gcd, "gcd", large_either_non_zero),+ (lcm, "lcm", large_either_non_zero)+ ]++int_ops :: [((Int -> Int -> Int), String, [(Int,Int)])]+int_ops = [ + ((+), "(+)", both_small),+ ((-), "(-)", both_small),+ ((^), "(^)", small_non_neg_r),+ (div, "div", non_min_l_or_zero_r),+ (mod, "mod", non_min_l_or_zero_r),+ (quot, "quot", non_min_l_or_zero_r),+ (rem, "rem", non_min_l_or_zero_r),+ (gcd, "gcd", non_min_either_non_zero),+ (lcm, "lcm", non_max_r_either_non_zero)+ ]++-- NOTE: when abs(minInt) is undefined (it is in GHC, because+-- abs(minInt) would be greater than maxInt), then gcd on Ints is also+-- undefined when either operand is minInt.++both_small, non_zero_r, non_min_either_non_zero, non_min_l_or_zero_r,+ non_max_r_either_non_zero, small_non_neg_r+ :: Integral a => [(a,a)]++both_small = [ (l,r) | l <- operands, r <- operands ]+both_large = [ (l,r) | l <- large_operands, r <- large_operands ]+large_non_zero_r = [ (l,r) | l <- operands, r <- large_operands, r /= 0 ]+non_zero_r = [ (l,r) | l <- operands, r <- operands, r /= 0 ]+non_min_either_non_zero = [ (l,r) | l <- non_min_operands, r <- non_min_operands, l /= 0 || r /= 0 ]+large_either_non_zero = [ (l,r) | l <- operands, r <- operands, l /= 0 || r /= 0 ]+small_non_neg_r = [ (l,r) | l <- operands, r <- small_operands, r >= 0 ]+non_min_l_or_zero_r = [ (l,r) | l <- non_min_operands, r <- operands, r /= 0 ]+non_max_r_either_non_zero = [ (l,r) | l <- operands, r <- non_max_operands, l /= 0 || r /= 0 ]++minInt = minBound :: Int+maxInt = maxBound :: Int
+ tests/arith004.hs view
@@ -0,0 +1,86 @@+-- !!! test quot/rem/div/mod functions on Ints and Integers+--+main+ = putStr+ (-- w/ Ints and Integers+ show (unzipWith div ints_list)+ ++ "\n"+ ++ show (unzipWith div integers_list)+ ++ "\n"+ ++ show (unzipWith rem ints_list)+ ++ "\n"+ ++ show (unzipWith rem integers_list)+ ++ "\n"+ ++ show (unzipWith quot ints_list)+ ++ "\n"+ ++ show (unzipWith quot integers_list)+ ++ "\n"+ ++ show (unzipWith mod ints_list)+ ++ "\n"+ ++ show (unzipWith mod integers_list)+ ++ "\n"+ ++ show (unzipWith law1 ints_list)+ ++ "\n"+ ++ show (unzipWith law1 integers_list)+ ++ "\n"+ ++ show (unzipWith law2 ints_list)+ ++ "\n"+ ++ show (unzipWith law2 integers_list)+ ++ "\n"+ )+ where+ ints_list :: [(Int, Int)]+ integers_list :: [(Integer, Integer)]++ ints_list = [+ (0, 4),+ (0, -8),+ (7, 3),+ (13, 4),+ (13, -4),+ (-13, 4),+ (-13, -4),+ (12345678, 10000),+ (12345678, -10000),+ (-12345678, 10000),+ (-12345678, -10000),+ (123456,10000),+ (1234567,20000),+ (12345678,-10000),+ (123456789,10000),+ (1234567890,-10000),+ (-12345,10000),+ (-123456789,-10000)+ ]++ integers_list = [+ (0, 4),+ (0, -8),+ (7, 3),+ (13, 4),+ (13, -4),+ (-13, 4),+ (-13, -4),+ (12345678, 10000),+ (12345678, -10000),+ (-12345678, 10000),+ (-12345678, -10000),+ (123456,10000),+ (1234567,20000),+ (12345678,-10000),+ (123456789,10000),+ (1234567890,-10000),+ (-12345,10000),+ (-123456789,-10000),+ (12345678900,500000000),+ (1234000000000000000000005678900,5001111111111111000000)+ ]++unzipWith :: (a -> b -> c) -> [(a,b)] -> [c]+unzipWith f [] = []+unzipWith f ((x,y):zs) = f x y : unzipWith f zs++law1, law2 :: Integral a => a -> a -> Bool++law1 x y = (x `quot` y)*y + (x `rem` y) == x+law2 x y = (x `div` y)*y + (x `mod` y) == x
+ tests/arith005.hs view
@@ -0,0 +1,60 @@+-- !!! test RealFrac ops (ceiling/floor/etc.) on Floats/Doubles+--+main = + putStr $+ unlines+ [ -- just for fun, we show the floats to+ -- exercise the code responsible.+ 'A' : show (float_list :: [Float])+ , 'B' : show (double_list :: [Double])+ -- {Float,Double} inputs, {Int,Integer} outputs+ , 'C' : show ((map ceiling small_float_list) :: [Int])+ , 'D' : show ((map ceiling float_list) :: [Integer])+ , 'E' : show ((map ceiling small_double_list) :: [Int])+ , 'F' : show ((map ceiling double_list) :: [Integer])+ , 'G' : show ((map floor small_float_list) :: [Int])+ , 'H' : show ((map floor float_list) :: [Integer])+ , 'I' : show ((map floor small_double_list) :: [Int])+ , 'J' : show ((map floor double_list) :: [Integer])+ , 'K' : show ((map truncate small_float_list) :: [Int])+ , 'L' : show ((map truncate float_list) :: [Integer])+ , 'M' : show ((map truncate small_double_list) :: [Int])+ , 'N' : show ((map truncate double_list) :: [Integer])+ , 'n' : show ((map round small_float_list) :: [Int])+ , 'O' : show ((map round float_list) :: [Integer])+ , 'P' : show ((map round small_double_list) :: [Int])+ , 'Q' : show ((map round double_list) :: [Integer])+ , 'R' : show ((map properFraction small_float_list) :: [(Int,Float)])+ , 'S' : show ((map properFraction float_list) :: [(Integer,Float)])+ , 'T' : show ((map properFraction small_double_list) :: [(Int,Double)])+ , 'U' : show ((map properFraction double_list) :: [(Integer,Double)])+ ]+ where+ -- these fit into an Int when truncated. Truncation when the+ -- result does not fit into the target is undefined - not explicitly+ -- so in Haskell 98, but that's the interpretation we've taken in GHC.+ -- See bug #1254+ small_float_list :: [Float]+ small_float_list = [+ 0.0, -0.0, 1.1, 2.8, 3.5, 4.5, -1.0000000001, -2.9999995,+ -3.50000000001, -4.49999999999, 1000012.0, 123.456, 100.25,+ 102.5, 0.0012, -0.00000012, 1.7e4, -1.7e-4, 0.15e-6, pi+ ]++ float_list :: [Float]+ float_list = small_float_list ++ [+ 1.18088e+11, 1.2111e+14 + ]++ -- these fit into an Int+ small_double_list :: [Double]+ small_double_list = [+ 0.0, -0.0, 1.1, 2.8, 3.5, 4.5, -1.0000000001, -2.9999995,+ -3.50000000001, -4.49999999999, 1000012.0, 123.456, 100.25,+ 102.5, 0.0012, -0.00000012, 1.7e4, -1.7e-4, 0.15e-6, pi+ ]++ double_list :: [Double]+ double_list = small_double_list ++ [+ 1.18088e+11, 1.2111e+14 + ]
+ tests/arith006.hs view
@@ -0,0 +1,4 @@+-- !!! printing Floats; was a bug in hbc (reported by andy)+--++main = print ((fromIntegral (42 :: Int)) :: Float)
+ tests/arith007.hs view
@@ -0,0 +1,23 @@+-- !!! test simple Integer things+--++f x y z = x y z++main = do+ putStr (shows integer_list "\n")+ where+ int_list :: [Int]+ integer_list :: [Integer]++ int_list = (map fromInteger integer_list)++ integer_list = (map (* 2)+ [1,3,5,7,9,+ 11111111111111111111111111111,+ 2222222222222222222222222222222222222,+ 3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333,+ -11111111111111111111111111111,+ -2222222222222222222222222222222222222,+ -3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333+ ])+
+ tests/arith008.hs view
@@ -0,0 +1,24 @@+-- !!! a random test from Nick North+-- (got this in mid-1993; don't remember why. WDP 95/02)+--++random_numbers :: (Int, Int, Int) -> [Float]+random_numbers (s1,s2,s3)+ = map (snd . properFraction . combine) (iterate f (s1,s2,s3))+ where+ combine :: (Int,Int,Int) -> Float+ combine (a,b,c) =+ fromIntegral(a)/30269 + fromIntegral(b)/30307+ + fromIntegral(c)/30323+ f (a,b,c) =+ ((171*a) `mod` 30269, (172*b) `mod` 30307, (170*c) `mod` 30323)++-- partain: changed to cvt spaces into newlines (easier to see bugs)+-- sof: define approp. version of showList to do this.+main = putStr (showL (showsPrec 0) (take 1000 (random_numbers (9807, 65, 32975))) "\n")++showL showx [] = showString "[]"+showL showx (x:xs) = showChar '[' . showx x . showl xs+ where+ showl [] = showChar ']'+ showl (x:xs) = showString ",\n" . showx x . showl xs
+ tests/arith009.hs view
@@ -0,0 +1,6 @@+-- a prefix minus precedence test++f :: Int -> Int -> Int -> Int+f x y z = - x * y ^ z++main = putStr (shows (f 5 2 3) "\n")
+ tests/arith010.hs view
@@ -0,0 +1,11 @@+-- Tests enumerations++main = do+ print [1..10]+ print [10..1] -- []+ print [1,3..10]+ print [10,8..1]+ print ['a'..'f']+ print ['f'..'a'] -- []+ print ['a','c'..'m']+ print ['m','l'..'a']
+ tests/arith011.hs view
@@ -0,0 +1,174 @@+-- !!! Testing Int and Word+module Main(main) where+import Data.Int+import Data.Word+import Data.Bits+import Data.Ix -- added SOF+import Control.Exception++main :: IO ()+main = test++test :: IO ()+test = do+ testIntlike "Int" (0::Int)+ testIntlike "Int8" (0::Int8)+ testIntlike "Int16" (0::Int16)+ testIntlike "Int32" (0::Int32)+ testIntlike "Int64" (0::Int64)+ testIntlike "Word8" (0::Word8)+ testIntlike "Word16" (0::Word16)+ testIntlike "Word32" (0::Word32)+ testIntlike "Word64" (0::Word64)+ testInteger++testIntlike :: (Bounded a, Integral a, Ix a, Show a, Read a, Bits a) => String -> a -> IO ()+testIntlike name zero = do+ putStrLn $ "--------------------------------"+ putStrLn $ "--Testing " ++ name+ putStrLn $ "--------------------------------"+ testBounded zero+ testEnum zero+ testReadShow zero+ testEq zero+ testOrd zero+ testNum zero+ testReal zero+ testIntegral zero+ testConversions zero+ testBits zero True++testInteger = do+ let zero = 0 :: Integer+ putStrLn $ "--------------------------------"+ putStrLn $ "--Testing Integer"+ putStrLn $ "--------------------------------"+ testEnum zero+ testReadShow zero+ testEq zero+ testOrd zero+ testNum zero+ testReal zero+ testIntegral zero+ testBits zero False++-- In all these tests, zero is a dummy element used to get+-- the overloading to work++testBounded zero = do+ putStrLn "testBounded"+ print $ (minBound-1, minBound, minBound+1) `asTypeOf` (zero,zero,zero)+ print $ (maxBound-1, maxBound, maxBound+1) `asTypeOf` (zero,zero,zero)++testEnum zero = do+ putStrLn "testEnum"+ print $ take 10 [zero .. ] -- enumFrom+ print $ take 10 [zero, toEnum 2 .. ] -- enumFromThen+ print [zero .. toEnum 20] -- enumFromTo+ print [zero, toEnum 2 .. toEnum 20] -- enumFromThenTo++testConversions zero = do+ putStrLn "testConversions"+ putStr "Integer : " >> print (map fromIntegral numbers :: [Integer])+ putStr "Int : " >> print (map fromIntegral numbers :: [Int])+ putStr "Int8 : " >> print (map fromIntegral numbers :: [Int8])+ putStr "Int16 : " >> print (map fromIntegral numbers :: [Int16])+ putStr "Int32 : " >> print (map fromIntegral numbers :: [Int32])+ putStr "Int64 : " >> print (map fromIntegral numbers :: [Int64])+ putStr "Word8 : " >> print (map fromIntegral numbers :: [Word8])+ putStr "Word16 : " >> print (map fromIntegral numbers :: [Word16])+ putStr "Word32 : " >> print (map fromIntegral numbers :: [Word32])+ putStr "Word64 : " >> print (map fromIntegral numbers :: [Word64])+ where numbers = [minBound, 0, maxBound] `asTypeOf` [zero]++samples :: (Num a) => a -> [a]+samples zero = map fromInteger ([-3 .. -1]++[0 .. 3])+ +table1 :: (Show a, Show b) => String -> (a -> b) -> [a] -> IO ()+table1 nm f xs = do+ sequence [ f' x | x <- xs ]+ putStrLn "#"+ where+ f' x = putStrLn (nm ++ " " ++ show x ++ " = " ++ show (f x))++table2 :: (Show a, Show b, Show c) => String -> (a -> b -> c) -> [a] -> [b] -> IO ()+table2 nm op xs ys = do+ sequence [ sequence [ op' x y | y <- ys ] >> putStrLn " "+ | x <- xs + ]+ putStrLn "#"+ where+ op' x y = do s <- Control.Exception.catch+ (evaluate (show (op x y)))+ (\e -> return (show (e :: SomeException)))+ putStrLn (show x ++ " " ++ nm ++ " " ++ show y ++ " = " ++ s)++testReadShow zero = do+ putStrLn "testReadShow"+ print xs+ print (map read_show xs)+ where+ xs = samples zero+ read_show x = (read (show x) `asTypeOf` zero)++testEq zero = do+ putStrLn "testEq"+ table2 "==" (==) xs xs+ table2 "/=" (/=) xs xs+ where+ xs = samples zero++testOrd zero = do+ putStrLn "testOrd"+ table2 "<=" (<=) xs xs+ table2 "< " (<) xs xs+ table2 "> " (>) xs xs+ table2 ">=" (>=) xs xs+ table2 "`compare`" compare xs xs+ where+ xs = samples zero++testNum zero = do+ putStrLn "testNum"+ table2 "+" (+) xs xs+ table2 "-" (-) xs xs+ table2 "*" (*) xs xs+ table1 "negate" negate xs+ where+ xs = samples zero++testReal zero = do+ putStrLn "testReal"+ table1 "toRational" toRational xs+ where+ xs = samples zero++testIntegral zero = do+ putStrLn "testIntegral"+ table2 "`divMod` " divMod xs xs+ table2 "`div` " div xs xs+ table2 "`mod` " mod xs xs+ table2 "`quotRem`" quotRem xs xs+ table2 "`quot` " quot xs xs+ table2 "`rem` " rem xs xs+ where+ xs = samples zero++testBits zero do_bitsize = do+ putStrLn "testBits"+ table2 ".&. " (.&.) xs xs+ table2 ".|. " (.|.) xs xs+ table2 "`xor`" xor xs xs+ table1 "complement" complement xs+ table2 "`shiftL`" shiftL xs ([0..3] ++ [32,64])+ table2 "`shiftR`" shiftR xs ([0..3] ++ [32,64]) + table2 "`rotate`" rotate xs ([-3..3] ++ [-64,-32,32,64])+ table1 "bit" (\ x -> (bit x) `asTypeOf` zero) [(0::Int)..3]+ table2 "`setBit`" setBit xs ([0..3] ++ [32,64])+ table2 "`clearBit`" clearBit xs ([0..3] ++ [32,64])+ table2 "`complementBit`" complementBit xs ([0..3] ++ [32,64])+ table2 "`testBit`" testBit xs ([0..3] ++ [32,64])+ if do_bitsize then table1 "bitSize" bitSize xs else return ()+ table1 "isSigned" isSigned xs+ where+ xs = samples zero
+ tests/arith012.hs view
@@ -0,0 +1,90 @@+-- !!! Testing NumExts+module Main(main) where++import Numeric+import Data.Char++main :: IO ()+main = tst++tst :: IO ()+tst = do+ test_doubleToFloat+ test_floatToDouble+ test_showHex+ test_showOct+ test_showBin++----+-- Test data:+doubles :: [Double]+doubles = [ -1.2 , 0, 0.1, 0.5, 1.0, 1234.45454, + 1.6053e4, 1.64022e12, 6.894e-4, 6.34543455634582173,+ 5342413403.40540423255]+ints :: [Int]+ints = [ 0, 1, 255, 65513, 6029, 1024, 256, 201357245]++integers :: [Integer]+integers = [ 0, 1, 255, 65513, 6029, 1024, 256,+ 2343243543500233, 656194962055457832]+---++test_doubleToFloat :: IO ()+test_doubleToFloat = do+ test_banner "doubleToFloat"+ putStrLn (show doubles)+ putStrLn (show $ map doubleToFloat doubles)++doubleToFloat :: Double -> Float+doubleToFloat = realToFrac++floatToDouble :: Float -> Double+floatToDouble = realToFrac++test_floatToDouble :: IO ()+test_floatToDouble = do+ test_banner "doubleToFloat"+ putStrLn (show doubles)+ putStrLn (show $ map doubleToFloat doubles)+ putStrLn (show $ map (floatToDouble.doubleToFloat) doubles)++test_showHex :: IO ()+test_showHex = do+ test_banner "showHex"+ putStrLn (show ints)+ putStrLn (showList' (map showHex ints))+ putStrLn (show integers)+ putStrLn (showList' (map showHex integers))++test_showBin :: IO ()+test_showBin = do+ test_banner "showBin"+ putStrLn (show ints)+ putStrLn (showList' (map showBin ints))+ putStrLn (show integers)+ putStrLn (showList' (map showBin integers))++showBin i = showIntAtBase 2 intToDigit i++showList' :: [ShowS] -> String+showList' [] = "[]"+showList' (x:xs) = showChar '[' . x $ showl xs ""+ where + showl [] = showChar ']'+ showl (x:xs) = showChar ',' . x . showl xs+++test_showOct :: IO ()+test_showOct = do+ test_banner "showOct"+ putStrLn (show ints)+ putStrLn (showList' (map showOct ints))+ putStrLn (show integers)+ putStrLn (showList' (map showOct integers))++----+test_banner :: String -> IO ()+test_banner tst = do+ putStrLn $ "--------------------------------"+ putStrLn $ "--Testing " ++ tst+ putStrLn $ "--------------------------------"
+ tests/arith013.hs view
@@ -0,0 +1,13 @@+-- Test gcdInt/gcdInteger++import GHC.Real ( gcdInt )+import GHC.Integer.GMP.Internals ( gcdInteger )++main :: IO ()+main = do+ test gcdInt [ -42, 0, 105 ]+ test gcdInteger [-12193263111263526900, -42, 0, 105, 1234567890 ]+++test :: (Show a, Integral a) => (a -> a -> a) -> [a] -> IO ()+test f xs = mapM_ print [ (a, b, f a b) | a <- xs, b <- reverse xs, a /= 0 || b /= 0 ]
+ tests/arith014.hs view
@@ -0,0 +1,11 @@+-- Test behaviour of fromInteger when the target type is out of range.++main :: IO ()+main = + print [+ fromInteger maxInt2 :: Int,+ fromInteger minInt2 :: Int+ ] ++maxInt2 = fromIntegral (maxBound :: Int) * 2 :: Integer+minInt2 = fromIntegral (minBound + 1 :: Int) * 2 :: Integer
+ tests/arith015.hs view
@@ -0,0 +1,5 @@+main = do+ print (map read strange_nums :: [Float]) + print (map read strange_nums :: [Double]) + where+ strange_nums = ["Infinity","NaN", "-Infinity"]
+ tests/arith016.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MagicHash #-}++module Main where++import GHC.Exts ( Float(F#), + eqFloat#, neFloat#, ltFloat#, + leFloat#, gtFloat#, geFloat# + )++fcmp_eq, fcmp_ne, fcmp_lt, fcmp_le, fcmp_gt, fcmp_ge :: (String, Float -> Float -> Bool)+fcmp_eq = ("==", \ (F# a) (F# b) -> a `eqFloat#` b)+fcmp_ne = ("/=", \ (F# a) (F# b) -> a `neFloat#` b)+fcmp_lt = ("< ", \ (F# a) (F# b) -> a `ltFloat#` b)+fcmp_le = ("<=", \ (F# a) (F# b) -> a `leFloat#` b)+fcmp_gt = ("> ", \ (F# a) (F# b) -> a `gtFloat#` b)+fcmp_ge = (">=", \ (F# a) (F# b) -> a `geFloat#` b)++float_fns = [fcmp_eq, fcmp_ne, fcmp_lt, fcmp_le, fcmp_gt, fcmp_ge]++float_vals :: [Float]+float_vals = [0.0, 1.0, read "NaN"]++float_text+ = [show4 arg1 ++ " " ++ fn_name ++ " " ++ show4 arg2 ++ " = " ++ show (fn arg1 arg2)+ | (fn_name, fn) <- float_fns,+ arg1 <- float_vals,+ arg2 <- float_vals+ ]+ where+ show4 x = take 4 (show x ++ repeat ' ')++main+ = putStrLn (unlines float_text)
+ tests/arith017.hs view
@@ -0,0 +1,10 @@+-- !!! test for a bug in integer->{Int,Word}64 conversion in GHC 5.04.x++import Data.Int+import Data.Word++main = do+ print (fromIntegral ((2^30 -1 + 2^30) - (2^30 + 2^30 :: Integer))+ :: Data.Int.Int64)+ print (fromIntegral ((2^30 -1 + 2^30) - (2^30 + 2^30 :: Integer))+ :: Data.Word.Word64)
+ tests/arith018.hs view
@@ -0,0 +1,12 @@+-- exposes a bug in the native code generator in GHC 6.4.1. Division by+-- a power of 2 was being mis-optimsed to a direct shift.++main = do+ print (map f4 [(-20) .. (-1)])+ print (map f8 [(-20) .. (-1)])++f4 :: Int -> Int+f4 x = x `quot` 4++f8 :: Int -> Int+f8 x = x `quot` 8
+ tests/arith019.hs view
@@ -0,0 +1,10 @@+-- demonstrates a bug in mulIntMayOflo in GHC 6.5 on 64-bit arches+-- (trac #867).+-- It thought it could represent 3049800625 * 3049800625 in an I#.++i :: Integer+i = 3049800625++main :: IO ()+main = print (i * i)+
+ tests/expfloat.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MagicHash #-}+-- tests that expFloat# works (had linking problems on Windows)++import GHC.Exts++main = do+ print (F# (expFloat# 3.45#))
+ tests/numrun009.hs view
@@ -0,0 +1,17 @@+-- !!! tests that minBound::Int is correctly handled (for Int & Integer++-- (not necessarily Haskell 98: relies on Int being a 32-bit type.)++main = do+ print (-2147483648 :: Int) -- -2147483648+ print ((-2147483647)-1 :: Int) -- -2147483648+ print (-2147483648 :: Integer) -- -2147483648+ print ((-2147483648 :: Int) >= 0) -- False+ print ((-2147483648 :: Integer) >= 0) -- False+ print (-(-2147483648) :: Int) -- <undefined>+ print (abs (-2147483648) :: Int) -- <undefined>+ print (abs ((-2147483647)-1) :: Int) -- <undefined>+ print (abs (-2147483648) :: Integer) -- 2147483648+ print (abs ((-2147483647)-1) :: Integer) -- 2147483648 (wrong in 4.04)+ print (fromInteger (-2147483648 :: Integer) :: Int) -- -2147483648+ print (fromInteger ((-2147483647)-1 :: Integer) :: Int) -- -2147483648
+ tests/numrun010.hs view
@@ -0,0 +1,13 @@+-- !!! tests that local fixity declarations work++-- If local fixity decls don't work you get "14"+-- The right answer is "11"++val = 3 +! 4 *! 2+ where (+!) = (+)+ (*!) = (*)+ infixl 6 +!+ infixl 7 *!++main = print val+
+ tests/numrun011.hs view
@@ -0,0 +1,2 @@+import Data.Ratio+main = print (fromRational (1 % 85070591730234615865843651857942052864) :: Float)
+ tests/numrun012.hs view
@@ -0,0 +1,35 @@++-- Test for trac #921++import GHC.Float+import Foreign+import Control.Monad++main :: IO ()+main = do -- The reported case+ putStrLn (show (map log2 vals))+ -- Smaller failing cases+ print (fromIntegral ((2^31) :: Int) :: Double)+ if_not_32 $ print (round ((2^33) :: Double) :: Int)+ print (fromIntegral ((2^31) :: Int) :: Float)+ if_not_32 $ print (round ((2^33) :: Float) :: Int)+ -- The underlying failing internal operations+ print (int2Double (2^31))+ if_not_32 $ print (double2Int (2^33))+ print (int2Float (2^31))+ if_not_32 $ print (float2Int (2^33))+ where+ -- the value of float2Int x where the result would be outside the+ -- range of the target is undefined. We also take the view in GHC+ -- that round and truncate are similarly undefined when the result+ -- would be outside the range of the target type (see #1254)+ if_not_32 = when (sizeOf (undefined::Int) > 4)++log2 x = ceiling log_x+ where log_x :: Double+ log_x = logBase 2 (fromIntegral (max 1 x))++vals = [1, 2, 17, 259, 1000, 10000,+ 2^30 + 9000, 2^31 - 1, 2^31 + 1,+ 2^32 - 1, 2^32 + 1]+
+ tests/numrun013.hs view
@@ -0,0 +1,17 @@++-- Test for trac #1042++import Control.Exception+import Data.Int+import Prelude hiding (catch)++main :: IO ()+main = do print ((minBound :: Int) `div` (-1)) `myCatch` print+ print ((minBound :: Int8) `div` (-1)) `myCatch` print+ print ((minBound :: Int16) `div` (-1)) `myCatch` print+ print ((minBound :: Int32) `div` (-1)) `myCatch` print+ print ((minBound :: Int64) `div` (-1)) `myCatch` print++myCatch :: IO a -> (ArithException -> IO a) -> IO a+myCatch = catch+
+ tests/numrun014.hs view
@@ -0,0 +1,211 @@++-- Test that we don't have rules (or othre optimisations) doing the+-- wrong thing for constant folding with Doubles.++module Main (main) where++zero :: Double+zero = 0++one :: Double+one = 1++nan :: Double+nan = 0 / 0++inf :: Double+inf = 1 / 0++neginf :: Double+neginf = -1 / 0++fzero :: Float+fzero = 0++fone :: Float+fone = 1++fnan :: Float+fnan = 0 / 0++finf :: Float+finf = 1 / 0++fneginf :: Float+fneginf = -1 / 0++main :: IO ()+main = do putStrLn "=== Subtraction ==="+ print (zero - zero)+ print (zero - nan)+ print (zero - inf)+ print (zero - neginf)+ print (nan - zero)+ print (nan - nan)+ print (nan - inf)+ print (nan - neginf)+ print (inf - zero)+ print (inf - nan)+ print (inf - inf)+ print (inf - neginf)+ print (neginf - zero)+ print (neginf - nan)+ print (neginf - inf)+ print (neginf - neginf)+ putStrLn "=== Addition ==="+ print (zero + zero)+ print (zero + nan)+ print (zero + inf)+ print (zero + neginf)+ print (nan + zero)+ print (nan + nan)+ print (nan + inf)+ print (nan + neginf)+ print (inf + zero)+ print (inf + nan)+ print (inf + inf)+ print (inf + neginf)+ print (neginf + zero)+ print (neginf + nan)+ print (neginf + inf)+ print (neginf + neginf)+ putStrLn "=== Mutiplication ==="+ print (zero * zero)+ print (zero * one)+ print (zero * nan)+ print (zero * inf)+ print (zero * neginf)+ print (one * zero)+ print (one * one)+ print (one * nan)+ print (one * inf)+ print (one * neginf)+ print (nan * zero)+ print (nan * one)+ print (nan * nan)+ print (nan * inf)+ print (nan * neginf)+ print (inf * zero)+ print (inf * one)+ print (inf * nan)+ print (inf * inf)+ print (inf * neginf)+ print (neginf * zero)+ print (neginf * one)+ print (neginf * nan)+ print (neginf * inf)+ print (neginf * neginf)+ putStrLn "=== Division ==="+ print (zero / zero)+ print (zero / one)+ print (zero / nan)+ print (zero / inf)+ print (zero / neginf)+ print (one / zero)+ print (one / one)+ print (one / nan)+ print (one / inf)+ print (one / neginf)+ print (nan / zero)+ print (nan / one)+ print (nan / nan)+ print (nan / inf)+ print (nan / neginf)+ print (inf / zero)+ print (inf / one)+ print (inf / nan)+ print (inf / inf)+ print (inf / neginf)+ print (neginf / zero)+ print (neginf / one)+ print (neginf / nan)+ print (neginf / inf)+ print (neginf / neginf)++ putStrLn "=== Subtraction ==="+ print (fzero - fzero)+ print (fzero - fnan)+ print (fzero - finf)+ print (fzero - fneginf)+ print (fnan - fzero)+ print (fnan - fnan)+ print (fnan - finf)+ print (fnan - fneginf)+ print (finf - fzero)+ print (finf - fnan)+ print (finf - finf)+ print (finf - fneginf)+ print (fneginf - fzero)+ print (fneginf - fnan)+ print (fneginf - finf)+ print (fneginf - fneginf)+ putStrLn "=== Addition ==="+ print (fzero + fzero)+ print (fzero + fnan)+ print (fzero + finf)+ print (fzero + fneginf)+ print (fnan + fzero)+ print (fnan + fnan)+ print (fnan + finf)+ print (fnan + fneginf)+ print (finf + fzero)+ print (finf + fnan)+ print (finf + finf)+ print (finf + fneginf)+ print (fneginf + fzero)+ print (fneginf + fnan)+ print (fneginf + finf)+ print (fneginf + fneginf)+ putStrLn "=== Mutiplication ==="+ print (fzero * fzero)+ print (fzero * fone)+ print (fzero * fnan)+ print (fzero * finf)+ print (fzero * fneginf)+ print (fone * fzero)+ print (fone * fone)+ print (fone * fnan)+ print (fone * finf)+ print (fone * fneginf)+ print (fnan * fzero)+ print (fnan * fone)+ print (fnan * fnan)+ print (fnan * finf)+ print (fnan * fneginf)+ print (finf * fzero)+ print (finf * fone)+ print (finf * fnan)+ print (finf * finf)+ print (finf * fneginf)+ print (fneginf * fzero)+ print (fneginf * fone)+ print (fneginf * fnan)+ print (fneginf * finf)+ print (fneginf * fneginf)+ putStrLn "=== Division ==="+ print (fzero / fzero)+ print (fzero / fone)+ print (fzero / fnan)+ print (fzero / finf)+ print (fzero / fneginf)+ print (fone / fzero)+ print (fone / fone)+ print (fone / fnan)+ print (fone / finf)+ print (fone / fneginf)+ print (fnan / fzero)+ print (fnan / fone)+ print (fnan / fnan)+ print (fnan / finf)+ print (fnan / fneginf)+ print (finf / fzero)+ print (finf / fone)+ print (finf / fnan)+ print (finf / finf)+ print (finf / fneginf)+ print (fneginf / fzero)+ print (fneginf / fone)+ print (fneginf / fnan)+ print (fneginf / finf)+ print (fneginf / fneginf)+