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