diff options
Diffstat (limited to 'testsuite/tests/codeGen')
179 files changed, 4434 insertions, 0 deletions
diff --git a/testsuite/tests/codeGen/Makefile b/testsuite/tests/codeGen/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/codeGen/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/codeGen/should_compile/1916.hs b/testsuite/tests/codeGen/should_compile/1916.hs new file mode 100644 index 0000000000..7210aaf41c --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/1916.hs @@ -0,0 +1,3 @@ +module Bug (tst) where +tst :: Float -> Bool +tst x = truncate x > (0::Int) diff --git a/testsuite/tests/codeGen/should_compile/2388.hs b/testsuite/tests/codeGen/should_compile/2388.hs new file mode 100644 index 0000000000..f3364f5b6e --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/2388.hs @@ -0,0 +1,14 @@ +module Q where + +import Data.Bits +import Data.Word +import Data.Int + +test1 :: Word32 -> Char +test1 w | w .&. 0x80000000 /= 0 = 'a' +test1 _ = 'b' + +-- this should use a testq instruction on x86_64 +test2 :: Int64 -> Char +test2 w | w .&. (-3) /= 0 = 'a' +test2 _ = 'b' diff --git a/testsuite/tests/codeGen/should_compile/2578.hs b/testsuite/tests/codeGen/should_compile/2578.hs new file mode 100644 index 0000000000..c851b54f88 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/2578.hs @@ -0,0 +1,17 @@ + +{-# LANGUAGE EmptyDataDecls #-} + +-- This used to give warnings: +-- ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o +-- ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o +-- ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o +-- when compiling on OS X (trac #2578). + +module Main (main) where + +data MyType +data MyType2 + +main :: IO () +main = print () + diff --git a/testsuite/tests/codeGen/should_compile/3132.hs b/testsuite/tests/codeGen/should_compile/3132.hs new file mode 100644 index 0000000000..c6aa2579e9 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/3132.hs @@ -0,0 +1,6 @@ +module Spring where + +import Data.Array.Unboxed + +step :: UArray Int Double -> [Double] +step y = [y!1 + y!0] diff --git a/testsuite/tests/codeGen/should_compile/3579.hs b/testsuite/tests/codeGen/should_compile/3579.hs new file mode 100644 index 0000000000..29711e147b --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/3579.hs @@ -0,0 +1,7 @@ +module Bug where + +compose :: [a -> a] -> a -> a +compose = foldr (.) id + +class Compose a where + compose1 :: a -> a -> a diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile new file mode 100644 index 0000000000..ff43099198 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/Makefile @@ -0,0 +1,7 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +2578: + '$(TEST_HC)' $(TEST_HC_OPTS) --make 2578 -fforce-recomp -v0 + diff --git a/testsuite/tests/codeGen/should_compile/T3286.hs b/testsuite/tests/codeGen/should_compile/T3286.hs new file mode 100644 index 0000000000..0cc852db94 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T3286.hs @@ -0,0 +1,45 @@ + +module T3286 (train) where + +import qualified Data.Map as M +import Data.List (groupBy, foldl') +import Data.Maybe (fromMaybe, fromJust) +import Data.Function (on) +import T3286b + +type Prob = LogFloat + +learn_states :: (Ord state) => [(observation, state)] -> M.Map state Prob +learn_states xs = histogram $ map snd xs + +learn_observations :: (Ord state, Ord observation) => + M.Map state Prob + -> [(observation, state)] + -> M.Map (observation, state) Prob +learn_observations state_prob = M.mapWithKey f . histogram + where f (_, state) prob = prob / (fromJust $ M.lookup state state_prob) + +histogram :: (Ord a) => [a] -> M.Map a Prob +histogram xs = let hist = foldl' undefined M.empty xs in + M.map (/ M.foldrWithKey (\_ a b -> a + b) 0 hist) hist + +train :: (Ord observation, Ord state) => + [(observation, state)] + -> (observation -> [Prob]) +train sample = model + where + states = learn_states sample + state_list = M.keys states + + observations = learn_observations states sample + observation_probs = fromMaybe (fill state_list []) . (flip M.lookup $ + M.fromList $ map (\ (e, xs) -> (e, fill state_list xs)) $ + map (\ xs -> (fst $ head xs, map snd xs)) $ + groupBy ((==) `on` fst) + [(observation, (state, prob)) + | ((observation, state), prob) <- M.toAscList observations]) + + model = observation_probs + + fill :: Eq state => [state] -> [(state, Prob)] -> [Prob] + fill = undefined diff --git a/testsuite/tests/codeGen/should_compile/T3286b.hs b/testsuite/tests/codeGen/should_compile/T3286b.hs new file mode 100644 index 0000000000..f6c1fdbeac --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T3286b.hs @@ -0,0 +1,15 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module T3286b (LogFloat) where + +newtype LogFloat = LogFloat Double + deriving (Eq, Ord, Num, Show) + +instance Fractional LogFloat where + (/) (LogFloat x) (LogFloat y) + | x == 1 + && y == 1 = error "(/)" + | otherwise = LogFloat (x-y) + fromRational = LogFloat . fromRational + diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T new file mode 100644 index 0000000000..ba29c2a145 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -0,0 +1,19 @@ +test('cg001', only_compiler_types(['ghc']), compile, ['']) +test('cg002', normal, compile, ['']) +test('cg003', only_ways(['optasm']), compile, ['']) +test('cg004', normal, compile, ['']) +test('cg005', only_ways(['optasm']), compile, ['']) +test('cg006', normal, compile, ['']) +test('cg007', normal, compile, ['']) +test('cg008', normal, compile, ['']) + +test('1916', normal, compile, ['']) +test('2388', normal, compile, ['']) +test('3132', normal, compile, ['-dcmm-lint']) +test('T3286', extra_clean(['T3286b.o','T3286b.hi']), + multimod_compile, ['T3286', '-v0']) +test('3579', normal, compile, ['']) +test('2578', normal, run_command, ['$MAKE -s --no-print-directory 2578']) +# skip llvm on i386 as we don't support fPIC +test('jmp_tbl', if_arch('i386', omit_ways(['llvm', 'optllvm'])), compile, ['-fPIC -O']) +test('massive_array', if_arch('i386', omit_ways(['llvm', 'optllvm'])), compile, ['-fPIC']) diff --git a/testsuite/tests/codeGen/should_compile/cg001.hs b/testsuite/tests/codeGen/should_compile/cg001.hs new file mode 100644 index 0000000000..ad00a8f89c --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg001.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} + +module ShouldCompile where + +import GHC.Exts + +data STRef s a = STRef (MutVar# s a) + +-- ghc 4.08 had a problem with returning a MutVar#. + +from :: STRef s a -> MutVar# s a +from (STRef x) = x + +to :: MutVar# s a -> STRef s a +to x = STRef x diff --git a/testsuite/tests/codeGen/should_compile/cg002.hs b/testsuite/tests/codeGen/should_compile/cg002.hs new file mode 100644 index 0000000000..9d655d9d12 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg002.hs @@ -0,0 +1,5 @@ + +module M where +import Data.Char +{-# INLINE f #-} +f = map ord . map chr diff --git a/testsuite/tests/codeGen/should_compile/cg003.hs b/testsuite/tests/codeGen/should_compile/cg003.hs new file mode 100644 index 0000000000..e7cea2e0b3 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg003.hs @@ -0,0 +1,7 @@ +module Test where + +-- !!! caused compiler to generate bogus HC code, fixed in +-- basicTypes/Literal.lhs rev. 1.36. + +f :: Double -> Int +f x = round (x - (-5.0)) diff --git a/testsuite/tests/codeGen/should_compile/cg004.hs b/testsuite/tests/codeGen/should_compile/cg004.hs new file mode 100644 index 0000000000..fb8e3cc413 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg004.hs @@ -0,0 +1,30 @@ +module ShouldCompile where + +-- Killed GHC 6.0 in isCrossDllArg +-- +-- ghc-6.0: panic! (the `impossible' happened, GHC version 6.0): +-- coreSyn/CoreUtils.lhs:1188: Non-exhaustive patterns in function isCrossDllArg +-- +-- The reason was that newST had the form +-- newST = \ @ v -> GHC.Base.: +-- @ (Environment.Scope v) +-- (case $fScopeOpersScope @ v +-- of tpl_B1 { Environment.:DScopeOpers tpl_B2 tpl_B3 -> +-- tpl_B2 +-- }) +-- (GHC.Base.[] @ (Environment.Scope v)) + +class ScopeOpers s where + emptyScope :: s + op :: s -> s + +data Scope v = NewScope + +instance ScopeOpers (Scope v) where + emptyScope = error "emptyScope" + op = error "op" + +newtype SymbolTable v = SymbolTable [Scope v] + +newST :: SymbolTable v +newST = SymbolTable [emptyScope] diff --git a/testsuite/tests/codeGen/should_compile/cg005.hs b/testsuite/tests/codeGen/should_compile/cg005.hs new file mode 100644 index 0000000000..a25ad4250a --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg005.hs @@ -0,0 +1,20 @@ +module Bug where
+
+import Foreign hiding ( unsafePerformIO )
+import Foreign.ForeignPtr
+import Data.Char
+import System.IO.Unsafe
+
+data PackedString = PS !(ForeignPtr Word8) !Int !Int
+
+(!) :: PackedString -> Int -> Word8
+(PS x s _l) ! i
+ = unsafePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i)
+
+w2c :: Word8 -> Char
+w2c = chr . fromIntegral
+
+indexPS :: PackedString -> Int -> Char
+indexPS theps i | i < 0 = error "Negative index in indexPS"
+ | otherwise = w2c $ theps ! i
+
diff --git a/testsuite/tests/codeGen/should_compile/cg006.hs b/testsuite/tests/codeGen/should_compile/cg006.hs new file mode 100644 index 0000000000..494b37937b --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg006.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash #-} +module ShouldCompile where + +-- exposed a bug in the NCG in 6.4.2 +import GHC.Base +class Unboxable a where + writeUnboxable :: MutableByteArray# RealWorld -> a -> State# RealWorld -> State# RealWorld + writeUnboxable arr a s = writeInt8Array# arr 0# (getTag 0) s diff --git a/testsuite/tests/codeGen/should_compile/cg007.hs b/testsuite/tests/codeGen/should_compile/cg007.hs new file mode 100644 index 0000000000..5ef739bd47 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg007.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module ShouldCompile where + +import Foreign.C.Types + +{- +During 6.11, this was failing like this: + +In file included from /ghc/includes/Stg.h:207, + + from /tmp/ghc2904_0/ghc2904_0.hc:3:0: +/tmp/ghc2904_0/ghc2904_0.hc: In function `swM_ret': + +/tmp/ghc2904_0/ghc2904_0.hc:22:0: + error: `gamma' undeclared (first use in this function) + +/tmp/ghc2904_0/ghc2904_0.hc:22:0: + error: (Each undeclared identifier is reported only once + +/tmp/ghc2904_0/ghc2904_0.hc:22:0: + error: for each function it appears in.) +-} + +foreign import ccall unsafe "math.h gamma" + gamma :: CDouble -> CDouble + diff --git a/testsuite/tests/codeGen/should_compile/cg008.hs b/testsuite/tests/codeGen/should_compile/cg008.hs new file mode 100644 index 0000000000..10099c1b48 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/cg008.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +{-# OPTIONS_GHC -O0 #-} + +-- Variant of cgrun066; compilation as a module is different. + +module Cg008 (hashStr) where + +import Foreign.C +import Data.Word +import Foreign.Ptr +import GHC.Exts + +import Control.Exception + +hashStr :: Ptr Word8 -> Int -> Int +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | n GHC.Exts.==# len# = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# diff --git a/testsuite/tests/codeGen/should_compile/jmp_tbl.hs b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs new file mode 100644 index 0000000000..56904ed7a1 --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE NamedFieldPuns #-} + +{- +This funny module was reduced from a failing build of stage2 using +the new code generator and the linear register allocator, with this bug: + +"inplace/bin/ghc-stage1" -fPIC -dynamic -H32m -O -Wall -H64m -O0 -package-name ghc-7.1.20110414 -hide-all-packages -i -icompiler/basicTypes -icompiler/cmm -icompiler/codeGen -icompiler/coreSyn -icompiler/deSugar -icompiler/ghci -icompiler/hsSyn -icompiler/iface -icompiler/llvmGen -icompiler/main -icompiler/nativeGen -icompiler/parser -icompiler/prelude -icompiler/profiling -icompiler/rename -icompiler/simplCore -icompiler/simplStg -icompiler/specialise -icompiler/stgSyn -icompiler/stranal -icompiler/typecheck -icompiler/types -icompiler/utils -icompiler/vectorise -icompiler/stage2/build -icompiler/stage2/build/autogen -Icompiler/stage2/build -Icompiler/stage2/build/autogen -Icompiler/../libffi/build/include -Icompiler/stage2 -Icompiler/../libraries/base/cbits -Icompiler/../libraries/base/include -Icompiler/. -Icompiler/parser -Icompiler/utils -optP-DGHCI -optP-include -optPcompiler/stage2/build/autogen/cabal_macros.h -package Cabal-1.11.0 -package array-0.3.0.2 -package base-4.3.1.0 -package bin-package-db-0.0.0.0 -package bytestring-0.9.1.10 -package containers-0.4.0.0 -package directory-1.1.0.0 -package filepath-1.2.0.0 -package hoopl-3.8.7.0 -package hpc-0.5.0.6 -package old-time-1.0.0.6 -package process-1.0.1.4 -package template-haskell-2.5.0.0 -package unix-2.4.1.0 -Wall -fno-warn-name-shadowing -fno-warn-orphans -XHaskell98 -XNondecreasingIndentation -XCPP -XMagicHash -XUnboxedTuples -XPatternGuards -XForeignFunctionInterface -XEmptyDataDecls -XTypeSynonymInstances -XMultiParamTypeClasses -XFlexibleInstances -XRank2Types -XScopedTypeVariables -XDeriveDataTypeable -DGHCI_TABLES_NEXT_TO_CODE -DSTAGE=2 -O2 -O -DGHC_DEFAULT_NEW_CODEGEN -no-user-package-conf -rtsopts -odir compiler/stage2/build -hidir compiler/stage2/build -stubdir compiler/stage2/build -hisuf dyn_hi -osuf dyn_o -hcsuf dyn_hc -c compiler/main/DriverPipeline.hs -o compiler/stage2/build/DriverPipeline.dyn_o -fforce-recomp -dno-debug-output -fno-warn-unused-binds + +ghc-stage1: panic! (the 'impossible' happened) + (GHC version 7.1.20110414 for x86_64-unknown-linux): + Cannot patch JMP_TBL + +This panic only appears to show up on x86-64 and with -fPIC. I wasn't +able to get the produced optimized C-- to crash the linear register +allocator. To see the bug, you need some extra patches for the new code +generator, in particular, this set (which can be acquired from the +jmp_tbl_bug tag at <https://github.com/ezyang/ghc>): + + commit 7b275c93df7944f0a9b51034cf1f64e3e70582a5 + Author: Edward Z. Yang <ezyang@mit.edu> + Date: Thu Apr 14 21:20:21 2011 +0100 + + Give manifestSP better information about the actual SP location. + + This patch fixes silliness where the SP pointer is continually + bumped up and down. + + Signed-off-by: Edward Z. Yang <ezyang@mit.edu> + + commit 5b5add4246d3997670ae995f7d2a028db92fff95 + Author: Edward Z. Yang <ezyang@mit.edu> + Date: Wed Apr 13 11:16:36 2011 +0100 + + Generalized assignment rewriting pass. + + This assignment rewriting pass subsumes the previous reload + sinking pass, and also performs basic inlining. + + Signed-off-by: Edward Z. Yang <ezyang@mit.edu> + +The ostensible cause is that the linear register allocator is getting +really unlucky and needs to insert a fixup block after precisely one +jump in a jump table, because the block it jumps to was processed +already. As you can see, actually getting the linear register allocator +into this funk is /very/ difficult. + +-} + +module DriverPipeline (compileFile) where + +import Control.Exception + +data Phase + = Unlit () + | Ccpp + | Cc + | Cobjc + | HCc + | SplitAs + | As + | LlvmOpt + | LlvmLlc + | LlvmMangle + | MergeStub + | StopLn + deriving (Show) + +data PipeState = PipeState { + stop_phase :: Phase, + src_basename :: String, + output_spec :: (), + hsc_env :: Maybe String, + maybe_loc :: Maybe String + } + +newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \state -> return (state, a) + P m >>= k = P $ \state -> do (state',a) <- m state + unP (k a) state' + +eqPhase :: Phase -> Phase -> Bool +eqPhase (Unlit _) (Unlit _) = True +eqPhase Ccpp Ccpp = True +eqPhase Cc Cc = True +eqPhase HCc HCc = True +eqPhase SplitAs SplitAs = True +eqPhase As As = True +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase MergeStub MergeStub = True +eqPhase StopLn StopLn = True +eqPhase _ _ = False + +compileFile start_phase state = do + unP (pipeLoop start_phase) state + getOutputFilename undefined undefined undefined undefined undefined undefined + +pipeLoop phase = do + dflags@PipeState{stop_phase} <- getPipeState + io $ evaluate (phase `eqPhase` stop_phase) + runPhase phase dflags + pipeLoop phase + +getOutputFilename :: Phase -> () -> String -> Maybe String -> Phase -> Maybe String -> IO String +getOutputFilename p o b md p' ml + | p' `eqPhase` p, () <- o = undefined + | Just l <- ml = return l + | Just d <- md = return $ d ++ b + | otherwise = undefined + +runPhase p _ | p `eqPhase` Cc || p `eqPhase` Ccpp || p `eqPhase` HCc || p `eqPhase` Cobjc = undefined +runPhase LlvmMangle _ = undefined +runPhase SplitAs _ = undefined +runPhase LlvmOpt _ = undefined +runPhase LlvmLlc dflags = phaseOutputFilename >> io (evaluate dflags) >> return undefined +runPhase MergeStub _ = phaseOutputFilename >> undefined +runPhase other _ = io (evaluate (show other)) >> undefined + +phaseOutputFilename :: CompPipeline () +phaseOutputFilename = do + PipeState{stop_phase, src_basename, output_spec, maybe_loc, hsc_env} <- getPipeState + io $ getOutputFilename stop_phase output_spec src_basename hsc_env StopLn maybe_loc + +getPipeState = P $ \state -> return (state, state) +io m = P $ \state -> do a <- m; return (state, ()) diff --git a/testsuite/tests/codeGen/should_compile/massive_array.hs b/testsuite/tests/codeGen/should_compile/massive_array.hs new file mode 100644 index 0000000000..a9db12bc4c --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/massive_array.hs @@ -0,0 +1,520 @@ +{-# OPTIONS_GHC -fno-ignore-interface-pragmas -fasm #-} + +-- This test breaks the linear register allocator when compiled the +-- flags -fnew-codegen, -fPIC and -dynamic, running out of stack +-- slots. You actually don't need 500 elements; 32-bit fails +-- with only about 260 or so. Works for stage1 too! It's a bit touchy +-- about optimization flags; if you specify -O or -O0 in OPTIONS_GHC +-- the bug goes away. Shows up in GHC 7.0.3. +-- +-- The -fno-ignore-interface-pragmas flag is pretty important! (Though I +-- don't quite know why yet.) Gigantic arrays like this show up in +-- generated code, in particular Parser.hs from Happy in GHC. + +module MassiveArray where + +import Data.Array + +f = array (0, 499) + $ [ + (0, 0), + (1, 1), + (2, 2), + (3, 3), + (4, 4), + (5, 5), + (6, 6), + (7, 7), + (8, 8), + (9, 9), + (10, 10), + (11, 11), + (12, 12), + (13, 13), + (14, 14), + (15, 15), + (16, 16), + (17, 17), + (18, 18), + (19, 19), + (20, 20), + (21, 21), + (22, 22), + (23, 23), + (24, 24), + (25, 25), + (26, 26), + (27, 27), + (28, 28), + (29, 29), + (30, 30), + (31, 31), + (32, 32), + (33, 33), + (34, 34), + (35, 35), + (36, 36), + (37, 37), + (38, 38), + (39, 39), + (40, 40), + (41, 41), + (42, 42), + (43, 43), + (44, 44), + (45, 45), + (46, 46), + (47, 47), + (48, 48), + (49, 49), + (50, 50), + (51, 51), + (52, 52), + (53, 53), + (54, 54), + (55, 55), + (56, 56), + (57, 57), + (58, 58), + (59, 59), + (60, 60), + (61, 61), + (62, 62), + (63, 63), + (64, 64), + (65, 65), + (66, 66), + (67, 67), + (68, 68), + (69, 69), + (70, 70), + (71, 71), + (72, 72), + (73, 73), + (74, 74), + (75, 75), + (76, 76), + (77, 77), + (78, 78), + (79, 79), + (80, 80), + (81, 81), + (82, 82), + (83, 83), + (84, 84), + (85, 85), + (86, 86), + (87, 87), + (88, 88), + (89, 89), + (90, 90), + (91, 91), + (92, 92), + (93, 93), + (94, 94), + (95, 95), + (96, 96), + (97, 97), + (98, 98), + (99, 99), + (100, 100), + (101, 101), + (102, 102), + (103, 103), + (104, 104), + (105, 105), + (106, 106), + (107, 107), + (108, 108), + (109, 109), + (110, 110), + (111, 111), + (112, 112), + (113, 113), + (114, 114), + (115, 115), + (116, 116), + (117, 117), + (118, 118), + (119, 119), + (120, 120), + (121, 121), + (122, 122), + (123, 123), + (124, 124), + (125, 125), + (126, 126), + (127, 127), + (128, 128), + (129, 129), + (130, 130), + (131, 131), + (132, 132), + (133, 133), + (134, 134), + (135, 135), + (136, 136), + (137, 137), + (138, 138), + (139, 139), + (140, 140), + (141, 141), + (142, 142), + (143, 143), + (144, 144), + (145, 145), + (146, 146), + (147, 147), + (148, 148), + (149, 149), + (150, 150), + (151, 151), + (152, 152), + (153, 153), + (154, 154), + (155, 155), + (156, 156), + (157, 157), + (158, 158), + (159, 159), + (160, 160), + (161, 161), + (162, 162), + (163, 163), + (164, 164), + (165, 165), + (166, 166), + (167, 167), + (168, 168), + (169, 169), + (170, 170), + (171, 171), + (172, 172), + (173, 173), + (174, 174), + (175, 175), + (176, 176), + (177, 177), + (178, 178), + (179, 179), + (180, 180), + (181, 181), + (182, 182), + (183, 183), + (184, 184), + (185, 185), + (186, 186), + (187, 187), + (188, 188), + (189, 189), + (190, 190), + (191, 191), + (192, 192), + (193, 193), + (194, 194), + (195, 195), + (196, 196), + (197, 197), + (198, 198), + (199, 199), + (200, 200), + (201, 201), + (202, 202), + (203, 203), + (204, 204), + (205, 205), + (206, 206), + (207, 207), + (208, 208), + (209, 209), + (210, 210), + (211, 211), + (212, 212), + (213, 213), + (214, 214), + (215, 215), + (216, 216), + (217, 217), + (218, 218), + (219, 219), + (220, 220), + (221, 221), + (222, 222), + (223, 223), + (224, 224), + (225, 225), + (226, 226), + (227, 227), + (228, 228), + (229, 229), + (230, 230), + (231, 231), + (232, 232), + (233, 233), + (234, 234), + (235, 235), + (236, 236), + (237, 237), + (238, 238), + (239, 239), + (240, 240), + (241, 241), + (242, 242), + (243, 243), + (244, 244), + (245, 245), + (246, 246), + (247, 247), + (248, 248), + (249, 249), + (250, 250), + (251, 251), + (252, 252), + (253, 253), + (254, 254), + (255, 255), + (256, 256), + (257, 257), + (258, 258), + (259, 259), + (260, 260), + (261, 261), + (262, 262), + (263, 263), + (264, 264), + (265, 265), + (266, 266), + (267, 267), + (268, 268), + (269, 269), + (270, 270), + (271, 271), + (272, 272), + (273, 273), + (274, 274), + (275, 275), + (276, 276), + (277, 277), + (278, 278), + (279, 279), + (280, 280), + (281, 281), + (282, 282), + (283, 283), + (284, 284), + (285, 285), + (286, 286), + (287, 287), + (288, 288), + (289, 289), + (290, 290), + (291, 291), + (292, 292), + (293, 293), + (294, 294), + (295, 295), + (296, 296), + (297, 297), + (298, 298), + (299, 299), + (300, 300), + (301, 301), + (302, 302), + (303, 303), + (304, 304), + (305, 305), + (306, 306), + (307, 307), + (308, 308), + (309, 309), + (310, 310), + (311, 311), + (312, 312), + (313, 313), + (314, 314), + (315, 315), + (316, 316), + (317, 317), + (318, 318), + (319, 319), + (320, 320), + (321, 321), + (322, 322), + (323, 323), + (324, 324), + (325, 325), + (326, 326), + (327, 327), + (328, 328), + (329, 329), + (330, 330), + (331, 331), + (332, 332), + (333, 333), + (334, 334), + (335, 335), + (336, 336), + (337, 337), + (338, 338), + (339, 339), + (340, 340), + (341, 341), + (342, 342), + (343, 343), + (344, 344), + (345, 345), + (346, 346), + (347, 347), + (348, 348), + (349, 349), + (350, 350), + (351, 351), + (352, 352), + (353, 353), + (354, 354), + (355, 355), + (356, 356), + (357, 357), + (358, 358), + (359, 359), + (360, 360), + (361, 361), + (362, 362), + (363, 363), + (364, 364), + (365, 365), + (366, 366), + (367, 367), + (368, 368), + (369, 369), + (370, 370), + (371, 371), + (372, 372), + (373, 373), + (374, 374), + (375, 375), + (376, 376), + (377, 377), + (378, 378), + (379, 379), + (380, 380), + (381, 381), + (382, 382), + (383, 383), + (384, 384), + (385, 385), + (386, 386), + (387, 387), + (388, 388), + (389, 389), + (390, 390), + (391, 391), + (392, 392), + (393, 393), + (394, 394), + (395, 395), + (396, 396), + (397, 397), + (398, 398), + (399, 399), + (400, 400), + (401, 401), + (402, 402), + (403, 403), + (404, 404), + (405, 405), + (406, 406), + (407, 407), + (408, 408), + (409, 409), + (410, 410), + (411, 411), + (412, 412), + (413, 413), + (414, 414), + (415, 415), + (416, 416), + (417, 417), + (418, 418), + (419, 419), + (420, 420), + (421, 421), + (422, 422), + (423, 423), + (424, 424), + (425, 425), + (426, 426), + (427, 427), + (428, 428), + (429, 429), + (430, 430), + (431, 431), + (432, 432), + (433, 433), + (434, 434), + (435, 435), + (436, 436), + (437, 437), + (438, 438), + (439, 439), + (440, 440), + (441, 441), + (442, 442), + (443, 443), + (444, 444), + (445, 445), + (446, 446), + (447, 447), + (448, 448), + (449, 449), + (450, 450), + (451, 451), + (452, 452), + (453, 453), + (454, 454), + (455, 455), + (456, 456), + (457, 457), + (458, 458), + (459, 459), + (460, 460), + (461, 461), + (462, 462), + (463, 463), + (464, 464), + (465, 465), + (466, 466), + (467, 467), + (468, 468), + (469, 469), + (470, 470), + (471, 471), + (472, 472), + (473, 473), + (474, 474), + (475, 475), + (476, 476), + (477, 477), + (478, 478), + (479, 479), + (480, 480), + (481, 481), + (482, 482), + (483, 483), + (484, 484), + (485, 485), + (486, 486), + (487, 487), + (488, 488), + (489, 489), + (490, 490), + (491, 491), + (492, 492), + (493, 493), + (494, 494), + (495, 495), + (496, 496), + (497, 497), + (498, 498), + (499, 499) + ] diff --git a/testsuite/tests/codeGen/should_run/1852.hs b/testsuite/tests/codeGen/should_run/1852.hs new file mode 100644 index 0000000000..f5d9370741 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/1852.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +import Data.List + +data Vec4 = Vec4 !Float !Float !Float !Float + + +main :: IO () +main = print traceList + +traceList = concatMap (\(x,y) -> let (r,g,b,a) = getPixel (x,y) in [r,g,b,a]) + [(0,0)] + where + getPixel (x,y) = (red,green,blue,alpha) + where + Vec4 fr fg fb fa = seq x (Vec4 1 2 3 4) + red = round fr + green = round fg + blue = round fb + alpha = round fa diff --git a/testsuite/tests/codeGen/should_run/1852.stdout b/testsuite/tests/codeGen/should_run/1852.stdout new file mode 100644 index 0000000000..8adb9bb604 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/1852.stdout @@ -0,0 +1 @@ +[1,2,3,4] diff --git a/testsuite/tests/codeGen/should_run/1861.hs b/testsuite/tests/codeGen/should_run/1861.hs new file mode 100644 index 0000000000..b6136f4ea2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/1861.hs @@ -0,0 +1,9 @@ +import System.Environment +main = do [x] <- getArgs + print (read x < (1e400 :: Double)) + print (read x < (-1e400 :: Double)) + print (read x == (0/0 :: Double)) + -- the last doesn't get constant-folded to NaN, so we're not really + -- testing properly here. Still, we might manage to constant fold + -- this in the future, so I'll leave it in place. + diff --git a/testsuite/tests/codeGen/should_run/1861.stdout b/testsuite/tests/codeGen/should_run/1861.stdout new file mode 100644 index 0000000000..06eb4d10ee --- /dev/null +++ b/testsuite/tests/codeGen/should_run/1861.stdout @@ -0,0 +1,3 @@ +True +False +False diff --git a/testsuite/tests/codeGen/should_run/2080.hs b/testsuite/tests/codeGen/should_run/2080.hs new file mode 100644 index 0000000000..a1baf757f5 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/2080.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -XMagicHash #-} +module Main where +import GHC.Base + +import Foreign +import Foreign.C +import GHC.Ptr (Ptr(..)) + +utf8DecodeChar# :: Addr# -> Bool -> Bool +{-# NOINLINE utf8DecodeChar# #-} +utf8DecodeChar# a# fred = + case () of + _ | word2Int# (indexWord8OffAddr# a# 0#) <=# 0x7F# -> True + +-- Omitting the next line gives an ASSERT error: +-- ghc-6.9: panic! (the 'impossible' happened) +-- (GHC version 6.9 for x86_64-unknown-linux): +-- ASSERT failed! file nativeGen/MachCodeGen.hs line 1049 +-- %MO_S_Le_I8(I8[R2], 127 :: I8) + | fred -> True + + | otherwise -> False + +main = print (utf8DecodeChar# "\128"# False) -- should be False + diff --git a/testsuite/tests/codeGen/should_run/2080.stdout b/testsuite/tests/codeGen/should_run/2080.stdout new file mode 100644 index 0000000000..bc59c12aa1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/2080.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/codeGen/should_run/2838.hs b/testsuite/tests/codeGen/should_run/2838.hs new file mode 100644 index 0000000000..0933c1203e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/2838.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Main(main,complement) where + +import GHC.Base +import GHC.Num + +complement (I# x#) = I# (word2Int# (int2Word# (4294967295#) `xor#` int2Word# (-1#))) + +main = print (complement (-1)) diff --git a/testsuite/tests/codeGen/should_run/2838.stdout b/testsuite/tests/codeGen/should_run/2838.stdout new file mode 100644 index 0000000000..573541ac97 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/2838.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/codeGen/should_run/2838.stdout-ws-64 b/testsuite/tests/codeGen/should_run/2838.stdout-ws-64 new file mode 100644 index 0000000000..1862ace676 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/2838.stdout-ws-64 @@ -0,0 +1 @@ +-4294967296 diff --git a/testsuite/tests/codeGen/should_run/3207.hs b/testsuite/tests/codeGen/should_run/3207.hs new file mode 100644 index 0000000000..4738fca343 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3207.hs @@ -0,0 +1,29 @@ +module Main where + +import Control.Monad.ST.Lazy +import Data.STRef.Lazy +import Data.Array.ST +import Data.Int +import Debug.Trace + +data Refs s = Refs + { memory :: STArray s Int8 Int8 + , pc :: STRef s Int8 + } + +main :: IO () +main = do + print $ runST m + where + m = do + m <- newArray_ (0,30) + p <- newSTRef 0 + let r = Refs m p + writeArray m 0 0x4 + v <- readSTRef p + modifySTRef p (+1) +-- trace ("v: " ++ show v) $ return () + op <- readArray m v + case {- trace ("v: " ++ show v) $ -} op of + 0x4 -> modifySTRef p (+100) -- should run this + n -> error ("should never match this: " ++ show n) diff --git a/testsuite/tests/codeGen/should_run/3207.stdout b/testsuite/tests/codeGen/should_run/3207.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3207.stdout @@ -0,0 +1 @@ +() diff --git a/testsuite/tests/codeGen/should_run/3561.hs b/testsuite/tests/codeGen/should_run/3561.hs new file mode 100644 index 0000000000..44258a839c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3561.hs @@ -0,0 +1,10 @@ +main = print $ pqr' 0 1 + +pqr' :: Int -> Int -> Integer +pqr' a b | a == b - 1 = rab + | otherwise = ram * rmb + where m = (a + b) `div` 2 + ram = pqr' a m + rmb = pqr' m b + rab = toInteger (6 * b - 5) * toInteger (2 * b - 1) * + toInteger (6 * b - 1) diff --git a/testsuite/tests/codeGen/should_run/3561.stdout b/testsuite/tests/codeGen/should_run/3561.stdout new file mode 100644 index 0000000000..7ed6ff82de --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3561.stdout @@ -0,0 +1 @@ +5 diff --git a/testsuite/tests/codeGen/should_run/3677.hs b/testsuite/tests/codeGen/should_run/3677.hs new file mode 100644 index 0000000000..67b12b2672 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3677.hs @@ -0,0 +1,15 @@ +module Main(main) where + +main = print (take 2 (edi2 0)) + +-- In 6.12, edi2 lead to a stack overflow (see #3677) + +edi :: Integer -> [Integer] +edi x | x `mod` 1000000 == 0 = x : edi (x+1) + | otherwise = edi (x+1) + +edi2 :: Integer -> [Integer] +edi2 x | x `mod` 1000000 == 0 = x : y + | otherwise = y + where + y = edi2 (x+1) diff --git a/testsuite/tests/codeGen/should_run/3677.stdout b/testsuite/tests/codeGen/should_run/3677.stdout new file mode 100644 index 0000000000..53b22189de --- /dev/null +++ b/testsuite/tests/codeGen/should_run/3677.stdout @@ -0,0 +1 @@ +[0,1000000] diff --git a/testsuite/tests/codeGen/should_run/4441.hs b/testsuite/tests/codeGen/should_run/4441.hs new file mode 100644 index 0000000000..ee96170af8 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/4441.hs @@ -0,0 +1,20 @@ +module Main where + +import Numeric +import System.IO + +main = do + let d = read "2.0e-2" :: Double + print $ "Float Version : " ++ (fToStr $ realToFrac d) + print $ "Double Version: " ++ (dToStr d) + +double :: IO Double +double = do + x <- getLine + return $ read x + +dToStr :: Double -> String +dToStr d = show d + +fToStr :: Float -> String +fToStr = (dToStr . realToFrac) diff --git a/testsuite/tests/codeGen/should_run/4441.stdout b/testsuite/tests/codeGen/should_run/4441.stdout new file mode 100644 index 0000000000..865b73fb17 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/4441.stdout @@ -0,0 +1,2 @@ +"Float Version : 1.9999999552965164e-2" +"Double Version: 2.0e-2" diff --git a/testsuite/tests/codeGen/should_run/5129.hs b/testsuite/tests/codeGen/should_run/5129.hs new file mode 100644 index 0000000000..6bc1912754 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/5129.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +import Control.Exception as E +import Data.Typeable + +throwIfNegative :: Int -> String +throwIfNegative n | n < 0 = error "negative" + | otherwise = "no worries" +{-# NOINLINE throwIfNegative #-} + +data HUnitFailure = HUnitFailure String deriving (Show,Typeable) +instance Exception HUnitFailure + +assertFailure msg = E.throw (HUnitFailure msg) + +case_negative = + handleJust errorCalls (const $ return ()) $ do + evaluate $ throwIfNegative (-1) + assertFailure "must throw when given a negative number" + where errorCalls (ErrorCall _) = Just () + +main = case_negative diff --git a/testsuite/tests/codeGen/should_run/5149.hs b/testsuite/tests/codeGen/should_run/5149.hs new file mode 100644 index 0000000000..c0c88e3015 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/5149.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} +module Main where + +import GHC.Exts + +foreign import prim "f5149" f :: Int# -> Int# -> Double# -> Int# + +main = print (I# (f 1# 2# 1.0##)) diff --git a/testsuite/tests/codeGen/should_run/5149.stdout b/testsuite/tests/codeGen/should_run/5149.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/5149.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/codeGen/should_run/5149_cmm.cmm b/testsuite/tests/codeGen/should_run/5149_cmm.cmm new file mode 100644 index 0000000000..b1e3dd6c43 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/5149_cmm.cmm @@ -0,0 +1,29 @@ +#include "Cmm.h" + +/* This code is carefully arranged to tickle the bug reported in #5149 */ +f5149 +{ + D_ z; + + z = D1; + + W_ x,y; + x = R1; + y = R2; + + if (x > y) { + goto a; /* this jump is shortcutted to g5149 */ + } else { + goto b; + } + + a: + jump g5149; + b: + RET_N(TO_W_(%f2i32(z))); +} + +g5149 +{ + jump %ENTRY_CODE(Sp(0)); +} diff --git a/testsuite/tests/codeGen/should_run/Cgrun067A.hs b/testsuite/tests/codeGen/should_run/Cgrun067A.hs new file mode 100644 index 0000000000..96e944ed25 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/Cgrun067A.hs @@ -0,0 +1,16 @@ +-- Bug doesn't show up on -O0 +{-# OPTIONS_GHC -O #-} +module Cgrun067A (miscompiledFn) where + +import Foreign.C +import Foreign + +miscompiledFn :: CString -> IO String +miscompiledFn cp = do + l <- lengthArray0 0 cp + if l <= 0 then return "" else loop "" (l-1) + where + loop s i = do + xval <- peekElemOff cp i + let val = castCCharToChar xval + val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1) diff --git a/testsuite/tests/codeGen/should_run/Makefile b/testsuite/tests/codeGen/should_run/Makefile new file mode 100644 index 0000000000..4a268530f1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/Makefile @@ -0,0 +1,4 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T new file mode 100644 index 0000000000..f4a5dc66af --- /dev/null +++ b/testsuite/tests/codeGen/should_run/all.T @@ -0,0 +1,89 @@ +# Test +RTS -G1 here (it isn't tested anywhere else) +setTestOpts(extra_ways(['g1'])) + +test('cgrun001', normal, compile_and_run, ['']) +test('cgrun002', normal, compile_and_run, ['']) +test('cgrun003', normal, compile_and_run, ['']) +test('cgrun004', normal, compile_and_run, ['']) +test('cgrun005', normal, compile_and_run, ['']) +test('cgrun006', normal, compile_and_run, ['']) +test('cgrun007', normal, compile_and_run, ['']) +test('cgrun008', normal, compile_and_run, ['']) +test('cgrun009', normal, compile_and_run, ['']) +test('cgrun010', normal, compile_and_run, ['']) +test('cgrun011', normal, compile_and_run, ['']) +test('cgrun012', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun013', normal, compile_and_run, ['']) +test('cgrun014', normal, compile_and_run, ['']) +test('cgrun015', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun016', exit_code(1), compile_and_run, ['']) +test('cgrun017', normal, compile_and_run, ['']) +test('cgrun018', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun019', normal, compile_and_run, ['']) +test('cgrun020', normal, compile_and_run, ['']) +test('cgrun021', normal, compile_and_run, ['']) +test('cgrun022', normal, compile_and_run, ['']) +test('cgrun024', normal, compile_and_run, ['']) +test('cgrun025', compose(reqlib('regex-compat'), compose(extra_run_opts('cg025.hs'),exit_code(1))), + compile_and_run, ['-package regex-compat']) +test('cgrun026', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun027', normal, compile_and_run, ['']) +test('cgrun028', normal, compile_and_run, ['']) +test('cgrun031', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun032', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun033', only_compiler_types(['ghc']), compile_and_run, ['']) +test('cgrun034', normal, compile_and_run, ['']) +test('cgrun035', normal, compile_and_run, ['']) +test('cgrun036', normal, compile_and_run, ['']) +test('cgrun037', normal, compile_and_run, ['']) +test('cgrun038', normal, compile_and_run, ['']) +test('cgrun039', normal, compile_and_run, ['']) +test('cgrun040', normal, compile_and_run, ['']) +test('cgrun043', normal, compile_and_run, ['']) +test('cgrun044', normal, compile_and_run, ['']) +test('cgrun045', exit_code(1), compile_and_run, ['']) +test('cgrun046', normal, compile_and_run, ['']) +test('cgrun047', normal, compile_and_run, ['']) +test('cgrun048', normal, compile_and_run, ['']) +test('cgrun049', normal, compile_and_run, ['-funbox-strict-fields']) +test('cgrun050', normal, compile_and_run, ['']) +# Doesn't work with External Core due to datatype declaration with no constructors +test('cgrun051', (compose (expect_fail_for(['extcore','optextcore']),exit_code(1))), compile_and_run, ['']) +test('cgrun052', only_ways(['optasm']), compile_and_run, ['-funbox-strict-fields']) +test('cgrun053', normal, compile_and_run, ['']) +test('cgrun054', normal, compile_and_run, ['']) +test('cgrun055', normal, compile_and_run, ['']) +test('cgrun056', normal, compile_and_run, ['']) +test('cgrun057', composes([expect_broken(948), + only_ways(['prof','profasm']), + extra_run_opts('+RTS -xc')]), + compile_and_run, ['']) +test('cgrun058', normal, compile_and_run, ['']) +test('cgrun059', exit_code(1), compile_and_run, ['']) +test('cgrun060', + extra_run_opts('+RTS -K64k -RTS'), + compile_and_run, ['']) +test('cgrun061', normal, compile_and_run, ['']) +test('cgrun062', normal, compile_and_run, ['']) +test('cgrun063', normal, compile_and_run, ['']) +test('cgrun064', normal, compile_and_run, ['']) +test('cgrun065', normal, compile_and_run, ['']) +test('cgrun066', normal, compile_and_run, ['']) +test('cgrun067', extra_clean(['Cgrun067A.hi', 'Cgrun067A.o']), + compile_and_run, ['']) +test('cgrun068', reqlib('random'), compile_and_run, ['']) +test('cgrun069', omit_ways(['ghci']), multisrc_compile_and_run, + ['cgrun069', ['cgrun069_cmm.cmm'], '']) +test('cgrun070', normal, compile_and_run, ['']) + +test('1852', normal, compile_and_run, ['']) +test('1861', extra_run_opts('0'), compile_and_run, ['']) +test('2080', normal, compile_and_run, ['']) +test('2838', normal, compile_and_run, ['']) +test('3207', normal, compile_and_run, ['']) +test('3561', normal, compile_and_run, ['']) +test('3677', extra_run_opts('+RTS -K8k -RTS'), compile_and_run, ['']) +test('4441', normal, compile_and_run, ['']) +test('5149', omit_ways(['ghci']), multisrc_compile_and_run, + ['5149', ['5149_cmm.cmm'], '']) +test('5129', normal, compile_and_run, ['']) diff --git a/testsuite/tests/codeGen/should_run/cgrun001.hs b/testsuite/tests/codeGen/should_run/cgrun001.hs new file mode 100644 index 0000000000..5482f13127 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun001.hs @@ -0,0 +1,6 @@ +-- !! cg001: main = -42 -- take 1 + +main = print ( f () ) + where + f :: a -> Int + f x = -42 diff --git a/testsuite/tests/codeGen/should_run/cgrun001.stdout b/testsuite/tests/codeGen/should_run/cgrun001.stdout new file mode 100644 index 0000000000..6a0e60d48b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun001.stdout @@ -0,0 +1 @@ +-42 diff --git a/testsuite/tests/codeGen/should_run/cgrun002.hs b/testsuite/tests/codeGen/should_run/cgrun002.hs new file mode 100644 index 0000000000..dddaabd66f --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun002.hs @@ -0,0 +1,12 @@ +main = print ((f id2) (10 + thirty_two)) + where + f x = g x + where + g x = h x + where + h x = x + + thirty_two :: Int + thirty_two = 32 + +id2 x = x diff --git a/testsuite/tests/codeGen/should_run/cgrun002.stdout b/testsuite/tests/codeGen/should_run/cgrun002.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun002.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun003.hs b/testsuite/tests/codeGen/should_run/cgrun003.hs new file mode 100644 index 0000000000..47b2d9e7bf --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun003.hs @@ -0,0 +1,11 @@ +main = print (id2 (id2 id2) (42::Int)) +-- where +-- id2 = s k k + +-- id2 x = s k k x + +id2 = s k k + +s x y z = x z (y z) + +k x y = x diff --git a/testsuite/tests/codeGen/should_run/cgrun003.stdout b/testsuite/tests/codeGen/should_run/cgrun003.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun003.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun004.hs b/testsuite/tests/codeGen/should_run/cgrun004.hs new file mode 100644 index 0000000000..1f4a2737c3 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun004.hs @@ -0,0 +1 @@ +main = print (length ([9,8,7,6,5,4,3,2,1] :: [Int])) diff --git a/testsuite/tests/codeGen/should_run/cgrun004.stdout b/testsuite/tests/codeGen/should_run/cgrun004.stdout new file mode 100644 index 0000000000..ec635144f6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun004.stdout @@ -0,0 +1 @@ +9 diff --git a/testsuite/tests/codeGen/should_run/cgrun005.hs b/testsuite/tests/codeGen/should_run/cgrun005.hs new file mode 100644 index 0000000000..4159d4c882 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun005.hs @@ -0,0 +1,6 @@ +-- !! answer: 65532 + +main = print foo + +foo :: Int +foo = ((1 + 2 + 32767 - 4) * 6) --later? `div` 3 diff --git a/testsuite/tests/codeGen/should_run/cgrun005.stdout b/testsuite/tests/codeGen/should_run/cgrun005.stdout new file mode 100644 index 0000000000..12bd33f964 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun005.stdout @@ -0,0 +1 @@ +196596 diff --git a/testsuite/tests/codeGen/should_run/cgrun006.hs b/testsuite/tests/codeGen/should_run/cgrun006.hs new file mode 100644 index 0000000000..609c3c2b4b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun006.hs @@ -0,0 +1,6 @@ +main = print (length thirteen_ones) + where + thirteen_ones = take (13::Int) ones + + ones :: [Int] + ones = 1 : ones diff --git a/testsuite/tests/codeGen/should_run/cgrun006.stdout b/testsuite/tests/codeGen/should_run/cgrun006.stdout new file mode 100644 index 0000000000..b1bd38b62a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun006.stdout @@ -0,0 +1 @@ +13 diff --git a/testsuite/tests/codeGen/should_run/cgrun007.hs b/testsuite/tests/codeGen/should_run/cgrun007.hs new file mode 100644 index 0000000000..317b921a42 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun007.hs @@ -0,0 +1,14 @@ +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +main = print (height our_tree) + where + our_tree :: Tree Int + our_tree = + Branch (Branch (Leaf 1) (Branch (Branch (Leaf 1) (Leaf 1)) (Leaf 1))) + (Branch (Leaf 1) (Leaf 1)) + + +height :: Tree a -> Int + +height (Leaf _) = 1 +height (Branch t1 t2) = 1 + max (height t1) (height t2) diff --git a/testsuite/tests/codeGen/should_run/cgrun007.stdout b/testsuite/tests/codeGen/should_run/cgrun007.stdout new file mode 100644 index 0000000000..7ed6ff82de --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun007.stdout @@ -0,0 +1 @@ +5 diff --git a/testsuite/tests/codeGen/should_run/cgrun008.hs b/testsuite/tests/codeGen/should_run/cgrun008.hs new file mode 100644 index 0000000000..1713b4834e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun008.hs @@ -0,0 +1,12 @@ +main = print (length comp_list) + where + comp_list :: [(Int,Int)] + comp_list = [ (elem1,elem2) + | elem1 <- given_list, + elem2 <- given_list, + elem1 >= (4::Int), + elem2 < (3::Int) + ] + + given_list :: [Int] + given_list = [1,2,3,4,5,6,7,8,9] diff --git a/testsuite/tests/codeGen/should_run/cgrun008.stdout b/testsuite/tests/codeGen/should_run/cgrun008.stdout new file mode 100644 index 0000000000..48082f72f0 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun008.stdout @@ -0,0 +1 @@ +12 diff --git a/testsuite/tests/codeGen/should_run/cgrun009.hs b/testsuite/tests/codeGen/should_run/cgrun009.hs new file mode 100644 index 0000000000..de03fc42cd --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun009.hs @@ -0,0 +1,7 @@ +main = print (length take_list) + where + take_list :: [Int] + take_list = takeWhile (\ x -> x < 6) given_list + + given_list :: [Int] + given_list = [1,2,3,4,5,6,7,8,9] diff --git a/testsuite/tests/codeGen/should_run/cgrun009.stdout b/testsuite/tests/codeGen/should_run/cgrun009.stdout new file mode 100644 index 0000000000..7ed6ff82de --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun009.stdout @@ -0,0 +1 @@ +5 diff --git a/testsuite/tests/codeGen/should_run/cgrun010.hs b/testsuite/tests/codeGen/should_run/cgrun010.hs new file mode 100644 index 0000000000..ccc323d4cf --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun010.hs @@ -0,0 +1,5 @@ +main = print a + where + a :: Int + b :: Int + (a, b) = (3 + 4, 5 + 6) diff --git a/testsuite/tests/codeGen/should_run/cgrun010.stdout b/testsuite/tests/codeGen/should_run/cgrun010.stdout new file mode 100644 index 0000000000..7f8f011eb7 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun010.stdout @@ -0,0 +1 @@ +7 diff --git a/testsuite/tests/codeGen/should_run/cgrun011.hs b/testsuite/tests/codeGen/should_run/cgrun011.hs new file mode 100644 index 0000000000..c687e50272 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun011.hs @@ -0,0 +1,29 @@ +-- !!! simple overloading example + +class Foo a where + foo :: a -> a -> Bool + +class (Foo a) => Bar a where + bar :: a -> a -> Bool + +instance Foo Int where + foo a b = a /= b + +instance Foo Bool where + foo a b = a /= b + +instance Bar Int where + bar a b = a < b + +instance Bar Bool where + bar a b = a < b + +foO = if bar (2::Int) (3::Int) then + if bar False True then + (42::Int) + else + (888::Int) + else + (999::Int) + +main = print foO diff --git a/testsuite/tests/codeGen/should_run/cgrun011.stdout b/testsuite/tests/codeGen/should_run/cgrun011.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun011.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun012.hs b/testsuite/tests/codeGen/should_run/cgrun012.hs new file mode 100644 index 0000000000..8fe0a869c4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun012.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE MagicHash #-} +-- !!! move arguments around on the stacks, mainly the B stack + +import GHC.Base ( Float#, Double#, Int#, Int(..) ) + + +main = print foo + +foo = I# + ( f 1.1## + 2.1# + True + 3.1## + 4.1# + 5.1## + 6.1## + 42# -- the answer! + 7.1# + 8.1# ) + where + f :: Double# -> Float# -> Bool -> Double# -> Float# + -> Double# -> Double# -> Int# -> Float# -> Float# + -> Int# + f b1 s2 t b3 s4 b5 b6 i42 s7 s8 + -- evens, then odds + = g s2 b3 b5 i42 s8 b1 t s4 b6 s7 + + g :: Float# -> Double# -> Double# -> Int# -> Float# + -> Double# -> Bool -> Float# -> Double# -> Float# + -> Int# + g s2 b3 b5 i42 s8 b1 t s4 b6 s7 + -- powers of 2 backwards, then others forwards + = h s7 b6 t b5 s2 b3 i42 s8 b1 s4 + + h :: Float# -> Double# -> Bool -> Double# -> Float# + -> Double# -> Int# -> Float# -> Double# -> Float# + -> Int# + h s7 b6 t b5 s2 b3 i42 s8 b1 s4 + = i42 diff --git a/testsuite/tests/codeGen/should_run/cgrun012.stdout b/testsuite/tests/codeGen/should_run/cgrun012.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun012.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun013.hs b/testsuite/tests/codeGen/should_run/cgrun013.hs new file mode 100644 index 0000000000..4d2f06de6c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun013.hs @@ -0,0 +1,78 @@ +{- +From: Kevin Hammond <kh> +To: partain +Subject: Nasty Overloading +Date: Wed, 23 Oct 91 16:19:46 BST +-} +module Main where + +class Foo a where + o1 :: a -> a -> Bool + o2 :: a -> Int + +-- o2 :: Int + -- Lennart: The type of method o2 does not contain the variable a + -- (and it must according to line 1 page 29 of the manual). + +class Foo tyvar => Bar tyvar where + o3 :: a -> tyvar -> tyvar + +-- class (Eq a, Foo a) => Baz a where +class (Ord a, Foo a) => Baz a where + o4 :: a -> a -> (String,String,String,a) + +instance (Ord a, Foo a) => Foo [a] where + o2 x = 100 + o1 a b = a < b || o1 (head a) (head b) + +-- instance Bar [a] where +instance (Ord a, Foo a) => Bar [a] where + o3 x l = [] + -- + -- Lennart: I guess the instance declaration + -- instance Bar [w] where + -- o3 x l = [] + -- is wrong because to be a Bar you have to be a Foo. For [w] to + -- be a Foo, w has to be Ord and Foo. But w is not Ord or Foo in + -- this instance declaration so it must be wrong. (Page 31, line + -- 7: The context c' must imply ...) + +instance Baz a => Baz [a] where + o4 [] [] = ("Nil", "Nil", "Nil", []) + o4 l1 l2 = + (if o1 l1 l2 then "Y" else "N", + if l1 == l2 then "Y" else "N", +-- if o4 (head l1) (head l2) then "Y" else "N", + case o4 (head l1) (head l2) of + (_,_,_,l3) -> if (o1 (head l1) l3) then "Y" else "N", + l1 ++ l2 ) + +instance Foo Int where + o2 x = x + o1 i j = i == j + +instance Bar Int where + o3 _ j = j + 1 + +instance Baz Int where +-- o4 i j = i > j + o4 i j = (if i>j then "Y" else "Z", "p", "q", i+j) +--simpl:o4 i j = ("Z", "p", "q", i+j) + +{- also works w/ glhc! -} + +main = if o4 [1,2,3] [1,3,2::Int] /= ("Y","N","Y",[1,2,3,1,3,2]) then + (print "43\n") + else (print "144\n") + +{- works: glhc +main = case o4 [1,2,3] [1,3,2::Int] of + (s1,s2,s3,x) -> print s1 + +main = case o4 ([]::[Int]) ([]::[Int]) of + (s1,s2,s3,x) -> print s1 +-} + +{- simple main: breaks nhc, works w/ glhc +main = case o4 (3::Int) (4::Int) of (s1,s2,s3,x) -> print s1 +-} diff --git a/testsuite/tests/codeGen/should_run/cgrun013.stdout b/testsuite/tests/codeGen/should_run/cgrun013.stdout new file mode 100644 index 0000000000..a865e6b929 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun013.stdout @@ -0,0 +1 @@ +"43\n" diff --git a/testsuite/tests/codeGen/should_run/cgrun014.hs b/testsuite/tests/codeGen/should_run/cgrun014.hs new file mode 100644 index 0000000000..a01c1017ad --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun014.hs @@ -0,0 +1,3 @@ +-- !! cg014: main = -42 -- twice: in Float and Double + +main = print ((show ( (-42) :: Float )) ++ " " ++ (show ( (-42) :: Double )) ++ "\n") diff --git a/testsuite/tests/codeGen/should_run/cgrun014.stdout b/testsuite/tests/codeGen/should_run/cgrun014.stdout new file mode 100644 index 0000000000..6f6cbc5cba --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun014.stdout @@ -0,0 +1 @@ +"-42.0 -42.0\n" diff --git a/testsuite/tests/codeGen/should_run/cgrun015.hs b/testsuite/tests/codeGen/should_run/cgrun015.hs new file mode 100644 index 0000000000..eba3b8ab30 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun015.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MagicHash #-} +module Main ( main ) where + +import Foreign +import Foreign.C +import GHC.Exts + +data CList = CNil | CCons Int# CList + +mk :: Int# -> CList +mk n = if (n ==# 0#) + then CNil + else CCons 1# (mk (n -# 1#)) + +clen :: CList -> Int# +clen CNil = 0# +clen (CCons _ cl) = 1# +# (clen cl) + +main = case (clen list4) of + len4 -> + case (len4 +# len4) of + 8# -> finish 65# -- 'A' + _ -> finish 66# -- 'B' + where + list4 = mk 4# + +finish :: Int# -> IO () +finish n = c_putchar (castCharToCChar (C# (chr# n))) >> return () + +foreign import ccall unsafe "putchar" + c_putchar :: CChar -> IO CInt diff --git a/testsuite/tests/codeGen/should_run/cgrun015.stdout b/testsuite/tests/codeGen/should_run/cgrun015.stdout new file mode 100644 index 0000000000..8c7e5a667f --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun015.stdout @@ -0,0 +1 @@ +A
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun016.hs b/testsuite/tests/codeGen/should_run/cgrun016.hs new file mode 100644 index 0000000000..ba5dd04fea --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun016.hs @@ -0,0 +1,9 @@ +-- !!! tests calls of `error' (that make calls of `error'...) +-- +main = error ("1st call to error\n"++( + error ("2nd call to error\n"++( + error ("3rd call to error\n"++( + error ("4th call to error\n"++( + error ("5th call to error\n"++( + error ("6th call to error" + ))))))))))) diff --git a/testsuite/tests/codeGen/should_run/cgrun016.stderr b/testsuite/tests/codeGen/should_run/cgrun016.stderr new file mode 100644 index 0000000000..03635bfa36 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun016.stderr @@ -0,0 +1 @@ +cgrun016: 6th call to error diff --git a/testsuite/tests/codeGen/should_run/cgrun016.stdout b/testsuite/tests/codeGen/should_run/cgrun016.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun016.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun017.hs b/testsuite/tests/codeGen/should_run/cgrun017.hs new file mode 100644 index 0000000000..275eb9b31b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun017.hs @@ -0,0 +1,33 @@ +-- !!! test of cyclic default methods +-- +class Foo a where + op1 :: Fractional b => a -> b -> Bool + op2 :: Fractional b => a -> b -> Bool + op3 :: Fractional b => a -> b -> Bool + op4 :: Fractional b => a -> b -> Bool + op5 :: Fractional b => a -> b -> Bool + op6 :: Fractional b => a -> b -> Bool + + -- each depends on the next: + op1 a b = not (op2 a b) + op2 a b = not (op3 a b) + op3 a b = not (op4 a b) + op4 a b = not (op5 a b) + op5 a b = not (op6 a b) + op6 a b = not (op1 a b) + +-- now some instance decls to break the cycle: +instance Foo Int where + op1 a b = a == 42 + +instance Foo Char where + op1 a b = a == 'c' + +instance Foo a => Foo [a] where + op1 a b = null a + +-- try it: +main = do + putStr (show (op2 (3::Int) 3.14159)) + putStr (show (op2 'X' 3.14159)) + putStr (show (op2 ([]::[Char])3.14159)) diff --git a/testsuite/tests/codeGen/should_run/cgrun017.stdout b/testsuite/tests/codeGen/should_run/cgrun017.stdout new file mode 100644 index 0000000000..c5b23b39d2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun017.stdout @@ -0,0 +1 @@ +TrueTrueFalse
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun018.hs b/testsuite/tests/codeGen/should_run/cgrun018.hs new file mode 100644 index 0000000000..49f9800cb6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun018.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MagicHash #-} +-- !!! test of datatype with many unboxed fields +-- +import GHC.Base( Float# ) +import GHC.Float + +main = print (selectee1 + selectee2) + +data Tfo = Tfo Float# Float# Float# Float# Float# Float# Float# Float# Float# Float# Float# Float# + +yyy = (Tfo (-0.0018#) (-0.8207#) (0.5714#) + (0.2679#) (-0.5509#) (-0.7904#) + (0.9634#) (0.1517#) (0.2209#) + (0.0073#) (8.4030#) (0.6232#)) + +xxx = (Tfo (-0.8143#) (-0.5091#) (-0.2788#) + (-0.0433#) (-0.4257#) (0.9038#) + (-0.5788#) (0.7480#) (0.3246#) + (1.5227#) (6.9114#) (-7.0765#)) + +selectee1 = F# (case xxx of + Tfo _ _ _ _ _ _ _ x _ _ _ _ -> x) + +selectee2 = F# (case xxx of + Tfo _ _ y _ _ _ _ _ _ _ _ _ -> y) diff --git a/testsuite/tests/codeGen/should_run/cgrun018.stdout b/testsuite/tests/codeGen/should_run/cgrun018.stdout new file mode 100644 index 0000000000..805ee30112 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun018.stdout @@ -0,0 +1 @@ +0.46920002 diff --git a/testsuite/tests/codeGen/should_run/cgrun019.hs b/testsuite/tests/codeGen/should_run/cgrun019.hs new file mode 100644 index 0000000000..242ea3b4df --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun019.hs @@ -0,0 +1,3 @@ +-- !!! printing of floating-pt numbers +-- +main = print (1.234e5 :: Float) diff --git a/testsuite/tests/codeGen/should_run/cgrun019.stdout b/testsuite/tests/codeGen/should_run/cgrun019.stdout new file mode 100644 index 0000000000..9ed4dbb21c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun019.stdout @@ -0,0 +1 @@ +123400.0 diff --git a/testsuite/tests/codeGen/should_run/cgrun020.hs b/testsuite/tests/codeGen/should_run/cgrun020.hs new file mode 100644 index 0000000000..9f4b7c64e1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun020.hs @@ -0,0 +1,3 @@ +-- !!! reading/showing of Ints/Integers +-- +main = print ((read "-1") :: Integer) diff --git a/testsuite/tests/codeGen/should_run/cgrun020.stdout b/testsuite/tests/codeGen/should_run/cgrun020.stdout new file mode 100644 index 0000000000..3a2e3f4984 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun020.stdout @@ -0,0 +1 @@ +-1 diff --git a/testsuite/tests/codeGen/should_run/cgrun021.hs b/testsuite/tests/codeGen/should_run/cgrun021.hs new file mode 100644 index 0000000000..190f8dd155 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun021.hs @@ -0,0 +1,60 @@ +-- !!! Tests garbage collection in the branch of a case +-- !!! alternative where the constructor is returned in the heap. + +{- This is also a rather stressful test for another reason. + The mutual recursion between munch and f causes lots of + closures to be built, of the form (munch n s), for some n and s. + Now, all of these closures are entered and each has as its value + the result delivere by the next; so the result is that there is + a massive chain of identical updates. + + As it turns out, they are mostly garbage, so the GC could eliminate + them (though this isn't implemented at present), but that isn't + necessarily the case. + + The only correct solution is to spot that the updates are all + updating with the same value (update frames stacked on top of each + other), and update all but one with indirections to the last + remaining one. This could be done by GC, or at the moment the + frame is pushed. + + Incidentally, hbc won't have this particular problem, because it + updates immediately. + + NOTE: [March 97] Now that stack squeezing happens when GC happens, + the stack is squished at GC. So this program uses a small stack + in a small heap (eg 4m heap 2m stack), but in a big heap (no GC) + it needs a much bigger stack (10m)! It would be better to try GC/stack + squeezing on stack oflo. +-} + +module Main where + +main = munch 100000 (inf 3) + +data Stream a + = MkStream a a a a a a a a a (Stream a) + | Empty + +inf :: Int -> Stream Int +inf n = MkStream n n n n n n n n n (inf n) + +munch :: Int -> Stream a -> IO () + +munch n Empty = return () -- error "this never happens!\n" + -- this first equation mks it non-strict in "n" + -- (NB: call the "error" makes it strict) + +munch 0 _ = putStr "I succeeded!\n" +munch n s = case (f n s) of + (True, rest) -> rest + (False, _) -> error "this never happens either\n" + +--f :: Int -> Stream a -> (Bool, [Request]) + +f n (MkStream _ _ _ _ _ _ _ _ _ rest) + = -- garbage collection *HERE*, please! + -- (forced by the closure for n-1) + (True, munch (n - 1) rest) + +-- munch and f are mutually recursive, just to be nasty diff --git a/testsuite/tests/codeGen/should_run/cgrun021.stdout b/testsuite/tests/codeGen/should_run/cgrun021.stdout new file mode 100644 index 0000000000..17203effa1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun021.stdout @@ -0,0 +1 @@ +I succeeded! diff --git a/testsuite/tests/codeGen/should_run/cgrun022.hs b/testsuite/tests/codeGen/should_run/cgrun022.hs new file mode 100644 index 0000000000..e69675431c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun022.hs @@ -0,0 +1,10 @@ +-- !!! tests stack stubbing: if "f" doesn't stub "ns", +-- !!! the program has a space leak. + +module Main where + +main = f (putStr "a") + (take 1000000 (repeat True)) + (putStr "b") + +f a ns b = if last ns then a else b diff --git a/testsuite/tests/codeGen/should_run/cgrun022.stdout b/testsuite/tests/codeGen/should_run/cgrun022.stdout new file mode 100644 index 0000000000..2e65efe2a1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun022.stdout @@ -0,0 +1 @@ +a
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun023.stdout b/testsuite/tests/codeGen/should_run/cgrun023.stdout new file mode 100644 index 0000000000..c1f22fbc23 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun023.stdout @@ -0,0 +1 @@ +False
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun024.hs b/testsuite/tests/codeGen/should_run/cgrun024.hs new file mode 100644 index 0000000000..7a695474e5 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun024.hs @@ -0,0 +1,8 @@ +-- !!! test super-dictionary grabification +-- + +main = putStr (show (is_one (1.2::Double))) + +is_one :: RealFloat a => a -> Bool + +is_one x = x == 1.0 diff --git a/testsuite/tests/codeGen/should_run/cgrun024.stdout b/testsuite/tests/codeGen/should_run/cgrun024.stdout new file mode 100644 index 0000000000..c1f22fbc23 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun024.stdout @@ -0,0 +1 @@ +False
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun025.hs b/testsuite/tests/codeGen/should_run/cgrun025.hs new file mode 100644 index 0000000000..8df8945088 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun025.hs @@ -0,0 +1,23 @@ +-- !!! test various I/O Requests +-- +-- +import IO +import System +import Debug.Trace (trace) +import Text.Regex +import Maybe + +main = do + prog <- getProgName + let Just (name:_) = matchRegex (mkRegex ".*(cg025)") prog + hPutStr stderr (shows name "\n") + args <- getArgs + hPutStr stderr (shows args "\n") + path <- getEnv "PATH" + hPutStr stderr ("GOT PATH\n") + stdin_txt <- getContents + putStr stdin_txt + file_cts <- readFile (head args) + hPutStr stderr file_cts + trace "hello, trace" $ + catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error") diff --git a/testsuite/tests/codeGen/should_run/cgrun025.stderr b/testsuite/tests/codeGen/should_run/cgrun025.stderr new file mode 100644 index 0000000000..a62fc44c04 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun025.stderr @@ -0,0 +1,28 @@ +"cgrun025" +["cgrun025.hs"] +GOT PATH +-- !!! test various I/O Requests +-- +-- +import IO +import System +import Debug.Trace (trace) +import Text.Regex +import Maybe + +main = do + prog <- getProgName + let Just (name:_) = matchRegex (mkRegex ".*(cgrun025)") prog + hPutStr stderr (shows name "\n") + args <- getArgs + hPutStr stderr (shows args "\n") + path <- getEnv "PATH" + hPutStr stderr ("GOT PATH\n") + stdin_txt <- getContents + putStr stdin_txt + file_cts <- readFile (head args) + hPutStr stderr file_cts + trace "hello, trace" $ + catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error") +hello, trace +cgrun025: hello, error diff --git a/testsuite/tests/codeGen/should_run/cgrun025.stdout b/testsuite/tests/codeGen/should_run/cgrun025.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun025.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun026.hs b/testsuite/tests/codeGen/should_run/cgrun026.hs new file mode 100644 index 0000000000..4f15f93f8e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun026.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE MagicHash #-} + +-- !!! simple tests of primitive arrays +-- +module Main ( main ) where + +import GHC.Exts +import Data.Char ( chr ) + +import Control.Monad.ST +import Data.Array.ST +import Data.Array.Unboxed + +import Data.Ratio + +main = putStr + (test_chars ++ "\n" ++ + test_ints ++ "\n" ++ + test_addrs ++ "\n" ++ + test_floats ++ "\n" ++ + test_doubles ++ "\n" ++ + test_ptrs ++ "\n") + + +-- Arr# Char# ------------------------------------------- +-- (main effort is in packString#) + +test_chars :: String +test_chars + = let arr# = f 1000 + in + shows (lookup_range arr# 42# 416#) "\n" + where + f :: Int -> UArray Int Char + + f size@(I# size#) + = runST ( + -- allocate an array of the specified size + newArray_ (0, (size-1)) >>= \ arr# -> + + -- fill in all elements; elem i has "i" put in it + fill_in arr# 0# (size# -# 1#) >> + + -- freeze the puppy: + freeze arr# + ) + + fill_in :: STUArray s Int Char -> Int# -> Int# -> ST s () + + fill_in arr_in# first# last# + = if (first# ># last#) + then return () + else writeArray arr_in# (I# first#) ((chr (I# first#))) >> + fill_in arr_in# (first# +# 1#) last# + + lookup_range :: UArray Int Char -> Int# -> Int# -> [Char] + lookup_range arr from# to# + = if (from# ># to#) + then [] + else (arr ! (I# from#)) + : (lookup_range arr (from# +# 1#) to#) + +-- Arr# Int# ------------------------------------------- + +test_ints :: String +test_ints + = let arr# = f 1000 + in + shows (lookup_range arr# 42# 416#) "\n" + where + f :: Int -> UArray Int Int + + f size@(I# size#) + = runST ( + -- allocate an array of the specified size + newArray_ (0, (size-1)) >>= \ arr# -> + + -- fill in all elements; elem i has i^2 put in it + fill_in arr# 0# (size# -# 1#) >> + + -- freeze the puppy: + freeze arr# + ) + + fill_in :: STUArray s Int Int -> Int# -> Int# -> ST s () + + fill_in arr_in# first# last# + = if (first# ># last#) + then return () + else writeArray arr_in# (I# first#) (I# (first# *# first#)) >> + fill_in arr_in# (first# +# 1#) last# + + lookup_range :: UArray Int Int -> Int# -> Int# -> [Int] + lookup_range arr from# to# + = if (from# ># to#) + then [] + else (arr ! (I# from#)) + : (lookup_range arr (from# +# 1#) to#) + +-- Arr# Addr# ------------------------------------------- + +test_addrs :: String +test_addrs + = let arr# = f 1000 + in + shows (lookup_range arr# 42# 416#) "\n" + where + f :: Int -> UArray Int (Ptr ()) + + f size@(I# size#) + = runST ( + -- allocate an array of the specified size + newArray_ (0, (size-1)) >>= \ arr# -> + + -- fill in all elements; elem i has i^2 put in it + fill_in arr# 0# (size# -# 1#) >> + + -- freeze the puppy: + freeze arr# + ) + + fill_in :: STUArray s Int (Ptr ()) -> Int# -> Int# -> ST s () + + fill_in arr_in# first# last# + = if (first# ># last#) + then return () + else writeArray arr_in# (I# first#) + (Ptr (int2Addr# (first# *# first#))) >> + fill_in arr_in# (first# +# 1#) last# + + lookup_range :: UArray Int (Ptr ()) -> Int# -> Int# -> [ Int ] + lookup_range arr from# to# + = let + a2i (Ptr a#) = I# (addr2Int# a#) + in + if (from# ># to#) + then [] + else (a2i (arr ! (I# from#))) + : (lookup_range arr (from# +# 1#) to#) + +-- Arr# Float# ------------------------------------------- + +test_floats :: String +test_floats + = let arr# = f 1000 + in + shows (lookup_range arr# 42# 416#) "\n" + where + f :: Int -> UArray Int Float + + f size@(I# size#) + = runST ( + -- allocate an array of the specified size + newArray_ (0, (size-1)) >>= \ arr# -> + + -- fill in all elements; elem i has "i * pi" put in it + fill_in arr# 0# (size# -# 1#) >> + + -- freeze the puppy: + freeze arr# + ) + + fill_in :: STUArray s Int Float -> Int# -> Int# -> ST s () + + fill_in arr_in# first# last# + = if (first# ># last#) + then return () +{- else let e = ((fromIntegral (I# first#)) * pi) + in trace (show e) $ writeFloatArray arr_in# (I# first#) e >> + fill_in arr_in# (first# +# 1#) last# +-} + else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >> + fill_in arr_in# (first# +# 1#) last# + + lookup_range :: UArray Int Float -> Int# -> Int# -> [Float] + lookup_range arr from# to# + = if (from# ># to#) + then [] + else (arr ! (I# from#)) + : (lookup_range arr (from# +# 1#) to#) + +-- Arr# Double# ------------------------------------------- + +test_doubles :: String +test_doubles + = let arr# = f 1000 + in + shows (lookup_range arr# 42# 416#) "\n" + where + f :: Int -> UArray Int Double + + f size@(I# size#) + = runST ( + -- allocate an array of the specified size + newArray_ (0, (size-1)) >>= \ arr# -> + + -- fill in all elements; elem i has "i * pi" put in it + fill_in arr# 0# (size# -# 1#) >> + + -- freeze the puppy: + freeze arr# + ) + + fill_in :: STUArray s Int Double -> Int# -> Int# -> ST s () + + fill_in arr_in# first# last# + = if (first# ># last#) + then return () + else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >> + fill_in arr_in# (first# +# 1#) last# + + lookup_range :: UArray Int Double -> Int# -> Int# -> [Double] + lookup_range arr from# to# + = if (from# ># to#) + then [] + else (arr ! (I# from#)) + : (lookup_range arr (from# +# 1#) to#) + +-- Arr# (Ratio Int) (ptrs) --------------------------------- +-- just like Int# test + +test_ptrs :: String +test_ptrs + = let arr# = f 1000 + in + shows (lookup_range arr# 42 416) "\n" + where + f :: Int -> Array Int (Ratio Int) + + f size + = runST ( + newArray (1, size) (3 % 5) >>= \ arr# -> + -- don't fill in the whole thing + fill_in arr# 1 400 >> + freeze arr# + ) + + fill_in :: STArray s Int (Ratio Int) -> Int -> Int -> ST s () + + fill_in arr_in# first last + = if (first > last) + then return () + else writeArray arr_in# first (fromIntegral (first * first)) >> + fill_in arr_in# (first + 1) last + + lookup_range :: Array Int (Ratio Int) -> Int -> Int -> [Ratio Int] + lookup_range array from too + = if (from > too) + then [] + else (array ! from) : (lookup_range array (from + 1) too) diff --git a/testsuite/tests/codeGen/should_run/cgrun026.stdout b/testsuite/tests/codeGen/should_run/cgrun026.stdout new file mode 100644 index 0000000000..92043490a7 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun026.stdout @@ -0,0 +1,12 @@ +"*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255\256\257\258\259\260\261\262\263\264\265\266\267\268\269\270\271\272\273\274\275\276\277\278\279\280\281\282\283\284\285\286\287\288\289\290\291\292\293\294\295\296\297\298\299\300\301\302\303\304\305\306\307\308\309\310\311\312\313\314\315\316\317\318\319\320\321\322\323\324\325\326\327\328\329\330\331\332\333\334\335\336\337\338\339\340\341\342\343\344\345\346\347\348\349\350\351\352\353\354\355\356\357\358\359\360\361\362\363\364\365\366\367\368\369\370\371\372\373\374\375\376\377\378\379\380\381\382\383\384\385\386\387\388\389\390\391\392\393\394\395\396\397\398\399\400\401\402\403\404\405\406\407\408\409\410\411\412\413\414\415\416" + +[1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,16641,16900,17161,17424,17689,17956,18225,18496,18769,19044,19321,19600,19881,20164,20449,20736,21025,21316,21609,21904,22201,22500,22801,23104,23409,23716,24025,24336,24649,24964,25281,25600,25921,26244,26569,26896,27225,27556,27889,28224,28561,28900,29241,29584,29929,30276,30625,30976,31329,31684,32041,32400,32761,33124,33489,33856,34225,34596,34969,35344,35721,36100,36481,36864,37249,37636,38025,38416,38809,39204,39601,40000,40401,40804,41209,41616,42025,42436,42849,43264,43681,44100,44521,44944,45369,45796,46225,46656,47089,47524,47961,48400,48841,49284,49729,50176,50625,51076,51529,51984,52441,52900,53361,53824,54289,54756,55225,55696,56169,56644,57121,57600,58081,58564,59049,59536,60025,60516,61009,61504,62001,62500,63001,63504,64009,64516,65025,65536,66049,66564,67081,67600,68121,68644,69169,69696,70225,70756,71289,71824,72361,72900,73441,73984,74529,75076,75625,76176,76729,77284,77841,78400,78961,79524,80089,80656,81225,81796,82369,82944,83521,84100,84681,85264,85849,86436,87025,87616,88209,88804,89401,90000,90601,91204,91809,92416,93025,93636,94249,94864,95481,96100,96721,97344,97969,98596,99225,99856,100489,101124,101761,102400,103041,103684,104329,104976,105625,106276,106929,107584,108241,108900,109561,110224,110889,111556,112225,112896,113569,114244,114921,115600,116281,116964,117649,118336,119025,119716,120409,121104,121801,122500,123201,123904,124609,125316,126025,126736,127449,128164,128881,129600,130321,131044,131769,132496,133225,133956,134689,135424,136161,136900,137641,138384,139129,139876,140625,141376,142129,142884,143641,144400,145161,145924,146689,147456,148225,148996,149769,150544,151321,152100,152881,153664,154449,155236,156025,156816,157609,158404,159201,160000,160801,161604,162409,163216,164025,164836,165649,166464,167281,168100,168921,169744,170569,171396,172225,173056] + +[1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,16641,16900,17161,17424,17689,17956,18225,18496,18769,19044,19321,19600,19881,20164,20449,20736,21025,21316,21609,21904,22201,22500,22801,23104,23409,23716,24025,24336,24649,24964,25281,25600,25921,26244,26569,26896,27225,27556,27889,28224,28561,28900,29241,29584,29929,30276,30625,30976,31329,31684,32041,32400,32761,33124,33489,33856,34225,34596,34969,35344,35721,36100,36481,36864,37249,37636,38025,38416,38809,39204,39601,40000,40401,40804,41209,41616,42025,42436,42849,43264,43681,44100,44521,44944,45369,45796,46225,46656,47089,47524,47961,48400,48841,49284,49729,50176,50625,51076,51529,51984,52441,52900,53361,53824,54289,54756,55225,55696,56169,56644,57121,57600,58081,58564,59049,59536,60025,60516,61009,61504,62001,62500,63001,63504,64009,64516,65025,65536,66049,66564,67081,67600,68121,68644,69169,69696,70225,70756,71289,71824,72361,72900,73441,73984,74529,75076,75625,76176,76729,77284,77841,78400,78961,79524,80089,80656,81225,81796,82369,82944,83521,84100,84681,85264,85849,86436,87025,87616,88209,88804,89401,90000,90601,91204,91809,92416,93025,93636,94249,94864,95481,96100,96721,97344,97969,98596,99225,99856,100489,101124,101761,102400,103041,103684,104329,104976,105625,106276,106929,107584,108241,108900,109561,110224,110889,111556,112225,112896,113569,114244,114921,115600,116281,116964,117649,118336,119025,119716,120409,121104,121801,122500,123201,123904,124609,125316,126025,126736,127449,128164,128881,129600,130321,131044,131769,132496,133225,133956,134689,135424,136161,136900,137641,138384,139129,139876,140625,141376,142129,142884,143641,144400,145161,145924,146689,147456,148225,148996,149769,150544,151321,152100,152881,153664,154449,155236,156025,156816,157609,158404,159201,160000,160801,161604,162409,163216,164025,164836,165649,166464,167281,168100,168921,169744,170569,171396,172225,173056] + +[131.9469,135.08849,138.23009,141.37167,144.51326,147.65486,150.79645,153.93805,157.07964,160.22124,163.36282,166.50441,169.64601,172.7876,175.9292,179.07079,182.21237,185.35397,188.49556,191.63716,194.77875,197.92035,201.06194,204.20352,207.34512,210.48671,213.62831,216.7699,219.9115,223.05309,226.19467,229.33627,232.47786,235.61946,238.76105,241.90263,245.04424,248.18582,251.32742,254.46901,257.6106,260.7522,263.8938,267.03537,270.17697,273.31857,276.46017,279.60175,282.74335,285.88495,289.02652,292.16812,295.30972,298.45132,301.5929,304.7345,307.8761,311.01767,314.15927,317.30087,320.44247,323.58405,326.72565,329.86725,333.00882,336.15042,339.29202,342.4336,345.5752,348.7168,351.8584,354.99997,358.14157,361.28317,364.42474,367.56635,370.70795,373.84955,376.99112,380.13272,383.27432,386.4159,389.5575,392.6991,395.8407,398.98227,402.12387,405.26547,408.40704,411.54865,414.69025,417.83185,420.97342,424.11502,427.25662,430.3982,433.5398,436.6814,439.823,442.96457,446.10617,449.24777,452.38934,455.53094,458.67255,461.81415,464.95572,468.09732,471.23892,474.3805,477.5221,480.6637,483.80527,486.94687,490.08847,493.23007,496.37164,499.51324,502.65485,505.79642,508.93802,512.0796,515.2212,518.3628,521.5044,524.646,527.7876,530.9292,534.07074,537.21234,540.35394,543.49554,546.63715,549.77875,552.92035,556.0619,559.2035,562.3451,565.4867,568.6283,571.7699,574.9115,578.05304,581.19464,584.33624,587.47784,590.61945,593.76105,596.90265,600.0442,603.1858,606.3274,609.469,612.6106,615.7522,618.8938,622.03534,625.17694,628.31854,631.46014,634.60175,637.74335,640.88495,644.0265,647.1681,650.3097,653.4513,656.5929,659.7345,662.8761,666.01764,669.15924,672.30084,675.44244,678.58405,681.72565,684.8672,688.0088,691.1504,694.292,697.4336,700.5752,703.7168,706.85834,709.99994,713.14154,716.28314,719.42474,722.56635,725.70795,728.8495,731.9911,735.1327,738.2743,741.4159,744.5575,747.6991,750.84064,753.98224,757.12384,760.26544,763.40704,766.54865,769.69025,772.8318,775.9734,779.115,782.2566,785.3982,788.5398,791.6814,794.82294,797.96454,801.10614,804.24774,807.38934,810.53094,813.67255,816.8141,819.9557,823.0973,826.2389,829.3805,832.5221,835.6637,838.80524,841.94684,845.08844,848.23004,851.37164,854.51324,857.65485,860.7964,863.938,867.0796,870.2212,873.3628,876.5044,879.646,882.78754,885.92914,889.07074,892.21234,895.35394,898.49554,901.63715,904.7787,907.9203,911.0619,914.2035,917.3451,920.4867,923.6283,926.76984,929.91144,933.05304,936.19464,939.33624,942.47784,945.6194,948.761,951.9026,955.0442,958.1858,961.3274,964.469,967.61053,970.75214,973.89374,977.03534,980.17694,983.31854,986.46014,989.6017,992.7433,995.8849,999.0265,1002.1681,1005.3097,1008.4513,1011.59283,1014.73444,1017.87604,1021.01764,1024.1592,1027.3008,1030.4424,1033.584,1036.7256,1039.8672,1043.0088,1046.1504,1049.292,1052.4336,1055.5752,1058.7168,1061.8584,1065.0,1068.1415,1071.2831,1074.4247,1077.5663,1080.7079,1083.8495,1086.9911,1090.1327,1093.2743,1096.4159,1099.5575,1102.6991,1105.8407,1108.9822,1112.1238,1115.2654,1118.407,1121.5486,1124.6902,1127.8318,1130.9734,1134.115,1137.2566,1140.3982,1143.5398,1146.6814,1149.823,1152.9645,1156.1061,1159.2477,1162.3893,1165.5309,1168.6725,1171.8141,1174.9557,1178.0973,1181.2389,1184.3805,1187.5221,1190.6637,1193.8053,1196.9468,1200.0884,1203.23,1206.3716,1209.5132,1212.6548,1215.7964,1218.938,1222.0796,1225.2212,1228.3628,1231.5044,1234.646,1237.7876,1240.9291,1244.0707,1247.2123,1250.3539,1253.4955,1256.6371,1259.7787,1262.9203,1266.0619,1269.2035,1272.3451,1275.4867,1278.6283,1281.7699,1284.9114,1288.053,1291.1946,1294.3362,1297.4778,1300.6194,1303.761,1306.9026] + +[131.94689145077132,135.0884841043611,138.23007675795088,141.3716694115407,144.51326206513048,147.6548547187203,150.79644737231007,153.93804002589985,157.07963267948966,160.22122533307945,163.36281798666926,166.50441064025904,169.64600329384882,172.78759594743863,175.92918860102841,179.0707812546182,182.212373908208,185.3539665617978,188.49555921538757,191.63715186897738,194.77874452256717,197.92033717615698,201.06192982974676,204.20352248333654,207.34511513692635,210.48670779051614,213.62830044410595,216.76989309769573,219.9114857512855,223.05307840487532,226.1946710584651,229.3362637120549,232.4778563656447,235.61944901923448,238.76104167282426,241.90263432641407,245.04422698000386,248.18581963359367,251.32741228718345,254.46900494077323,257.610597594363,260.75219024795285,263.89378290154264,267.0353755551324,270.1769682087222,273.318560862312,276.46015351590177,279.6017461694916,282.7433388230814,285.88493147667117,289.02652413026095,292.16811678385073,295.3097094374406,298.45130209103036,301.59289474462014,304.7344873982099,307.8760800517997,311.01767270538954,314.1592653589793,317.3008580125691,320.4424506661589,323.5840433197487,326.7256359733385,329.8672286269283,333.0088212805181,336.15041393410786,339.29200658769764,342.4335992412874,345.57519189487726,348.71678454846705,351.85837720205683,354.9999698556466,358.1415625092364,361.28315516282623,364.424747816416,367.5663404700058,370.7079331235956,373.84952577718536,376.99111843077515,380.132711084365,383.27430373795477,386.41589639154455,389.55748904513433,392.6990816987241,395.84067435231395,398.98226700590374,402.1238596594935,405.2654523130833,408.4070449666731,411.5486376202629,414.6902302738527,417.8318229274425,420.97341558103227,424.11500823462205,427.2566008882119,430.3981935418017,433.53978619539146,436.68137884898124,439.822971502571,442.9645641561608,446.10615680975064,449.2477494633404,452.3893421169302,455.53093477052,458.6725274241098,461.8141200776996,464.9557127312894,468.0973053848792,471.23889803846896,474.38049069205874,477.5220833456485,480.66367599923836,483.80526865282815,486.94686130641793,490.0884539600077,493.2300466135975,496.37163926718733,499.5132319207771,502.6548245743669,505.7964172279567,508.93800988154646,512.0796025351362,515.221195188726,518.3627878423158,521.5043804959057,524.6459731494955,527.7875658030853,530.929158456675,534.0707511102648,537.2123437638546,540.3539364174444,543.4955290710342,546.637121724624,549.7787143782137,552.9203070318035,556.0618996853934,559.2034923389832,562.345084992573,565.4866776461628,568.6282702997526,571.7698629533423,574.9114556069321,578.0530482605219,581.1946409141117,584.3362335677015,587.4778262212914,590.6194188748811,593.7610115284709,596.9026041820607,600.0441968356505,603.1857894892403,606.3273821428301,609.4689747964198,612.6105674500096,615.7521601035994,618.8937527571892,622.0353454107791,625.1769380643689,628.3185307179587,631.4601233715484,634.6017160251382,637.743308678728,640.8849013323178,644.0264939859076,647.1680866394973,650.3096792930871,653.451271946677,656.5928646002668,659.7344572538566,662.8760499074464,666.0176425610362,669.1592352146259,672.3008278682157,675.4424205218055,678.5840131753953,681.7256058289851,684.8671984825748,688.0087911361647,691.1503837897545,694.2919764433443,697.4335690969341,700.5751617505239,703.7167544041137,706.8583470577034,709.9999397112932,713.141532364883,716.2831250184728,719.4247176720626,722.5663103256525,725.7079029792422,728.849495632832,731.9910882864218,735.1326809400116,738.2742735936014,741.4158662471912,744.557458900781,747.6990515543707,750.8406442079605,753.9822368615503,757.1238295151402,760.26542216873,763.4070148223198,766.5486074759095,769.6902001294993,772.8317927830891,775.9733854366789,779.1149780902687,782.2565707438584,785.3981633974482,788.5397560510381,791.6813487046279,794.8229413582177,797.9645340118075,801.1061266653973,804.247719318987,807.3893119725768,810.5309046261666,813.6724972797564,816.8140899333462,819.955682586936,823.0972752405258,826.2388678941156,829.3804605477054,832.5220532012952,835.663645854885,838.8052385084748,841.9468311620645,845.0884238156543,848.2300164692441,851.3716091228339,854.5132017764238,857.6547944300136,860.7963870836033,863.9379797371931,867.0795723907829,870.2211650443727,873.3627576979625,876.5043503515523,879.645943005142,882.7875356587318,885.9291283123216,889.0707209659115,892.2123136195013,895.3539062730911,898.4954989266809,901.6370915802706,904.7786842338604,907.9202768874502,911.06186954104,914.2034621946298,917.3450548482195,920.4866475018093,923.6282401553992,926.769832808989,929.9114254625788,933.0530181161686,936.1946107697584,939.3362034233481,942.4777960769379,945.6193887305277,948.7609813841175,951.9025740377073,955.044166691297,958.185759344887,961.3273519984767,964.4689446520665,967.6105373056563,970.7521299592461,973.8937226128359,977.0353152664256,980.1769079200154,983.3185005736052,986.460093227195,989.6016858807849,992.7432785343747,995.8848711879644,999.0264638415542,1002.168056495144,1005.3096491487338,1008.4512418023236,1011.5928344559134,1014.7344271095031,1017.8760197630929,1021.0176124166827,1024.1592050702725,1027.3007977238624,1030.442390377452,1033.583983031042,1036.7255756846316,1039.8671683382215,1043.0087609918114,1046.150353645401,1049.291946298991,1052.4335389525806,1055.5751316061705,1058.7167242597602,1061.85831691335,1064.9999095669398,1068.1415022205297,1071.2830948741193,1074.4246875277092,1077.5662801812991,1080.7078728348888,1083.8494654884787,1086.9910581420684,1090.1326507956583,1093.274243449248,1096.4158361028378,1099.5574287564275,1102.6990214100174,1105.840614063607,1108.982206717197,1112.1237993707869,1115.2653920243765,1118.4069846779664,1121.548577331556,1124.690169985146,1127.8317626387357,1130.9733552923256,1134.1149479459152,1137.2565405995051,1140.398133253095,1143.5397259066847,1146.6813185602746,1149.8229112138642,1152.9645038674541,1156.1060965210438,1159.2476891746337,1162.3892818282234,1165.5308744818133,1168.672467135403,1171.8140597889928,1174.9556524425827,1178.0972450961724,1181.2388377497623,1184.380430403352,1187.5220230569419,1190.6636157105315,1193.8052083641214,1196.946801017711,1200.088393671301,1203.2299863248907,1206.3715789784806,1209.5131716320705,1212.6547642856601,1215.79635693925,1218.9379495928397,1222.0795422464296,1225.2211349000193,1228.3627275536091,1231.5043202071988,1234.6459128607887,1237.7875055143784,1240.9290981679683,1244.0706908215582,1247.2122834751478,1250.3538761287377,1253.4954687823274,1256.6370614359173,1259.778654089507,1262.9202467430969,1266.0618393966865,1269.2034320502764,1272.345024703866,1275.486617357456,1278.628210011046,1281.7698026646356,1284.9113953182255,1288.0529879718151,1291.194580625405,1294.3361732789947,1297.4777659325846,1300.6193585861743,1303.7609512397642,1306.902543893354] + +[1764 % 1,1849 % 1,1936 % 1,2025 % 1,2116 % 1,2209 % 1,2304 % 1,2401 % 1,2500 % 1,2601 % 1,2704 % 1,2809 % 1,2916 % 1,3025 % 1,3136 % 1,3249 % 1,3364 % 1,3481 % 1,3600 % 1,3721 % 1,3844 % 1,3969 % 1,4096 % 1,4225 % 1,4356 % 1,4489 % 1,4624 % 1,4761 % 1,4900 % 1,5041 % 1,5184 % 1,5329 % 1,5476 % 1,5625 % 1,5776 % 1,5929 % 1,6084 % 1,6241 % 1,6400 % 1,6561 % 1,6724 % 1,6889 % 1,7056 % 1,7225 % 1,7396 % 1,7569 % 1,7744 % 1,7921 % 1,8100 % 1,8281 % 1,8464 % 1,8649 % 1,8836 % 1,9025 % 1,9216 % 1,9409 % 1,9604 % 1,9801 % 1,10000 % 1,10201 % 1,10404 % 1,10609 % 1,10816 % 1,11025 % 1,11236 % 1,11449 % 1,11664 % 1,11881 % 1,12100 % 1,12321 % 1,12544 % 1,12769 % 1,12996 % 1,13225 % 1,13456 % 1,13689 % 1,13924 % 1,14161 % 1,14400 % 1,14641 % 1,14884 % 1,15129 % 1,15376 % 1,15625 % 1,15876 % 1,16129 % 1,16384 % 1,16641 % 1,16900 % 1,17161 % 1,17424 % 1,17689 % 1,17956 % 1,18225 % 1,18496 % 1,18769 % 1,19044 % 1,19321 % 1,19600 % 1,19881 % 1,20164 % 1,20449 % 1,20736 % 1,21025 % 1,21316 % 1,21609 % 1,21904 % 1,22201 % 1,22500 % 1,22801 % 1,23104 % 1,23409 % 1,23716 % 1,24025 % 1,24336 % 1,24649 % 1,24964 % 1,25281 % 1,25600 % 1,25921 % 1,26244 % 1,26569 % 1,26896 % 1,27225 % 1,27556 % 1,27889 % 1,28224 % 1,28561 % 1,28900 % 1,29241 % 1,29584 % 1,29929 % 1,30276 % 1,30625 % 1,30976 % 1,31329 % 1,31684 % 1,32041 % 1,32400 % 1,32761 % 1,33124 % 1,33489 % 1,33856 % 1,34225 % 1,34596 % 1,34969 % 1,35344 % 1,35721 % 1,36100 % 1,36481 % 1,36864 % 1,37249 % 1,37636 % 1,38025 % 1,38416 % 1,38809 % 1,39204 % 1,39601 % 1,40000 % 1,40401 % 1,40804 % 1,41209 % 1,41616 % 1,42025 % 1,42436 % 1,42849 % 1,43264 % 1,43681 % 1,44100 % 1,44521 % 1,44944 % 1,45369 % 1,45796 % 1,46225 % 1,46656 % 1,47089 % 1,47524 % 1,47961 % 1,48400 % 1,48841 % 1,49284 % 1,49729 % 1,50176 % 1,50625 % 1,51076 % 1,51529 % 1,51984 % 1,52441 % 1,52900 % 1,53361 % 1,53824 % 1,54289 % 1,54756 % 1,55225 % 1,55696 % 1,56169 % 1,56644 % 1,57121 % 1,57600 % 1,58081 % 1,58564 % 1,59049 % 1,59536 % 1,60025 % 1,60516 % 1,61009 % 1,61504 % 1,62001 % 1,62500 % 1,63001 % 1,63504 % 1,64009 % 1,64516 % 1,65025 % 1,65536 % 1,66049 % 1,66564 % 1,67081 % 1,67600 % 1,68121 % 1,68644 % 1,69169 % 1,69696 % 1,70225 % 1,70756 % 1,71289 % 1,71824 % 1,72361 % 1,72900 % 1,73441 % 1,73984 % 1,74529 % 1,75076 % 1,75625 % 1,76176 % 1,76729 % 1,77284 % 1,77841 % 1,78400 % 1,78961 % 1,79524 % 1,80089 % 1,80656 % 1,81225 % 1,81796 % 1,82369 % 1,82944 % 1,83521 % 1,84100 % 1,84681 % 1,85264 % 1,85849 % 1,86436 % 1,87025 % 1,87616 % 1,88209 % 1,88804 % 1,89401 % 1,90000 % 1,90601 % 1,91204 % 1,91809 % 1,92416 % 1,93025 % 1,93636 % 1,94249 % 1,94864 % 1,95481 % 1,96100 % 1,96721 % 1,97344 % 1,97969 % 1,98596 % 1,99225 % 1,99856 % 1,100489 % 1,101124 % 1,101761 % 1,102400 % 1,103041 % 1,103684 % 1,104329 % 1,104976 % 1,105625 % 1,106276 % 1,106929 % 1,107584 % 1,108241 % 1,108900 % 1,109561 % 1,110224 % 1,110889 % 1,111556 % 1,112225 % 1,112896 % 1,113569 % 1,114244 % 1,114921 % 1,115600 % 1,116281 % 1,116964 % 1,117649 % 1,118336 % 1,119025 % 1,119716 % 1,120409 % 1,121104 % 1,121801 % 1,122500 % 1,123201 % 1,123904 % 1,124609 % 1,125316 % 1,126025 % 1,126736 % 1,127449 % 1,128164 % 1,128881 % 1,129600 % 1,130321 % 1,131044 % 1,131769 % 1,132496 % 1,133225 % 1,133956 % 1,134689 % 1,135424 % 1,136161 % 1,136900 % 1,137641 % 1,138384 % 1,139129 % 1,139876 % 1,140625 % 1,141376 % 1,142129 % 1,142884 % 1,143641 % 1,144400 % 1,145161 % 1,145924 % 1,146689 % 1,147456 % 1,148225 % 1,148996 % 1,149769 % 1,150544 % 1,151321 % 1,152100 % 1,152881 % 1,153664 % 1,154449 % 1,155236 % 1,156025 % 1,156816 % 1,157609 % 1,158404 % 1,159201 % 1,160000 % 1,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5,3 % 5] + diff --git a/testsuite/tests/codeGen/should_run/cgrun027.hs b/testsuite/tests/codeGen/should_run/cgrun027.hs new file mode 100644 index 0000000000..646d05c38b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun027.hs @@ -0,0 +1,13 @@ +-- !!! simple test of 0-method classes +-- + +class (Num a, Integral a) => Foo a + +main = putStr (shows (f ((fromInteger 21)::Int) + ((fromInteger 37))) "\n") + +instance Foo Int + +f :: Foo a => a -> a -> Integer + +f a b = toInteger (a + b) diff --git a/testsuite/tests/codeGen/should_run/cgrun027.stdout b/testsuite/tests/codeGen/should_run/cgrun027.stdout new file mode 100644 index 0000000000..8c61d23e12 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun027.stdout @@ -0,0 +1 @@ +58 diff --git a/testsuite/tests/codeGen/should_run/cgrun028.hs b/testsuite/tests/codeGen/should_run/cgrun028.hs new file mode 100644 index 0000000000..3fa877cdb8 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun028.hs @@ -0,0 +1,10 @@ +main = putStr (shows (f (read "42.0")) "\n") + +-- f compiled to bogus code with ghc 0.18 and earlier +-- switch() on a DoubleReg + +f :: Double -> Int +f 1.0 = 1 +f 2.0 = 2 +f 3.0 = 3 +f x = round x diff --git a/testsuite/tests/codeGen/should_run/cgrun028.stdout b/testsuite/tests/codeGen/should_run/cgrun028.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun028.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun031.hs b/testsuite/tests/codeGen/should_run/cgrun031.hs new file mode 100644 index 0000000000..2a2c7a9b64 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun031.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MagicHash #-} +-- !! test GEN reps w/ unboxed values in them +-- !! NB: it was the static ones that were hosed... +-- +module Main ( main ) where + +--import PrelBase +import GHC.Base + +main = do + putStr (shows (sum ([1..1{-30-}]++[1..1{-40-}]++[11,22])) "\n") + putStr (shows (prog 1{-30-} 1{-40-}) "\n") + +data Foo a + = MkFoo [a] Int# [Int] Int# [(a,Int)] Int# + -- The above will cause a *horrible* GEN rep'n. + +prog :: Int -> Int -> Int + +prog size_1 size_2 + = let + list1 = static1 : (map mk_foo [1 .. size_1]) + list2 = static2 : (map mk_foo [1 .. size_2]) + in + I# (add_up 0# list1 (reverse list2)) + +static1 = MkFoo (error "static11") 11# [] 11# (error "static12") 11# +static2 = MkFoo (error "static21") 22# [] 22# (error "static22") 22# + +one, two :: Int +one = 1; two = 2 + +mk_foo i@(I# i#) + = MkFoo (error "list1") i# [i,i] i# (error "list2") i# + +add_up :: Int# -> [Foo a] -> [Foo a] -> Int# + +add_up acc [] [] = acc +add_up acc [] ys = add_up acc ys [] +add_up acc (x:xs) (y:ys) = add_up (acc +# add x y) xs ys +add_up acc (x:xs) [] = add_up acc xs [] + +add :: Foo a -> Foo a -> Int# +add (MkFoo _ _ _ _ _ x) (MkFoo _ _ _ _ _ y) + = x +# y diff --git a/testsuite/tests/codeGen/should_run/cgrun031.stdout b/testsuite/tests/codeGen/should_run/cgrun031.stdout new file mode 100644 index 0000000000..a91166f4a3 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun031.stdout @@ -0,0 +1,2 @@ +35 +35 diff --git a/testsuite/tests/codeGen/should_run/cgrun032.hs b/testsuite/tests/codeGen/should_run/cgrun032.hs new file mode 100644 index 0000000000..3c1404b319 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun032.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash #-} +-- !! pattern-matching failure on functions that return Int# + +--import PrelBase --ghc1.3 +import GHC.Base + +main = putStr (shows (I# (foo bar1 bar2)) "\n") + where + bar1 = Bar1 40 (39,38) resps + bar2 = Bar1 2 ( 1, 0) resps + resps = error "1.2 responses" + +data Response = Response -- stub + +data Bar + = Bar1 Int (Int,Int) [Response] + | Bar2 Int Int# + | Bar3 Int + +foo :: Bar -> Bar -> Int# + +foo (Bar1 (I# i) _ _) (Bar1 (I# j) _ _) = i +# j diff --git a/testsuite/tests/codeGen/should_run/cgrun032.stdout b/testsuite/tests/codeGen/should_run/cgrun032.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun032.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/codeGen/should_run/cgrun033.hs b/testsuite/tests/codeGen/should_run/cgrun033.hs new file mode 100644 index 0000000000..6e4a0b9a9d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun033.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE MagicHash #-} +-- !! worker/wrapper turns ( \ <absent> -> Int# ) function +-- !! into Int# -- WRONG + +--import PrelBase --ghc1.3 +import GHC.Base + +main = putStr (shows true_or_false "\n") + where + true_or_false + = case (cmp_name True imp1 imp2) of + -1# -> False + 0# -> True + 1# -> False + + imp1 = Imp s "Imp1" s s + imp2 = Imp s "Imp2" s s + + s = "String!" + +-- taken from compiler: basicTypes/ProtoName.lhs + +cmp_name :: Bool -> ProtoName -> ProtoName -> Int# + +cmp_name by_local (Unk n1) (Unk n2) = cmpString n1 n2 +cmp_name by_local (Unk n1) (Imp m n2 _ o2) = cmpString n1 (if by_local then o2 else n2) +cmp_name by_local (Unk n1) (Prel nm) + = let (_, n2) = getOrigName nm in + cmpString n1 n2 + +cmp_name by_local (Prel n1) (Prel n2) = cmpName n1 n2 + +cmp_name True (Imp _ _ _ o1) (Imp _ _ _ o2) = cmpString o1 o2 + +cmp_name False (Imp m1 n1 _ _) (Imp m2 n2 _ _) + = case cmpString n1 n2 of { + -1# -> -1#; + 0# -> case cmpString m1 m2 of { + 0# -> 0#; + xxx -> if null m1 || null m2 + then 0# + else xxx + }; + _ -> 1# + } + +cmp_name True (Imp _ _ _ o1) (Prel nm) + = let + (_, n2) = getOrigName nm + in + cmpString o1 n2 + +cmp_name False (Imp m1 n1 _ _) (Prel nm) + = case getOrigName nm of { (m2, n2) -> + case cmpString n1 n2 of { -1# -> -1#; 0# -> cmpString m1 m2; _ -> 1# }} + +cmp_name by_local other_p1 other_p2 + = case cmp_name by_local other_p2 other_p1 of -- compare the other way around + -1# -> 1# + 0# -> 0# + _ -> -1# + +data ProtoName + = Unk String -- local name in module + + | Imp String -- name of defining module + String -- name used in defining name + String -- name of the module whose interface told me + -- about this thing + String -- occurrence name + + | Prel String{-Name-} + +cmpString, cmpName :: String -> String -> Int# +cmpString a b = 0# +cmpName = cmpString + +getOrigName :: String -> (String, String) +getOrigName x = ("MODULE", x) diff --git a/testsuite/tests/codeGen/should_run/cgrun033.stdout b/testsuite/tests/codeGen/should_run/cgrun033.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun033.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/codeGen/should_run/cgrun034.hs b/testsuite/tests/codeGen/should_run/cgrun034.hs new file mode 100644 index 0000000000..0f7f05297e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun034.hs @@ -0,0 +1,161 @@ +-- !! fromRational woes +import Data.Ratio -- 1.3 + +main = putStr ( + shows tinyFloat ( '\n' + : shows t_f ( '\n' + : shows hugeFloat ( '\n' + : shows h_f ( '\n' + : shows tinyDouble ( '\n' + : shows t_d ( '\n' + : shows hugeDouble ( '\n' + : shows h_d ( '\n' + : shows x_f ( '\n' + : shows x_d ( '\n' + : shows y_f ( '\n' + : shows y_d ( "\n" + ))))))))))))) + where + t_f :: Float + t_d :: Double + h_f :: Float + h_d :: Double + x_f :: Float + x_d :: Double + y_f :: Float + y_d :: Double + t_f = fromRationalX (toRational tinyFloat) + t_d = fromRationalX (toRational tinyDouble) + h_f = fromRationalX (toRational hugeFloat) + h_d = fromRationalX (toRational hugeDouble) + x_f = fromRationalX (1.82173691287639817263897126389712638972163e-300 :: Rational) + x_d = fromRationalX (1.82173691287639817263897126389712638972163e-300 :: Rational) + y_f = 1.82173691287639817263897126389712638972163e-300 + y_d = 1.82173691287639817263897126389712638972163e-300 + +fromRationalX :: (RealFloat a) => Rational -> a +fromRationalX r = + let + h = ceiling (huge `asTypeOf` x) + b = toInteger (floatRadix x) + x = fromRat 0 r + fromRat e0 r' = + let d = denominator r' + n = numerator r' + in if d > h then + let e = integerLogBase b (d `div` h) + 1 + in fromRat (e0-e) (n % (d `div` (b^e))) + else if abs n > h then + let e = integerLogBase b (abs n `div` h) + 1 + in fromRat (e0+e) ((n `div` (b^e)) % d) + else + scaleFloat e0 (rationalToRealFloat {-fromRational-} r') + in x + +{- +fromRationalX r = + rationalToRealFloat r +{- Hmmm... + let + h = ceiling (huge `asTypeOf` x) + b = toInteger (floatRadix x) + x = fromRat 0 r + + fromRat e0 r' = +{--} trace (shows e0 ('/' : shows r' ('/' : shows h "\n"))) ( + let d = denominator r' + n = numerator r' + in if d > h then + let e = integerLogBase b (d `div` h) + 1 + in fromRat (e0-e) (n % (d `div` (b^e))) + else if abs n > h then + let e = integerLogBase b (abs n `div` h) + 1 + in fromRat (e0+e) ((n `div` (b^e)) % d) + else + scaleFloat e0 (rationalToRealFloat r') + -- now that we know things are in-bounds, + -- we use the "old" Prelude code. +{--} ) + in x +-} +-} + +-- Compute the discrete log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + doDiv :: Integer -> Int -> Int + doDiv i l = if i < b then l else doDiv (i `div` b) (l+1) + in doDiv (i `div` (b^l)) l + + +------------ + +-- Compute smallest and largest floating point values. +tiny :: (RealFloat a) => a +tiny = + let (l, _) = floatRange x + x = encodeFloat 1 (l-1) + in x + +huge :: (RealFloat a) => a +huge = + let (_, u) = floatRange x + d = floatDigits x + x = encodeFloat (floatRadix x ^ d - 1) (u - d) + in x + +tinyDouble = tiny :: Double +tinyFloat = tiny :: Float +hugeDouble = huge :: Double +hugeFloat = huge :: Float + +{- +[In response to a request by simonpj, Joe Fasel writes:] + +A quite reasonable request! This code was added to the Prelude just +before the 1.2 release, when Lennart, working with an early version +of hbi, noticed that (read . show) was not the identity for +floating-point numbers. (There was a one-bit error about half the time.) +The original version of the conversion function was in fact simply +a floating-point divide, as you suggest above. The new version is, +I grant you, somewhat denser. + +How's this? + +--Joe +-} + + +rationalToRealFloat :: (RealFloat a) => Rational -> a + +rationalToRealFloat x = x' + where x' = f e + +-- If the exponent of the nearest floating-point number to x +-- is e, then the significand is the integer nearest xb^(-e), +-- where b is the floating-point radix. We start with a good +-- guess for e, and if it is correct, the exponent of the +-- floating-point number we construct will again be e. If +-- not, one more iteration is needed. + + f e = if e' == e then y else f e' + where y = encodeFloat (round (x * (1%b)^^e)) e + (_,e') = decodeFloat y + b = floatRadix x' + +-- We obtain a trial exponent by doing a floating-point +-- division of x's numerator by its denominator. The +-- result of this division may not itself be the ultimate +-- result, because of an accumulation of three rounding +-- errors. + + (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' + / fromInteger (denominator x)) + diff --git a/testsuite/tests/codeGen/should_run/cgrun034.stdout b/testsuite/tests/codeGen/should_run/cgrun034.stdout new file mode 100644 index 0000000000..0c2be1c979 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun034.stdout @@ -0,0 +1,12 @@ +1.1754944e-38 +1.1754944e-38 +3.4028235e38 +3.4028235e38 +2.2250738585072014e-308 +2.2250738585072014e-308 +1.7976931348623157e308 +1.7976931348623157e308 +0.0 +1.821736912876398e-300 +0.0 +1.821736912876398e-300 diff --git a/testsuite/tests/codeGen/should_run/cgrun035.hs b/testsuite/tests/codeGen/should_run/cgrun035.hs new file mode 100644 index 0000000000..dfd73cb40a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun035.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Foreign.C +import System.IO.Unsafe ( unsafePerformIO ) + +c :: Double -> Double +c x = cos x + where + cos :: Double -> Double + cos x = realToFrac (unsafePerformIO (c_cos (realToFrac x))) + +foreign import ccall unsafe "cos" + c_cos :: CDouble -> IO CDouble + +main = putStr (shows (c 0.0) "\n") diff --git a/testsuite/tests/codeGen/should_run/cgrun035.stdout b/testsuite/tests/codeGen/should_run/cgrun035.stdout new file mode 100644 index 0000000000..d3827e75a5 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun035.stdout @@ -0,0 +1 @@ +1.0 diff --git a/testsuite/tests/codeGen/should_run/cgrun036.hs b/testsuite/tests/codeGen/should_run/cgrun036.hs new file mode 100644 index 0000000000..40bfa74328 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun036.hs @@ -0,0 +1,16 @@ +-- !! Won't compile unless the compile succeeds on +-- !! the "single occurrence of big thing in a duplicated small thing" +-- !! inlining old-chestnut. WDP 95/03 +-- +module Main ( main, g ) where + +main = putStr (shows (g 42 45 45) "\n") + +g :: Int -> Int -> Int -> [Int] + +g x y z + = let + f a b = a + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + g c = f c c + in + [g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y] diff --git a/testsuite/tests/codeGen/should_run/cgrun036.stdout b/testsuite/tests/codeGen/should_run/cgrun036.stdout new file mode 100644 index 0000000000..7b74638be6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun036.stdout @@ -0,0 +1 @@ +[1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425,1276425,1037862,1276425] diff --git a/testsuite/tests/codeGen/should_run/cgrun037.hs b/testsuite/tests/codeGen/should_run/cgrun037.hs new file mode 100644 index 0000000000..9c16f37962 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun037.hs @@ -0,0 +1,6 @@ +-- Andy Gill bug report 95/08: +-- Constant strings with '\0' in them don't work :- +-- +main = putStrLn "hello\0 world" +--main = putStrLn "hello0 world" + diff --git a/testsuite/tests/codeGen/should_run/cgrun037.stdout b/testsuite/tests/codeGen/should_run/cgrun037.stdout Binary files differnew file mode 100644 index 0000000000..fa50190f4c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun037.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun038.hs b/testsuite/tests/codeGen/should_run/cgrun038.hs new file mode 100644 index 0000000000..57669c6d29 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun038.hs @@ -0,0 +1,13 @@ +{- +From: Rajiv Mirani <mirani> +Date: Sat, 26 Aug 95 21:14:47 -0400 +Subject: GHC bug + +GHC can't parse the following program when there is no newline at the +end of the last line: +-} + +module Main where +main :: IO () +main = return () +-- random comment
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun038.stdout b/testsuite/tests/codeGen/should_run/cgrun038.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun038.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun039.hs b/testsuite/tests/codeGen/should_run/cgrun039.hs new file mode 100644 index 0000000000..b7b301794d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun039.hs @@ -0,0 +1,14 @@ +-- !!! From a Rick Morgan bug report: +-- !!! Single-method class with a locally-polymorphic +-- !!! method. + +module Main where + +class Poly a where + poly :: a -> b -> b + +instance Poly [a] where + poly [] y = y + poly x y = y + +main = print ("hurrah" `poly` "Hello, world!\n") diff --git a/testsuite/tests/codeGen/should_run/cgrun039.stdout b/testsuite/tests/codeGen/should_run/cgrun039.stdout new file mode 100644 index 0000000000..1c2d5d620b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun039.stdout @@ -0,0 +1 @@ +"Hello, world!\n" diff --git a/testsuite/tests/codeGen/should_run/cgrun040.hs b/testsuite/tests/codeGen/should_run/cgrun040.hs new file mode 100644 index 0000000000..d747d4ab8b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun040.hs @@ -0,0 +1,16 @@ +module Main(main) where + +data Burble a = B1 { op1 :: a -> Int, op2 :: Int -> a, op3 :: Int} + | B2 { op2 :: Int -> a, op4 :: Int -> Int } + + +f1 :: Int -> Burble Int +f1 n = B1 { op1 = \x->x+n, op2 = \x -> x, op3 = n } + +f2 :: Burble a -> Int -> Int +f2 r@(B1 {op1 = op1 , op2 = op2 }) n = op1 (op2 n) + op3 r + +f3 :: Burble a -> Burble a +f3 x@(B1 {op3=op3}) = x {op3 = op3+1} + +main = print (f2 (f3 (f1 3)) 4) diff --git a/testsuite/tests/codeGen/should_run/cgrun040.stdout b/testsuite/tests/codeGen/should_run/cgrun040.stdout new file mode 100644 index 0000000000..b4de394767 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun040.stdout @@ -0,0 +1 @@ +11 diff --git a/testsuite/tests/codeGen/should_run/cgrun043.hs b/testsuite/tests/codeGen/should_run/cgrun043.hs new file mode 100644 index 0000000000..88de4c92f2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun043.hs @@ -0,0 +1,18 @@ +-- !!! Tickled a bug in core2stg +-- !!! (CoreSyn.Coerce constructors were not peeled off +-- !!! when converting CoreSyn.App) + +module Main where + +getData :: String -> IO () +getData filename = case leng filename of {0 -> return ()} +leng :: String -> Int +leng [] = 0 --case ls of {[] -> 0 ; (_:xs) -> 1 + leng xs } +leng ls = leng ls + +f [] [] = [] +f xs ys = f xs ys + +main = + return () >>= \ _ -> + case f [] [] of { [] -> getData [] } diff --git a/testsuite/tests/codeGen/should_run/cgrun043.stdout b/testsuite/tests/codeGen/should_run/cgrun043.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun043.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun044.hs b/testsuite/tests/codeGen/should_run/cgrun044.hs new file mode 100644 index 0000000000..cc2c5d64e5 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun044.hs @@ -0,0 +1,195 @@ +{-# OPTIONS -cpp #-} +-- !!! Testing IEEE Float and Double extremity predicates. +module Main(main) where + +import Data.Char +import Control.Monad.ST +import Data.Word +import Data.Array.ST + +#include "ghcconfig.h" + +reverse_if_bigendian :: [a] -> [a] +#ifdef WORDS_BIGENDIAN +reverse_if_bigendian = reverse +#else +reverse_if_bigendian = id +#endif + + +main :: IO () +main = do + sequence_ (map putStrLn double_tests) + sequence_ (map putStrLn float_tests) + where + double_tests = run_tests double_numbers + float_tests = run_tests float_numbers + + run_tests nums = + map ($ nums) + [ denorm + , pos_inf + , neg_inf + , nan + , neg_zero + , pos_zero + ] + +------------- +double_numbers :: [Double] +double_numbers = + [ 0 + , encodeFloat 0 0 -- 0 using encodeFloat method + , mkDouble (reverse_if_bigendian [0,0,0,0,0,0, 0xf0, 0x7f]) -- +inf + , encodeFloat 1 2047 -- +Inf + , encodeFloat 1 2048 + , encodeFloat 1 2047 -- signalling NaN + , encodeFloat 0xf000000000000 2047 -- quiet NaN + , 0/(0::Double) + -- misc + , 1.82173691287639817263897126389712638972163e-300 + , 1.82173691287639817263897126389712638972163e+300 + , 4.9406564558412465e-324 -- smallest possible denorm number + -- (as reported by enquire running + -- on a i686-pc-linux.) + , 2.2250738585072014e-308 + , 0.11 + , 0.100 + , -3.4 + -- smallest + , let (l, _) = floatRange x + x = encodeFloat 1 (l-1) + in x + -- largest + , let (_, u) = floatRange x + d = floatDigits x + x = encodeFloat (floatRadix x ^ d - 1) (u - d) + in x + ] + +float_numbers :: [Float] +float_numbers = + [ 0 + , encodeFloat 0 0 -- 0 using encodeFloat method + , encodeFloat 1 255 -- +Inf + , encodeFloat 1 256 + , encodeFloat 11 255 -- signalling NaN + , encodeFloat 0xf00000 255 -- quiet NaN + , 0/(0::Float) + -- misc + , 1.82173691287639817263897126389712638972163e-300 + , 1.82173691287639817263897126389712638972163e+300 + , 1.40129846e-45 + , 1.17549435e-38 + , 2.98023259e-08 + , 0.11 + , 0.100 + , -3.4 + -- smallest + , let (l, _) = floatRange x + x = encodeFloat 1 (l-1) + in x + -- largest + , let (_, u) = floatRange x + d = floatDigits x + x = encodeFloat (floatRadix x ^ d - 1) (u - d) + in x + ] + +------------- + +denorm :: RealFloat a => [a] -> String +denorm numbers = + unlines + ( "" + : "*********************************" + : ("Denormalised numbers: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (isDenormalized) "isDenormalised" + +pos_inf :: RealFloat a => [a] -> String +pos_inf numbers = + unlines + ( "" + : "*********************************" + : ("Positive Infinity: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (isInfinite) "isInfinite" + +neg_inf :: RealFloat a => [a] -> String +neg_inf numbers = + unlines + ( "" + : "*********************************" + : ("Negative Infinity: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (\ x -> isInfinite x && x < 0) "isNegInfinite" + +nan :: RealFloat a => [a] -> String +nan numbers = + unlines + ( "" + : "*********************************" + : ("NaN: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (isNaN) "isNaN" + +pos_zero :: RealFloat a => [a] -> String +pos_zero numbers = + unlines + ( "" + : "*********************************" + : ("Positive zero: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (==0) "isPosZero" + +neg_zero :: RealFloat a => [a] -> String +neg_zero numbers = + unlines + ( "" + : "*********************************" + : ("Negative zero: " ++ doubleOrFloat numbers) + : "" + : map showPerform numbers) + where + showPerform = showAndPerform (isNegativeZero) "isNegativeZero" + +-- what a hack. +doubleOrFloat :: RealFloat a => [a] -> String +doubleOrFloat ls + | (floatDigits atType) == (floatDigits (0::Double)) = "Double" + | (floatDigits atType) == (floatDigits (0::Float)) = "Float" + | otherwise = "unknown RealFloat type" + where + atType = undefined `asTypeOf` (head ls) + +-- make a double from a list of 8 bytes +-- (caller deals with byte ordering.) +mkDouble :: [Word8] -> Double +mkDouble ls = + runST (( do + arr <- newArray_ (0,7) + sequence (zipWith (writeArray arr) [(0::Int)..] (take 8 ls)) + arr' <- castSTUArray arr + readArray arr' 0 + ) :: ST s Double ) + +showAndPerform :: (Show a, Show b) + => (a -> b) + -> String + -> a + -> String +showAndPerform fun name_fun val = + name_fun ++ ' ':show val ++ " = " ++ show (fun val) + + diff --git a/testsuite/tests/codeGen/should_run/cgrun044.stdout b/testsuite/tests/codeGen/should_run/cgrun044.stdout new file mode 100644 index 0000000000..0eb505e236 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun044.stdout @@ -0,0 +1,264 @@ + +********************************* +Denormalised numbers: Double + +isDenormalised 0.0 = False +isDenormalised 0.0 = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised NaN = False +isDenormalised 1.821736912876398e-300 = False +isDenormalised 1.8217369128763983e300 = False +isDenormalised 5.0e-324 = True +isDenormalised 2.2250738585072014e-308 = False +isDenormalised 0.11 = False +isDenormalised 0.1 = False +isDenormalised -3.4 = False +isDenormalised 2.2250738585072014e-308 = False +isDenormalised 1.7976931348623157e308 = False + + +********************************* +Positive Infinity: Double + +isInfinite 0.0 = False +isInfinite 0.0 = False +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite NaN = False +isInfinite 1.821736912876398e-300 = False +isInfinite 1.8217369128763983e300 = False +isInfinite 5.0e-324 = False +isInfinite 2.2250738585072014e-308 = False +isInfinite 0.11 = False +isInfinite 0.1 = False +isInfinite -3.4 = False +isInfinite 2.2250738585072014e-308 = False +isInfinite 1.7976931348623157e308 = False + + +********************************* +Negative Infinity: Double + +isNegInfinite 0.0 = False +isNegInfinite 0.0 = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite NaN = False +isNegInfinite 1.821736912876398e-300 = False +isNegInfinite 1.8217369128763983e300 = False +isNegInfinite 5.0e-324 = False +isNegInfinite 2.2250738585072014e-308 = False +isNegInfinite 0.11 = False +isNegInfinite 0.1 = False +isNegInfinite -3.4 = False +isNegInfinite 2.2250738585072014e-308 = False +isNegInfinite 1.7976931348623157e308 = False + + +********************************* +NaN: Double + +isNaN 0.0 = False +isNaN 0.0 = False +isNaN Infinity = False +isNaN Infinity = False +isNaN Infinity = False +isNaN Infinity = False +isNaN Infinity = False +isNaN NaN = True +isNaN 1.821736912876398e-300 = False +isNaN 1.8217369128763983e300 = False +isNaN 5.0e-324 = False +isNaN 2.2250738585072014e-308 = False +isNaN 0.11 = False +isNaN 0.1 = False +isNaN -3.4 = False +isNaN 2.2250738585072014e-308 = False +isNaN 1.7976931348623157e308 = False + + +********************************* +Negative zero: Double + +isNegativeZero 0.0 = False +isNegativeZero 0.0 = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero NaN = False +isNegativeZero 1.821736912876398e-300 = False +isNegativeZero 1.8217369128763983e300 = False +isNegativeZero 5.0e-324 = False +isNegativeZero 2.2250738585072014e-308 = False +isNegativeZero 0.11 = False +isNegativeZero 0.1 = False +isNegativeZero -3.4 = False +isNegativeZero 2.2250738585072014e-308 = False +isNegativeZero 1.7976931348623157e308 = False + + +********************************* +Positive zero: Double + +isPosZero 0.0 = True +isPosZero 0.0 = True +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero NaN = False +isPosZero 1.821736912876398e-300 = False +isPosZero 1.8217369128763983e300 = False +isPosZero 5.0e-324 = False +isPosZero 2.2250738585072014e-308 = False +isPosZero 0.11 = False +isPosZero 0.1 = False +isPosZero -3.4 = False +isPosZero 2.2250738585072014e-308 = False +isPosZero 1.7976931348623157e308 = False + + +********************************* +Denormalised numbers: Float + +isDenormalised 0.0 = False +isDenormalised 0.0 = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised Infinity = False +isDenormalised NaN = False +isDenormalised 0.0 = False +isDenormalised Infinity = False +isDenormalised 1.0e-45 = True +isDenormalised 1.1754944e-38 = False +isDenormalised 2.9802326e-8 = False +isDenormalised 0.11 = False +isDenormalised 0.1 = False +isDenormalised -3.4 = False +isDenormalised 1.1754944e-38 = False +isDenormalised 3.4028235e38 = False + + +********************************* +Positive Infinity: Float + +isInfinite 0.0 = False +isInfinite 0.0 = False +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite Infinity = True +isInfinite NaN = False +isInfinite 0.0 = False +isInfinite Infinity = True +isInfinite 1.0e-45 = False +isInfinite 1.1754944e-38 = False +isInfinite 2.9802326e-8 = False +isInfinite 0.11 = False +isInfinite 0.1 = False +isInfinite -3.4 = False +isInfinite 1.1754944e-38 = False +isInfinite 3.4028235e38 = False + + +********************************* +Negative Infinity: Float + +isNegInfinite 0.0 = False +isNegInfinite 0.0 = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite Infinity = False +isNegInfinite NaN = False +isNegInfinite 0.0 = False +isNegInfinite Infinity = False +isNegInfinite 1.0e-45 = False +isNegInfinite 1.1754944e-38 = False +isNegInfinite 2.9802326e-8 = False +isNegInfinite 0.11 = False +isNegInfinite 0.1 = False +isNegInfinite -3.4 = False +isNegInfinite 1.1754944e-38 = False +isNegInfinite 3.4028235e38 = False + + +********************************* +NaN: Float + +isNaN 0.0 = False +isNaN 0.0 = False +isNaN Infinity = False +isNaN Infinity = False +isNaN Infinity = False +isNaN Infinity = False +isNaN NaN = True +isNaN 0.0 = False +isNaN Infinity = False +isNaN 1.0e-45 = False +isNaN 1.1754944e-38 = False +isNaN 2.9802326e-8 = False +isNaN 0.11 = False +isNaN 0.1 = False +isNaN -3.4 = False +isNaN 1.1754944e-38 = False +isNaN 3.4028235e38 = False + + +********************************* +Negative zero: Float + +isNegativeZero 0.0 = False +isNegativeZero 0.0 = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero Infinity = False +isNegativeZero NaN = False +isNegativeZero 0.0 = False +isNegativeZero Infinity = False +isNegativeZero 1.0e-45 = False +isNegativeZero 1.1754944e-38 = False +isNegativeZero 2.9802326e-8 = False +isNegativeZero 0.11 = False +isNegativeZero 0.1 = False +isNegativeZero -3.4 = False +isNegativeZero 1.1754944e-38 = False +isNegativeZero 3.4028235e38 = False + + +********************************* +Positive zero: Float + +isPosZero 0.0 = True +isPosZero 0.0 = True +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero Infinity = False +isPosZero NaN = False +isPosZero 0.0 = True +isPosZero Infinity = False +isPosZero 1.0e-45 = False +isPosZero 1.1754944e-38 = False +isPosZero 2.9802326e-8 = False +isPosZero 0.11 = False +isPosZero 0.1 = False +isPosZero -3.4 = False +isPosZero 1.1754944e-38 = False +isPosZero 3.4028235e38 = False + diff --git a/testsuite/tests/codeGen/should_run/cgrun045.hs b/testsuite/tests/codeGen/should_run/cgrun045.hs new file mode 100644 index 0000000000..efd0b5c119 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun045.hs @@ -0,0 +1,8 @@ + +module Main( main ) where + + +main :: IO () +main = seq (error "hello world!" :: Int) (return ()) + + diff --git a/testsuite/tests/codeGen/should_run/cgrun045.stderr b/testsuite/tests/codeGen/should_run/cgrun045.stderr new file mode 100644 index 0000000000..711048f792 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun045.stderr @@ -0,0 +1 @@ +cgrun045: hello world! diff --git a/testsuite/tests/codeGen/should_run/cgrun045.stdout b/testsuite/tests/codeGen/should_run/cgrun045.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun045.stdout diff --git a/testsuite/tests/codeGen/should_run/cgrun046.hs b/testsuite/tests/codeGen/should_run/cgrun046.hs new file mode 100644 index 0000000000..be414a8a75 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun046.hs @@ -0,0 +1,10 @@ +module Main where + +import System.IO + +-- !!! CAF space leaks + +main = lots_of_xs 10000 + +lots_of_xs 0 = return () +lots_of_xs n = putChar 'x' >> lots_of_xs (n-1) diff --git a/testsuite/tests/codeGen/should_run/cgrun046.stdout b/testsuite/tests/codeGen/should_run/cgrun046.stdout new file mode 100644 index 0000000000..f2776bdd89 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun046.stdout @@ -0,0 +1 @@ +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun047.hs b/testsuite/tests/codeGen/should_run/cgrun047.hs new file mode 100644 index 0000000000..234c6671b6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun047.hs @@ -0,0 +1,18 @@ +module Main where + +-- GHC 4.04 +-- I've been having problems getting GHC to compile some code I'm working +-- on with optimisation (-O) turned on. Compilation is fine without -O +-- specified. Through a process of elimination I've managed to reproduce +-- the problemin the following (much simpler) piece of code: + +import Data.List + +test es = + concat (groupBy eq (zip [0..(length es) - 1] es)) + where + eq a b = (fst a) == (fst b) + +main = putStr (show (test [1,2,3,4])) + + diff --git a/testsuite/tests/codeGen/should_run/cgrun047.stdout b/testsuite/tests/codeGen/should_run/cgrun047.stdout new file mode 100644 index 0000000000..732d4fe8ff --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun047.stdout @@ -0,0 +1 @@ +[(0,1),(1,2),(2,3),(3,4)]
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun048.hs b/testsuite/tests/codeGen/should_run/cgrun048.hs new file mode 100644 index 0000000000..30f0b3e387 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun048.hs @@ -0,0 +1,24 @@ + +-- The new register allocator in 4.08 had a bug wherein +-- flow edges away from an insn which does a jump through +-- a switch table were not being added to the flow graph, +-- which causes computation of live ranges and thus register +-- assignment to be wrong in the alternatives and default. +-- This was fixed properly in the head branch (pre 4.09) +-- and avoided in 4.08.1 by disabling jump table generation +-- in the NCG -- it generates trees of ifs instead. + +module Main ( main ) where + +main = print (map f [1 .. 7]) + + + +{-# NOINLINE f #-} +f :: Int -> Bool +f 7 = False +f 1 = False +f 4 = False +f 6 = False +f 5 = False +f x = if x * 10 == 20 then True else False diff --git a/testsuite/tests/codeGen/should_run/cgrun048.stdout b/testsuite/tests/codeGen/should_run/cgrun048.stdout new file mode 100644 index 0000000000..ff596497db --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun048.stdout @@ -0,0 +1 @@ +[False,True,False,False,False,False,False] diff --git a/testsuite/tests/codeGen/should_run/cgrun049.hs b/testsuite/tests/codeGen/should_run/cgrun049.hs new file mode 100644 index 0000000000..d4b6a77908 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun049.hs @@ -0,0 +1,22 @@ +-- !! Data constructors with strict fields +-- This test should use -funbox-strict-fields + +module Main ( main ) where + +main = print (g (f t)) + +t = MkT 1 2 (3,4) (MkS 5 6) + +g (MkT x _ _ _) = x + +data T = MkT Int !Int !(Int,Int) !(S Int) + +data S a = MkS a a + + +{-# NOINLINE f #-} +f :: T -> T -- Takes apart the thing and puts it + -- back together differently +f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y) + + diff --git a/testsuite/tests/codeGen/should_run/cgrun049.stdout b/testsuite/tests/codeGen/should_run/cgrun049.stdout new file mode 100644 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun049.stdout @@ -0,0 +1 @@ +3 diff --git a/testsuite/tests/codeGen/should_run/cgrun050.hs b/testsuite/tests/codeGen/should_run/cgrun050.hs new file mode 100644 index 0000000000..7eb2cee05f --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun050.hs @@ -0,0 +1,23 @@ +-- !! Test strict, recursive newtypes +-- This test made a pre-5.02 fall over +-- Reason: the seq arising from the !F didn't see that +-- the represtation of F is a function. + +-- NB It's crucial to compile this test *without* -O +-- The $ then prevents the 'F' from seeing the '\x' +-- and hence makes the evaluation happen at runtime + +module Main ( main ) where + +newtype F = F (Int -> Val) -- NB: F and Val are +data Val = VFn !F | VInt !Int -- mutually recursive + +f :: Val -> Val +f (VFn (F f)) = f 4 + +main = print (f (VFn (F $ (\x -> VInt (x+3))))) + +instance Show Val where + show (VInt n) = show n + + diff --git a/testsuite/tests/codeGen/should_run/cgrun050.stdout b/testsuite/tests/codeGen/should_run/cgrun050.stdout new file mode 100644 index 0000000000..7f8f011eb7 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun050.stdout @@ -0,0 +1 @@ +7 diff --git a/testsuite/tests/codeGen/should_run/cgrun051.hs b/testsuite/tests/codeGen/should_run/cgrun051.hs new file mode 100644 index 0000000000..c8ebb7f5e3 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun051.hs @@ -0,0 +1,9 @@ + +module Main where + +data T1 -- No constructors +data T2 = T2 !T1 Int + +main = print (case (T2 (error "OK") 1) of { T2 x y -> y }) + +-- We should hit the (error "OK") case
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun051.stderr b/testsuite/tests/codeGen/should_run/cgrun051.stderr new file mode 100644 index 0000000000..fddcb81968 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun051.stderr @@ -0,0 +1 @@ +cgrun051: OK diff --git a/testsuite/tests/codeGen/should_run/cgrun052.hs b/testsuite/tests/codeGen/should_run/cgrun052.hs new file mode 100644 index 0000000000..cfce05442f --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun052.hs @@ -0,0 +1,13 @@ +-- !!! Caused a crash in GHC 5.04.2, fixed in CoreToStg.lhs rev. 1.98 + +data T1 = T1 +data T2 = C1 !T1 | C2 +data T3 = C3 !T2 Int + +{-# NOINLINE f #-} +f 0 = C3 (C1 T1) 42 +f n = C3 (C1 T1) n + +main = case f 23 of + C3 y z -> case y of + C1 T1 -> putStrLn "ok" diff --git a/testsuite/tests/codeGen/should_run/cgrun052.stdout b/testsuite/tests/codeGen/should_run/cgrun052.stdout new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun052.stdout @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/codeGen/should_run/cgrun053.hs b/testsuite/tests/codeGen/should_run/cgrun053.hs new file mode 100644 index 0000000000..f100cc983d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun053.hs @@ -0,0 +1,3 @@ +-- should run successfully and exit, i.e. without evaluating the +-- argument to return. +main = return undefined diff --git a/testsuite/tests/codeGen/should_run/cgrun054.hs b/testsuite/tests/codeGen/should_run/cgrun054.hs new file mode 100644 index 0000000000..cff967e9bb --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun054.hs @@ -0,0 +1,29 @@ +module Main where + +data Y = X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8 + deriving( Show ) + +data X = WithY Y + | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 + +foo :: X -> Y +foo A1 = X1 +foo A2 = X2 +foo A3 = X3 +foo A4 = X4 +foo A5 = X5 +foo A6 = X6 +foo A7 = X7 +foo A8 = X8 +foo (WithY _) = X1 + +bar :: X -> Y +bar (WithY x) = x +bar y = foobar (foo y) -- The WithY case can't occur, and in an + -- earlier version that confused the code generator + +{-# NOINLINE foobar #-} +foobar x = x + + +main = print (map bar [WithY X2, A4, A5]) diff --git a/testsuite/tests/codeGen/should_run/cgrun054.stdout b/testsuite/tests/codeGen/should_run/cgrun054.stdout new file mode 100644 index 0000000000..8b7f679ed1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun054.stdout @@ -0,0 +1 @@ +[X2,X4,X5] diff --git a/testsuite/tests/codeGen/should_run/cgrun055.hs b/testsuite/tests/codeGen/should_run/cgrun055.hs new file mode 100644 index 0000000000..737632748d --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun055.hs @@ -0,0 +1,46 @@ +-- This program broke GHC 6.3, becuase dataToTag was called with +-- an unevaluated argument + +module Main where + +import System.Environment (getArgs) + +-- NOTE: When if you remove Eight (or any other constructor) everything works +-- Having at least 9 constructors has something to do with the bug +data Digit = Zero | One | Two | Three | Four | Five | Six | Seven | Eight + deriving (Eq,Enum) + +instance Show Digit where + show Five = "Five" + show Six = "Six" + show _ = undefined + +-- Use either of these instances (instead of derived) and everything works +{-instance Enum Digit where + fromEnum Five = 5 + fromEnum _ = undefined + toEnum 6 = Six + toEnum _ = undefined-} + +{-instance Eq Digit where + Five == Five = True + Six == Six = True + _ == _ = undefined-} + +isFive :: Digit -> Bool +isFive a = succ a == Six + +main :: IO() +main = do + putStrLn ("======") + -- These next two lines are just here to keep ghc from optimizing away stuff + args <- getArgs + let x = if length args == -1 then undefined else Five + putStrLn ("x: " ++ show x) + let y = succ x + putStrLn ("let y = succ x") + putStrLn ("y: " ++ show y) + putStrLn ("y == Six: " ++ show (y == Six)) + putStrLn ("succ x == Six: " ++ show (succ x == Six)) + putStrLn ("isFive x: " ++ show (isFive x)) + diff --git a/testsuite/tests/codeGen/should_run/cgrun055.stdout b/testsuite/tests/codeGen/should_run/cgrun055.stdout new file mode 100644 index 0000000000..c5907cac04 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun055.stdout @@ -0,0 +1,7 @@ +====== +x: Five +let y = succ x +y: Six +y == Six: True +succ x == Six: True +isFive x: True diff --git a/testsuite/tests/codeGen/should_run/cgrun056.hs b/testsuite/tests/codeGen/should_run/cgrun056.hs new file mode 100644 index 0000000000..e1a10511a7 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun056.hs @@ -0,0 +1,8 @@ +-- Another test for the evaluated-ness of data2tag + +module Main where + + data S e = A | B | C | D | E | F | G | H | I deriving (Eq) + newtype R = T (S R) deriving (Eq) + + main = do { print (T A == T B) ; print (T I == T I) } diff --git a/testsuite/tests/codeGen/should_run/cgrun056.stdout b/testsuite/tests/codeGen/should_run/cgrun056.stdout new file mode 100644 index 0000000000..91d6f80f27 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun056.stdout @@ -0,0 +1,2 @@ +False +True diff --git a/testsuite/tests/codeGen/should_run/cgrun057.hs b/testsuite/tests/codeGen/should_run/cgrun057.hs new file mode 100644 index 0000000000..09119546fb --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun057.hs @@ -0,0 +1,7 @@ +-- For testing +RTS -xc +import Control.Exception +main = try (evaluate (f ())) + +f x = g x + +g x = error (show x) diff --git a/testsuite/tests/codeGen/should_run/cgrun057.stderr b/testsuite/tests/codeGen/should_run/cgrun057.stderr new file mode 100644 index 0000000000..d3d46dacf3 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun057.stderr @@ -0,0 +1 @@ +<Main.g,Main.f,Main.main,Main.CAF>
\ No newline at end of file diff --git a/testsuite/tests/codeGen/should_run/cgrun058.hs b/testsuite/tests/codeGen/should_run/cgrun058.hs new file mode 100644 index 0000000000..f0001584d1 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun058.hs @@ -0,0 +1,30 @@ +-- Not really a code-gen test, but this program gave +-- incorrect results in Hugs (Hugs Trac #37), so I +-- thought I'd add it to GHC's test suite. + +module Main where + +data MInt = Zero | Succ MInt | Pred MInt deriving Show + +tn :: Int -> MInt +tn x | x<0 = Pred (tn (x+1)) +tn 0 = Zero +tn n = Succ (tn (n - 1)) + +ti :: MInt -> Int +ti Zero = 0 +ti (Succ x) = 1+(ti x) +ti (Pred x) = (ti x) -1 + +testi :: (MInt -> MInt -> MInt) -> (Int -> Int -> Int) -> Int -> Int -> Bool +testi f g x y = (ti (f (tn x) (tn y))) /= (g x y) + +myMul x y = tn ((ti x) * (ti y)) + +-- test should be empty! +test = [ (x,y,ti (myMul (tn x) (tn y)),x * y) + | x<-[-100, -99, -98, -97, -2, -1, 0, 1, 2, 97, 98, 99, 100], + y<-([-100..(-1)]++[1..100]), + testi myMul (*) x y ] + +main = print test diff --git a/testsuite/tests/codeGen/should_run/cgrun058.stdout b/testsuite/tests/codeGen/should_run/cgrun058.stdout new file mode 100644 index 0000000000..fe51488c70 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun058.stdout @@ -0,0 +1 @@ +[] diff --git a/testsuite/tests/codeGen/should_run/cgrun059.hs b/testsuite/tests/codeGen/should_run/cgrun059.hs new file mode 100644 index 0000000000..52d2ee88a5 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun059.hs @@ -0,0 +1,34 @@ +-- GHC 6.6 compiled YHC wrong; this is a cutdown testcase (from trac #1171). + +module Main where + +import System.Directory + +data Error + = ErrorFileNone + | ErrorFileMany + FilePath -- file you were looking for + +raiseError ErrorFileNone = error "Error: File not found" +raiseError (ErrorFileMany file) = error $ "Error: Found file multiple times: "++file + +data PackageData = PackageData [FilePath] deriving Show + +getModule :: PackageData -> String -> IO () +getModule (PackageData rs@(root:rest)) file = + do local <- testPackage root + res <- testPackage root + print (local, res) + case (local,res) of + ([x], _) -> return () + (_, [x]) -> return () + ([], []) -> raiseError $ ErrorFileNone + (as, bs) -> if as++bs == [] then error "Empty as++bs" else raiseError $ ErrorFileMany file + where + testPackage pkg = + do + bHi <- doesFileExist "" + return [("","") | bHi] + +main = getModule (PackageData ["7"]) "13" + diff --git a/testsuite/tests/codeGen/should_run/cgrun059.stderr b/testsuite/tests/codeGen/should_run/cgrun059.stderr new file mode 100644 index 0000000000..005f06e295 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun059.stderr @@ -0,0 +1 @@ +cgrun059: Error: File not found diff --git a/testsuite/tests/codeGen/should_run/cgrun059.stdout b/testsuite/tests/codeGen/should_run/cgrun059.stdout new file mode 100644 index 0000000000..929ec8f128 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun059.stdout @@ -0,0 +1 @@ +([],[]) diff --git a/testsuite/tests/codeGen/should_run/cgrun060.hs b/testsuite/tests/codeGen/should_run/cgrun060.hs new file mode 100644 index 0000000000..a7558029d4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun060.hs @@ -0,0 +1,18 @@ +-- tickled a bug in stack squeezing in 6.8.2. unsafePerformIO calls +-- noDuplicate#, which marks the update frames on the stack, and was +-- preventing subsequent update frames from being collapsed with the +-- marked frame. + +module Main where + +import System.IO.Unsafe + +main = print (sim (replicate 100000 ())) + +sim [] = True +sim (_:xs) = badStack (sim xs) + +goodStack x = fromJust (Just x) --no stack overflow +badStack x = unsafePerformIO (return x) --stack overflow + +fromJust (Just x) = x diff --git a/testsuite/tests/codeGen/should_run/cgrun060.stdout b/testsuite/tests/codeGen/should_run/cgrun060.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun060.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/codeGen/should_run/cgrun061.hs b/testsuite/tests/codeGen/should_run/cgrun061.hs new file mode 100644 index 0000000000..9e32c654db --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun061.hs @@ -0,0 +1,17 @@ + +module Main where + +newtype Test = Test { var :: String } + +{- +hugs (Sept 2006) gives +Program error: pattern match failure: instShow_v16_v1443 (Test_Test "a") +Program error: pattern match failure: instShow_v16_v1443 (Test_Test "b") +hugs trac #46 +-} + +main = do print (var x) + print (var (y{var="b"})) + where x = Test { var = "a" } + y = Test "a" + diff --git a/testsuite/tests/codeGen/should_run/cgrun061.stdout b/testsuite/tests/codeGen/should_run/cgrun061.stdout new file mode 100644 index 0000000000..071144f214 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun061.stdout @@ -0,0 +1,2 @@ +"a" +"b" diff --git a/testsuite/tests/codeGen/should_run/cgrun062.hs b/testsuite/tests/codeGen/should_run/cgrun062.hs new file mode 100644 index 0000000000..915f84c397 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun062.hs @@ -0,0 +1,17 @@ + +module Main where + +newtype T = C { f :: String } + +{- +hugs (Sept 2006) gives +"bc" +Program error: Prelude.undefined +hugs trac #48 +-} + +main = do print $ case C "abc" of + C { f = v } -> v + print $ case undefined of + C {} -> True + diff --git a/testsuite/tests/codeGen/should_run/cgrun062.stdout b/testsuite/tests/codeGen/should_run/cgrun062.stdout new file mode 100644 index 0000000000..3bb22bbe9a --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun062.stdout @@ -0,0 +1,2 @@ +"abc" +True diff --git a/testsuite/tests/codeGen/should_run/cgrun063.hs b/testsuite/tests/codeGen/should_run/cgrun063.hs new file mode 100644 index 0000000000..14f3cb8d14 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun063.hs @@ -0,0 +1,20 @@ + +{- +Check that we aren't making gcc misinterpret our strings as trigraphs. +Trac #2968. +http://gcc.gnu.org/onlinedocs/cpp/Initial-processing.html +-} + +module Main where + +main :: IO () +main = do putStrLn "??(" + putStrLn "??)" + putStrLn "??<" + putStrLn "??>" + putStrLn "??=" + putStrLn "??/" + putStrLn "??'" + putStrLn "??!" + putStrLn "??-" + diff --git a/testsuite/tests/codeGen/should_run/cgrun063.stdout b/testsuite/tests/codeGen/should_run/cgrun063.stdout new file mode 100644 index 0000000000..73f45448d9 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun063.stdout @@ -0,0 +1,9 @@ +??( +??) +??< +??> +??= +??/ +??' +??! +??- diff --git a/testsuite/tests/codeGen/should_run/cgrun064.hs b/testsuite/tests/codeGen/should_run/cgrun064.hs new file mode 100644 index 0000000000..aa037e8782 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun064.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- !!! simple tests of copying/cloning primitive arrays +-- + +module Main ( main ) where + +import GHC.Exts +import GHC.Prim +import GHC.ST + +main = putStr + (test_copyArray + ++ "\n" ++ test_copyMutableArray + ++ "\n" ++ test_copyMutableArrayOverlap + ++ "\n" ++ test_cloneArray + ++ "\n" ++ test_cloneMutableArray + ++ "\n" ++ test_cloneMutableArrayEmpty + ++ "\n" ++ test_freezeArray + ++ "\n" ++ test_thawArray + ++ "\n" + ) + +------------------------------------------------------------------------ +-- Constants + +-- All allocated arrays are of this size +len :: Int +len = 130 + +-- We copy these many elements +copied :: Int +copied = len - 2 + +------------------------------------------------------------------------ +-- copyArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_copyArray :: String +test_copyArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + src <- unsafeFreezeArray src + dst <- newArray len (-1) + -- Leave the first and last element untouched + copyArray src 1 dst 1 copied + unsafeFreezeArray dst + in shows (toList dst len) "\n" + +------------------------------------------------------------------------ +-- copyMutableArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_copyMutableArray :: String +test_copyMutableArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + dst <- newArray len (-1) + -- Leave the first and last element untouched + copyMutableArray src 1 dst 1 copied + unsafeFreezeArray dst + in shows (toList dst len) "\n" + +-- Perform a copy where the source and destination part overlap. +test_copyMutableArrayOverlap :: String +test_copyMutableArrayOverlap = + let arr = runST $ do + marr <- fromList inp + -- Overlap of two elements + copyMutableArray marr 5 marr 7 8 + unsafeFreezeArray marr + in shows (toList arr (length inp)) "\n" + where + -- This case was known to fail at some point. + inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196] + +------------------------------------------------------------------------ +-- cloneArray# + +-- Clone a slice of the source array into a destination array and +-- check that the clone succeeded. +test_cloneArray :: String +test_cloneArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + src <- unsafeFreezeArray src + -- Don't include the first and last element. + return $ cloneArray src 1 copied + in shows (toList dst copied) "\n" + +------------------------------------------------------------------------ +-- cloneMutableArray# + +-- Clone a slice of the source array into a destination array and +-- check that the clone succeeded. +test_cloneMutableArray :: String +test_cloneMutableArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + -- Don't include the first and last element. + dst <- cloneMutableArray src 1 copied + unsafeFreezeArray dst + in shows (toList dst copied) "\n" + +-- Check that zero-length clones work. +test_cloneMutableArrayEmpty :: String +test_cloneMutableArrayEmpty = + let dst = runST $ do + src <- newArray len 0 + dst <- cloneMutableArray src 0 0 + unsafeFreezeArray dst + in shows (toList dst 0) "\n" + +------------------------------------------------------------------------ +-- freezeArray# + +-- Clone a slice of the source array into a destination array and +-- check that the clone succeeded. +test_freezeArray :: String +test_freezeArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + -- Don't include the first and last element. + freezeArray src 1 copied + in shows (toList dst copied) "\n" + +------------------------------------------------------------------------ +-- thawArray# + +-- Clone a slice of the source array into a destination array and +-- check that the clone succeeded. +test_thawArray :: String +test_thawArray = + let dst = runST $ do + src <- newArray len 0 + fill src 0 len + src <- unsafeFreezeArray src + -- Don't include the first and last element. + dst <- thawArray src 1 copied + unsafeFreezeArray dst + in shows (toList dst copied) "\n" + +------------------------------------------------------------------------ +-- Test helpers + +-- Initialize the elements of this array, starting at the given +-- offset. The last parameter specifies the number of elements to +-- initialize. Element at index @i@ takes the value @i*i@ (i.e. the +-- first actually modified element will take value @off*off@). +fill :: MArray s Int -> Int -> Int -> ST s () +fill marr off count = go 0 + where + go i + | i >= count = return () + | otherwise = writeArray marr (off + i) (i*i) >> go (i + 1) + +fromList :: [Int] -> ST s (MArray s Int) +fromList xs0 = do + marr <- newArray (length xs0) bottomElem + let go [] i = i `seq` return marr + go (x:xs) i = writeArray marr i x >> go xs (i + 1) + go xs0 0 + where + bottomElem = error "undefined element" + +------------------------------------------------------------------------ +-- Convenience wrappers for Array# and MutableArray# + +data Array a = Array { unArray :: Array# a } +data MArray s a = MArray { unMArray :: MutableArray# s a } + +newArray :: Int -> a -> ST s (MArray s a) +newArray (I# n#) a = ST $ \s# -> case newArray# n# a s# of + (# s2#, marr# #) -> (# s2#, MArray marr# #) + +indexArray :: Array a -> Int -> a +indexArray arr (I# i#) = case indexArray# (unArray arr) i# of + (# a #) -> a + +writeArray :: MArray s a -> Int -> a -> ST s () +writeArray marr (I# i#) a = ST $ \ s# -> + case writeArray# (unMArray marr) i# a s# of + s2# -> (# s2#, () #) + +unsafeFreezeArray :: MArray s a -> ST s (Array a) +unsafeFreezeArray marr = ST $ \ s# -> + case unsafeFreezeArray# (unMArray marr) s# of + (# s2#, arr# #) -> (# s2#, Array arr# #) + +copyArray :: Array a -> Int -> MArray s a -> Int -> Int -> ST s () +copyArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# -> + case copyArray# (unArray src) six# (unMArray dst) dix# n# s# of + s2# -> (# s2#, () #) + +copyMutableArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s () +copyMutableArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# -> + case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of + s2# -> (# s2#, () #) + +cloneArray :: Array a -> Int -> Int -> Array a +cloneArray src (I# six#) (I# n#) = Array (cloneArray# (unArray src) six# n#) + +cloneMutableArray :: MArray s a -> Int -> Int -> ST s (MArray s a) +cloneMutableArray src (I# six#) (I# n#) = ST $ \ s# -> + case cloneMutableArray# (unMArray src) six# n# s# of + (# s2#, marr# #) -> (# s2#, MArray marr# #) + +freezeArray :: MArray s a -> Int -> Int -> ST s (Array a) +freezeArray src (I# six#) (I# n#) = ST $ \ s# -> + case freezeArray# (unMArray src) six# n# s# of + (# s2#, arr# #) -> (# s2#, Array arr# #) + +thawArray :: Array a -> Int -> Int -> ST s (MArray s a) +thawArray src (I# six#) (I# n#) = ST $ \ s# -> + case thawArray# (unArray src) six# n# s# of + (# s2#, marr# #) -> (# s2#, MArray marr# #) + +toList :: Array a -> Int -> [a] +toList arr n = go 0 + where + go i | i >= n = [] + | otherwise = indexArray arr i : go (i+1) diff --git a/testsuite/tests/codeGen/should_run/cgrun064.stdout b/testsuite/tests/codeGen/should_run/cgrun064.stdout new file mode 100644 index 0000000000..8e741ceec6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun064.stdout @@ -0,0 +1,16 @@ +[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1] + +[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1] + +[0,169,196,9,16,25,36,25,36,16,25,81,100,121,144] + +[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384] + +[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384] + +[] + +[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384] + +[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384] + diff --git a/testsuite/tests/codeGen/should_run/cgrun065.hs b/testsuite/tests/codeGen/should_run/cgrun065.hs new file mode 100644 index 0000000000..6934832013 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun065.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +module Main ( main ) where + +import GHC.Exts +import GHC.Prim +import GHC.ST + +main = putStr + (test_sizeofArray + ++ "\n" ++ test_sizeofMutableArray + ++ "\n" + ) + +test_sizeofArray :: String +test_sizeofArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s# + where + go i@(I# i#) acc s# + | i < 1000 = case newArray# i# 0 s# of + (# s2#, marr# #) -> case unsafeFreezeArray# marr# s2# of + (# s3#, arr# #) -> case sizeofArray# arr# of + j# -> go (i+1) ((I# j#):acc) s3# + | otherwise = (# s#, reverse acc #) + +test_sizeofMutableArray :: String +test_sizeofMutableArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s# + where + go i@(I# i#) acc s# + | i < 1000 = case newArray# i# 0 s# of + (# s2#, marr# #) -> case sizeofMutableArray# marr# of + j# -> go (i+1) ((I# j#):acc) s2# + | otherwise = (# s#, reverse acc #) + diff --git a/testsuite/tests/codeGen/should_run/cgrun065.stdout b/testsuite/tests/codeGen/should_run/cgrun065.stdout new file mode 100644 index 0000000000..bf895d50ef --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun065.stdout @@ -0,0 +1,4 @@ +[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999] + +[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999] + diff --git a/testsuite/tests/codeGen/should_run/cgrun066.hs b/testsuite/tests/codeGen/should_run/cgrun066.hs new file mode 100644 index 0000000000..aa1c621d71 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun066.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +{-# OPTIONS_GHC -O0 #-} + +import Foreign.C +import Data.Word +import Foreign.Ptr +import GHC.Exts + +import Control.Exception + +hashStr :: Ptr Word8 -> Int -> Int +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | n GHC.Exts.==# len# = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# + +-- Infinite loops with new code generator + C-- optimizations +main = do + withCStringLen "ff" $ \(ptr, l) -> do + print (hashStr (castPtr ptr) l) diff --git a/testsuite/tests/codeGen/should_run/cgrun066.stdout b/testsuite/tests/codeGen/should_run/cgrun066.stdout new file mode 100644 index 0000000000..b9cb48f6e4 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun066.stdout @@ -0,0 +1 @@ +885 diff --git a/testsuite/tests/codeGen/should_run/cgrun067.hs b/testsuite/tests/codeGen/should_run/cgrun067.hs new file mode 100644 index 0000000000..74666c1ee6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun067.hs @@ -0,0 +1,11 @@ +-- This test-case tickled a bug where an optimization pass incorrectly +-- reloaded a stack slot before the slot was initialized. It was a bit +-- tricky to reproduce, and I don't really know why this particular +-- harness was necessary. + +-- Miscompiled code must be in another module, otherwise problem doesn't +-- show up. +import Cgrun067A (miscompiledFn) +import Foreign.C.String + +main = withCString "foobar" $ \p -> print =<< miscompiledFn p diff --git a/testsuite/tests/codeGen/should_run/cgrun067.stdout b/testsuite/tests/codeGen/should_run/cgrun067.stdout new file mode 100644 index 0000000000..14e24d4190 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun067.stdout @@ -0,0 +1 @@ +"foobar" diff --git a/testsuite/tests/codeGen/should_run/cgrun068.hs b/testsuite/tests/codeGen/should_run/cgrun068.hs new file mode 100644 index 0000000000..f5096ad998 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun068.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash, + UnboxedTuples #-} + +-- !!! stress tests of copying/cloning primitive arrays + +-- Note: You can run this test manually with an argument +-- (i.e. ./cgrun068 10000) if you want to run the stress test for +-- longer. + +{- +Test strategy +============= + +We create an array of arrays of integers. Repeatedly we then either + +* allocate a new array in place of an old, or + +* copy a random segment of an array into another array (which might be + the source array). + +By running this process long enough we hope to trigger any bugs +related to garbage collection or edge cases. + +We only test copyMutableArray# and cloneArray# as they are +representative of all the primops. +-} + +module Main ( main ) where + +import Debug.Trace (trace) + +import Control.Exception (assert) +import Control.Monad +import Control.Monad.State.Strict +import GHC.Exts +import GHC.ST hiding (liftST) +import Prelude hiding (length, read) +import qualified Prelude as P +import qualified Prelude as P +import System.Environment +import System.Random + +main :: IO () +main = do + args <- getArgs + -- Number of copies to perform + let numMods = case args of + [] -> 100 + [n] -> P.read n :: Int + putStr (test_copyMutableArray numMods ++ "\n" ++ + test_cloneMutableArray numMods ++ "\n" + ) + +-- Number of arrays +numArrays :: Int +numArrays = 100 + +-- Maxmimum length of a sub-array +maxLen :: Int +maxLen = 1024 + +-- Create an array of arrays, with each sub-array having random length +-- and content. +setup :: Rng s (MArray s (MArray s Int)) +setup = do + len <- rnd (1, numArrays) + marr <- liftST $ new_ len + let go i + | i >= len = return () + | otherwise = do + n <- rnd (1, maxLen) + subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]] + liftST $ write marr i subarr + go (i+1) + go 0 + return marr + +-- Replace one of the sub-arrays with a newly allocated array. +allocate :: MArray s (MArray s Int) -> Rng s () +allocate marr = do + ix <- rnd (0, length marr - 1) + n <- rnd (1, maxLen) + subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]] + liftST $ write marr ix subarr + +type CopyFunction s a = + MArray s a -> Int -> MArray s a -> Int -> Int -> ST s () + +-- Copy a random segment of an array onto another array, using the +-- supplied copy function. +copy :: MArray s (MArray s a) -> CopyFunction s a + -> Rng s (Int, Int, Int, Int, Int) +copy marr f = do + six <- rnd (0, length marr - 1) + dix <- rnd (0, length marr - 1) + src <- liftST $ read marr six + dst <- liftST $ read marr dix + let srcLen = length src + srcOff <- rnd (0, srcLen - 1) + let dstLen = length dst + dstOff <- rnd (0, dstLen - 1) + n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff)) + liftST $ f src srcOff dst dstOff n + return (six, dix, srcOff, dstOff, n) + +type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a) + +-- Clone a random segment of an array, replacing another array, using +-- the supplied clone function. +clone :: MArray s (MArray s a) -> CloneFunction s a + -> Rng s (Int, Int, Int, Int) +clone marr f = do + six <- rnd (0, length marr - 1) + dix <- rnd (0, length marr - 1) + src <- liftST $ read marr six + let srcLen = length src + -- N.B. The array length might be zero if we previously cloned + -- zero elements from some array. + srcOff <- rnd (0, max 0 (srcLen - 1)) + n <- rnd (0, srcLen - srcOff) + dst <- liftST $ f src srcOff n + liftST $ write marr dix dst + return (six, dix, srcOff, n) + +------------------------------------------------------------------------ +-- copyMutableArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_copyMutableArray :: Int -> String +test_copyMutableArray numMods = runST $ run $ do + marr <- local setup + marrRef <- setup + let go i + | i >= numMods = return "test_copyMutableArray: OK" + | otherwise = do + -- Either allocate or copy + alloc <- rnd (True, False) + if alloc then doAlloc else doCopy + go (i+1) + + doAlloc = do + local $ allocate marr + allocate marrRef + + doCopy = do + inp <- liftST $ asList marr + _ <- local $ copy marr copyMArray + (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow + el <- liftST $ asList marr + elRef <- liftST $ asList marrRef + when (el /= elRef) $ + fail inp el elRef six dix srcOff dstOff n + go 0 + where + fail inp el elRef six dix srcOff dstOff n = + error $ "test_copyMutableArray: FAIL\n" + ++ " Input: " ++ unlinesShow inp + ++ " Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: " + ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n" + ++ "Expected: " ++ unlinesShow elRef + ++ " Actual: " ++ unlinesShow el + +asList :: MArray s (MArray s a) -> ST s [[a]] +asList marr = toListM =<< mapArrayM toListM marr + +unlinesShow :: Show a => [a] -> String +unlinesShow = concatMap (\ x -> show x ++ "\n") + +------------------------------------------------------------------------ +-- cloneMutableArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_cloneMutableArray :: Int -> String +test_cloneMutableArray numMods = runST $ run $ do + marr <- local setup + marrRef <- setup + let go i + | i >= numMods = return "test_cloneMutableArray: OK" + | otherwise = do + -- Either allocate or clone + alloc <- rnd (True, False) + if alloc then doAlloc else doClone + go (i+1) + + doAlloc = do + local $ allocate marr + allocate marrRef + + doClone = do + inp <- liftST $ asList marr + _ <- local $ clone marr cloneMArray + (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow + el <- liftST $ asList marr + elRef <- liftST $ asList marrRef + when (el /= elRef) $ + fail inp el elRef six dix srcOff n + go 0 + where + fail inp el elRef six dix srcOff n = + error $ "test_cloneMutableArray: FAIL\n" + ++ " Input: " ++ unlinesShow inp + ++ " Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: " + ++ show srcOff ++ " n: " ++ show n ++ "\n" + ++ "Expected: " ++ unlinesShow elRef + ++ " Actual: " ++ unlinesShow el + +------------------------------------------------------------------------ +-- Convenience wrappers for Array# and MutableArray# + +data Array a = Array + { unArray :: Array# a + , lengthA :: {-# UNPACK #-} !Int} + +data MArray s a = MArray + { unMArray :: MutableArray# s a + , lengthM :: {-# UNPACK #-} !Int} + +class IArray a where + length :: a -> Int +instance IArray (Array a) where + length = lengthA +instance IArray (MArray s a) where + length = lengthM + +instance Eq a => Eq (Array a) where + arr1 == arr2 = toList arr1 == toList arr2 + +new :: Int -> a -> ST s (MArray s a) +new n@(I# n#) a = + assert (n >= 0) $ + ST $ \s# -> case newArray# n# a s# of + (# s2#, marr# #) -> (# s2#, MArray marr# n #) + +new_ :: Int -> ST s (MArray s a) +new_ n = new n (error "Undefined element") + +write :: MArray s a -> Int -> a -> ST s () +write marr i@(I# i#) a = + assert (i >= 0) $ + assert (i < length marr) $ + ST $ \ s# -> + case writeArray# (unMArray marr) i# a s# of + s2# -> (# s2#, () #) + +read :: MArray s a -> Int -> ST s a +read marr i@(I# i#) = + assert (i >= 0) $ + assert (i < length marr) $ + ST $ \ s# -> + readArray# (unMArray marr) i# s# + +index :: Array a -> Int -> a +index arr i@(I# i#) = + assert (i >= 0) $ + assert (i < length arr) $ + case indexArray# (unArray arr) i# of + (# a #) -> a + +unsafeFreeze :: MArray s a -> ST s (Array a) +unsafeFreeze marr = ST $ \ s# -> + case unsafeFreezeArray# (unMArray marr) s# of + (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #) + +toList :: Array a -> [a] +toList arr = go 0 + where + go i | i >= length arr = [] + | otherwise = index arr i : go (i+1) + +fromList :: [e] -> ST s (MArray s e) +fromList es = do + marr <- new_ n + let go !_ [] = return () + go i (x:xs) = write marr i x >> go (i+1) xs + go 0 es + return marr + where + n = P.length es + +mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b) +mapArrayM f src = do + dst <- new_ n + let go i + | i >= n = return dst + | otherwise = do + el <- read src i + el' <- f el + write dst i el' + go (i+1) + go 0 + where + n = length src + +toListM :: MArray s e -> ST s [e] +toListM marr = + sequence [read marr i | i <- [0..(length marr)-1]] + +------------------------------------------------------------------------ +-- Wrappers around copy/clone primops + +copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s () +copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) = + assert (six >= 0) $ + assert (six + n <= length src) $ + assert (dix >= 0) $ + assert (dix + n <= length dst) $ + ST $ \ s# -> + case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of + s2# -> (# s2#, () #) + +cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a) +cloneMArray marr off@(I# off#) n@(I# n#) = + assert (off >= 0) $ + assert (off + n <= length marr) $ + ST $ \ s# -> + case cloneMutableArray# (unMArray marr) off# n# s# of + (# s2#, marr2 #) -> (# s2#, MArray marr2 n #) + +------------------------------------------------------------------------ +-- Manual versions of copy/clone primops. Used to validate the +-- primops + +copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () +copyMArraySlow !src !six !dst !dix n = + assert (six >= 0) $ + assert (six + n <= length src) $ + assert (dix >= 0) $ + assert (dix + n <= length dst) $ + if six < dix + then goB (six+n-1) (dix+n-1) 0 -- Copy backwards + else goF six dix 0 -- Copy forwards + where + goF !i !j c + | c >= n = return () + | otherwise = do b <- read src i + write dst j b + goF (i+1) (j+1) (c+1) + goB !i !j c + | c >= n = return () + | otherwise = do b <- read src i + write dst j b + goB (i-1) (j-1) (c+1) + +cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a) +cloneMArraySlow !marr !off n = + assert (off >= 0) $ + assert (off + n <= length marr) $ do + marr2 <- new_ n + let go !i !j c + | c >= n = return marr2 + | otherwise = do + b <- read marr i + write marr2 j b + go (i+1) (j+1) (c+1) + go off 0 0 + +------------------------------------------------------------------------ +-- Utilities for simplifying RNG passing + +newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a } + deriving Monad + +-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad. +rnd :: Random a => (a, a) -> Rng s a +rnd r = Rng $ do + g <- get + let (x, g') = randomR r g + put g' + return x + +-- Run a sub-computation without affecting the RNG state. +local :: Rng s a -> Rng s a +local m = Rng $ do + g <- get + x <- unRng m + put g + return x + +liftST :: ST s a -> Rng s a +liftST m = Rng $ lift m + +run :: Rng s a -> ST s a +run = flip evalStateT (mkStdGen 13) . unRng + diff --git a/testsuite/tests/codeGen/should_run/cgrun068.stdout b/testsuite/tests/codeGen/should_run/cgrun068.stdout new file mode 100644 index 0000000000..122a125a8e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun068.stdout @@ -0,0 +1,2 @@ +test_copyMutableArray: OK +test_cloneMutableArray: OK diff --git a/testsuite/tests/codeGen/should_run/cgrun069.hs b/testsuite/tests/codeGen/should_run/cgrun069.hs new file mode 100644 index 0000000000..076abc211e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun069.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} +module Main where + +import GHC.Exts +import Control.Exception +import System.IO + +foreign import prim "memintrinTest" basicTest :: Int# -> Int# + +foreign import prim "testMemset8_0" testMemset8_0 :: Int# -> Int# +foreign import prim "testMemset8_8" testMemset8_8 :: Int# -> Int# +foreign import prim "testMemset8_9" testMemset8_9 :: Int# -> Int# +foreign import prim "testMemset8_10" testMemset8_10 :: Int# -> Int# +foreign import prim "testMemset8_11" testMemset8_11 :: Int# -> Int# +foreign import prim "testMemset8_12" testMemset8_12 :: Int# -> Int# +foreign import prim "testMemset8_13" testMemset8_13 :: Int# -> Int# +foreign import prim "testMemset8_14" testMemset8_14 :: Int# -> Int# +foreign import prim "testMemset8_15" testMemset8_15 :: Int# -> Int# +foreign import prim "testMemset8_16" testMemset8_16 :: Int# -> Int# +foreign import prim "testMemset4_0" testMemset4_0 :: Int# -> Int# +foreign import prim "testMemset4_4" testMemset4_4 :: Int# -> Int# +foreign import prim "testMemset4_5" testMemset4_5 :: Int# -> Int# +foreign import prim "testMemset4_6" testMemset4_6 :: Int# -> Int# +foreign import prim "testMemset4_7" testMemset4_7 :: Int# -> Int# +foreign import prim "testMemset4_8" testMemset4_8 :: Int# -> Int# + +foreign import prim "testMemcpy8_0" testMemcpy8_0 :: Int# -> Int# +foreign import prim "testMemcpy8_8" testMemcpy8_8 :: Int# -> Int# +foreign import prim "testMemcpy8_9" testMemcpy8_9 :: Int# -> Int# +foreign import prim "testMemcpy8_10" testMemcpy8_10 :: Int# -> Int# +foreign import prim "testMemcpy8_11" testMemcpy8_11 :: Int# -> Int# +foreign import prim "testMemcpy8_12" testMemcpy8_12 :: Int# -> Int# +foreign import prim "testMemcpy8_13" testMemcpy8_13 :: Int# -> Int# +foreign import prim "testMemcpy8_14" testMemcpy8_14 :: Int# -> Int# +foreign import prim "testMemcpy8_15" testMemcpy8_15 :: Int# -> Int# +foreign import prim "testMemcpy8_16" testMemcpy8_16 :: Int# -> Int# +foreign import prim "testMemcpy4_0" testMemcpy4_0 :: Int# -> Int# +foreign import prim "testMemcpy4_4" testMemcpy4_4 :: Int# -> Int# +foreign import prim "testMemcpy4_5" testMemcpy4_5 :: Int# -> Int# +foreign import prim "testMemcpy4_6" testMemcpy4_6 :: Int# -> Int# +foreign import prim "testMemcpy4_7" testMemcpy4_7 :: Int# -> Int# +foreign import prim "testMemcpy4_8" testMemcpy4_8 :: Int# -> Int# + +main = do + putStrLn "Mem{cpy,set,move} Intrinsics Test..." + _ <- evaluate (I# (basicTest 1#)) + + _ <- evaluate (I# (testMemset8_0 1#)) + _ <- evaluate (I# (testMemset8_8 1#)) + _ <- evaluate (I# (testMemset8_9 1#)) + _ <- evaluate (I# (testMemset8_10 1#)) + _ <- evaluate (I# (testMemset8_11 1#)) + _ <- evaluate (I# (testMemset8_12 1#)) + _ <- evaluate (I# (testMemset8_13 1#)) + _ <- evaluate (I# (testMemset8_14 1#)) + _ <- evaluate (I# (testMemset8_15 1#)) + _ <- evaluate (I# (testMemset8_16 1#)) + _ <- evaluate (I# (testMemset4_0 1#)) + _ <- evaluate (I# (testMemset4_4 1#)) + _ <- evaluate (I# (testMemset4_5 1#)) + _ <- evaluate (I# (testMemset4_6 1#)) + _ <- evaluate (I# (testMemset4_7 1#)) + _ <- evaluate (I# (testMemset4_8 1#)) + + _ <- evaluate (I# (testMemcpy8_0 1#)) + _ <- evaluate (I# (testMemcpy8_8 1#)) + _ <- evaluate (I# (testMemcpy8_9 1#)) + _ <- evaluate (I# (testMemcpy8_10 1#)) + _ <- evaluate (I# (testMemcpy8_11 1#)) + _ <- evaluate (I# (testMemcpy8_12 1#)) + _ <- evaluate (I# (testMemcpy8_13 1#)) + _ <- evaluate (I# (testMemcpy8_14 1#)) + _ <- evaluate (I# (testMemcpy8_15 1#)) + _ <- evaluate (I# (testMemcpy8_16 1#)) + _ <- evaluate (I# (testMemcpy4_0 1#)) + _ <- evaluate (I# (testMemcpy4_4 1#)) + _ <- evaluate (I# (testMemcpy4_5 1#)) + _ <- evaluate (I# (testMemcpy4_6 1#)) + _ <- evaluate (I# (testMemcpy4_7 1#)) + _ <- evaluate (I# (testMemcpy4_8 1#)) + putStrLn "Test Passed!" + return () diff --git a/testsuite/tests/codeGen/should_run/cgrun069.stdout b/testsuite/tests/codeGen/should_run/cgrun069.stdout new file mode 100644 index 0000000000..bee6602b04 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun069.stdout @@ -0,0 +1,2 @@ +Mem{cpy,set,move} Intrinsics Test... +Test Passed! diff --git a/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm b/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm new file mode 100644 index 0000000000..b2f563bbf6 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm @@ -0,0 +1,214 @@ +#include "Cmm.h" + +// Test that the Memcpy, Memmove, Memset GHC intrinsic functions +// are working correctly. + +section "rodata" { memsetErr : bits8[] "Memset Error - align: %d size: %d\n"; } +section "rodata" { memcpyErr : bits8[] "Memcpy Error - align: %d size: %d\n"; } +// You have to call printf with the same number of args for every call. +// This is as the LLVM backend doesn't support vararg functions. +section "rodata" { memmoveErr : bits8[] "Memmove Error Occured\n"; } + +memintrinTest +{ + W_ size, src, dst, off, alignV, set; + bits8 set8; + + // Need two versions as memset takes a word for historical reasons + // but really its a bits8. We check that setting has ben done correctly + // at the bits8 level, so need bits8 version for checking. + set = 4; + set8 = 4::bits8; + + size = 1024; + alignV = 4; + + ("ptr" src) = foreign "C" malloc(size); + ("ptr" dst) = foreign "C" malloc(size); + + // Test memset + prim %memset(src "ptr", set, size, alignV) []; + + // Check memset worked + off = 0; +while1: + if (off == size) { + goto while1_end; + } + + if (bits8[src + off] != set8) { + // call with two dummy args for LLVM's benefit. + // they'll be ignored by printf + foreign "C" printf(memsetErr "ptr", 0, 0) []; + goto while1_end; + } + + off = off + 1; + goto while1; + +while1_end: + + // Test memcpy + prim %memcpy(dst "ptr", src "ptr", size, alignV) []; + + // Check memcpy worked + off = 0; +while2: + if (off == size) { + goto while2_end; + } + + if (bits8[dst + off] != set8) { + foreign "C" printf(memcpyErr "ptr", 0, 0) []; + goto while2_end; + } + + off = off + 1; + goto while2; + +while2_end: + + // Test memove + set = 8; + set8 = 8::bits8; + size = 100; + W_ src2; + src2 = src + 50; + + prim %memset(src "ptr", set, size, alignV) []; + prim %memmove(src2 "ptr", src "ptr", size, alignV) []; + + // Check memmove worked + off = 0; +while3: + if (off == size) { + goto while3_end; + } + + if (bits8[src2 + off] != set8) { + foreign "C" printf(memmoveErr "ptr", 0, 0) []; + goto while3_end; + } + + off = off + 1; + goto while3; + +while3_end: + + foreign "C" free(src); + foreign "C" free(dst); + + jump %ENTRY_CODE(Sp(0)); +} + +// --------------------------------------------------------------------- +// Tests for unrolling + +// We generate code for each configuration of alignment and size rather +// than looping over the possible alignments/sizes as the alignment and +// size needs to be statically known for unrolling to happen. + +// Below we need both 'set' and 'set8' as memset takes a word for +// historical reasons but really its a bits8. We check that setting +// has ben done correctly at the bits8 level, so need bits8 version +// for checking. +#define TEST_MEMSET(ALIGN,SIZE) \ + W_ size, src, dst, off, alignV, set; \ + bits8 set8; \ + set = 4; \ + set8 = 4::bits8; \ + size = SIZE; \ + alignV = ALIGN; \ + ("ptr" src) = foreign "C" malloc(size); \ + ("ptr" dst) = foreign "C" malloc(size); \ + prim %memset(src "ptr", set, size, alignV) []; \ + off = 0; \ +loop: \ + if (off == size) { \ + goto loop_end; \ + } \ + if (bits8[src + off] != set8) { \ + foreign "C" printf(memsetErr "ptr", ALIGN, SIZE) []; \ + goto loop_end; \ + } \ + off = off + 1; \ + goto loop; \ +loop_end: \ + foreign "C" free(src); \ + foreign "C" free(dst); \ + jump %ENTRY_CODE(Sp(0)); + +// This is not exactly beutiful but we need the separate functions to +// avoid collisions between labels. +// +// The specific tests are selected with knowledge of the implementation +// in mind in order to try to cover all branches and interesting corner +// cases. + +testMemset8_0 { TEST_MEMSET(8,0); } +testMemset8_8 { TEST_MEMSET(8,8); } +testMemset8_9 { TEST_MEMSET(8,9); } +testMemset8_10 { TEST_MEMSET(8,10); } +testMemset8_11 { TEST_MEMSET(8,11); } +testMemset8_12 { TEST_MEMSET(8,12); } +testMemset8_13 { TEST_MEMSET(8,13); } +testMemset8_14 { TEST_MEMSET(8,14); } +testMemset8_15 { TEST_MEMSET(8,15); } +testMemset8_16 { TEST_MEMSET(8,16); } + +testMemset4_0 { TEST_MEMSET(4,0); } +testMemset4_4 { TEST_MEMSET(4,4); } +testMemset4_5 { TEST_MEMSET(4,5); } +testMemset4_6 { TEST_MEMSET(4,6); } +testMemset4_7 { TEST_MEMSET(4,7); } +testMemset4_8 { TEST_MEMSET(4,8); } + +#define TEST_MEMCPY(ALIGN,SIZE) \ + W_ size, src, dst, off, alignV; \ + size = SIZE; \ + alignV = ALIGN; \ + ("ptr" src) = foreign "C" malloc(size); \ + ("ptr" dst) = foreign "C" malloc(size); \ + off = 0; \ +init: \ + if (off == size) { \ + goto init_end; \ + } \ + bits8[src + off] = 0xaa; \ + off = off + 1; \ + goto init; \ +init_end: \ + prim %memcpy(dst "ptr", src "ptr", size, alignV) []; \ + off = 0; \ +loop: \ + if (off == size) { \ + goto loop_end; \ + } \ + if (bits8[dst + off] != bits8[src + off]) { \ + foreign "C" printf(memcpyErr "ptr", ALIGN, SIZE) []; \ + goto loop_end; \ + } \ + off = off + 1; \ + goto loop; \ +loop_end: \ + foreign "C" free(src); \ + foreign "C" free(dst); \ + jump %ENTRY_CODE(Sp(0)); + +testMemcpy8_0 { TEST_MEMCPY(8,0); } +testMemcpy8_8 { TEST_MEMCPY(8,8); } +testMemcpy8_9 { TEST_MEMCPY(8,9); } +testMemcpy8_10 { TEST_MEMCPY(8,10); } +testMemcpy8_11 { TEST_MEMCPY(8,11); } +testMemcpy8_12 { TEST_MEMCPY(8,12); } +testMemcpy8_13 { TEST_MEMCPY(8,13); } +testMemcpy8_14 { TEST_MEMCPY(8,14); } +testMemcpy8_15 { TEST_MEMCPY(8,15); } +testMemcpy8_16 { TEST_MEMCPY(8,16); } + +testMemcpy4_0 { TEST_MEMCPY(4,0); } +testMemcpy4_4 { TEST_MEMCPY(4,4); } +testMemcpy4_5 { TEST_MEMCPY(4,5); } +testMemcpy4_6 { TEST_MEMCPY(4,6); } +testMemcpy4_7 { TEST_MEMCPY(4,7); } +testMemcpy4_8 { TEST_MEMCPY(4,8); } diff --git a/testsuite/tests/codeGen/should_run/cgrun070.hs b/testsuite/tests/codeGen/should_run/cgrun070.hs new file mode 100644 index 0000000000..1f6b5622ba --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun070.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- !!! simple tests of copying/cloning byte arrays +-- + +module Main ( main ) where + +import GHC.Word +import GHC.Exts +import GHC.Prim +import GHC.ST + +main = putStr + (test_copyByteArray + ++ "\n" ++ test_copyMutableByteArray + ++ "\n" ++ test_copyMutableByteArrayOverlap + ++ "\n" + ) + +------------------------------------------------------------------------ +-- Constants + +-- All allocated arrays are of this size +len :: Int +len = 130 + +-- We copy these many elements +copied :: Int +copied = len - 2 + +------------------------------------------------------------------------ +-- copyByteArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_copyByteArray :: String +test_copyByteArray = + let dst = runST $ do + src <- newByteArray len + fill src 0 len + src <- unsafeFreezeByteArray src + dst <- newByteArray len + -- Markers to detect errors + writeWord8Array dst 0 255 + writeWord8Array dst (len-1) 255 + -- Leave the first and last element untouched + copyByteArray src 1 dst 1 copied + unsafeFreezeByteArray dst + in shows (toList dst len) "\n" + +------------------------------------------------------------------------ +-- copyMutableByteArray# + +-- Copy a slice of the source array into a destination array and check +-- that the copy succeeded. +test_copyMutableByteArray :: String +test_copyMutableByteArray = + let dst = runST $ do + src <- newByteArray len + fill src 0 len + dst <- newByteArray len + -- Markers to detect errors + writeWord8Array dst 0 255 + writeWord8Array dst (len-1) 255 + -- Leave the first and last element untouched + copyMutableByteArray src 1 dst 1 copied + unsafeFreezeByteArray dst + in shows (toList dst len) "\n" + +-- Perform a copy where the source and destination part overlap. +test_copyMutableByteArrayOverlap :: String +test_copyMutableByteArrayOverlap = + let arr = runST $ do + marr <- fromList inp + -- Overlap of two elements + copyMutableByteArray marr 5 marr 7 8 + unsafeFreezeByteArray marr + in shows (toList arr (length inp)) "\n" + where + -- This case was known to fail at some point. + inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196] + +------------------------------------------------------------------------ +-- Test helpers + +-- Initialize the elements of this array, starting at the given +-- offset. The last parameter specifies the number of elements to +-- initialize. Element at index @i@ takes the value @i@ (i.e. the +-- first actually modified element will take value @off@). +fill :: MByteArray s -> Int -> Int -> ST s () +fill marr off count = go 0 + where + go i + | i >= fromIntegral count = return () + | otherwise = do writeWord8Array marr (off + i) (fromIntegral i) + go (i + 1) + +fromList :: [Word8] -> ST s (MByteArray s) +fromList xs0 = do + marr <- newByteArray (length xs0) + let go [] i = i `seq` return marr + go (x:xs) i = writeWord8Array marr i x >> go xs (i + 1) + go xs0 0 + +------------------------------------------------------------------------ +-- Convenience wrappers for ByteArray# and MutableByteArray# + +data ByteArray = ByteArray { unBA :: ByteArray# } +data MByteArray s = MByteArray { unMBA :: MutableByteArray# s } + +newByteArray :: Int -> ST s (MByteArray s) +newByteArray (I# n#) = ST $ \s# -> case newByteArray# n# s# of + (# s2#, marr# #) -> (# s2#, MByteArray marr# #) + +indexWord8Array :: ByteArray -> Int -> Word8 +indexWord8Array arr (I# i#) = case indexWord8Array# (unBA arr) i# of + a -> W8# a + +writeWord8Array :: MByteArray s -> Int -> Word8 -> ST s () +writeWord8Array marr (I# i#) (W8# a) = ST $ \ s# -> + case writeWord8Array# (unMBA marr) i# a s# of + s2# -> (# s2#, () #) + +unsafeFreezeByteArray :: MByteArray s -> ST s (ByteArray) +unsafeFreezeByteArray marr = ST $ \ s# -> + case unsafeFreezeByteArray# (unMBA marr) s# of + (# s2#, arr# #) -> (# s2#, ByteArray arr# #) + +copyByteArray :: ByteArray -> Int -> MByteArray s -> Int -> Int -> ST s () +copyByteArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# -> + case copyByteArray# (unBA src) six# (unMBA dst) dix# n# s# of + s2# -> (# s2#, () #) + +copyMutableByteArray :: MByteArray s -> Int -> MByteArray s -> Int -> Int + -> ST s () +copyMutableByteArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# -> + case copyMutableByteArray# (unMBA src) six# (unMBA dst) dix# n# s# of + s2# -> (# s2#, () #) + +toList :: ByteArray -> Int -> [Word8] +toList arr n = go 0 + where + go i | i >= n = [] + | otherwise = indexWord8Array arr i : go (i+1) diff --git a/testsuite/tests/codeGen/should_run/cgrun070.stdout b/testsuite/tests/codeGen/should_run/cgrun070.stdout new file mode 100644 index 0000000000..db95c83d7b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun070.stdout @@ -0,0 +1,6 @@ +[255,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,255] + +[255,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,255] + +[0,169,196,9,16,25,36,25,36,16,25,81,100,121,144] + |