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 void
  57 PreTraceHook (long fd)
  58 {
  59     const char msg[]="\n";
  60     write(fd,msg,sizeof(msg)-1);
  61 }
  62
  63 void
  64 PostTraceHook (long fd)
  65 {
  66 #if 0
  67     const char msg[]="\n";
  68     write(fd,msg,sizeof(msg)-1);
  69 #endif
  70 }
  71
  72 #if __GLASGOW_HASKELL__ >= 400
  73 void
  74 OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
  75   /* both in bytes */
  76 {
  77     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",
  78         request_size,
  79         heap_size);
  80 }
  81
  82 void
  83 StackOverflowHook (unsigned long stack_size)    /* in bytes */
  84 {
  85     fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
  86 }
  87
  88 #else /* GHC < 4.00 */
  89
  90 void
  91 OutOfHeapHook (W_ request_size, W_ heap_size)  /* both in bytes */
  92 {
  93     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",
  94         request_size,
  95         heap_size);
  96 }
  97
  98 void
  99 StackOverflowHook (I_ stack_size)    /* in bytes */
 100 {
 101     fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
 102 }
 103
 104 #endif
 105
 106 HsInt
 107 ghc_strlen( HsAddr a )
 108 {
 109     return (strlen((char *)a));
 110 }
 111
 112 HsInt
 113 ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len )
 114 {
 115     return (memcmp((char *)a1, a2, len));
 116 }
 117
 118 HsInt
 119 ghc_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len )
 120 {
 121     return (memcmp((char *)a1 + i, a2, len));
 122 }