diff options
Diffstat (limited to 'testsuite/tests/rts')
56 files changed, 1660 insertions, 0 deletions
diff --git a/testsuite/tests/rts/2047.hs b/testsuite/tests/rts/2047.hs new file mode 100644 index 0000000000..08b72664a9 --- /dev/null +++ b/testsuite/tests/rts/2047.hs @@ -0,0 +1,102 @@ +module Main where
+
+import qualified Data.Set as Set
+import Control.Monad
+import Data.List
+
+---
+---
+---
+
+data Direction = DirUp | DirLeft | DirRight | DirDown
+ deriving (Eq,Ord,Show,Read)
+
+directions = [DirUp,DirLeft,DirRight,DirDown]
+
+coordOffset DirUp = (-1,0)
+coordOffset DirLeft = (0,-1)
+coordOffset DirRight = (0,1)
+coordOffset DirDown = (1,0)
+
+move (r,c) d = (r+dr,c+dc) where (dr,dc) = coordOffset d
+
+sortPair (x,y) =
+ case compare x y of
+ EQ -> (x,y)
+ LT -> (x,y)
+ GT -> (y,x)
+mapPair12 f (x,y) = (f x,f y)
+
+cachedUsingList f = f'
+ where
+ list = map f [0..]
+ f' i = list !! i
+
+nubSorted [] = []
+nubSorted (x:xs) = nubSorted' x xs
+ where
+ nubSorted' x [] = [x]
+ nubSorted' x (y:ys)
+ | x == y = nubSorted' x ys
+ | otherwise = x : nubSorted' y ys
+
+---
+---
+---
+
+size = 21
+largestExplicitlyEnumeratedArea = 7
+
+type Cell = (Int,Int)
+type Edge = (Cell,Cell)
+
+mkEdge cell1 cell2 = sortPair (cell1,cell2)
+
+cellsAround area = nubSorted $ sort $
+ do
+ cell <- area
+ dir <- directions
+ let cell2 = move cell dir
+ guard $ cell2 `notElem` area
+ return $ cell2
+
+increaseAreas areas = nubSorted $ sort $
+ do
+ area <- areas
+ cell2 <- cellsAround area
+ return $ sort $ cell2 : area
+getAreas :: Int -> [[Cell]]
+getAreasRaw 1 = [[(0,0)]]
+getAreasRaw n = areas
+ where
+ areas = increaseAreas $ getAreas $ n - 1
+getAreas = cachedUsingList getAreasRaw
+
+getEdges area = mapPair12 (map snd) $ partition fst $ nubSorted $ sort $
+ do
+ cell <- area
+ dir <- directions
+ let cell2 = move cell dir
+ let isInternal = cell2 `elem` area
+ return (isInternal,mkEdge cell cell2)
+
+type SizedArea = (Int,((Set.Set Cell,Set.Set Cell),(Set.Set Edge,Set.Set Edge)))
+getExtendedAreas n =
+ do
+ area <- getAreas n
+ let areaAround = cellsAround area
+ let edgeInfo = getEdges area
+ return ((Set.fromList area,Set.fromList areaAround),mapPair12 Set.fromList edgeInfo)
+
+getSizedAreasThrough :: Int -> [SizedArea]
+getSizedAreasThrough n =
+ do
+ n' <- [1 .. n]
+ extendedArea <- getExtendedAreas n'
+ return $ (n',extendedArea)
+
+sizeForSizedArea (asize,_) = asize
+allSizedAreas = getSizedAreasThrough largestExplicitlyEnumeratedArea
+
+main = print $ allSizedAreas
+
diff --git a/testsuite/tests/rts/2783.hs b/testsuite/tests/rts/2783.hs new file mode 100644 index 0000000000..5edca4e7cd --- /dev/null +++ b/testsuite/tests/rts/2783.hs @@ -0,0 +1 @@ +main = print $ do x <- [ 0 .. 5 ] ; let { y = 5 - y } ; return y diff --git a/testsuite/tests/rts/2783.stderr b/testsuite/tests/rts/2783.stderr new file mode 100644 index 0000000000..86d45f2a1a --- /dev/null +++ b/testsuite/tests/rts/2783.stderr @@ -0,0 +1 @@ +2783: <<loop>> diff --git a/testsuite/tests/rts/3236.c b/testsuite/tests/rts/3236.c new file mode 100644 index 0000000000..92d4c12dcd --- /dev/null +++ b/testsuite/tests/rts/3236.c @@ -0,0 +1,7 @@ +#include "Rts.h" + +int main (int argc, char *argv[]) +{ + // should fail: RTS is not initialised + rts_lock(); +} diff --git a/testsuite/tests/rts/3236.stderr b/testsuite/tests/rts/3236.stderr new file mode 100644 index 0000000000..c1f0511021 --- /dev/null +++ b/testsuite/tests/rts/3236.stderr @@ -0,0 +1 @@ +newBoundTask: RTS is not initialised; call hs_init() first diff --git a/testsuite/tests/rts/3424.hs b/testsuite/tests/rts/3424.hs new file mode 100644 index 0000000000..e168df49c0 --- /dev/null +++ b/testsuite/tests/rts/3424.hs @@ -0,0 +1,611 @@ + +module Main (main) where + +import Control.Monad (guard) + +main :: IO () +main = print $ head z + +z :: [[Int]] +z = do x1 <- [0..3] + x2 <- [0..3] + x3 <- [0..3] + x4 <- [0..3] + x5 <- [0..3] + x6 <- [0..3] + x7 <- [0..3] + x8 <- [0..3] + x9 <- [0..3] + x10 <- [0..3] + x11 <- [0..3] + x12 <- [0..3] + x13 <- [0..3] + x14 <- [0..3] + x15 <- [0..3] + x16 <- [0..3] + x17 <- [0..3] + x18 <- [0..3] + x19 <- [0..3] + x20 <- [0..3] + x21 <- [0..3] + x22 <- [0..3] + x23 <- [0..3] + x24 <- [0..3] + x25 <- [0..3] + x26 <- [0..3] + x27 <- [0..3] + x28 <- [0..3] + x29 <- [0..3] + x30 <- [0..3] + x31 <- [0..3] + x32 <- [0..3] + x33 <- [0..3] + x34 <- [0..3] + x35 <- [0..3] + x36 <- [0..3] + x37 <- [0..3] + x38 <- [0..3] + x39 <- [0..3] + x40 <- [0..3] + x41 <- [0..3] + x42 <- [0..3] + x43 <- [0..3] + x44 <- [0..3] + x45 <- [0..3] + x46 <- [0..3] + x47 <- [0..3] + x48 <- [0..3] + x49 <- [0..3] + x50 <- [0..3] + x51 <- [0..3] + x52 <- [0..3] + x53 <- [0..3] + x54 <- [0..3] + x55 <- [0..3] + x56 <- [0..3] + x57 <- [0..3] + x58 <- [0..3] + x59 <- [0..3] + x60 <- [0..3] + x61 <- [0..3] + x62 <- [0..3] + x63 <- [0..3] + x64 <- [0..3] + x65 <- [0..3] + x66 <- [0..3] + x67 <- [0..3] + x68 <- [0..3] + x69 <- [0..3] + x70 <- [0..3] + x71 <- [0..3] + x72 <- [0..3] + x73 <- [0..3] + x74 <- [0..3] + x75 <- [0..3] + x76 <- [0..3] + x77 <- [0..3] + x78 <- [0..3] + x79 <- [0..3] + x80 <- [0..3] + x81 <- [0..3] + x82 <- [0..3] + x83 <- [0..3] + x84 <- [0..3] + x85 <- [0..3] + x86 <- [0..3] + x87 <- [0..3] + x88 <- [0..3] + x89 <- [0..3] + x90 <- [0..3] + x91 <- [0..3] + x92 <- [0..3] + x93 <- [0..3] + x94 <- [0..3] + x95 <- [0..3] + x96 <- [0..3] + x97 <- [0..3] + x98 <- [0..3] + x99 <- [0..3] + x100 <- [0..3] + x101 <- [0..3] + x102 <- [0..3] + x103 <- [0..3] + x104 <- [0..3] + x105 <- [0..3] + x106 <- [0..3] + x107 <- [0..3] + x108 <- [0..3] + x109 <- [0..3] + x110 <- [0..3] + x111 <- [0..3] + x112 <- [0..3] + x113 <- [0..3] + x114 <- [0..3] + x115 <- [0..3] + x116 <- [0..3] + x117 <- [0..3] + x118 <- [0..3] + x119 <- [0..3] + x120 <- [0..3] + x121 <- [0..3] + x122 <- [0..3] + x123 <- [0..3] + x124 <- [0..3] + x125 <- [0..3] + x126 <- [0..3] + x127 <- [0..3] + x128 <- [0..3] + x129 <- [0..3] + x130 <- [0..3] + x131 <- [0..3] + x132 <- [0..3] + x133 <- [0..3] + x134 <- [0..3] + x135 <- [0..3] + x136 <- [0..3] + x137 <- [0..3] + x138 <- [0..3] + x139 <- [0..3] + x140 <- [0..3] + x141 <- [0..3] + x142 <- [0..3] + x143 <- [0..3] + x144 <- [0..3] + x145 <- [0..3] + x146 <- [0..3] + x147 <- [0..3] + x148 <- [0..3] + x149 <- [0..3] + x150 <- [0..3] + x151 <- [0..3] + x152 <- [0..3] + x153 <- [0..3] + x154 <- [0..3] + x155 <- [0..3] + x156 <- [0..3] + x157 <- [0..3] + x158 <- [0..3] + x159 <- [0..3] + x160 <- [0..3] + x161 <- [0..3] + x162 <- [0..3] + x163 <- [0..3] + x164 <- [0..3] + x165 <- [0..3] + x166 <- [0..3] + x167 <- [0..3] + x168 <- [0..3] + x169 <- [0..3] + x170 <- [0..3] + x171 <- [0..3] + x172 <- [0..3] + x173 <- [0..3] + x174 <- [0..3] + x175 <- [0..3] + x176 <- [0..3] + x177 <- [0..3] + x178 <- [0..3] + x179 <- [0..3] + x180 <- [0..3] + x181 <- [0..3] + x182 <- [0..3] + x183 <- [0..3] + x184 <- [0..3] + x185 <- [0..3] + x186 <- [0..3] + x187 <- [0..3] + x188 <- [0..3] + x189 <- [0..3] + x190 <- [0..3] + x191 <- [0..3] + x192 <- [0..3] + x193 <- [0..3] + x194 <- [0..3] + x195 <- [0..3] + x196 <- [0..3] + x197 <- [0..3] + x198 <- [0..3] + x199 <- [0..3] + x200 <- [0..3] + x201 <- [0..3] + x202 <- [0..3] + x203 <- [0..3] + x204 <- [0..3] + x205 <- [0..3] + x206 <- [0..3] + x207 <- [0..3] + x208 <- [0..3] + x209 <- [0..3] + x210 <- [0..3] + x211 <- [0..3] + x212 <- [0..3] + x213 <- [0..3] + x214 <- [0..3] + x215 <- [0..3] + x216 <- [0..3] + x217 <- [0..3] + x218 <- [0..3] + x219 <- [0..3] + x220 <- [0..3] + x221 <- [0..3] + x222 <- [0..3] + x223 <- [0..3] + x224 <- [0..3] + x225 <- [0..3] + x226 <- [0..3] + x227 <- [0..3] + x228 <- [0..3] + x229 <- [0..3] + x230 <- [0..3] + x231 <- [0..3] + x232 <- [0..3] + x233 <- [0..3] + x234 <- [0..3] + x235 <- [0..3] + x236 <- [0..3] + x237 <- [0..3] + x238 <- [0..3] + x239 <- [0..3] + x240 <- [0..3] + x241 <- [0..3] + x242 <- [0..3] + x243 <- [0..3] + x244 <- [0..3] + x245 <- [0..3] + x246 <- [0..3] + x247 <- [0..3] + x248 <- [0..3] + x249 <- [0..3] + x250 <- [0..3] + x251 <- [0..3] + x252 <- [0..3] + x253 <- [0..3] + x254 <- [0..3] + x255 <- [0..3] + x256 <- [0..3] + x257 <- [0..3] + x258 <- [0..3] + x259 <- [0..3] + x260 <- [0..3] + x261 <- [0..3] + x262 <- [0..3] + x263 <- [0..3] + x264 <- [0..3] + x265 <- [0..3] + x266 <- [0..3] + x267 <- [0..3] + x268 <- [0..3] + x269 <- [0..3] + x270 <- [0..3] + x271 <- [0..3] + x272 <- [0..3] + x273 <- [0..3] + x274 <- [0..3] + x275 <- [0..3] + x276 <- [0..3] + x277 <- [0..3] + x278 <- [0..3] + x279 <- [0..3] + x280 <- [0..3] + x281 <- [0..3] + x282 <- [0..3] + x283 <- [0..3] + x284 <- [0..3] + x285 <- [0..3] + x286 <- [0..3] + x287 <- [0..3] + x288 <- [0..3] + x289 <- [0..3] + x290 <- [0..3] + x291 <- [0..3] + x292 <- [0..3] + x293 <- [0..3] + x294 <- [0..3] + x295 <- [0..3] + x296 <- [0..3] + x297 <- [0..3] + x298 <- [0..3] + x299 <- [0..3] + x300 <- [0..3] + x301 <- [0..3] + x302 <- [0..3] + x303 <- [0..3] + x304 <- [0..3] + x305 <- [0..3] + x306 <- [0..3] + x307 <- [0..3] + x308 <- [0..3] + x309 <- [0..3] + x310 <- [0..3] + x311 <- [0..3] + x312 <- [0..3] + x313 <- [0..3] + x314 <- [0..3] + x315 <- [0..3] + x316 <- [0..3] + x317 <- [0..3] + x318 <- [0..3] + x319 <- [0..3] + x320 <- [0..3] + x321 <- [0..3] + x322 <- [0..3] + x323 <- [0..3] + x324 <- [0..3] + x325 <- [0..3] + x326 <- [0..3] + x327 <- [0..3] + x328 <- [0..3] + x329 <- [0..3] + x330 <- [0..3] + x331 <- [0..3] + x332 <- [0..3] + x333 <- [0..3] + x334 <- [0..3] + x335 <- [0..3] + x336 <- [0..3] + x337 <- [0..3] + x338 <- [0..3] + x339 <- [0..3] + x340 <- [0..3] + x341 <- [0..3] + x342 <- [0..3] + x343 <- [0..3] + x344 <- [0..3] + x345 <- [0..3] + x346 <- [0..3] + x347 <- [0..3] + x348 <- [0..3] + x349 <- [0..3] + x350 <- [0..3] + x351 <- [0..3] + x352 <- [0..3] + x353 <- [0..3] + x354 <- [0..3] + x355 <- [0..3] + x356 <- [0..3] + x357 <- [0..3] + x358 <- [0..3] + x359 <- [0..3] + x360 <- [0..3] + x361 <- [0..3] + x362 <- [0..3] + x363 <- [0..3] + x364 <- [0..3] + x365 <- [0..3] + x366 <- [0..3] + x367 <- [0..3] + x368 <- [0..3] + x369 <- [0..3] + x370 <- [0..3] + x371 <- [0..3] + x372 <- [0..3] + x373 <- [0..3] + x374 <- [0..3] + x375 <- [0..3] + x376 <- [0..3] + x377 <- [0..3] + x378 <- [0..3] + x379 <- [0..3] + x380 <- [0..3] + x381 <- [0..3] + x382 <- [0..3] + x383 <- [0..3] + x384 <- [0..3] + x385 <- [0..3] + x386 <- [0..3] + x387 <- [0..3] + x388 <- [0..3] + x389 <- [0..3] + x390 <- [0..3] + x391 <- [0..3] + x392 <- [0..3] + x393 <- [0..3] + x394 <- [0..3] + x395 <- [0..3] + x396 <- [0..3] + x397 <- [0..3] + x398 <- [0..3] + x399 <- [0..3] + x400 <- [0..3] + x401 <- [0..3] + x402 <- [0..3] + x403 <- [0..3] + x404 <- [0..3] + x405 <- [0..3] + x406 <- [0..3] + x407 <- [0..3] + x408 <- [0..3] + x409 <- [0..3] + x410 <- [0..3] + x411 <- [0..3] + x412 <- [0..3] + x413 <- [0..3] + x414 <- [0..3] + x415 <- [0..3] + x416 <- [0..3] + x417 <- [0..3] + x418 <- [0..3] + x419 <- [0..3] + x420 <- [0..3] + x421 <- [0..3] + x422 <- [0..3] + x423 <- [0..3] + x424 <- [0..3] + x425 <- [0..3] + x426 <- [0..3] + x427 <- [0..3] + x428 <- [0..3] + x429 <- [0..3] + x430 <- [0..3] + x431 <- [0..3] + x432 <- [0..3] + x433 <- [0..3] + x434 <- [0..3] + x435 <- [0..3] + x436 <- [0..3] + x437 <- [0..3] + x438 <- [0..3] + x439 <- [0..3] + x440 <- [0..3] + x441 <- [0..3] + x442 <- [0..3] + x443 <- [0..3] + x444 <- [0..3] + x445 <- [0..3] + x446 <- [0..3] + x447 <- [0..3] + x448 <- [0..3] + x449 <- [0..3] + x450 <- [0..3] + x451 <- [0..3] + x452 <- [0..3] + x453 <- [0..3] + x454 <- [0..3] + x455 <- [0..3] + x456 <- [0..3] + x457 <- [0..3] + x458 <- [0..3] + x459 <- [0..3] + x460 <- [0..3] + x461 <- [0..3] + x462 <- [0..3] + x463 <- [0..3] + x464 <- [0..3] + x465 <- [0..3] + x466 <- [0..3] + x467 <- [0..3] + x468 <- [0..3] + x469 <- [0..3] + x470 <- [0..3] + x471 <- [0..3] + x472 <- [0..3] + x473 <- [0..3] + x474 <- [0..3] + x475 <- [0..3] + x476 <- [0..3] + x477 <- [0..3] + x478 <- [0..3] + x479 <- [0..3] + x480 <- [0..3] + x481 <- [0..3] + x482 <- [0..3] + x483 <- [0..3] + x484 <- [0..3] + x485 <- [0..3] + x486 <- [0..3] + x487 <- [0..3] + x488 <- [0..3] + x489 <- [0..3] + x490 <- [0..3] + x491 <- [0..3] + x492 <- [0..3] + x493 <- [0..3] + x494 <- [0..3] + x495 <- [0..3] + x496 <- [0..3] + x497 <- [0..3] + x498 <- [0..3] + x499 <- [0..3] + x500 <- [0..3] + x501 <- [0..3] + x502 <- [0..3] + x503 <- [0..3] + x504 <- [0..3] + x505 <- [0..3] + x506 <- [0..3] + x507 <- [0..3] + x508 <- [0..3] + x509 <- [0..3] + x510 <- [0..3] + x511 <- [0..3] + x512 <- [0..3] + x513 <- [0..3] + x514 <- [0..3] + x515 <- [0..3] + x516 <- [0..3] + x517 <- [0..3] + x518 <- [0..3] + x519 <- [0..3] + x520 <- [0..3] + x521 <- [0..3] + x522 <- [0..3] + x523 <- [0..3] + x524 <- [0..3] + x525 <- [0..3] + x526 <- [0..3] + x527 <- [0..3] + x528 <- [0..3] + x529 <- [0..3] + x530 <- [0..3] + x531 <- [0..3] + x532 <- [0..3] + x533 <- [0..3] + x534 <- [0..3] + x535 <- [0..3] + x536 <- [0..3] + x537 <- [0..3] + x538 <- [0..3] + x539 <- [0..3] + x540 <- [0..3] + x541 <- [0..3] + x542 <- [0..3] + x543 <- [0..3] + x544 <- [0..3] + x545 <- [0..3] + x546 <- [0..3] + x547 <- [0..3] + x548 <- [0..3] + x549 <- [0..3] + x550 <- [0..3] + x551 <- [0..3] + x552 <- [0..3] + x553 <- [0..3] + x554 <- [0..3] + x555 <- [0..3] + x556 <- [0..3] + x557 <- [0..3] + x558 <- [0..3] + x559 <- [0..3] + x560 <- [0..3] + x561 <- [0..3] + x562 <- [0..3] + x563 <- [0..3] + x564 <- [0..3] + x565 <- [0..3] + x566 <- [0..3] + x567 <- [0..3] + x568 <- [0..3] + x569 <- [0..3] + x570 <- [0..3] + x571 <- [0..3] + x572 <- [0..3] + x573 <- [0..3] + x574 <- [0..3] + x575 <- [0..3] + x576 <- [0..3] + x577 <- [0..3] + x578 <- [0..3] + x579 <- [0..3] + x580 <- [0..3] + x581 <- [0..3] + x582 <- [0..3] + x583 <- [0..3] + x584 <- [0..3] + x585 <- [0..3] + x586 <- [0..3] + x587 <- [0..3] + x588 <- [0..3] + x589 <- [0..3] + x590 <- [0..3] + x591 <- [0..3] + x592 <- [0..3] + x593 <- [0..3] + x594 <- [0..3] + x595 <- [0..3] + x596 <- [0..3] + x597 <- [0..3] + x598 <- [0..3] + x599 <- [0..3] + x600 <- [0..3] + guard (x1+x2+2*x3 >= 0) + return [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32,x33,x34,x35,x36,x37,x38,x39,x40,x41,x42,x43,x44,x45,x46,x47,x48,x49,x50,x51,x52,x53,x54,x55,x56,x57,x58,x59,x60,x61,x62,x63,x64,x65,x66,x67,x68,x69,x70,x71,x72,x73,x74,x75,x76,x77,x78,x79,x80,x81,x82,x83,x84,x85,x86,x87,x88,x89,x90,x91,x92,x93,x94,x95,x96,x97,x98,x99,x100,x101,x102,x103,x104,x105,x106,x107,x108,x109,x110,x111,x112,x113,x114,x115,x116,x117,x118,x119,x120,x121,x122,x123,x124,x125,x126,x127,x128,x129,x130,x131,x132,x133,x134,x135,x136,x137,x138,x139,x140,x141,x142,x143,x144,x145,x146,x147,x148,x149,x150,x151,x152,x153,x154,x155,x156,x157,x158,x159,x160,x161,x162,x163,x164,x165,x166,x167,x168,x169,x170,x171,x172,x173,x174,x175,x176,x177,x178,x179,x180,x181,x182,x183,x184,x185,x186,x187,x188,x189,x190,x191,x192,x193,x194,x195,x196,x197,x198,x199,x200,x201,x202,x203,x204,x205,x206,x207,x208,x209,x210,x211,x212,x213,x214,x215,x216,x217,x218,x219,x220,x221,x222,x223,x224,x225,x226,x227,x228,x229,x230,x231,x232,x233,x234,x235,x236,x237,x238,x239,x240,x241,x242,x243,x244,x245,x246,x247,x248,x249,x250,x251,x252,x253,x254,x255,x256,x257,x258,x259,x260,x261,x262,x263,x264,x265,x266,x267,x268,x269,x270,x271,x272,x273,x274,x275,x276,x277,x278,x279,x280,x281,x282,x283,x284,x285,x286,x287,x288,x289,x290,x291,x292,x293,x294,x295,x296,x297,x298,x299,x300,x301,x302,x303,x304,x305,x306,x307,x308,x309,x310,x311,x312,x313,x314,x315,x316,x317,x318,x319,x320,x321,x322,x323,x324,x325,x326,x327,x328,x329,x330,x331,x332,x333,x334,x335,x336,x337,x338,x339,x340,x341,x342,x343,x344,x345,x346,x347,x348,x349,x350,x351,x352,x353,x354,x355,x356,x357,x358,x359,x360,x361,x362,x363,x364,x365,x366,x367,x368,x369,x370,x371,x372,x373,x374,x375,x376,x377,x378,x379,x380,x381,x382,x383,x384,x385,x386,x387,x388,x389,x390,x391,x392,x393,x394,x395,x396,x397,x398,x399,x400,x401,x402,x403,x404,x405,x406,x407,x408,x409,x410,x411,x412,x413,x414,x415,x416,x417,x418,x419,x420,x421,x422,x423,x424,x425,x426,x427,x428,x429,x430,x431,x432,x433,x434,x435,x436,x437,x438,x439,x440,x441,x442,x443,x444,x445,x446,x447,x448,x449,x450,x451,x452,x453,x454,x455,x456,x457,x458,x459,x460,x461,x462,x463,x464,x465,x466,x467,x468,x469,x470,x471,x472,x473,x474,x475,x476,x477,x478,x479,x480,x481,x482,x483,x484,x485,x486,x487,x488,x489,x490,x491,x492,x493,x494,x495,x496,x497,x498,x499,x500,x501,x502,x503,x504,x505,x506,x507,x508,x509,x510,x511,x512,x513,x514,x515,x516,x517,x518,x519,x520,x521,x522,x523,x524,x525,x526,x527,x528,x529,x530,x531,x532,x533,x534,x535,x536,x537,x538,x539,x540,x541,x542,x543,x544,x545,x546,x547,x548,x549,x550,x551,x552,x553,x554,x555,x556,x557,x558,x559,x560,x561,x562,x563,x564,x565,x566,x567,x568,x569,x570,x571,x572,x573,x574,x575,x576,x577,x578,x579,x580,x581,x582,x583,x584,x585,x586,x587,x588,x589,x590,x591,x592,x593,x594,x595,x596,x597,x598,x599,x600] diff --git a/testsuite/tests/rts/3424.stdout b/testsuite/tests/rts/3424.stdout new file mode 100644 index 0000000000..e905960197 --- /dev/null +++ b/testsuite/tests/rts/3424.stdout @@ -0,0 +1 @@ +[0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] diff --git a/testsuite/tests/rts/4059.hs b/testsuite/tests/rts/4059.hs new file mode 100644 index 0000000000..5af5bbc4aa --- /dev/null +++ b/testsuite/tests/rts/4059.hs @@ -0,0 +1,22 @@ + +{-# LANGUAGE ForeignFunctionInterface #-} + +import Foreign hiding ( unsafePerformIO ) +import Foreign.C +import System.IO.Unsafe + +d f x = unsafePerformIO $ do + g <- mkfun f + r <- deriv g x 1 + return r + +main = do + print $ d (\x -> x * 2) 3 + print $ d (\x -> x * d (\y -> x + y) 5) 7 + + +foreign import ccall safe "deriv" + deriv :: FunPtr (CDouble -> CDouble) -> CDouble -> CDouble -> IO CDouble + +foreign import ccall safe "wrapper" + mkfun :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble)) diff --git a/testsuite/tests/rts/4059_c.c b/testsuite/tests/rts/4059_c.c new file mode 100644 index 0000000000..3595b82cae --- /dev/null +++ b/testsuite/tests/rts/4059_c.c @@ -0,0 +1,4 @@ + +double deriv(double f(double), double x, double h) { + return f(x) + h; +} diff --git a/testsuite/tests/rts/4850.hs b/testsuite/tests/rts/4850.hs new file mode 100644 index 0000000000..72616d97eb --- /dev/null +++ b/testsuite/tests/rts/4850.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Foreign +import Control.Concurrent + +type Fun = Int -> IO Int + +foreign import ccall "wrapper" mkF :: Fun -> IO (FunPtr Fun) + +foreign import ccall "dynamic" callF :: FunPtr Fun -> Fun + +-- This test should create 4 OS threads only: +-- one for main +-- worker 1 for the IO manager +-- worker 2 to run the first forkIO +-- worker 3 created when worker 2 makes its foreign call + +-- Due to #4850, an extra worker was being created because worker 2 was +-- lost after returning from its foreign call. + +main = do + m <- newEmptyMVar + callback m >> takeMVar m >>= print + callback m >> takeMVar m >>= print + +callback m = + forkIO $ do + f <- mkF $ \x -> return (x+1) + r <- callF f 3 + putMVar m r diff --git a/testsuite/tests/rts/4850.stdout b/testsuite/tests/rts/4850.stdout new file mode 100644 index 0000000000..b8626c4cff --- /dev/null +++ b/testsuite/tests/rts/4850.stdout @@ -0,0 +1 @@ +4 diff --git a/testsuite/tests/rts/5250.hs b/testsuite/tests/rts/5250.hs new file mode 100644 index 0000000000..f10c2e7c47 --- /dev/null +++ b/testsuite/tests/rts/5250.hs @@ -0,0 +1,60 @@ +module Main where + +import Foreign +import Foreign.C +import Text.Printf +import System.Exit +import Control.Monad + +foreign import ccall "getesp" getesp :: IO CInt + +main = do + checkSpAlignment + wrap checkSpAlignment >>= run + wrap1 args1 >>= \f -> run1 f 3 + wrap2 args2 >>= \f -> run2 f 3 4 + wrap3 args3 >>= \f -> run3 f 3 4 5 + wrap4 args4 >>= \f -> run4 f 3 4 5 6 + +foreign import ccall "wrapper" wrap :: IO () -> IO (FunPtr (IO ())) +foreign import ccall "dynamic" run :: FunPtr (IO ()) -> IO () + +type Args1 = Int -> IO () + +foreign import ccall "wrapper" wrap1 :: Args1 -> IO (FunPtr Args1) +foreign import ccall "dynamic" run1 :: FunPtr Args1 -> Args1 + +args1 :: Args1 +args1 _ = checkSpAlignment + +type Args2 = Int -> Int -> IO () + +foreign import ccall "wrapper" wrap2 :: Args2 -> IO (FunPtr Args2) +foreign import ccall "dynamic" run2 :: FunPtr Args2 -> Args2 + +args2 :: Args2 +args2 _ _ = checkSpAlignment + +type Args3 = Int -> Int -> Int -> IO () + +foreign import ccall "wrapper" wrap3 :: Args3 -> IO (FunPtr Args3) +foreign import ccall "dynamic" run3 :: FunPtr Args3 -> Args3 + +args3 :: Args3 +args3 _ _ _ = checkSpAlignment + +type Args4 = Int -> Int -> Int -> Int -> IO () + +foreign import ccall "wrapper" wrap4 :: Args4 -> IO (FunPtr Args4) +foreign import ccall "dynamic" run4 :: FunPtr Args4 -> Args4 + +args4 :: Args4 +args4 _ _ _ _ = checkSpAlignment + +checkSpAlignment :: IO () +checkSpAlignment = do + esp <- getesp + when (((esp + fromIntegral (sizeOf (undefined :: Ptr ()))) .&. 15) /= 0) $ do + printf "esp not aligned correctly: %x\n" (fromIntegral esp :: Word32) + exitWith (ExitFailure 1) + diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile new file mode 100644 index 0000000000..4a65b487fa --- /dev/null +++ b/testsuite/tests/rts/Makefile @@ -0,0 +1,38 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +outofmem-prep:: + '$(TEST_HC)' $(TEST_HC_OPTS) --make -fforce-recomp outofmem.hs -o outofmem + +outofmem:: + @$(MAKE) outofmem-prep >prep.out 2>prep.out + @ulimit -v 10000000 2>/dev/null; ./outofmem || echo "exit($$?)" + +outofmem2-prep:: + '$(TEST_HC)' $(TEST_HC_OPTS) -rtsopts --make -fforce-recomp outofmem2.hs -o outofmem2 + +outofmem2:: + @$(MAKE) outofmem2-prep >prep.out 2>prep.out + @ulimit -v 1000000 2>/dev/null; ./outofmem2 +RTS -M5m -RTS || echo "exit($$?)" + +T2615-prep: + $(RM) libfoo_T2615.so + '$(TEST_HC)' $(TEST_HC_OPTS) -fPIC -c libfoo_T2615.c -o libfoo_T2615.o + '$(TEST_HC)' $(TEST_HC_OPTS) -shared -no-auto-link-packages libfoo_T2615.o -o libfoo_T2615.so + +.PHONY: T4059 +T4059: + $(RM) 4059_c.o 4059.o 4059.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make 4059 4059_c.c + ./4059 + +exec_signals-prep: + $(CC) -o exec_signals_child exec_signals_child.c + $(CC) -o exec_signals_prepare exec_signals_prepare.c + +.PHONY: 4850 +4850: + $(RM) 4850.o 4850.hi 4850$(exeext) + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -rtsopts -debug -threaded --make 4850 + ./4850 +RTS -s 2>&1 | grep Task | wc -l | tr -d ' ' diff --git a/testsuite/tests/rts/T2615.hs b/testsuite/tests/rts/T2615.hs new file mode 100644 index 0000000000..ee04d93bcf --- /dev/null +++ b/testsuite/tests/rts/T2615.hs @@ -0,0 +1,9 @@ +import ObjLink + +library_name = "libfoo_script_T2615.so" -- this is really a linker script + +main = do + result <- loadDLL library_name + case result of + Nothing -> putStrLn (library_name ++ " loaded successfully") + Just x -> putStrLn ("error: " ++ x) diff --git a/testsuite/tests/rts/T2615.stdout b/testsuite/tests/rts/T2615.stdout new file mode 100644 index 0000000000..16a9ae1c20 --- /dev/null +++ b/testsuite/tests/rts/T2615.stdout @@ -0,0 +1 @@ +libfoo_script_T2615.so loaded successfully diff --git a/testsuite/tests/rts/T4059.stdout b/testsuite/tests/rts/T4059.stdout new file mode 100644 index 0000000000..34f64643a5 --- /dev/null +++ b/testsuite/tests/rts/T4059.stdout @@ -0,0 +1,2 @@ +7.0 +92.0 diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T new file mode 100644 index 0000000000..0b37ed19e4 --- /dev/null +++ b/testsuite/tests/rts/all.T @@ -0,0 +1,117 @@ +test('testblockalloc', compose(c_src, + compose(only_ways(['normal','threaded1']), + extra_run_opts('+RTS -I0'))), + compile_and_run, ['']) + + +# See bug #101, test requires +RTS -c (or equivalently +RTS -M<something>) +# only GHCi triggers the bug, but we run the test all ways for completeness. +test('bug1010', normal, compile_and_run, ['+RTS -c -RTS']) +test('derefnull', + composes([ + # LLVM Optimiser considers dereference of a null pointer + # undefined and marks the code as unreachable which means + # that later optimisations remove it altogether. + omit_ways(['optllvm']), + # SIGSEGV on Linux (which we make the default) + exit_code(139), + # Apparently the output can be different on different + # Linux setups, so just ignore it. As long as we get + # the right exit code we're OK. + if_os('linux', ignore_output), + # SIGBUS on OX X (PPC and x86 only; amd64 gives SEGV) + if_platform('i386-apple-darwin', exit_code(138)), + if_platform('powerpc-apple-darwin', exit_code(138)), + if_platform('i386-unknown-mingw32', exit_code(1))]), + compile_and_run, ['']) +test('divbyzero', + composes([ + # SIGFPE on Linux + exit_code(136), + # Apparently the output can be different on different + # Linux setups, so just ignore it. As long as we get + # the right exit code we're OK. + if_os('linux', ignore_output), + if_platform('i386-unknown-mingw32', exit_code(1))]), + compile_and_run, ['']) + +test('outofmem', normal, run_command, ['$MAKE -s --no-print-directory outofmem']) +test('outofmem2', extra_run_opts('+RTS -M5m -RTS'), + run_command, ['$MAKE -s --no-print-directory outofmem2']) + +test('2047', compose(ignore_output, extra_run_opts('+RTS -c -RTS')), + compile_and_run, ['-package containers']) + +# Blackhole-detection test. +# Skip GHCi due to #2786 +test('2783', [ omit_ways(['ghci']), exit_code(1) ], compile_and_run, ['']) + +# Test the work-stealing deque implementation. We run this test in +# both threaded1 (-threaded -debug) and threaded2 (-threaded) ways. +test('testwsdeque', [unless_in_tree_compiler(skip), + c_src, only_ways(['threaded1', 'threaded2'])], + compile_and_run, ['-I../../../rts']) + +test('3236', [c_src, only_ways(['normal','threaded1']), exit_code(1)], compile_and_run, ['']) + +test('stack001', extra_run_opts('+RTS -K32m -RTS'), compile_and_run, ['']) +test('stack002', extra_run_opts('+RTS -K32m -k4m -RTS'), compile_and_run, ['']) + +# run this test with very small stack chunks to exercise the stack +# overflow/underflow machinery. +test('stack003', [ omit_ways('ghci'), # uses unboxed tuples + extra_run_opts('500000 +RTS -kc1k -kb100 -K96m -RTS') ], + compile_and_run, ['']) + +test('atomicinc', [ c_src, only_ways(['normal']) ], compile_and_run, ['']) + +test('3424', # it's slow: + [ skip_if_fast, only_ways(['normal','threaded1','ghci']) ], + compile_and_run, ['']) + +# Test for out-of-range heap size +test('rtsflags001', [ only_ways(['normal']), exit_code(1), extra_run_opts('+RTS -H0m -RTS') ], compile_and_run, ['']) + +# Test to see if linker scripts link properly to real ELF files +test('T2615', + [ if_platform('i386-unknown-mingw32',skip), + # OS X doesn't seem to support linker scripts + if_os('darwin', skip), + # Solaris' linker does not support GNUish linker scripts + if_os('solaris2', skip), + cmd_prefix('$MAKE T2615-prep && ' + + # Add current directory to dlopen search path + 'LD_LIBRARY_PATH=$LD_LIBRARY_PATH:. '), + extra_clean(['libfoo_T2615.so'])], + compile_and_run, + ['-package ghc']) + +# omit dyn and profiling ways, because we don't build dyn_l or p_l +# variants of the RTS by default +test('traceEvent', [ omit_ways(['dyn'] + prof_ways), + extra_run_opts('+RTS -ls -RTS') ], + compile_and_run, ['-eventlog']) + +test('T4059', normal, run_command, ['$MAKE -s --no-print-directory T4059']) + +# Test for #4274 +test('exec_signals', [ + if_platform('i386-unknown-mingw32',skip), + cmd_prefix('$MAKE exec_signals-prep && ./exec_signals_prepare'), + extra_clean(['exec_signals_child', 'exec_signals_prepare']) + ], compile_and_run, ['']) + +test('return_mem_to_os', normal, compile_and_run, ['']) + +test('4850', extra_clean(['4850.o','4850.hi','4850']), + run_command, ['$MAKE -s --no-print-directory 4850']) + +def config_5250(opts): + if not (config.arch in ['i386','x86_64']): + opts.skip = 1; + +test('5250', [ config_5250, + extra_clean(['spalign.o']), + omit_ways(['ghci']) ], + compile_and_run, ['spalign.c']) + diff --git a/testsuite/tests/rts/atomicinc.c b/testsuite/tests/rts/atomicinc.c new file mode 100644 index 0000000000..8f1c8bf3ed --- /dev/null +++ b/testsuite/tests/rts/atomicinc.c @@ -0,0 +1,21 @@ +#define THREADED_RTS + +#include "Rts.h" + +StgWord i; + +int main(int argc, char *argv[]) +{ + StgWord j; + + i = 0; + j = atomic_inc(&i); + CHECK(j == 1); + CHECK(i == 1); + + j = atomic_dec(&i); + CHECK(j == 0); + CHECK(i == 0); + + return 0; +} diff --git a/testsuite/tests/rts/bug1010.hs b/testsuite/tests/rts/bug1010.hs new file mode 100644 index 0000000000..50329b738b --- /dev/null +++ b/testsuite/tests/rts/bug1010.hs @@ -0,0 +1,16 @@ +module Main where + +break2 p (x:xs) = if p x then + ([],x:xs) + else + let (b1,b2) = break2 p xs + in (x : b1, b2) +break2 p [] = ([],[]) + +surprise xs = b1 ++ "\n surprise " ++ b2 + where + (b1,b2) = break2 (=='\n') xs + +test n = length $ surprise $ [head (show i) | i <-[1..n] ] ++ "\n the end" + +main = print $ test 10000 diff --git a/testsuite/tests/rts/bug1010.stdout b/testsuite/tests/rts/bug1010.stdout new file mode 100644 index 0000000000..8a0934b514 --- /dev/null +++ b/testsuite/tests/rts/bug1010.stdout @@ -0,0 +1 @@ +10020 diff --git a/testsuite/tests/rts/derefnull.hs b/testsuite/tests/rts/derefnull.hs new file mode 100644 index 0000000000..474ff62c4c --- /dev/null +++ b/testsuite/tests/rts/derefnull.hs @@ -0,0 +1,14 @@ + +{- +By default, on Windows a segfault will pop up an annoying dialog box. +We want the RTS to catch it instead. +-} + +module Main where + +import Foreign + +main :: IO () +main = do x <- peek nullPtr + print (x :: Int) + diff --git a/testsuite/tests/rts/derefnull.stderr-x86_64-unknown-openbsd b/testsuite/tests/rts/derefnull.stderr-x86_64-unknown-openbsd new file mode 100644 index 0000000000..d1ecae163f --- /dev/null +++ b/testsuite/tests/rts/derefnull.stderr-x86_64-unknown-openbsd @@ -0,0 +1 @@ +Segmentation fault diff --git a/testsuite/tests/rts/derefnull.stdout-i386-unknown-mingw32 b/testsuite/tests/rts/derefnull.stdout-i386-unknown-mingw32 new file mode 100644 index 0000000000..5f2034dd57 --- /dev/null +++ b/testsuite/tests/rts/derefnull.stdout-i386-unknown-mingw32 @@ -0,0 +1 @@ +Segmentation fault/access violation in generated code diff --git a/testsuite/tests/rts/divbyzero.hs b/testsuite/tests/rts/divbyzero.hs new file mode 100644 index 0000000000..0cf82bbae5 --- /dev/null +++ b/testsuite/tests/rts/divbyzero.hs @@ -0,0 +1,13 @@ + +{- +By default, on Windows a division-by-zero will pop up an annoying dialog box. +We want the RTS to catch it instead. +-} + +module Main where + +import GHC.Base + +main :: IO () +main = print (5 `divInt` 0) + diff --git a/testsuite/tests/rts/divbyzero.stderr-x86_64-unknown-openbsd b/testsuite/tests/rts/divbyzero.stderr-x86_64-unknown-openbsd new file mode 100644 index 0000000000..da6f639f9d --- /dev/null +++ b/testsuite/tests/rts/divbyzero.stderr-x86_64-unknown-openbsd @@ -0,0 +1 @@ +Floating point exception diff --git a/testsuite/tests/rts/divbyzero.stdout-i386-unknown-mingw32 b/testsuite/tests/rts/divbyzero.stdout-i386-unknown-mingw32 new file mode 100644 index 0000000000..466709b368 --- /dev/null +++ b/testsuite/tests/rts/divbyzero.stdout-i386-unknown-mingw32 @@ -0,0 +1 @@ +divide by zero diff --git a/testsuite/tests/rts/exec_signals.hs b/testsuite/tests/rts/exec_signals.hs new file mode 100644 index 0000000000..a9433d206a --- /dev/null +++ b/testsuite/tests/rts/exec_signals.hs @@ -0,0 +1,20 @@ +import System.Process +import System.Posix.Signals +import Control.Monad(when) + +data SigState = Ignored | Default | Handled + deriving (Eq, Read, Show) + +data ChildInfo = ChildInfo { + masked :: [(Int,Bool)], + handlers :: [(Int, SigState)] } + deriving (Read, Show) + +main = do out <- readProcess "./exec_signals_child" [] "" + let ci = read out :: ChildInfo + blockedSigs = [x | (x, True) <- masked ci] + ignoredSigs = [x | (x, Ignored) <- handlers ci] + when (not $ null blockedSigs) $ + putStrLn ("signals " ++ show blockedSigs ++ " are blocked") + when (not $ null ignoredSigs) $ + putStrLn ("signals " ++ show ignoredSigs ++ " are ignored") diff --git a/testsuite/tests/rts/exec_signals_child.c b/testsuite/tests/rts/exec_signals_child.c new file mode 100644 index 0000000000..4b84008928 --- /dev/null +++ b/testsuite/tests/rts/exec_signals_child.c @@ -0,0 +1,47 @@ +#include <signal.h> +#include <stdio.h> +#include <errno.h> + +// Prints the state of the signal handlers to stdout +int main() +{ + int open = 0, i; + sigset_t blockedsigs; + + printf("ChildInfo { masked = ["); + + sigprocmask(SIG_BLOCK, NULL, &blockedsigs); + for(i = 0; i < NSIG; ++i) + { + int ret = sigismember(&blockedsigs, i); + if(ret >= 0) + { + if(!open) + open=1; + else + printf(","); + printf("(%d,%s)", i, ret == 1 ? "True" : "False"); + } + } + printf("], handlers = ["); + + open = 0; + for(i = 0; i < NSIG; ++i) + { + struct sigaction old; + if(sigaction(i, NULL, &old) >= 0) + { + if(!open) + open=1; + else + printf(","); + + printf("(%d,%s)", i, + old.sa_handler == SIG_IGN ? "Ignored" : + (old.sa_handler == SIG_DFL ? "Default" : "Handled")); + } + } + printf("]}"); + + return 0; +} diff --git a/testsuite/tests/rts/exec_signals_prepare.c b/testsuite/tests/rts/exec_signals_prepare.c new file mode 100644 index 0000000000..26f30acc57 --- /dev/null +++ b/testsuite/tests/rts/exec_signals_prepare.c @@ -0,0 +1,29 @@ +#include <signal.h> +#include <stdio.h> +#include <errno.h> +#include <string.h> + +// Invokes a process, making sure that the state of the signal +// handlers has all been set back to the unix default. +int main(int argc, char **argv) +{ + int i; + sigset_t blockedsigs; + struct sigaction action; + + // unblock all signals + sigemptyset(&blockedsigs); + sigprocmask(SIG_BLOCK, NULL, NULL); + + // reset all signals to SIG_DFL + memset(&action, 0, sizeof(action)); + action.sa_handler = SIG_DFL; + action.sa_flags = 0; + sigemptyset(&action.sa_mask); + for(i = 0; i < NSIG; ++i) + sigaction(i, &action, NULL); + + execv(argv[1], argv+1); + fprintf(stderr, "failed to execv %s\n", argv[1]); + return 0; +} diff --git a/testsuite/tests/rts/libfoo_T2615.c b/testsuite/tests/rts/libfoo_T2615.c new file mode 100644 index 0000000000..a83cb18e7a --- /dev/null +++ b/testsuite/tests/rts/libfoo_T2615.c @@ -0,0 +1,2 @@ +void foo( void ); +void foo() {} diff --git a/testsuite/tests/rts/libfoo_script_T2615.so b/testsuite/tests/rts/libfoo_script_T2615.so new file mode 100644 index 0000000000..d744ae9604 --- /dev/null +++ b/testsuite/tests/rts/libfoo_script_T2615.so @@ -0,0 +1,5 @@ +/* GNU ld script + Use the shared library, but some functions are only in + the static library, so try that secondarily. */ +OUTPUT_FORMAT(elf64-x86-64) +GROUP ( libfoo_T2615.so ) diff --git a/testsuite/tests/rts/outofmem.hs b/testsuite/tests/rts/outofmem.hs new file mode 100644 index 0000000000..9392ab1da0 --- /dev/null +++ b/testsuite/tests/rts/outofmem.hs @@ -0,0 +1,7 @@ +module Main where +import Data.Array.IO +import Control.Monad +main = do + arrs <- sequence $ repeat $ (newArray_ (0,2^28) :: IO (IOUArray Int Int)) + -- larger than 2^28 causes other problems... + print (length arrs) diff --git a/testsuite/tests/rts/outofmem.stderr b/testsuite/tests/rts/outofmem.stderr new file mode 100644 index 0000000000..81856a7544 --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr @@ -0,0 +1 @@ +outofmem.exe: out of memory diff --git a/testsuite/tests/rts/outofmem.stderr-i386-apple-darwin b/testsuite/tests/rts/outofmem.stderr-i386-apple-darwin new file mode 100644 index 0000000000..929879a922 --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr-i386-apple-darwin @@ -0,0 +1 @@ +outofmem: memory allocation failed (requested 1074790400 bytes) diff --git a/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 b/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 new file mode 100644 index 0000000000..81856a7544 --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 @@ -0,0 +1 @@ +outofmem.exe: out of memory diff --git a/testsuite/tests/rts/outofmem.stderr-powerpc-apple-darwin b/testsuite/tests/rts/outofmem.stderr-powerpc-apple-darwin new file mode 100644 index 0000000000..929879a922 --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr-powerpc-apple-darwin @@ -0,0 +1 @@ +outofmem: memory allocation failed (requested 1074790400 bytes) diff --git a/testsuite/tests/rts/outofmem.stderr-ws-32 b/testsuite/tests/rts/outofmem.stderr-ws-32 new file mode 100644 index 0000000000..6147d23e91 --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr-ws-32 @@ -0,0 +1 @@ +outofmem: out of memory (requested 1074790400 bytes) diff --git a/testsuite/tests/rts/outofmem.stderr-ws-64 b/testsuite/tests/rts/outofmem.stderr-ws-64 new file mode 100644 index 0000000000..42a4696fcf --- /dev/null +++ b/testsuite/tests/rts/outofmem.stderr-ws-64 @@ -0,0 +1 @@ +outofmem: out of memory (requested 2148532224 bytes) diff --git a/testsuite/tests/rts/outofmem.stdout b/testsuite/tests/rts/outofmem.stdout new file mode 100644 index 0000000000..63a3a6988c --- /dev/null +++ b/testsuite/tests/rts/outofmem.stdout @@ -0,0 +1 @@ +exit(1) diff --git a/testsuite/tests/rts/outofmem2.hs b/testsuite/tests/rts/outofmem2.hs new file mode 100644 index 0000000000..b206d7147e --- /dev/null +++ b/testsuite/tests/rts/outofmem2.hs @@ -0,0 +1,10 @@ +-- Test for bug #1791 +import Control.Monad.ST +import Data.Array.ST +import Data.Array.MArray +import Data.Array.Base(unsafeNewArray_) +main = print (runST (do make_empty_table >> return ())) + +make_empty_table:: ST s (STArray s (Int, Int) (Maybe ep)) +make_empty_table = + unsafeNewArray_ ((1, 1), (16384, 16384)) diff --git a/testsuite/tests/rts/outofmem2.stderr b/testsuite/tests/rts/outofmem2.stderr new file mode 100644 index 0000000000..5fa8ba00e7 --- /dev/null +++ b/testsuite/tests/rts/outofmem2.stderr @@ -0,0 +1,3 @@ +Heap exhausted; +Current maximum heap size is 5242880 bytes (5 MB); +use `+RTS -M<size>' to increase it. diff --git a/testsuite/tests/rts/outofmem2.stdout b/testsuite/tests/rts/outofmem2.stdout new file mode 100644 index 0000000000..1acdde769d --- /dev/null +++ b/testsuite/tests/rts/outofmem2.stdout @@ -0,0 +1 @@ +exit(251) diff --git a/testsuite/tests/rts/return_mem_to_os.hs b/testsuite/tests/rts/return_mem_to_os.hs new file mode 100644 index 0000000000..242ccc3bb0 --- /dev/null +++ b/testsuite/tests/rts/return_mem_to_os.hs @@ -0,0 +1,21 @@ + +import Control.Concurrent +import System.IO +import System.Mem + +main :: IO () +main = do hSetBuffering stdout LineBuffering + mapM_ doIter [1..3] + +doIter :: Int -> IO () +doIter n = do putStrLn ("Iteration " ++ show n) + let xs = [n .. 1000000 + n] + putStrLn ("Last: " ++ show (last xs)) + putStrLn "GC 1 start" + performGC + putStrLn "GC 1 done" + putStrLn ("Head: " ++ show (head xs)) + putStrLn "GC 2 start" + performGC + putStrLn "GC 2 done" + diff --git a/testsuite/tests/rts/return_mem_to_os.stdout b/testsuite/tests/rts/return_mem_to_os.stdout new file mode 100644 index 0000000000..01ddffa89e --- /dev/null +++ b/testsuite/tests/rts/return_mem_to_os.stdout @@ -0,0 +1,21 @@ +Iteration 1 +Last: 1000001 +GC 1 start +GC 1 done +Head: 1 +GC 2 start +GC 2 done +Iteration 2 +Last: 1000002 +GC 1 start +GC 1 done +Head: 2 +GC 2 start +GC 2 done +Iteration 3 +Last: 1000003 +GC 1 start +GC 1 done +Head: 3 +GC 2 start +GC 2 done diff --git a/testsuite/tests/rts/rtsflags001.hs b/testsuite/tests/rts/rtsflags001.hs new file mode 100644 index 0000000000..b3549c2fe3 --- /dev/null +++ b/testsuite/tests/rts/rtsflags001.hs @@ -0,0 +1 @@ +main = return () diff --git a/testsuite/tests/rts/rtsflags001.stderr-ws-32 b/testsuite/tests/rts/rtsflags001.stderr-ws-32 new file mode 100644 index 0000000000..2bdd8ab066 --- /dev/null +++ b/testsuite/tests/rts/rtsflags001.stderr-ws-32 @@ -0,0 +1 @@ +rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 4294967295) diff --git a/testsuite/tests/rts/rtsflags001.stderr-ws-64 b/testsuite/tests/rts/rtsflags001.stderr-ws-64 new file mode 100644 index 0000000000..f50a3ee22b --- /dev/null +++ b/testsuite/tests/rts/rtsflags001.stderr-ws-64 @@ -0,0 +1 @@ +rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 18446744073709551615) diff --git a/testsuite/tests/rts/spalign.c b/testsuite/tests/rts/spalign.c new file mode 100644 index 0000000000..0b776e17cc --- /dev/null +++ b/testsuite/tests/rts/spalign.c @@ -0,0 +1,30 @@ +#include "Rts.h" + +#ifdef darwin_HOST_OS +#define STG_GLOBAL ".globl " +#else +#define STG_GLOBAL ".global " +#endif + +#ifdef LEADING_UNDERSCORE +#define GETESP "_getesp" +#else +#define GETESP "getesp" +#endif + +void __dummy__(void) +{ + __asm__ volatile ( + STG_GLOBAL GETESP "\n" + GETESP ":\n\t" + +#if defined(i386_HOST_ARCH) + "movl %%esp, %%eax\n\t" +#elif defined(x86_64_HOST_ARCH) + "movq %%rsp, %%rax\n\t" +#else +#error splign.c: not implemented for this architecture +#endif + "ret" + : : ); +} diff --git a/testsuite/tests/rts/stack001.hs b/testsuite/tests/rts/stack001.hs new file mode 100644 index 0000000000..4676e046ac --- /dev/null +++ b/testsuite/tests/rts/stack001.hs @@ -0,0 +1,9 @@ +module Main where + +import Control.Concurrent +import Control.Exception + +main = do + -- stack will grow as we evaluate the expression, and then shrink again + evaluate $ foldr (+) 0 [1..200000] + threadDelay 10 -- allow stack to shrink back to its smallest size diff --git a/testsuite/tests/rts/stack002.hs b/testsuite/tests/rts/stack002.hs new file mode 100644 index 0000000000..e6c8ee8d69 --- /dev/null +++ b/testsuite/tests/rts/stack002.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE CPP #-} +#include "stack001.hs" diff --git a/testsuite/tests/rts/stack003.hs b/testsuite/tests/rts/stack003.hs new file mode 100644 index 0000000000..4b6b29fa8d --- /dev/null +++ b/testsuite/tests/rts/stack003.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +import GHC.Exts +import System.Environment + +main = do + [n] <- fmap (fmap read) getArgs + case g n of + (# a, b, c, d, e, f, g, h, i #) -> print a + +-- a deep stack in which each frame is an unboxed tuple-return, to exercise +-- the stack underflow machinery. +g :: Int -> (# Int,Float,Double,Int#,Float#,Double#,Int,Float,Double #) +g 0 = (# 1, 2.0, 3.0, 1#, 2.0#, 3.0##, 1, 2.0, 3.0 #) +g x = case g (x-1) of + (# a, b, c, d, e, f, g, h, i #) -> + (# a+1, b, c, d, e, f, g, h, i #) diff --git a/testsuite/tests/rts/stack003.stdout b/testsuite/tests/rts/stack003.stdout new file mode 100644 index 0000000000..1567408305 --- /dev/null +++ b/testsuite/tests/rts/stack003.stdout @@ -0,0 +1 @@ +500001 diff --git a/testsuite/tests/rts/testblockalloc.c b/testsuite/tests/rts/testblockalloc.c new file mode 100644 index 0000000000..5ccc14bf59 --- /dev/null +++ b/testsuite/tests/rts/testblockalloc.c @@ -0,0 +1,75 @@ +#include "Rts.h" + +#include <stdio.h> + +extern bdescr *allocGroup_lock_lock(nat n); +extern void freeGroup_lock(bdescr *p); + +const int ARRSIZE = 256; +const int LOOPS = 100; +const int MAXALLOC = ((8 * 1024 * 1024) / BLOCK_SIZE - 1); +//const int MAXALLOC = ((64 * 1024 * 1024) / BLOCK_SIZE - 1); +const int SEED = 0xf00f00; + +extern lnat mblocks_allocated; + +int main (int argc, char *argv[]) +{ + int i, j, b; + + bdescr *a[ARRSIZE]; + + srand(SEED); + + hs_init(&argc, &argv); + + // repeatedly sweep though the array, allocating new random-sized + // objects and deallocating the old ones. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + if (i > 0) + { + IF_DEBUG(block_alloc, debugBelch("A%d: freeing %p, %d blocks @ %p\n", j, a[j], a[j]->blocks, a[j]->start)); + freeGroup_lock(a[j]); + DEBUG_ONLY(checkFreeListSanity()); + } + b = (rand() % MAXALLOC) + 1; + a[j] = allocGroup_lock(b); + IF_DEBUG(block_alloc, debugBelch("A%d: allocated %p, %d blocks @ %p\n", j, a[j], b, a[j]->start)); + // allocating zero blocks isn't allowed + DEBUG_ONLY(checkFreeListSanity()); + } + } + + for (j=0; j < ARRSIZE; j++) + { + freeGroup_lock(a[j]); + } + + // this time, sweep forwards allocating new blocks, and then + // backwards deallocating them. + for (i=0; i < LOOPS; i++) + { + for (j=0; j < ARRSIZE; j++) + { + b = (rand() % MAXALLOC) + 1; + a[j] = allocGroup_lock(b); + IF_DEBUG(block_alloc, debugBelch("B%d,%d: allocated %p, %d blocks @ %p\n", i, j, a[j], b, a[j]->start)); + DEBUG_ONLY(checkFreeListSanity()); + } + for (j=ARRSIZE-1; j >= 0; j--) + { + IF_DEBUG(block_alloc, debugBelch("B%d,%d: freeing %p, %d blocks @ %p\n", i, j, a[j], a[j]->blocks, a[j]->start)); + freeGroup_lock(a[j]); + DEBUG_ONLY(checkFreeListSanity()); + } + } + + DEBUG_ONLY(checkFreeListSanity()); + + hs_exit(); // will do a memory leak test + + exit(0); +} diff --git a/testsuite/tests/rts/testheapalloced.c b/testsuite/tests/rts/testheapalloced.c new file mode 100644 index 0000000000..cc4dad40d4 --- /dev/null +++ b/testsuite/tests/rts/testheapalloced.c @@ -0,0 +1,100 @@ +#include "Rts.h" +#include "RtsFlags.h" +#ifdef DEBUG +#define INLINE_HEADER +#endif +#include "MBlock.h" +#ifdef DEBUG +extern void *getFirstMBlock(void); +extern void *getNextMBlock(void *mblock); +#endif + +#include <stdio.h> +#include <string.h> + +extern bdescr *allocGroup_lock_lock(nat n); +extern void freeGroup_lock(bdescr *p); + +const int ARRSIZE = 2000; +const int LOOPS = 20000; +const int MAXALLOC = ((8 * 1024 * 1024) / BLOCK_SIZE - 1); +//const int MAXALLOC = ((4 * 1024 * 1024) / BLOCK_SIZE - 1); +const int SEED = 0xf00f00; + +extern lnat mblocks_allocated; + +int main (int argc, char *argv[]) +{ + int i, j, b; + + bdescr *a[ARRSIZE]; + + srand(SEED); + + hs_init(&argc, &argv); + + memset(a, 0, ARRSIZE * sizeof(bdescr*)); + + for (i=0; i < LOOPS; i++) + { + j = rand() % ARRSIZE; + if (a[j]) { freeGroup_lock(a[j]); } + a[j] = allocGroup_lock(rand() % MAXALLOC + 1); + } + +#ifdef DEBUG + { + void *p; + i = 0; + for (p = getFirstMBlock(); p != NULL; p = getNextMBlock(p)) + { + if (!HEAP_ALLOCED(p)) barf("%p",p); + i++; + } + printf("%d\n", i); + } +#endif + + { + void *p, *base; + + j = 0; + base = RtsFlags.GcFlags.heapBase; + + for (i=0; i < LOOPS*2000; i++) + { + // this is for testing: generate random addresses anywhere + // in the address space. + // + // 48 bits is: 0x800000000000 - 0x7fffffffffff + // so ((StgInt)rand() >> 4) varies between -2^27 and 2^27-1. + // and << 20 of this is a random signed 48-bit megablock address + // + // p = (void*)((StgWord)((StgInt)rand() >> 4) << 20); + + // this is for benchmarking: roughly half of these + // addresses will be in the heap. + p = base + (((StgWord)rand() << 10) % + ((StgWord)ARRSIZE * MAXALLOC * BLOCK_SIZE)); + + if (HEAP_ALLOCED(p)) { + // printf("%p\n",p); + j++; + } + } + printf("%d\n", j); + } + + printf("misses: %ld, %ld%\n", mpc_misses, mpc_misses / (LOOPS*20)); + + for (i=0; i < ARRSIZE; i++) + { + if (a[i]) { freeGroup_lock(a[i]); } + } + + hs_exit(); // will do a memory leak test + + exit(0); +} + +// 48 bits is: 0x800000000000 - 0x7fffffffffff diff --git a/testsuite/tests/rts/testwsdeque.c b/testsuite/tests/rts/testwsdeque.c new file mode 100644 index 0000000000..51aeec1ca4 --- /dev/null +++ b/testsuite/tests/rts/testwsdeque.c @@ -0,0 +1,167 @@ +#define THREADED_RTS + +#include "Rts.h" +#include "WSDeque.h" +#include <stdio.h> + +#define SCRATCH_SIZE (1024*1024) +#define THREADS 3 +#define POP 2 + +WSDeque *q; + +StgWord scratch[SCRATCH_SIZE]; +StgWord done; + +OSThreadId ids[THREADS]; + +// ----------------------------------------------------------------------------- +// version of stealWSDeque() that logs its actions, for debugging + +#ifdef DEBUG + +#define BUF 128 + +int bufs[THREADS]; + +StgWord last_b[THREADS][BUF]; +StgWord last_t[THREADS][BUF]; +StgWord last_v[THREADS][BUF]; + +#define CASTOP(addr,old,new) ((old) == cas(((StgPtr)addr),(old),(new))) + +void * +myStealWSDeque_ (WSDeque *q, nat n) +{ + void * stolen; + StgWord b,t; + +// Can't do this on someone else's spark pool: +// ASSERT_WSDEQUE_INVARIANTS(q); + + // NB. these loads must be ordered, otherwise there is a race + // between steal and pop. + t = q->top; + load_load_barrier(); + b = q->bottom; + + // NB. b and t are unsigned; we need a signed value for the test + // below, because it is possible that t > b during a + // concurrent popWSQueue() operation. + if ((long)b - (long)t <= 0 ) { + return NULL; /* already looks empty, abort */ + } + + /* now access array, see pushBottom() */ + stolen = q->elements[t & q->moduloSize]; + + /* now decide whether we have won */ + if ( !(CASTOP(&(q->top),t,t+1)) ) { + /* lost the race, someon else has changed top in the meantime */ + return NULL; + } /* else: OK, top has been incremented by the cas call */ + + // debugBelch("stealWSDeque_: t=%d b=%d\n", t, b); + +// Can't do this on someone else's spark pool: +// ASSERT_WSDEQUE_INVARIANTS(q); + + bufs[n] ++; + if (bufs[n] == BUF) { bufs[n] = 0; } + last_b[n][bufs[n]] = b; + last_t[n][bufs[n]] = t; + last_v[n][bufs[n]] = (StgWord)stolen; + return stolen; +} + +void * +myStealWSDeque (WSDeque *q, nat n) +{ + void *stolen; + + do { + stolen = myStealWSDeque_(q,n); + } while (stolen == NULL && !looksEmptyWSDeque(q)); + + return stolen; +} + +void dump(void) +{ + nat n; + nat i; + for (n = 0; n < THREADS; n++) { + debugBelch("\nthread %d:\n", n); + for (i = bufs[n]; i >= stg_max(bufs[n]-20,0); i--) { + debugBelch("%d: t=%ld b=%ld = %ld\n", i, last_t[n][i], last_b[n][i], last_v[n][i]); + } + } +} + +#endif // DEBUG + +// ----------------------------------------------------------------------------- + +void work(void *p, nat n) +{ + StgWord val; + + // debugBelch("work %ld %d\n", p, n); + val = *(StgWord *)p; + if (val != 0) { + fflush(stdout); + fflush(stderr); + barf("FAIL: %ld %d %d", p, n, val); + } + *(StgWord*)p = n+10; +} + +void OSThreadProcAttr thief(void *info) +{ + void *p; + StgWord n; + nat count = 0; + + n = (StgWord)info; + + while (!done) { +#ifdef DEBUG + p = myStealWSDeque(q,n); +#else + p = stealWSDeque(q); +#endif + if (p != NULL) { work(p,n+1); count++; } + } + debugBelch("thread %ld finished, stole %d", n, count); +} + +int main(int argc, char*argv[]) +{ + int n; + nat count = 0; + void *p; + + q = newWSDeque(1024); + done = 0; + + for (n=0; n < SCRATCH_SIZE; n++) { + scratch[n] = 0; + } + + for (n=0; n < THREADS; n++) { + createOSThread(&ids[n], thief, (void*)(StgWord)n); + } + + for (n=0; n < SCRATCH_SIZE; n++) { + if (n % POP) { + p = popWSDeque(q); + if (p != NULL) { work(p,0); count++; } + } + pushWSDeque(q,&scratch[n]); + } + +#ifdef DEBUG + debugBelch("main thread finished, popped %d", count); +#endif + exit(0); +} diff --git a/testsuite/tests/rts/traceEvent.hs b/testsuite/tests/rts/traceEvent.hs new file mode 100644 index 0000000000..ef641816d4 --- /dev/null +++ b/testsuite/tests/rts/traceEvent.hs @@ -0,0 +1,5 @@ +import GHC.Exts + +main = do + traceEvent "testing" + traceEvent "%s" -- see #3874 |