1 module PreludeBuiltin (
16 import List ( (++), foldr, takeWhile )
17 import TyArray ( Array(..) )
18 import PreludeErrIO ( errorIO )
19 import PreludeGlaST -- state transformer stuff
20 import PreludeDialogueIO ( appendChan# )
21 #ifndef __PARALLEL_HASKELL__
22 import PreludeGlaMisc ( deRefStablePtr )
24 import PS ( _PackedString, _unpackPS, _packCBytes )
25 import Stdio ( _FILE )
29 ---------------------------------------------------------------
31 packCString# :: [Char] -> ByteArray#
33 packCString# str = packString# str -- ToDo: more satisfactorily
36 ---------------------------------------------------------------
37 -- ******** defns of `error' and `trace' using Glasgow IO *****
38 -- No specialised versions are required for these bottoming Ids
41 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
43 error__ :: (_FILE -> PrimIO ()) -> String -> a
46 #ifdef __PARALLEL_HASKELL__
47 = errorIO (msg_hdr sTDERR{-msg hdr-} `seqPrimIO`
48 _ccall_ fflush sTDERR `seqPrimIO`
49 appendChan# sTDERR s `seqPrimIO`
50 _ccall_ fflush sTDERR `seqPrimIO`
51 _ccall_ stg_exit (1::Int)
54 = errorIO (msg_hdr sTDERR{-msg hdr-} `seqPrimIO`
55 _ccall_ fflush sTDERR `seqPrimIO`
56 appendChan# sTDERR s `seqPrimIO`
57 _ccall_ fflush sTDERR `seqPrimIO`
58 _ccall_ getErrorHandler `thenPrimIO` \ errorHandler ->
59 if errorHandler == (-1::Int)
60 then _ccall_ stg_exit (1::Int)
62 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
63 `thenPrimIO` \ osptr ->
64 _ccall_ decrementErrorCount `thenPrimIO` \ () ->
65 deRefStablePtr osptr `thenPrimIO` \ oact ->
68 #endif {- !parallel -}
70 sTDERR = (``stderr'' :: _FILE)
72 absent# = error "Oops! The program has entered an `absent' argument!\n"
74 parError# = error "Oops! Entered parError# (a GHC bug -- please report it!)\n"
76 ---------------------------------------------------------------
77 _runST m = case m (S# realWorld#) of
80 ---------------------------------------------------------------
81 -- Used for compiler-generated error message;
82 -- encoding saves bytes of string junk.
84 patError# :: String -> a
87 = error__ (\ x -> _ccall_ PatErrorHdrHook x) (expand (encoded_msg ++ "\n"))
90 expand ('%':next:rest)
95 'D' -> "No default method for \""
96 'E' -> "No explicit method for \""
97 'N' -> ": non-exhaustive guards"
98 'F' -> "incomplete pattern(s) to match in function \""
99 'L' -> "pattern-matching failed in lambda"
100 'C' -> "pattern-matching failed in case"
101 '~' -> ": pattern-match failed on an irrefutable pattern"
103 _ -> error ("BAD call to builtin patError#:" ++ (next:rest))
105 decoded ++ expand rest
107 expand (c:rest) = c : expand rest
109 ---------------------------------------------------------------
110 -- ******** defn of `_trace' using Glasgow IO *******
112 {-# GENERATE_SPECS _trace a #-}
113 _trace :: String -> a -> a
116 = unsafePerformPrimIO (
117 ((_ccall_ PreTraceHook sTDERR{-msg-})::PrimIO ()) `seqPrimIO`
118 appendChan# sTDERR string `seqPrimIO`
119 ((_ccall_ PostTraceHook sTDERR{-msg-})::PrimIO ()) `seqPrimIO`
122 sTDERR = (``stderr'' :: _FILE)
124 --------------------------------------------------------------------------
126 unpackPS# :: Addr# -> [Char] -- calls injected by compiler
127 unpackPS2# :: Addr# -> Int# -> [Char] -- calls injected by compiler
128 unpackAppendPS# :: Addr# -> [Char] -> [Char] -- ditto?
129 unpackFoldrPS# :: Addr# -> (Char -> a -> a) -> a -> a -- ditto?
131 unpackPS# addr -- calls injected by compiler
135 | ch `eqChar#` '\0'# = []
136 | True = C# ch : unpack (nh +# 1#)
138 ch = indexCharOffAddr# addr nh
140 unpackAppendPS# addr rest
144 | ch `eqChar#` '\0'# = rest
145 | True = C# ch : unpack (nh +# 1#)
147 ch = indexCharOffAddr# addr nh
149 unpackFoldrPS# addr f z
153 | ch `eqChar#` '\0'# = z
154 | True = C# ch `f` unpack (nh +# 1#)
156 ch = indexCharOffAddr# addr nh
158 unpackPS2# addr len -- calls injected by compiler
159 -- this one is for literal strings with NULs in them; rare.
160 = _unpackPS (_packCBytes (I# len) (A# addr))