ghc/compiler/parser/hschooks.c

   1 /*
   2 These routines customise the error messages
   3 for various bits of the RTS.  They are linked
   4 in instead of the defaults.
   5 */
   6
   7 #if __GLASGOW_HASKELL__ >= 400
   8 #include "Rts.h"
   9 #else
  10 #include "rtsdefs.h"
  11 #endif
  12
  13 #if __GLASGOW_HASKELL__ >= 408
  14 #include "../includes/RtsFlags.h"
  15 #include "HsFFI.h"
  16 #endif
  17
  18 #ifdef HAVE_UNISTD_H
  19 #include <unistd.h>
  20 #endif
  21
  22 void
  23 defaultsHook (void)
  24 {
  25 #if __GLASGOW_HASKELL__ >= 408
  26     RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE;
  27     RtsFlags.GcFlags.maxStkSize         = 8*1024*1024 / sizeof(W_);
  28 #endif
  29 #if __GLASGOW_HASKELL__ >= 411
  30     RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;
  31     RtsFlags.GcFlags.statsFile = stderr;
  32 #endif
  33 }
  34
  35 void
  36 enableTimingStats( void )       /* called from the driver */
  37 {
  38 #if __GLASGOW_HASKELL__ >= 411
  39     RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS;
  40 #endif
  41     /* ignored when bootstrapping with an older GHC */
  42 }
  43
  44 void
  45 setHeapSize( HsInt size )
  46 {
  47 #if __GLASGOW_HASKELL__ >= 408
  48     RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE;
  49     if (RtsFlags.GcFlags.maxHeapSize != 0 &&
  50         RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) {
  51         RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
  52     }
  53 #endif
  54 }
  55
  56 #if __GLASGOW_HASKELL__ >= 303
  57
  58 void
  59 ErrorHdrHook (long fd)
  60 {
  61     char msg[]="\n";
  62     write(fd,msg,1);
  63 }
  64
  65 void
  66 PatErrorHdrHook (long fd)
  67 {
  68     const char msg[]="\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@haskell.org.\n\nFail:";
  69     write(fd,msg,sizeof(msg)-1);
  70 }
  71
  72 void
  73 PreTraceHook (long fd)
  74 {
  75     const char msg[]="\n";
  76     write(fd,msg,sizeof(msg)-1);
  77 }
  78
  79 void
  80 PostTraceHook (long fd)
  81 {
  82 #if 0
  83     const char msg[]="\n";
  84     write(fd,msg,sizeof(msg)-1);
  85 #endif
  86 }
  87
  88 #else /* pre-3.03 GHC with old IO system */
  89
  90 void
  91 ErrorHdrHook (FILE *where)
  92 {
  93     fprintf(where, "\n"); /* no "Fail: " */
  94 }
  95
  96 void
  97 PatErrorHdrHook (FILE *where)
  98 {
  99     fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@haskell.org.\n\nFail: ");
 100 }
 101
 102 void
 103 PreTraceHook (FILE *where)
 104 {
 105     fprintf(where, "\n"); /* not "Trace On" */
 106 }
 107
 108 void
 109 PostTraceHook (FILE *where)
 110 {
 111     fprintf(where, "\n"); /* not "Trace Off" */
 112 }
 113
 114 #endif
 115
 116 #if __GLASGOW_HASKELL__ >= 400
 117 void
 118 OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
 119   /* both in bytes */
 120 {
 121     fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
 122         request_size,
 123         heap_size);
 124 }
 125
 126 void
 127 StackOverflowHook (unsigned long stack_size)    /* in bytes */
 128 {
 129     fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
 130 }
 131
 132 #else /* GHC < 4.00 */
 133
 134 void
 135 OutOfHeapHook (W_ request_size, W_ heap_size)  /* both in bytes */
 136 {
 137     fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
 138         request_size,
 139         heap_size);
 140 }
 141
 142 void
 143 StackOverflowHook (I_ stack_size)    /* in bytes */
 144 {
 145     fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
 146 }
 147
 148 #endif
 149
 150 HsInt
 151 ghc_strlen( HsAddr a )
 152 {
 153     return (strlen((char *)a));
 154 }
 155
 156 HsInt
 157 ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len )
 158 {
 159     return (memcmp((char *)a1, a2, len));
 160 }
 161
 162 HsInt
 163 ghc_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len )
 164 {
 165     return (memcmp((char *)a1 + i, a2, len));
 166 }