home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / os2.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  9KB  |  376 lines
  1. /* -*-C-*-
  2.  
  3. $Id: os2.c,v 1.8 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1994-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #include "os2.h"
  23.  
  24. /* Define OS2_USE_SUBHEAP_MALLOC to use this custom malloc
  25.    implementation for most of Scheme's memory.  This implementation,
  26.    by virtue of being separate from the system's malloc, and also by
  27.    having specific redundancy checks, offers some features that can be
  28.    valuable during debugging of memory problems.  */
  29.  
  30. /* #define OS2_USE_SUBHEAP_MALLOC */
  31. #ifdef OS2_USE_SUBHEAP_MALLOC
  32.  
  33. static PVOID malloc_object;
  34. static ULONG malloc_object_size = 0x200000; /* two megabytes */
  35.  
  36. typedef struct
  37. {
  38.   char * check;
  39.   unsigned int size;
  40. } malloc_header_t;
  41.  
  42. void
  43. OS2_initialize_malloc (void)
  44. {
  45.   if (((DosAllocMem ((&malloc_object),
  46.              malloc_object_size,
  47.              (PAG_EXECUTE | PAG_READ | PAG_WRITE)))
  48.        != NO_ERROR)
  49.       || ((DosSubSetMem (malloc_object,
  50.              (DOSSUB_INIT | DOSSUB_SPARSE_OBJ | DOSSUB_SERIALIZE),
  51.              malloc_object_size))
  52.       != NO_ERROR))
  53.     termination_init_error ();
  54. }
  55.  
  56. static malloc_header_t *
  57. guarantee_valid_malloc_pointer (void * ptr)
  58. {
  59.   malloc_header_t * header = (((malloc_header_t *) ptr) - 1);
  60.   if ((((char *) header) < ((char *) malloc_object))
  61.       || (((char *) header) > (((char *) malloc_object) + malloc_object_size))
  62.       || ((((ULONG) header) & 7) != 0)
  63.       || ((header -> check) != (((char *) header) - 47)))
  64.     OS2_logic_error ("Bad pointer passed to OS_free.");
  65.   return (header);
  66. }
  67.  
  68. void *
  69. OS2_malloc_noerror (unsigned int size)
  70. {
  71.   PVOID result;
  72.   APIRET rc
  73.     = (DosSubAllocMem (malloc_object,
  74.                (&result),
  75.                (size + (sizeof (malloc_header_t)))));
  76.   if (rc == ERROR_DOSSUB_NOMEM)
  77.     return (0);
  78.   if (rc != NO_ERROR)
  79.     {
  80.       char buffer [1024];
  81.       sprintf (buffer, "DosSubAllocMem error: %d.", rc);
  82.       OS2_logic_error (buffer);
  83.     }
  84.   (((malloc_header_t *) result) -> check) = (((char *) result) - 47);
  85.   (((malloc_header_t *) result) -> size) = size;
  86.   return (((malloc_header_t *) result) + 1);
  87. }
  88.  
  89. void
  90. OS_free (void * ptr)
  91. {
  92.   malloc_header_t * header = (guarantee_valid_malloc_pointer (ptr));
  93.   APIRET rc;
  94.   (header -> check) = 0;
  95.   rc = (DosSubFreeMem (malloc_object, header, (header -> size)));
  96.   if (rc != NO_ERROR)
  97.     {
  98.       char buffer [1024];
  99.       sprintf (buffer, "DosSubFreeMem error: %d.", rc);
  100.       OS2_logic_error (buffer);
  101.     }
  102. }
  103.  
  104. void *
  105. OS2_realloc_noerror (void * ptr, unsigned int size)
  106. {
  107.   unsigned int osize = ((guarantee_valid_malloc_pointer (ptr)) -> size);
  108.   if (osize == size)
  109.     return (ptr);
  110.   {
  111.     void * result = (OS2_malloc_noerror (size));
  112.     if (result != 0)
  113.       {
  114.     char * scan1 = ptr;
  115.     char * end1 = (scan1 + ((osize < size) ? osize : size));
  116.     char * scan2 = result;
  117.     while (scan1 < end1)
  118.       (*scan2++) = (*scan1++);
  119.     OS_free (ptr);
  120.       }
  121.     return (result);
  122.   }
  123. }
  124.  
  125. #else /* not OS2_USE_SUBHEAP_MALLOC */
  126.  
  127. /* Use malloc.  */
  128.  
  129. void
  130. OS2_initialize_malloc (void)
  131. {
  132. }
  133.  
  134. void *
  135. OS2_malloc_noerror (unsigned int size)
  136. {
  137.   return (malloc (size));
  138. }
  139.  
  140. void *
  141. OS2_realloc_noerror (void * ptr, unsigned int size)
  142. {
  143.   return (realloc (ptr, size));
  144. }
  145.  
  146. void
  147. OS_free (void * ptr)
  148. {
  149.   free (ptr);
  150. }
  151.  
  152. #endif /* not OS2_USE_SUBHEAP_MALLOC */
  153.  
  154. void *
  155. OS_malloc (unsigned int size)
  156. {
  157.   void * result = (OS2_malloc_noerror (size));
  158.   if (result == 0)
  159.     OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_malloc);
  160.   return (result);
  161. }
  162.  
  163. void *
  164. OS_realloc (void * ptr, unsigned int size)
  165. {
  166.   void * result = (OS2_realloc_noerror (ptr, size));
  167.   if (result == 0)
  168.     OS2_error_system_call (ERROR_NOT_ENOUGH_MEMORY, syscall_realloc);
  169.   return (result);
  170. }
  171.  
  172. HMTX
  173. OS2_create_mutex_semaphore (PSZ name, int sharedp)
  174. {
  175.   HMTX result;
  176.   STD_API_CALL
  177.     (dos_create_mutex_sem,
  178.      (name, (&result), (sharedp ? DC_SEM_SHARED : 0), 0));
  179.   return (result);
  180. }
  181.  
  182. void
  183. OS2_close_mutex_semaphore (HMTX s)
  184. {
  185.   STD_API_CALL (dos_close_mutex_sem, (s));
  186. }
  187.  
  188. void
  189. OS2_request_mutex_semaphore (HMTX s)
  190. {
  191.   while (1)
  192.     {
  193.       APIRET rc = (dos_request_mutex_sem (s, SEM_INDEFINITE_WAIT));
  194.       if (rc == NO_ERROR)
  195.     break;
  196.       /* This return code has been regularly occurring on my machine.
  197.      On one occurrence, I proceeded past the error in the
  198.      debugger, and the program continued working without errors.
  199.      However, more recently proceeding past this error has caused
  200.      a subsequent error when unlocking the semaphore because the
  201.      lock didn't succeed.  IBM tech support is mystified because
  202.      this code appears nowhere in their sources.  */
  203.       if (rc == 3000)
  204.     {
  205.       PID pid;
  206.       TID tid;
  207.       ULONG count;
  208.       DosQueryMutexSem (s, (&pid), (&tid), (&count));
  209.       if ((count > 0) && (tid == (OS2_current_tid ())))
  210.         break;
  211.     }
  212.       else if (rc != ERROR_INTERRUPT)
  213.     OS2_error_system_call (rc, syscall_dos_request_mutex_sem);
  214.     }
  215. }
  216.  
  217. void
  218. OS2_release_mutex_semaphore (HMTX s)
  219. {
  220.   STD_API_CALL (dos_release_mutex_sem, (s));
  221. }
  222.  
  223. HEV
  224. OS2_create_event_semaphore (PSZ name, int sharedp)
  225. {
  226.   HEV result;
  227.   STD_API_CALL
  228.     (dos_create_event_sem,
  229.      (name, (&result), (sharedp ? DC_SEM_SHARED : 0), 0));
  230.   return (result);
  231. }
  232.  
  233. void
  234. OS2_close_event_semaphore (HEV s)
  235. {
  236.   STD_API_CALL (dos_close_event_sem, (s));
  237. }
  238.  
  239. int
  240. OS2_post_event_semaphore (HEV s)
  241. {
  242.   XTD_API_CALL
  243.     (dos_post_event_sem, (s),
  244.      {
  245.        if (rc == ERROR_ALREADY_POSTED)
  246.      return (1);
  247.      });
  248.   return (0);
  249. }
  250.  
  251. ULONG
  252. OS2_reset_event_semaphore (HEV s)
  253. {
  254.   ULONG post_count;
  255.   XTD_API_CALL
  256.     (dos_reset_event_sem, (s, (&post_count)),
  257.      {
  258.        if (rc == ERROR_ALREADY_RESET)
  259.      return (0);
  260.      });
  261.   return (post_count);
  262. }
  263.  
  264. int
  265. OS2_wait_event_semaphore (HEV s, int blockp)
  266. {
  267.   XTD_API_CALL
  268.     (dos_wait_event_sem,
  269.      (s, (blockp ? SEM_INDEFINITE_WAIT : SEM_IMMEDIATE_RETURN)),
  270.      {
  271.        if ((rc == ERROR_TIMEOUT) && (!blockp))
  272.      return (0);
  273.      });
  274.   return (1);
  275. }
  276.  
  277. HMTX OS2_create_queue_lock;
  278.  
  279. HQUEUE
  280. OS2_create_queue (ULONG priority)
  281. {
  282.   static unsigned int n = 0;
  283.   unsigned int this_n;
  284.   char buffer [64];
  285.   HQUEUE result;
  286.   OS2_request_mutex_semaphore (OS2_create_queue_lock);
  287.   this_n = (n++);
  288.   OS2_release_mutex_semaphore (OS2_create_queue_lock);
  289.   sprintf (buffer, "\\queues\\scm%d\\%d.que", OS2_scheme_pid, this_n);
  290.   STD_API_CALL (dos_create_queue, ((&result), priority, buffer));
  291.   return (result);
  292. }
  293.  
  294. void
  295. OS2_close_queue (HQUEUE q)
  296. {
  297.   STD_API_CALL (dos_close_queue, (q));
  298. }
  299.  
  300. void
  301. OS2_write_queue (HQUEUE q, ULONG type, ULONG length, PVOID data, ULONG priority)
  302. {
  303.   STD_API_CALL (dos_write_queue, (q, type, length, data, priority));
  304. }
  305.  
  306. int
  307. OS2_read_queue (HQUEUE q, ULONG * type, ULONG * length, PVOID * data, HEV s)
  308. {
  309.   REQUESTDATA request;
  310.   BYTE priority;
  311.   (request.pid) = OS2_scheme_pid;
  312.   if (s != NULLHANDLE)
  313.     (void) OS2_reset_event_semaphore (s);
  314.   XTD_API_CALL
  315.     (dos_read_queue,
  316.      (q, (&request), length, data, 0,
  317.       ((s == NULLHANDLE) ? DCWW_WAIT : DCWW_NOWAIT), (&priority), s),
  318.      {
  319.        if ((rc == ERROR_QUE_EMPTY) && (s != NULLHANDLE))
  320.      return (0);
  321.      });
  322.   (*type) = (request.ulData);
  323.   return (1);
  324. }
  325.  
  326. ULONG
  327. OS2_system_variable (ULONG index)
  328. {
  329.   ULONG result;
  330.   STD_API_CALL
  331.     (dos_query_sys_info, (index, index, (&result), (sizeof (result))));
  332.   return (result);
  333. }
  334.  
  335. int
  336. OS2_essential_thread_p (TID tid)
  337. {
  338.   extern TID OS2_pm_tid;
  339.   extern TID OS2_timer_tid;
  340.   extern TID OS2_console_tid;
  341.   return ((tid == OS2_scheme_tid)
  342.       || (tid == OS2_pm_tid)
  343.       || (tid == OS2_timer_tid)
  344.       || (tid == OS2_console_tid));
  345. }
  346.  
  347. void
  348. OS2_logic_error_1 (const char * description,
  349.            const char * file,
  350.            unsigned int line)
  351. {
  352.   extern TID OS2_child_wait_tid;
  353.   char * format = "%s error in thread %d, file \"%s\", line %d: %s%s\
  354.   This indicates a bug in the Scheme implementation.\
  355.   Please report this information to a Scheme wizard.";
  356.   TID tid = (OS2_current_tid ());
  357.   if (OS2_essential_thread_p (tid))
  358.     {
  359.       outf_fatal (format, "Fatal", tid, file, line, description, "");
  360.       outf_fatal ("\n\n");
  361.       termination_init_error ();
  362.     }
  363.   else
  364.     {
  365.       extern void OS2_message_box (const char *, const char *, int);
  366.       char buffer [1024];
  367.       sprintf (buffer, format, "Non-fatal", tid, file, line, description,
  368.            ((tid == OS2_child_wait_tid)
  369.         ? "  The thread will be killed.\
  370.   Afterwards, Scheme will not be able to manage subprocesses properly."
  371.         : "  The thread will be killed."));
  372.       OS2_message_box ("Scheme Error", buffer, 0);
  373.       OS2_endthread ();
  374.     }
  375. }
  376.