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
|
{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
-- From trac #1947
-- Should fail with heap exhaustion
-- See notes below with "Infinite loop here".
module Main(main) where
import System.IO.Unsafe
import System.IO
import System.Environment
import System.Exit
import Foreign.C.Types
import Data.Char(ord,chr)
-- low level imports
import GHC.Base (realWorld#)
import GHC.IO (IO(IO), unIO, unsafePerformIO)
import GHC.Prim (State#,RealWorld)
-- FFI replacements for Haskell stuff
foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt
foreign import ccall unsafe "ctype.h iswspace" isspace :: CInt -> CInt
skipCAF :: State# RealWorld -> a -> a
skipCAF _ x = x
-- IO Subsystem
-- Unboxed IO is more efficient, but requires a certain level of
-- optimisation, so provide a BOXED_IO fallback
data RW_Box = RW_Box (State# RealWorld)
type RW_Pair a = (RW_Box, a)
fromIO :: IO a -> (RW_Box -> RW_Pair a)
fromIO a (RW_Box r) = case unIO a r of (# r, x #) -> (RW_Box r, x)
toIO :: (RW_Box -> RW_Pair a) -> IO a
toIO f = IO $ \r -> case f (RW_Box r) of (RW_Box r, x) -> (# r, x #)
-- IO functions not dependent on the IO primitives
main :: IO ()
main = toIO main_generated
typeRealWorld :: RW_Box -> RW_Box
typeRealWorld x = x
overlay_get_char :: RW_Box -> RW_Pair Int
overlay_get_char = fromIO $ do
c <- getchar
return $ fromIntegral c
system_IO_hPutChar :: Handle -> Int -> RW_Box -> RW_Pair ()
system_IO_hPutChar h c = fromIO $ hPutChar h (chr c)
overlay_errorIO :: [Int] -> RW_Box -> RW_Pair a
overlay_errorIO x r = case fromIO (putStrLn ("ERROR: " ++ map chr x)) r of
(r, _) -> fromIO exitFailure r
system_Environment_getArgs :: RW_Box -> RW_Pair [[Int]]
system_Environment_getArgs r = case (fromIO getArgs) r of
(r, s) -> (r, map str_ s)
overlay_supero_wrap x = x
-- Primitives
prelude_seq = seq
prelude_error x = error (map chr x)
aDD_W = (+) :: Int -> Int -> Int
mUL_W = (*) :: Int -> Int -> Int
sUB_W = (-) :: Int -> Int -> Int
eQ_W = (==) :: Int -> Int -> Bool
nE_W = (/=) :: Int -> Int -> Bool
gT_W = (>) :: Int -> Int -> Bool
gE_W = (>=) :: Int -> Int -> Bool
lT_W = (<) :: Int -> Int -> Bool
lE_W = (<=) :: Int -> Int -> Bool
qUOT = quot :: Int -> Int -> Int
rEM = rem :: Int -> Int -> Int
nEG_W = negate :: Int -> Int
yHC_Primitive_primIntAbs = abs :: Int -> Int
yHC_Primitive_primIntSignum = signum :: Int -> Int
yHC_Primitive_primIntegerAdd = (+) :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerEq = (==) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerFromInt = toInteger :: Int -> Integer
yHC_Primitive_primIntegerGe = (>=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerGt = (>) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerLe = (<=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerMul = (*) :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerNe = (/=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerNeg = negate :: Integer -> Integer
yHC_Primitive_primIntegerQuot = quot :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerQuotRem = quotRem :: Integer -> Integer -> (Integer, Integer)
yHC_Primitive_primIntegerRem = rem :: Integer -> Integer -> Integer
yHC_Primitive_primIntFromInteger = fromInteger :: Integer -> Int
yHC_Primitive_primIntegerLt = (<) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerSub = (-) :: Integer -> Integer -> Integer
aDD_D = (+) :: Double -> Double -> Double
sUB_D = (-) :: Double -> Double -> Double
lT_D = (<) :: Double -> Double -> Bool
lE_D = (<=) :: Double -> Double -> Bool
gT_D = (>) :: Double -> Double -> Bool
gE_D = (>=) :: Double -> Double -> Bool
eQ_D = (==) :: Double -> Double -> Bool
mUL_D = (*) :: Double -> Double -> Double
nEG_D = (negate) :: Double -> Double
nE_D = (/=) :: Double -> Double -> Bool
sLASH_D = (/) :: Double -> Double -> Double
yHC_Primitive_primDecodeDouble = decodeFloat :: Double -> (Integer,Int)
yHC_Primitive_primDoubleACos = acos :: Double -> Double
yHC_Primitive_primDoubleASin = asin :: Double -> Double
yHC_Primitive_primDoubleATan = atan :: Double -> Double
yHC_Primitive_primDoubleAbs = abs :: Double -> Double
yHC_Primitive_primDoubleCos = cos :: Double -> Double
yHC_Primitive_primDoubleExp = exp :: Double -> Double
yHC_Primitive_primDoubleFromInteger = fromInteger :: Integer -> Double
yHC_Primitive_primDoubleLog = log :: Double -> Double
yHC_Primitive_primDoublePow = (**) :: Double -> Double -> Double
yHC_Primitive_primDoubleSignum = signum :: Double -> Double
yHC_Primitive_primDoubleSin = sin :: Double -> Double
yHC_Primitive_primDoubleSqrt = sqrt :: Double -> Double
yHC_Primitive_primDoubleTan = tan :: Double -> Double
yHC_Primitive_primEncodeDouble = encodeFloat :: Integer -> Int -> Double
-- things which Yhc decides should be hopelessly slow
prelude_Int_Integral_mod = mod :: Int -> Int -> Int
prelude_Integer_Integral_div = div :: Integer -> Integer -> Integer
prelude_Integer_Integral_mod = mod :: Integer -> Integer -> Integer
prelude_Integer_Num_signum = signum :: Integer -> Integer
prelude_Integer_Num_abs = abs :: Integer -> Integer
int_ x = x :: Int
chr_ x = ord x
str_ x = map chr_ x
system_IO_stdin = stdin
system_IO_stdout = stdout
data_Char_isSpace :: Int -> Bool
data_Char_isSpace c = isspace (toEnum c) /= 0
type ReadsPrec a = Int -> [Int] -> [(a,[Int])]
prelude_Int_Read_readsPrec :: ReadsPrec Int
prelude_Int_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Int_Read_readList = undefined
prelude_Integer_Read_readsPrec :: ReadsPrec Integer
prelude_Integer_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Integer_Read_readList = undefined
prelude_Double_Read_readsPrec :: ReadsPrec Double
prelude_Double_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Double_Read_readList = undefined
prelude_Char_Read_readsPrec :: ReadsPrec Int
prelude_Char_Read_readsPrec p s = [(chr_ (a :: Char), str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Char_Show_showList :: [Int] -> [Int] -> [Int]
prelude_Char_Show_showList value rest = str_ (show (map chr value)) ++ rest
prelude_Char_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
prelude_Char_Show_showsPrec prec i rest = str_ (showsPrec prec (chr i) []) ++ rest
prelude_Int_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
prelude_Int_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
prelude_Integer_Show_showsPrec :: Int -> Integer -> [Int] -> [Int]
prelude_Integer_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
prelude_Double_Show_showsPrec :: Int -> Double -> [Int] -> [Int]
prelude_Double_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest
prelude_'amp'amp27 v1 v2 =
case (data_Char_isSpace v1) of
True ->
case v2 of
[] -> True
(:) v4 v5 -> prelude_'amp'amp27 v4 v5
False -> False
prelude_LAMBDA22 v1 v2 =
case v1 of
(,) v267 v268 ->
case v268 of
[] -> prelude_LAMBDA24 v267 v2
(:) v7 v8 ->
let v11 = prelude_'amp'amp27 v7 v8
in case v11 of
True -> prelude_LAMBDA24 v267 v2
False -> prelude__foldr25 v2
prelude_LAMBDA24 v1 v2 = (:) v1 (prelude__foldr25 v2)
prelude_IO_Monad_fail41 v1 =
overlay_errorIO
(skipCAF realWorld# (str_ "pattern-match failure in do expression"))
v1
prelude__foldr25 v1 =
case v1 of
[] -> []
(:) v296 v297 -> prelude_LAMBDA22 v296 v297
f17 uncaf = skipCAF uncaf (str_ "Prelude.read: no parse")
f18 v1 v2 =
case v1 of
(,) v176 v177 ->
case v177 of
[] -> f20 v176 v2
(:) v7 v8 ->
let v11 = prelude_'amp'amp27 v7 v8
in case v11 of
True -> f20 v176 v2
False ->
case v2 of
[] -> prelude_error (f17 realWorld#)
(:) v4 v5 -> f18 v4 v5
f20 v1 v2 =
case v2 of
[] -> v1
(:) v257 v258 ->
let v9 = prelude_LAMBDA22 v257 v258
in case v9 of
[] -> v1
(:) v10 v11 ->
prelude_error
(skipCAF realWorld# (str_ "Prelude.read: ambiguous parse"))
-- Infinite loop here. It was originally:
-- f34 v1 v2 v3 =
-- let v336 = f34 v1 v2 v3
-- in v336
--
-- But that now (correctly) just makes a non-allocating infinite loop
-- instead of (incorrectly) eta-reducing to f34 = f34.
-- So I've changed to an infinite, allocating loop, which makes
-- the heap get exhausted.
f34 v1 v2 v3 =
if abs v2 < 1000 then
let v336 = f34 (v1+1) (-v2) v3
in v336
else if v2 == 2000 then 0 else v1
f38 v1 v2 =
case v1 of
[] -> system_IO_hPutChar system_IO_stdout (chr_ '\n') v2
(:) v350 v351 ->
case (system_IO_hPutChar
system_IO_stdout
v350
(typeRealWorld v2)) of
( v7 , v8 ) -> f38 v351 v7
main_generated v1 =
case (system_Environment_getArgs (typeRealWorld v1)) of
( v3 , v4 ) ->
case v4 of
(:) v7 v8 ->
case v8 of
(:) v9 v12 ->
case v12 of
(:) v13 v14 ->
case v14 of
[] ->
case (prelude_Int_Show_showsPrec
(int_ 0)
(let v8 =
case (prelude_Int_Read_readsPrec
(int_ 0)
v7) of
[] -> prelude_error (f17 realWorld#)
(:) v12 v14 -> f18 v12 v14
v10 =
case (prelude_Int_Read_readsPrec
(int_ 0)
v9) of
[] -> prelude_error (f17 realWorld#)
(:) v15 v16 -> f18 v15 v16
v11 =
case (prelude_Int_Read_readsPrec
(int_ 0)
v13) of
[] -> prelude_error (f17 realWorld#)
(:) v17 v18 -> f18 v17 v18
in case (lT_W v10 v8) of
True ->
let v7 = f34 v8 v10 v11
in v7
False -> v11)
(skipCAF realWorld# (str_ ""))) of
[] ->
system_IO_hPutChar
system_IO_stdout
(chr_ '\n')
(typeRealWorld v3)
(:) v11 v12 ->
case (system_IO_hPutChar
system_IO_stdout
v11
(typeRealWorld (typeRealWorld v3))) of
( v7 , v8 ) -> f38 v12 v7
(:) v15 v16 -> prelude_IO_Monad_fail41 v3
[] -> prelude_IO_Monad_fail41 v3
[] -> prelude_IO_Monad_fail41 v3
[] -> prelude_IO_Monad_fail41 v3
|
