ghc/lib/prelude/Builtin.hs

   1 module PreludeBuiltin (
   2         _runST,
   3         _trace,
   4         absent#,
   5         error,
   6         patError#,
   7         parError#
   8     ) where
   9
  10 import Cls
  11 import Core
  12 import IInt
  13 import List             ( (++), foldr, takeWhile )
  14 import TyArray          ( Array(..) )
  15 import PreludeErrIO     ( errorIO )
  16 import PreludeGlaST     -- state transformer stuff
  17 import PreludeDialogueIO ( appendChan# )
  18 #ifndef __PARALLEL_HASKELL__
  19 import PreludeGlaMisc   ( deRefStablePtr )
  20 #endif
  21 import PS               ( _PackedString, _unpackPS )
  22 import Stdio            ( _FILE )
  23 import Text
  24 import TyComplex
  25
  26 ---------------------------------------------------------------
  27 {- OLD:
  28 packCString# :: [Char] -> ByteArray#
  29
  30 packCString# str = packString# str -- ToDo: more satisfactorily
  31 -}
  32
  33 ---------------------------------------------------------------
  34 -- ******** defns of `error' and `trace' using Glasgow IO *****
  35 -- No specialised versions are required for these bottoming Ids
  36
  37 error  :: String -> a
  38 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
  39
  40 error__ :: (_FILE -> PrimIO ()) -> String -> a
  41
  42 error__ msg_hdr s
  43 #ifdef __PARALLEL_HASKELL__
  44   = errorIO (msg_hdr sTDERR{-msg hdr-}          `seqPrimIO`
  45              _ccall_ fflush sTDERR              `seqPrimIO`
  46              appendChan# sTDERR s               `seqPrimIO`
  47              _ccall_ fflush sTDERR              `seqPrimIO`
  48              _ccall_ stg_exit (1::Int)
  49             )
  50 #else
  51   = errorIO (msg_hdr sTDERR{-msg hdr-}          `seqPrimIO`
  52              _ccall_ fflush sTDERR              `seqPrimIO`
  53              appendChan# sTDERR s               `seqPrimIO`
  54              _ccall_ fflush sTDERR              `seqPrimIO`
  55              _ccall_ getErrorHandler            `thenPrimIO` \ errorHandler ->
  56              if errorHandler == (-1::Int)
  57              then _ccall_ stg_exit (1::Int)
  58              else
  59                _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
  60                                                 `thenPrimIO` \ osptr ->
  61                _ccall_ decrementErrorCount      `thenPrimIO` \ () ->
  62                deRefStablePtr osptr             `thenPrimIO` \ oact ->
  63                oact
  64             )
  65 #endif {- !parallel -}
  66   where
  67     sTDERR = (``stderr'' :: _FILE)
  68
  69 absent# = error "Oops! The program has entered an `absent' argument!\n"
  70
  71 parError# = error "Oops! Entered parError# (a GHC bug -- please report it!)\n"
  72
  73 ---------------------------------------------------------------
  74 _runST m = case m (S# realWorld#) of
  75            (r,_) -> r
  76
  77 ---------------------------------------------------------------
  78 -- Used for compiler-generated error message;
  79 -- encoding saves bytes of string junk.
  80
  81 patError# :: String -> a
  82
  83 patError# encoded_msg
  84   = error__ (\ x -> _ccall_ PatErrorHdrHook x) (expand (encoded_msg ++ "\n"))
  85   where
  86     expand [] = []
  87     expand ('%':next:rest)
  88       = let
  89             decoded
  90               = case next of
  91                   '%' -> "%"
  92                   'D' -> "No default method for \""
  93                   'E' -> "No explicit method for \""
  94                   'N' -> ": non-exhaustive guards"
  95                   'F' -> "incomplete pattern(s) to match in function \""
  96                   'L' -> "pattern-matching failed in lambda"
  97                   'C' -> "pattern-matching failed in case"
  98                   '~' -> ": pattern-match failed on an irrefutable pattern"
  99                   'l' -> "\", line "
 100                   _   -> error ("BAD call to builtin patError#:" ++ (next:rest))
 101         in
 102         decoded ++ expand rest
 103
 104     expand (c:rest) = c : expand rest
 105
 106 ---------------------------------------------------------------
 107 -- ******** defn of `_trace' using Glasgow IO *******
 108
 109 {-# GENERATE_SPECS _trace a #-}
 110 _trace :: String -> a -> a
 111
 112 _trace string expr
 113   = unsafePerformPrimIO (
 114         ((_ccall_ PreTraceHook sTDERR{-msg-})::PrimIO ())       `seqPrimIO`
 115         appendChan# sTDERR string                               `seqPrimIO`
 116         ((_ccall_ PostTraceHook sTDERR{-msg-})::PrimIO ())      `seqPrimIO`
 117         returnPrimIO expr )
 118   where
 119     sTDERR = (``stderr'' :: _FILE)