source: release/1.7/source/lisp-kernel/windows-calls.c @ 15267

Last change on this file since 15267 was 14619, checked in by rme, 8 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

File size: 21.9 KB
Line 
1/*
2   Copyright (C) 2008-2009, Clozure Associates and contributors,
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "x86-exceptions.h"
19#include <io.h>
20#include <unistd.h>
21#include <sys/fcntl.h>
22#include <errno.h>
23#include <sys/stat.h>
24#include <windows.h>
25#include <psapi.h>
26#include <dirent.h>
27#include <signal.h>
28#undef __argv
29#include <stdio.h>
30#include <math.h>
31
32#ifndef WIN_32
33#define _dosmaperr mingw_dosmaperr
34#else
35void
36_dosmaperr(unsigned long oserrno)
37{
38  switch(oserrno) {
39  case  ERROR_INVALID_FUNCTION:
40    errno = EINVAL;
41    break;
42  case ERROR_FILE_NOT_FOUND:
43    errno = ENOENT;
44    break;
45  case ERROR_PATH_NOT_FOUND:
46    errno = ENOENT;
47    break;
48  case  ERROR_TOO_MANY_OPEN_FILES:
49    errno = EMFILE;
50    break;
51  case  ERROR_ACCESS_DENIED:
52    errno = EACCES;
53    break;
54  case  ERROR_ARENA_TRASHED:
55    errno = ENOMEM;
56    break;
57  case  ERROR_NOT_ENOUGH_MEMORY:
58    errno = ENOMEM;
59    break;
60  case  ERROR_INVALID_BLOCK:
61    errno = ENOMEM;
62    break;
63  case  ERROR_BAD_ENVIRONMENT:
64    errno = E2BIG;
65    break;
66  case  ERROR_BAD_FORMAT:
67    errno = ENOEXEC;
68    break;
69  case  ERROR_INVALID_ACCESS:
70    errno = EINVAL;
71    break;
72  case  ERROR_INVALID_DATA:
73    errno = EINVAL;
74    break;
75  case  ERROR_INVALID_DRIVE:
76    errno = ENOENT;
77    break;
78  case  ERROR_CURRENT_DIRECTORY:
79    errno = EACCES;
80    break;
81  case  ERROR_NOT_SAME_DEVICE:
82    errno = EXDEV;
83    break;
84  case  ERROR_NO_MORE_FILES:
85    errno = ENOENT;
86    break;
87  case  ERROR_LOCK_VIOLATION:
88    errno = EACCES;
89    break;
90  case  ERROR_BAD_NETPATH:
91    errno = ENOENT;
92    break;
93  case  ERROR_NETWORK_ACCESS_DENIED:
94    errno = EACCES;
95    break;
96  case  ERROR_BAD_NET_NAME:
97    errno = ENOENT;
98    break;
99  case  ERROR_FILE_EXISTS:
100    errno = EEXIST;
101    break;
102  case  ERROR_CANNOT_MAKE:
103    errno = EACCES;
104    break;
105  case  ERROR_FAIL_I24:
106    errno = EACCES;
107    break;
108  case  ERROR_INVALID_PARAMETER:
109    errno = EINVAL;
110    break;
111  case  ERROR_NO_PROC_SLOTS:
112    errno = EAGAIN;
113    break;
114  case  ERROR_DRIVE_LOCKED:
115    errno = EACCES;
116    break;
117  case  ERROR_BROKEN_PIPE:
118    errno = EPIPE;
119    break;
120  case  ERROR_DISK_FULL:
121    errno = ENOSPC;
122    break;
123  case  ERROR_INVALID_TARGET_HANDLE:
124    errno = EBADF;
125    break;
126  case  ERROR_INVALID_HANDLE:
127    errno = EINVAL;
128    break;
129  case  ERROR_WAIT_NO_CHILDREN:
130    errno = ECHILD;
131    break;
132  case  ERROR_CHILD_NOT_COMPLETE:
133    errno = ECHILD;
134    break;
135  case  ERROR_DIRECT_ACCESS_HANDLE:
136    errno = EBADF;
137    break;
138  case  ERROR_NEGATIVE_SEEK:
139    errno = EINVAL;
140    break;
141  case  ERROR_SEEK_ON_DEVICE:   
142    errno = EACCES;
143    break;
144  case  ERROR_DIR_NOT_EMPTY:
145    errno = ENOTEMPTY;
146    break;
147  case  ERROR_NOT_LOCKED:
148    errno = EACCES;
149    break;
150  case  ERROR_BAD_PATHNAME:
151    errno = ENOENT;
152    break;
153  case  ERROR_MAX_THRDS_REACHED:
154    errno = EAGAIN;
155    break;
156  case  ERROR_LOCK_FAILED:
157    errno = EACCES;
158    break;
159  case  ERROR_ALREADY_EXISTS:
160    errno = EEXIST;
161    break;
162  case  ERROR_FILENAME_EXCED_RANGE:
163    errno = ENOENT;
164    break;
165  case  ERROR_NESTING_NOT_ALLOWED:
166    errno = EAGAIN;
167    break;
168  case  ERROR_NOT_ENOUGH_QUOTA:
169    errno = ENOMEM;
170    break;
171  case ERROR_OPERATION_ABORTED:
172    errno = EINTR;
173    break;
174  default:
175    errno = EINVAL;
176    break;
177  }
178}
179   
180#endif
181
182#define MAX_FD 32
183
184HANDLE
185lisp_open(wchar_t *path, int flag, int mode)
186{
187  HANDLE hfile;
188  DWORD dwDesiredAccess = 0;
189  DWORD dwShareMode = 0;
190  DWORD dwCreationDistribution = 0;
191  DWORD dwFlagsAndAttributes = 0;
192  SECURITY_ATTRIBUTES sa = {sizeof(SECURITY_ATTRIBUTES), NULL, TRUE};
193
194  dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE;
195
196  if ((flag & _O_WRONLY) == _O_WRONLY) {
197    dwDesiredAccess |= GENERIC_WRITE;
198  } else if ((flag & _O_RDWR) == _O_RDWR) {
199    dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ;
200  } else {
201    dwDesiredAccess |= GENERIC_READ;
202  }
203   
204
205  if ((flag & (_O_CREAT | _O_EXCL)) == (_O_CREAT | _O_EXCL)) {
206    dwCreationDistribution |= CREATE_NEW;
207  } else if ((flag &  O_TRUNC) == O_TRUNC) {
208    if ((flag &  O_CREAT) ==  O_CREAT) {
209      dwCreationDistribution |= CREATE_ALWAYS;
210    } else if ((flag & O_RDONLY) != O_RDONLY) {
211      dwCreationDistribution |= TRUNCATE_EXISTING;
212    }
213  } else if ((flag & _O_APPEND) == _O_APPEND) {
214    dwCreationDistribution |= OPEN_EXISTING;
215  } else if ((flag &  _O_CREAT) == _O_CREAT) {
216    dwCreationDistribution |= OPEN_ALWAYS;
217  } else {
218    dwCreationDistribution |= OPEN_EXISTING;
219  }
220  if ((flag &  _O_RANDOM) == _O_RANDOM) {
221    dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS;
222  }
223  if ((flag &  _O_SEQUENTIAL) == _O_SEQUENTIAL) {
224    dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN;
225  }
226
227  if ((flag &  _O_TEMPORARY) == _O_TEMPORARY) {
228    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
229  }
230
231  if ((flag &  _O_SHORT_LIVED) == _O_SHORT_LIVED) {
232    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
233  }
234
235  if (flag & _O_NOINHERIT) {
236    sa.bInheritHandle = FALSE;
237  }
238
239#if 0
240  dwFlagsAndAttributes |= FILE_FLAG_OVERLAPPED;
241#endif
242   
243
244  hfile = CreateFileW(path,
245                      dwDesiredAccess,
246                      dwShareMode,
247                      &sa,
248                      dwCreationDistribution,
249                      dwFlagsAndAttributes,
250                      NULL);
251  if (hfile == ((HANDLE)-1)) {
252    _dosmaperr(GetLastError());
253    return (HANDLE)-1;
254  }
255  return hfile;
256}
257
258int
259wopen(wchar_t *path, int flag, int mode)
260{
261  HANDLE h = lisp_open(path, flag, mode);
262
263  if (h == (HANDLE)-1) {
264    return -1;                  /* errno already set */
265  }
266  return  _open_osfhandle((intptr_t)h,0);
267}
268
269int
270lisp_close(HANDLE hfile)
271{
272  int err;
273
274  if (closesocket((SOCKET)hfile) == 0) {
275    return 0;
276  }
277
278  err = WSAGetLastError();
279  if (err != WSAENOTSOCK) {
280    _dosmaperr(err);
281    return -1;
282  }
283  if (CloseHandle(hfile)) {
284    return 0;
285  }
286  _dosmaperr(GetLastError());
287  return -1;
288}
289
290extern TCR *get_tcr(int);
291
292ssize_t
293lisp_standard_read(HANDLE hfile, void *buf, unsigned int count)
294{
295  HANDLE hevent;
296  OVERLAPPED overlapped;
297  DWORD err, nread, wait_result;
298  pending_io pending;
299  TCR *tcr;
300 
301 
302  memset(&overlapped,0,sizeof(overlapped));
303
304  if (GetFileType(hfile) == FILE_TYPE_DISK) {
305    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
306  }
307
308  tcr = (TCR *)get_tcr(1);
309  pending.h = hfile;
310  pending.o = &overlapped;
311  TCR_AUX(tcr)->pending_io_info = &pending;
312  hevent = (HANDLE)(TCR_AUX(tcr)->io_datum);
313  overlapped.hEvent = hevent;
314  ResetEvent(hevent);
315  if (ReadFile(hfile, buf, count, &nread, &overlapped)) {
316    TCR_AUX(tcr)->pending_io_info = NULL;
317    return nread;
318  }
319
320  err = GetLastError();
321 
322  if (err == ERROR_HANDLE_EOF) {
323    TCR_AUX(tcr)->pending_io_info = NULL;
324    return 0;
325  }
326
327  if (err != ERROR_IO_PENDING) {
328    _dosmaperr(err);
329    TCR_AUX(tcr)->pending_io_info = NULL;
330    return -1;
331  }
332 
333  err = 0;
334 
335  /* We block here */   
336  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
337
338
339
340  TCR_AUX(tcr)->pending_io_info = NULL;
341  if (wait_result == WAIT_OBJECT_0) {
342    err = overlapped.Internal;
343    if (err == ERROR_HANDLE_EOF) {
344      return 0;
345    }
346    if (err) {
347      _dosmaperr(err);
348      return -1;
349    }
350    return overlapped.InternalHigh;
351  }
352
353  if (wait_result == WAIT_IO_COMPLETION) {
354    CancelIo(hfile);
355    errno = EINTR;
356    return -1;
357  }
358  err = GetLastError();
359 
360
361  switch (err) {
362  case ERROR_HANDLE_EOF: 
363    return 0;
364  default:
365    _dosmaperr(err);
366    return -1;
367  }
368}
369
370ssize_t
371pipe_read(HANDLE hfile, void *buf, unsigned int count)
372{
373  DWORD navail, err;;
374
375  do {
376    navail = 0;
377    if (PeekNamedPipe(hfile, NULL, 0, NULL, &navail, NULL) == 0) {
378      err = GetLastError();
379      if (err = ERROR_HANDLE_EOF) {
380        return 0;
381      } else {
382        _dosmaperr(err);
383        return -1;
384      }
385    }
386    if (navail != 0) {
387      return lisp_standard_read(hfile, buf, count);
388    }
389    if (SleepEx(50, TRUE) == WAIT_IO_COMPLETION) {
390      errno = EINTR;
391      return -1;
392    }
393  } while (1);
394}
395
396ssize_t
397console_read(HANDLE hfile, void *buf, unsigned int count)
398{
399  DWORD err, eventcount, i, n;
400  INPUT_RECORD ir;
401
402  do {
403    err = WaitForSingleObjectEx(hfile, INFINITE, TRUE);
404    switch (err) {
405    case WAIT_OBJECT_0:
406      eventcount = 0;
407      GetNumberOfConsoleInputEvents(hfile, &eventcount);
408      for (i = 0; i < eventcount; i++) {
409        PeekConsoleInput(hfile, &ir, 1, &n);
410        if (ir.EventType == KEY_EVENT) {
411          return lisp_standard_read(hfile, buf, count);
412        } else {
413          ReadConsoleInput(hfile, &ir, 1, &n);
414        }
415      }
416      break;
417    case WAIT_IO_COMPLETION:
418      errno = EINTR;
419      return -1;
420      break;
421    case WAIT_FAILED:
422      _dosmaperr(GetLastError());
423      return -1;
424      break;
425    }
426  } while (1);
427}
428
429ssize_t
430lisp_read(HANDLE hfile, void *buf, unsigned int count) {
431  switch(GetFileType(hfile)) {
432  case FILE_TYPE_CHAR:
433    return console_read(hfile, buf, count);
434    break;
435
436  case FILE_TYPE_PIPE:          /* pipe or one of these newfangled socket things */
437    {
438      int socktype, optlen = sizeof(int);
439      if ((getsockopt((SOCKET)hfile, SOL_SOCKET, SO_TYPE, (char *)&socktype, &optlen) != 0) && (GetLastError() == WSAENOTSOCK)) {
440        return pipe_read(hfile, buf, count);
441      }
442    }
443    /* It's a socket, fall through */
444   
445  case FILE_TYPE_DISK:
446    return lisp_standard_read(hfile, buf, count);
447    break;
448
449  default:
450    errno = EBADF;
451    return -1;
452  }
453}
454
455
456
457ssize_t
458lisp_write(HANDLE hfile, void *buf, ssize_t count)
459{
460  HANDLE hevent;
461  OVERLAPPED overlapped;
462  DWORD err, nwritten, wait_result;
463  pending_io pending;
464  TCR *tcr = (TCR *)get_tcr(1);
465
466  hevent = (HANDLE)TCR_AUX(tcr)->io_datum;
467  if (hfile == (HANDLE)1) {
468    hfile = GetStdHandle(STD_OUTPUT_HANDLE);
469  } else if (hfile == (HANDLE) 2) {
470    hfile = GetStdHandle(STD_ERROR_HANDLE);
471  }
472
473
474  memset(&overlapped,0,sizeof(overlapped));
475
476  if (GetFileType(hfile) == FILE_TYPE_DISK) {
477    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
478  }
479
480
481  pending.h = hfile;
482  pending.o = &overlapped;
483  TCR_AUX(tcr)->pending_io_info = &pending;
484  overlapped.hEvent = hevent;
485  ResetEvent(hevent);
486  if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) {
487    TCR_AUX(tcr)->pending_io_info = NULL;
488    return nwritten;
489  }
490 
491  err = GetLastError();
492  if (err != ERROR_IO_PENDING) {
493    _dosmaperr(err);
494    TCR_AUX(tcr)->pending_io_info = NULL;
495    return -1;
496  }
497  err = 0;
498  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
499  TCR_AUX(tcr)->pending_io_info = NULL;
500  if (wait_result == WAIT_OBJECT_0) {
501    err = overlapped.Internal;
502    if (err) {
503      _dosmaperr(err);
504      return -1;
505    }
506    return overlapped.InternalHigh;
507  }
508  if (wait_result == WAIT_IO_COMPLETION) {
509    CancelIo(hfile);
510    errno = EINTR;
511    return -1;
512  }
513  err = GetLastError();
514  _dosmaperr(err);
515  return -1;
516}
517
518int
519lisp_fchmod(HANDLE hfile, int mode)
520{
521  errno = ENOSYS;
522  return -1;
523}
524
525__int64
526lisp_lseek(HANDLE hfile, __int64 offset, int whence)
527{
528  DWORD high, low;
529
530  high = ((__int64)offset)>>32;
531  low = offset & 0xffffffff;
532  low = SetFilePointer(hfile, low, &high, whence);
533  if (low != INVALID_SET_FILE_POINTER) {
534    return ((((__int64)high)<<32)|low);
535  }
536  _dosmaperr(GetLastError());
537  return -1;
538}
539
540#define ALL_USERS(f) ((f) | ((f)>> 3) | ((f >> 6)))
541#define STAT_READONLY ALL_USERS(_S_IREAD)
542#define STAT_READWRITE ALL_USERS((_S_IREAD|_S_IWRITE))
543int
544lisp_stat(wchar_t *path, struct __stat64 *buf)
545{
546  return _wstat64(path,buf);
547}
548
549#define UNIX_EPOCH_IN_WINDOWS_EPOCH  116444736000000000LL
550
551__time64_t
552filetime_to_unix_time(FILETIME *ft)
553{
554  __time64_t then = *((__time64_t *) ft);
555
556  then -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
557  return then/10000000;
558}
559
560int
561lisp_fstat(HANDLE hfile, struct __stat64 *buf)
562{
563  int filetype;
564
565  filetype = GetFileType(hfile) & ~FILE_TYPE_REMOTE;
566
567  if (filetype == FILE_TYPE_UNKNOWN) {
568    errno = EBADF;
569    return -1;
570  }
571
572  memset(buf, 0, sizeof(*buf));
573  buf->st_nlink = 1;
574 
575  switch(filetype) {
576  case FILE_TYPE_CHAR:
577  case FILE_TYPE_PIPE:
578    if (filetype == FILE_TYPE_CHAR) {
579      buf->st_mode = _S_IFCHR;
580    } else {
581      buf->st_mode = _S_IFIFO;
582    }
583    break;
584  case FILE_TYPE_DISK:
585    {
586      BY_HANDLE_FILE_INFORMATION info;
587
588      if (!GetFileInformationByHandle(hfile, &info)) {
589        _dosmaperr(GetLastError());
590        return -1;
591      }
592
593      if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY) {
594        buf->st_mode = STAT_READONLY;
595      } else {
596        buf->st_mode = STAT_READWRITE;
597      }
598      buf->st_mode |= _S_IFREG;
599      buf->st_size = ((((__int64)(info.nFileSizeHigh))<<32LL) |
600                      ((__int64)(info.nFileSizeLow)));
601      buf->st_mtime = filetime_to_unix_time(&info.ftLastWriteTime);
602      buf->st_atime = filetime_to_unix_time(&info.ftLastAccessTime);
603      buf->st_ctime = filetime_to_unix_time(&info.ftCreationTime);
604    }
605    break;
606  case FILE_TYPE_UNKNOWN:
607  default:
608    errno = EBADF;
609    return -1;
610  }
611  return 0;
612}
613
614int
615lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3)
616{
617  errno = ENOSYS;
618  return -1;
619}
620
621
622__int64
623lisp_ftruncate(HANDLE hfile, off_t new_size)
624{
625  __int64 oldpos;
626
627
628  oldpos = lisp_lseek(hfile, 0, SEEK_END);
629  if (oldpos == -1) {
630    return 0;
631  }
632  if (oldpos < new_size) {
633    char buf[4096];
634    __int64 n = new_size-oldpos;
635    DWORD nwritten, to_write;
636
637    memset(buf,0,sizeof(buf));
638    while(n) {
639      if (n > 4096LL) {
640        to_write = 4096;
641      } else {
642        to_write = n;
643      }
644      if (!WriteFile(hfile,buf,to_write,&nwritten,NULL)) {
645        _dosmaperr(GetLastError());
646        return -1;
647      }
648      n -= nwritten;
649    }
650    return 0;
651  }
652  lisp_lseek(hfile, new_size, SEEK_SET);
653  if (SetEndOfFile(hfile)) {
654    return 0;
655  }
656  _dosmaperr(GetLastError());
657  return -1;
658}
659
660
661_WDIR *
662lisp_opendir(wchar_t *path)
663{
664  return _wopendir(path);
665}
666
667struct _wdirent *
668lisp_readdir(_WDIR *dir)
669{
670  return _wreaddir(dir);
671}
672
673__int64
674lisp_closedir(_WDIR *dir)
675{
676  return _wclosedir(dir);
677}
678
679int
680lisp_pipe(int fd[2])
681{
682  HANDLE input, output;
683  SECURITY_ATTRIBUTES sa;
684
685  sa.nLength= sizeof(SECURITY_ATTRIBUTES);
686  sa.lpSecurityDescriptor = NULL;
687  sa.bInheritHandle = TRUE;
688
689  if (!CreatePipe(&input, &output, &sa, 0))
690    {
691      wperror("CreatePipe");
692      return -1;
693    }
694  fd[0] = (int) ((intptr_t)input);
695  fd[1] = (int) ((intptr_t)output);
696  return 0;
697}
698
699int
700lisp_gettimeofday(struct timeval *tp, void *tzp)
701{
702  __time64_t now;
703
704  gettimeofday(tp,tzp);       /* trust it to get time zone right, at least */
705  GetSystemTimeAsFileTime((FILETIME*)&now);
706  now -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
707  now /= 10000;               /* convert time to milliseconds */
708  tp->tv_sec = now/1000LL;
709  tp->tv_usec = 1000 * (now%1000LL); /* convert milliseconds to microseconds */
710  return 0;
711}
712
713int
714lisp_sigexit(int signum)
715{
716  signal(signum, SIG_DFL);
717  return raise(signum);
718}
719
720/* Make sure that the lisp calls these functions, when they do something */
721/* This code is taken from the 32-bit mingw library and is in the
722   public domain */
723double
724acosh(double x)
725{
726  if (isnan (x)) 
727    return x;
728
729  if (x < 1.0)
730    {
731      errno = EDOM;
732      return nan("");
733    }
734
735  if (x > 0x1p32)
736    /*  Avoid overflow (and unnecessary calculation when
737        sqrt (x * x - 1) == x). GCC optimizes by replacing
738        the long double M_LN2 const with a fldln2 insn.  */ 
739    return log (x) + 6.9314718055994530941723E-1L;
740
741  /* Since  x >= 1, the arg to log will always be greater than
742     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
743  return log (x + sqrt((x + 1.0) * (x - 1.0)));
744}
745
746float
747acoshf(float x)
748{
749  if (isnan (x)) 
750    return x;
751  if (x < 1.0f)
752    {
753      errno = EDOM;
754      return nan("");
755    }
756
757 if (x > 0x1p32f)
758    /*  Avoid overflow (and unnecessary calculation when
759        sqrt (x * x - 1) == x). GCC optimizes by replacing
760        the long double M_LN2 const with a fldln2 insn.  */ 
761    return log (x) + 6.9314718055994530941723E-1L;
762
763  /* Since  x >= 1, the arg to log will always be greater than
764     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
765  return log (x + sqrt((x + 1.0) * (x - 1.0)));
766}
767
768double
769asinh(double x)
770{
771  double z;
772  if (!isfinite (x))
773    return x;
774  z = fabs (x);
775
776  /* Avoid setting FPU underflow exception flag in x * x. */
777#if 0
778  if ( z < 0x1p-32)
779    return x;
780#endif
781
782  /* Use log1p to avoid cancellation with small x. Put
783     x * x in denom, so overflow is harmless.
784     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
785              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
786
787  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
788
789  return ( x >= 0.0 ? z : -z);
790}
791
792float
793asinhf(float x)
794{
795  float z;
796  if (!isfinite (x))
797    return x;
798  z = fabsf (x);
799
800  /* Avoid setting FPU underflow exception flag in x * x. */
801#if 0
802  if ( z < 0x1p-32)
803    return x;
804#endif
805
806
807  /* Use log1p to avoid cancellation with small x. Put
808     x * x in denom, so overflow is harmless.
809     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
810              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
811
812  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
813
814  return ( x >= 0.0 ? z : -z);
815}
816
817double
818atanh(double x)
819{
820  double z;
821  if (isnan (x))
822    return x;
823  z = fabs (x);
824  if (z == 1.0)
825    {
826      errno  = ERANGE;
827      return (x > 0 ? INFINITY : -INFINITY);
828    }
829  if (z > 1.0)
830    {
831      errno = EDOM;
832      return nan("");
833    }
834  /* Rearrange formula to avoid precision loss for small x.
835
836  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
837           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
838           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
839           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
840  z = 0.5 * log1p ((z + z) / (1.0 - z));
841  return x >= 0 ? z : -z;
842}
843
844float
845atanhf(float x)
846{
847  float z;
848  if (isnan (x))
849    return x;
850  z = fabsf (x);
851  if (z == 1.0)
852    {
853      errno  = ERANGE;
854      return (x > 0 ? INFINITY : -INFINITY);
855    }
856  if ( z > 1.0)
857    {
858      errno = EDOM;
859      return nanf("");
860    }
861  /* Rearrange formula to avoid precision loss for small x.
862
863  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
864           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
865           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
866           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
867  z = 0.5 * log1p ((z + z) / (1.0 - z));
868  return x >= 0 ? z : -z;
869}
870
871
872typedef struct {
873  char *name;
874  void *addr;
875} math_fn_entry;
876
877
878math_fn_entry math_fn_entries [] = {
879  {"acos",acos},
880  {"acosf",acosf},
881  {"acosh",acosh},
882  {"acoshf",acoshf},
883  {"asin",asin},
884  {"asinf",asinf},
885  {"asinh",asinh},
886  {"asinhf",asinhf},
887  {"atan",atan},
888  {"atan2",atan2},
889  {"atan2f",atan2f},
890  {"atanf",atanf},
891  {"atanh",atanh},
892  {"atanhf",atanhf},
893  {"cos",cos},
894  {"cosf",cosf},
895  {"cosh",cosh},
896  {"coshf",coshf},
897  {"exp",exp},
898  {"expf",expf},
899  {"log",log},
900  {"logf",logf},
901  {"pow",pow},
902  {"powf",powf},
903  {"sin",sin},
904  {"sinf",sinf},
905  {"sinh",sinh},
906  {"sinhf",sinhf},
907  {"tan",tan},
908  {"tanf",tanf},
909  {"tanh",tanh},
910  {"tanhf",tanhf},
911  {NULL, 0}};
912
913void *
914lookup_math_fn(char *name)
915{
916  math_fn_entry *p = math_fn_entries;
917  char *entry_name;
918 
919  while ((entry_name = p->name) != NULL) {
920    if (!strcmp(name, entry_name)) {
921      return p->addr;
922    }
923    p++;
924  }
925  return NULL;
926}
927
928HMODULE *modules = NULL;
929DWORD cbmodules = 0;
930HANDLE find_symbol_lock = 0;
931
932void *
933windows_find_symbol(void *handle, char *name)
934{
935  void *addr;
936
937  if ((handle == ((void *)-2L)) ||
938      (handle == ((void *)-1L))) {
939    handle = NULL;
940  }
941  if (handle != NULL) {
942    addr = GetProcAddress(handle, name);
943  } else {
944    DWORD cbneeded,  have, i;
945    WaitForSingleObject(find_symbol_lock,INFINITE);
946
947    if (cbmodules == 0) {
948      cbmodules = 16 * sizeof(HANDLE);
949      modules = malloc(cbmodules);
950    }
951   
952    while (1) {
953      EnumProcessModules(GetCurrentProcess(),modules,cbmodules,&cbneeded);
954      if (cbmodules >= cbneeded) {
955        break;
956      }
957      cbmodules = cbneeded;
958      modules = realloc(modules,cbmodules);
959    }
960    have = cbneeded/sizeof(HANDLE);
961
962    for (i = 0; i < have; i++) {
963      addr = GetProcAddress(modules[i],name);
964
965      if (addr) {
966        break;
967      }
968    }
969    ReleaseMutex(find_symbol_lock);
970    if (addr) {
971      return addr;
972    }
973    return lookup_math_fn(name);
974  }
975}
976
977/* Note that we're using 8-bit strings here */
978
979void *
980windows_open_shared_library(char *path)
981{
982  HMODULE module = (HMODULE)0;
983
984  /* Try to open an existing module in a way that increments its
985     reference count without running any initialization code in
986     the dll. */
987  if (!GetModuleHandleExA(0,path,&module)) {
988    /* If that failed ... */
989    module = LoadLibraryA(path);
990  }
991  return (void *)module;
992}
993
994
995void
996init_windows_io()
997{
998  find_symbol_lock = CreateMutex(NULL,false,NULL);
999}
1000
1001void
1002init_winsock()
1003{
1004  WSADATA data;
1005
1006  WSAStartup((2<<8)|2,&data);
1007}
1008
1009/*
1010 * Reserve TLS slots 30 through 63 in the TEB for (part of) the TCR.
1011 *
1012 * On Windows 7 x64, #_TlsAlloc returns 23 in a fresh lisp.  On
1013 * Windows XP, it returns 11.  With any luck, this will leave enough
1014 * wiggle room for the C runtime or whatever to use a few more TLS
1015 * slots, and still leave 30 through 63 free for us.
1016 */
1017void
1018reserve_tls_slots()
1019{
1020  unsigned int first_available, n, i;
1021
1022  first_available = TlsAlloc();
1023  if (first_available > 30) {
1024    fprintf(dbgout, "Can't allocate required TLS indexes.\n");
1025    fprintf(dbgout, "First available index value was %u\n", first_available);
1026    exit(1);
1027  }
1028  TlsFree(first_available);
1029
1030  for (i = first_available; i < 30; i++) {
1031    n = TlsAlloc();
1032    if (n != i) {
1033      fprintf(dbgout, "unexpected TLS index value: wanted %u, got %u\n", i, n);
1034      exit(1);
1035    }
1036  }
1037  for (i = 30; i < 64; i++) {
1038    n = TlsAlloc();
1039    if (n != i) {
1040      fprintf(dbgout, "unexpected TLS index value: wanted %u, got %u\n", i, n);
1041      exit(1);
1042    }
1043  }
1044  for (i = first_available; i < 30; i++)
1045    TlsFree(i);
1046}
Note: See TracBrowser for help on using the repository browser.