ghc/lib/prelude/Builtin.hs

   1 module PreludeBuiltin (
   2         _runST,
   3         _trace,
   4         absent#,
   5         error,
   6         patError#,
   7         parError#,
   8         unpackPS#, unpackPS2#,
   9         unpackAppendPS#,
  10         unpackFoldrPS#
  11     ) where
  12
  13 import Cls
  14 import Core
  15 import IInt
  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 )
  23 #endif
  24 import PS               ( _PackedString, _unpackPS, _packCBytes )
  25 import Stdio            ( _FILE )
  26 import Text
  27 import TyComplex
  28
  29 ---------------------------------------------------------------
  30 {- OLD:
  31 packCString# :: [Char] -> ByteArray#
  32
  33 packCString# str = packString# str -- ToDo: more satisfactorily
  34 -}
  35
  36 ---------------------------------------------------------------
  37 -- ******** defns of `error' and `trace' using Glasgow IO *****
  38 -- No specialised versions are required for these bottoming Ids
  39
  40 error  :: String -> a
  41 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
  42
  43 error__ :: (_FILE -> PrimIO ()) -> String -> a
  44
  45 error__ msg_hdr s
  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)
  52             )
  53 #else
  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)
  61              else
  62                _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
  63                                                 `thenPrimIO` \ osptr ->
  64                _ccall_ decrementErrorCount      `thenPrimIO` \ () ->
  65                deRefStablePtr osptr             `thenPrimIO` \ oact ->
  66                oact
  67             )
  68 #endif {- !parallel -}
  69   where
  70     sTDERR = (``stderr'' :: _FILE)
  71
  72 absent# = error "Oops! The program has entered an `absent' argument!\n"
  73
  74 parError# = error "Oops! Entered parError# (a GHC bug -- please report it!)\n"
  75
  76 ---------------------------------------------------------------
  77 _runST m = case m (S# realWorld#) of
  78            (r,_) -> r
  79
  80 ---------------------------------------------------------------
  81 -- Used for compiler-generated error message;
  82 -- encoding saves bytes of string junk.
  83
  84 patError# :: String -> a
  85
  86 patError# encoded_msg
  87   = error__ (\ x -> _ccall_ PatErrorHdrHook x) (expand (encoded_msg ++ "\n"))
  88   where
  89     expand [] = []
  90     expand ('%':next:rest)
  91       = let
  92             decoded
  93               = case next of
  94                   '%' -> "%"
  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"
 102                   'l' -> "\", line "
 103                   _   -> error ("BAD call to builtin patError#:" ++ (next:rest))
 104         in
 105         decoded ++ expand rest
 106
 107     expand (c:rest) = c : expand rest
 108
 109 ---------------------------------------------------------------
 110 -- ******** defn of `_trace' using Glasgow IO *******
 111
 112 {-# GENERATE_SPECS _trace a #-}
 113 _trace :: String -> a -> a
 114
 115 _trace string expr
 116   = unsafePerformPrimIO (
 117         ((_ccall_ PreTraceHook sTDERR{-msg-})::PrimIO ())       `seqPrimIO`
 118         appendChan# sTDERR string                               `seqPrimIO`
 119         ((_ccall_ PostTraceHook sTDERR{-msg-})::PrimIO ())      `seqPrimIO`
 120         returnPrimIO expr )
 121   where
 122     sTDERR = (``stderr'' :: _FILE)
 123
 124 --------------------------------------------------------------------------
 125
 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?
 130
 131 unpackPS# addr -- calls injected by compiler
 132   = unpack 0#
 133   where
 134     unpack nh
 135       | ch `eqChar#` '\0'# = []
 136       | True               = C# ch : unpack (nh +# 1#)
 137       where
 138         ch = indexCharOffAddr# addr nh
 139
 140 unpackAppendPS# addr rest
 141   = unpack 0#
 142   where
 143     unpack nh
 144       | ch `eqChar#` '\0'# = rest
 145       | True               = C# ch : unpack (nh +# 1#)
 146       where
 147         ch = indexCharOffAddr# addr nh
 148
 149 unpackFoldrPS# addr f z
 150   = unpack 0#
 151   where
 152     unpack nh
 153       | ch `eqChar#` '\0'# = z
 154       | True               = C# ch `f` unpack (nh +# 1#)
 155       where
 156         ch = indexCharOffAddr# addr nh
 157
 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))