ghc/lib/prelude/Builtin.hs

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