source: trunk/source/lisp-kernel/x86-exceptions.c @ 11523

Last change on this file since 11523 was 11523, checked in by gb, 11 years ago

x86 support for FLASH-FREEZE.
Use signed_natural in x86 gc-like functions.
RECURSIVE-LOCK-WHOSTATE and the RWLOCK-WHOSTATE functions: use
WITH-STANDARD-IO-SYNTAX when consing up the string. Do that in
higher-level code, to avoid early refs to CL-USER pacjage.
(In general, other things similar to RECURSIVE-LOCK-WHOSTATE are
suspect, in that they call (FORMAT NIL ...) in a random environment
where things like *PRINT-READABLY* may be in effect. There are
probably other cases of this.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 95.7 KB
Line 
1/*
2   Copyright (C) 2005 Clozure Associates
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL 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 "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "Threads.h"
21#include <ctype.h>
22#include <stdio.h>
23#include <stddef.h>
24#include <string.h>
25#include <stdarg.h>
26#include <errno.h>
27#include <stdio.h>
28#ifdef LINUX
29#include <strings.h>
30#include <sys/mman.h>
31#include <fpu_control.h>
32#include <linux/prctl.h>
33#endif
34#ifdef DARWIN
35#include <sysexits.h>
36#endif
37#ifndef WINDOWS
38#include <sys/syslog.h>
39#endif
40#ifdef WINDOWS
41#include <windows.h>
42#ifdef WIN_64
43#include <winternl.h>
44#include <ntstatus.h>
45#endif
46#ifndef EXCEPTION_WRITE_FAULT
47#define EXCEPTION_WRITE_FAULT 1
48#endif
49#endif
50
51int
52page_size = 4096;
53
54int
55log2_page_size = 12;
56
57
58void
59update_bytes_allocated(TCR* tcr, void *cur_allocptr)
60{
61  BytePtr
62    last = (BytePtr) tcr->last_allocptr, 
63    current = (BytePtr) cur_allocptr;
64  if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) {
65    tcr->bytes_allocated += last-current;
66  }
67  tcr->last_allocptr = 0;
68}
69
70
71
72//  This doesn't GC; it returns true if it made enough room, false
73//  otherwise.
74//  If "extend" is true, it can try to extend the dynamic area to
75//  satisfy the request.
76
77
78Boolean
79new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr)
80{
81  area *a;
82  natural newlimit, oldlimit;
83  natural log2_allocation_quantum = tcr->log2_allocation_quantum;
84
85  a  = active_dynamic_area;
86  oldlimit = (natural) a->active;
87  newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) +
88              align_to_power_of_2(need, log2_allocation_quantum));
89  if (newlimit > (natural) (a->high)) {
90    if (extend) {
91      signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
92      natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold;
93      do {
94        if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) {
95          break;
96        }
97        extend_by = align_to_power_of_2(extend_by>>1,log2_allocation_quantum);
98        if (extend_by < 4<<20) {
99          return false;
100        }
101      } while (1);
102    } else {
103      return false;
104    }
105  }
106  a->active = (BytePtr) newlimit;
107  tcr->last_allocptr = (void *)newlimit;
108  tcr->save_allocptr = (void *)newlimit;
109  xpGPR(xp,Iallocptr) = (LispObj) newlimit;
110  tcr->save_allocbase = (void *) oldlimit;
111
112  return true;
113}
114
115Boolean
116allocate_object(ExceptionInformation *xp,
117                natural bytes_needed, 
118                signed_natural disp_from_allocptr,
119                TCR *tcr)
120{
121  area *a = active_dynamic_area;
122
123  /* Maybe do an EGC */
124  if (a->older && lisp_global(OLDEST_EPHEMERAL)) {
125    if (((a->active)-(a->low)) >= a->threshold) {
126      gc_from_xp(xp, 0L);
127    }
128  }
129
130  /* Life is pretty simple if we can simply grab a segment
131     without extending the heap.
132  */
133  if (new_heap_segment(xp, bytes_needed, false, tcr)) {
134    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
135    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
136    return true;
137  }
138 
139  /* It doesn't make sense to try a full GC if the object
140     we're trying to allocate is larger than everything
141     allocated so far.
142  */
143  if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) {
144    untenure_from_area(tenured_area); /* force a full GC */
145    gc_from_xp(xp, 0L);
146  }
147 
148  /* Try again, growing the heap if necessary */
149  if (new_heap_segment(xp, bytes_needed, true, tcr)) {
150    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
151    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
152    return true;
153  }
154 
155  return false;
156}
157
158natural gc_deferred = 0, full_gc_deferred = 0;
159
160signed_natural
161flash_freeze(TCR *tcr, signed_natural param)
162{
163  return 0;
164}
165
166
167Boolean
168handle_gc_trap(ExceptionInformation *xp, TCR *tcr)
169{
170  LispObj selector = xpGPR(xp,Iimm0);
171#ifdef X8664
172  LispObj arg = xpGPR(xp,Iimm1);
173#else
174  LispObj arg = xpMMXreg(xp,Imm0);
175#endif
176  area *a = active_dynamic_area;
177  Boolean egc_was_enabled = (a->older != NULL);
178 
179  natural gc_previously_deferred = gc_deferred;
180
181  switch (selector) {
182  case GC_TRAP_FUNCTION_EGC_CONTROL:
183    egc_control(arg != 0, a->active);
184    xpGPR(xp,Iarg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0);
185    break;
186
187  case GC_TRAP_FUNCTION_CONFIGURE_EGC:
188#ifdef X8664
189    a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x));
190#else
191    a->threshold = unbox_fixnum(xpGPR(xp, Itemp0));
192#endif
193    g1_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_y));
194    g2_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_z));
195    xpGPR(xp,Iarg_z) = lisp_nil+t_offset;
196    break;
197
198  case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD:
199    if (((signed_natural) arg) > 0) {
200      lisp_heap_gc_threshold = 
201        align_to_power_of_2((arg-1) +
202                            (heap_segment_size - 1),
203                            log2_heap_segment_size);
204    }
205    /* fall through */
206  case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD:
207    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
208    break;
209
210  case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD:
211    /*  Try to put the current threshold in effect.  This may
212        need to disable/reenable the EGC. */
213    untenure_from_area(tenured_area);
214    resize_dynamic_heap(a->active,lisp_heap_gc_threshold);
215    if (egc_was_enabled) {
216      if ((a->high - a->active) >= a->threshold) {
217        tenure_to_area(tenured_area);
218      }
219    }
220    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
221    break;
222
223  case GC_TRAP_FUNCTION_FLASH_FREEZE: /* Like freeze below, but no GC */
224    untenure_from_area(tenured_area);
225    gc_like_from_xp(xp,flash_freeze,0);
226    a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
227    tenured_area->static_dnodes = area_dnode(a->active, a->low);
228    if (egc_was_enabled) {
229      tenure_to_area(tenured_area);
230    }
231    xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
232    break;
233
234  default:
235    update_bytes_allocated(tcr, (void *) tcr->save_allocptr);
236
237    if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) {
238      if (!full_gc_deferred) {
239        gc_from_xp(xp, 0L);
240        break;
241      }
242      /* Tried to do a full GC when gc was disabled.  That failed,
243         so try full GC now */
244      selector = GC_TRAP_FUNCTION_GC;
245    }
246   
247    if (egc_was_enabled) {
248      egc_control(false, (BytePtr) a->active);
249    }
250    gc_from_xp(xp, 0L);
251    if (gc_deferred > gc_previously_deferred) {
252      full_gc_deferred = 1;
253    } else {
254      full_gc_deferred = 0;
255    }
256    if (selector > GC_TRAP_FUNCTION_GC) {
257      if (selector & GC_TRAP_FUNCTION_IMPURIFY) {
258        impurify_from_xp(xp, 0L);
259        /*        nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */
260        gc_from_xp(xp, 0L);
261        release_readonly_area();
262      }
263      if (selector & GC_TRAP_FUNCTION_PURIFY) {
264        purify_from_xp(xp, 0L);
265        gc_from_xp(xp, 0L);
266      }
267      if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) {
268        OSErr err;
269        extern OSErr save_application(unsigned);
270        area *vsarea = tcr->vs_area;
271
272#ifdef WINDOWS 
273        arg = _open_osfhandle(arg,0);
274#endif
275        nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1);
276        err = save_application(arg);
277        if (err == noErr) {
278          _exit(0);
279        }
280        fatal_oserr(": save_application", err);
281      }
282      switch (selector) {
283      case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE:
284        xpGPR(xp, Iimm0) = 0;
285        break;
286      case GC_TRAP_FUNCTION_FREEZE:
287        a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
288        tenured_area->static_dnodes = area_dnode(a->active, a->low);
289        xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
290        break;
291      default:
292        break;
293      }
294    }
295    if (egc_was_enabled) {
296      egc_control(true, NULL);
297    }
298    break;
299  }
300  return true;
301}
302
303 
304
305
306
307void
308push_on_lisp_stack(ExceptionInformation *xp, LispObj value)
309{
310  LispObj *vsp = (LispObj *)xpGPR(xp,Isp);
311  *--vsp = value;
312  xpGPR(xp,Isp) = (LispObj)vsp;
313}
314
315
316/* Hard to know if or whether this is necessary in general.  For now,
317   do it when we get a "wrong number of arguments" trap.
318*/
319void
320finish_function_entry(ExceptionInformation *xp)
321{
322#ifdef X8664
323  natural nargs = (xpGPR(xp,Inargs)&0xffff)>> fixnumshift;
324#else
325  natural nargs = xpGPR(xp,Inargs)>>fixnumshift;
326#endif
327  signed_natural disp;
328  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
329   
330  xpGPR(xp,Isp) = (LispObj) vsp;
331
332#ifdef X8664
333  disp = nargs - 3;
334#endif
335#ifdef X8632
336  disp = nargs - 2;
337#endif
338
339#ifdef X8664
340  if (disp > 0) {               /* implies that nargs > 3 */
341    vsp[disp] = xpGPR(xp,Irbp);
342    vsp[disp+1] = ra;
343    xpGPR(xp,Irbp) = (LispObj)(vsp+disp);
344    push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
345    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
346    push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
347  } else {
348    push_on_lisp_stack(xp,ra);
349    push_on_lisp_stack(xp,xpGPR(xp,Irbp));
350    xpGPR(xp,Irbp) = xpGPR(xp,Isp);
351    if (nargs == 3) {
352      push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
353    }
354    if (nargs >= 2) {
355      push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
356    }
357    if (nargs >= 1) {
358      push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
359    }
360  }
361#endif
362#ifdef X8632
363  if (disp > 0) {               /* implies that nargs > 2 */
364    vsp[disp] = xpGPR(xp,Iebp);
365    vsp[disp+1] = ra;
366    xpGPR(xp,Iebp) = (LispObj)(vsp+disp);
367    xpGPR(xp,Isp) = (LispObj)vsp;
368    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
369    push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
370  } else {
371    push_on_lisp_stack(xp,ra);
372    push_on_lisp_stack(xp,xpGPR(xp,Iebp));
373    xpGPR(xp,Iebp) = xpGPR(xp,Isp);
374    if (nargs == 2) {
375      push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
376    }
377    if (nargs >= 1) {
378      push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
379    }
380  }
381#endif
382}
383
384Boolean
385object_contains_pc(LispObj container, LispObj addr)
386{
387  if (fulltag_of(container) >= fulltag_misc) {
388    natural elements = header_element_count(header_of(container));
389    if ((addr >= container) &&
390        (addr < ((LispObj)&(deref(container,1+elements))))) {
391      return true;
392    }
393  }
394  return false;
395}
396
397LispObj
398create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr)
399{
400  LispObj containing_uvector = 0, 
401    relative_pc, 
402    nominal_function = lisp_nil, 
403    f, tra, tra_f = 0, abs_pc;
404
405  f = xpGPR(xp,Ifn);
406  tra = *(LispObj*)(xpGPR(xp,Isp));
407
408#ifdef X8664
409  if (tag_of(tra) == tag_tra) {
410    if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
411        (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
412      int sdisp = (*(int *) (tra+3));
413      tra_f = RECOVER_FN_FROM_RIP_LENGTH+tra+sdisp;
414    }
415    if (fulltag_of(tra_f) != fulltag_function) {
416      tra_f = 0;
417    }
418  } else {
419    tra = 0;
420  }
421#endif
422#ifdef X8632
423  if (fulltag_of(tra) == fulltag_tra) {
424    if (*(unsigned char *)tra == RECOVER_FN_OPCODE) {
425      tra_f = (LispObj)*(LispObj *)(tra + 1);
426    }
427    if (tra_f && header_subtag(header_of(tra_f)) != subtag_function) {
428      tra_f = 0;
429    }
430  } else {
431    tra = 0;
432  }
433#endif
434
435  abs_pc = (LispObj)xpPC(xp);
436
437#ifdef X8664
438  if (fulltag_of(f) == fulltag_function) 
439#else
440    if (fulltag_of(f) == fulltag_misc &&
441        header_subtag(header_of(f)) == subtag_function) 
442#endif
443      {
444        nominal_function = f;
445      } else {
446      if (tra_f) {
447        nominal_function = tra_f;
448      }
449    }
450 
451  f = xpGPR(xp,Ifn);
452  if (object_contains_pc(f, abs_pc)) {
453    containing_uvector = untag(f)+fulltag_misc;
454  } else {
455    f = xpGPR(xp,Ixfn);
456    if (object_contains_pc(f, abs_pc)) {
457      containing_uvector = untag(f)+fulltag_misc;
458    } else {
459      if (tra_f) {
460        f = tra_f;
461        if (object_contains_pc(f, abs_pc)) {
462          containing_uvector = untag(f)+fulltag_misc;
463          relative_pc = (abs_pc - f) << fixnumshift;
464        }
465      }
466    }
467  }
468  if (containing_uvector) {
469    relative_pc = (abs_pc - (LispObj)&(deref(containing_uvector,1))) << fixnumshift;
470  } else {
471    containing_uvector = lisp_nil;
472    relative_pc = abs_pc << fixnumshift;
473  }
474  push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev));
475  push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp));
476  push_on_lisp_stack(xp,tra);
477  push_on_lisp_stack(xp,(LispObj)xp);
478  push_on_lisp_stack(xp,containing_uvector); 
479  push_on_lisp_stack(xp,relative_pc);
480  push_on_lisp_stack(xp,nominal_function);
481  push_on_lisp_stack(xp,0);
482#ifdef X8664
483  push_on_lisp_stack(xp,xpGPR(xp,Irbp));
484  xpGPR(xp,Irbp) = xpGPR(xp,Isp);
485#else
486  push_on_lisp_stack(xp,xpGPR(xp,Iebp));
487  xpGPR(xp,Iebp) = xpGPR(xp,Isp);
488#endif
489  return xpGPR(xp,Isp);
490}
491
492#ifndef XMEMFULL
493#define XMEMFULL (76)
494#endif
495
496void
497lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed )
498{
499  LispObj xcf = create_exception_callback_frame(xp, tcr),
500    cmain = nrs_CMAIN.vcell;
501  int skip;
502   
503  tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
504  xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
505
506  skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
507  xpPC(xp) += skip;
508}
509
510/*
511  Allocate a large list, where "large" means "large enough to
512  possibly trigger the EGC several times if this was done
513  by individually allocating each CONS."  The number of
514  ocnses in question is in arg_z; on successful return,
515  the list will be in arg_z
516*/
517
518Boolean
519allocate_list(ExceptionInformation *xp, TCR *tcr)
520{
521  natural
522    nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))),
523    bytes_needed = (nconses << dnode_shift);
524  LispObj
525    prev = lisp_nil,
526    current,
527    initial = xpGPR(xp,Iarg_y);
528
529  if (nconses == 0) {
530    /* Silly case */
531    xpGPR(xp,Iarg_z) = lisp_nil;
532    xpGPR(xp,Iallocptr) = lisp_nil;
533    return true;
534  }
535  update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
536  if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) {
537    tcr->save_allocptr -= fulltag_cons;
538    for (current = xpGPR(xp,Iallocptr);
539         nconses;
540         prev = current, current+= dnode_size, nconses--) {
541      deref(current,0) = prev;
542      deref(current,1) = initial;
543    }
544    xpGPR(xp,Iarg_z) = prev;
545  } else {
546    lisp_allocation_failure(xp,tcr,bytes_needed);
547  }
548  return true;
549}
550
551Boolean
552handle_alloc_trap(ExceptionInformation *xp, TCR *tcr)
553{
554  natural cur_allocptr, bytes_needed;
555  unsigned allocptr_tag;
556  signed_natural disp;
557 
558  cur_allocptr = xpGPR(xp,Iallocptr);
559  allocptr_tag = fulltag_of(cur_allocptr);
560  if (allocptr_tag == fulltag_misc) {
561#ifdef X8664
562    disp = xpGPR(xp,Iimm1);
563#else
564    disp = xpGPR(xp,Iimm0);
565#endif
566  } else {
567    disp = dnode_size-fulltag_cons;
568  }
569  bytes_needed = disp+allocptr_tag;
570
571  update_bytes_allocated(tcr,((BytePtr)(cur_allocptr+disp)));
572  if (allocate_object(xp, bytes_needed, disp, tcr)) {
573    return true;
574  }
575 
576  lisp_allocation_failure(xp,tcr,bytes_needed);
577
578  return true;
579}
580
581 
582int
583callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp,
584                  natural arg1, natural arg2, natural arg3, natural arg4, natural arg5)
585{
586  natural  callback_ptr;
587  int delta;
588  unsigned old_mxcsr = get_mxcsr();
589#ifdef X8632
590  natural saved_node_regs_mask = tcr->node_regs_mask;
591  LispObj *vsp = (LispObj *)xpGPR(xp, Isp);
592#endif
593
594  set_mxcsr(0x1f80);
595
596  /* Put the active stack pointers where .SPcallback expects them */
597#ifdef X8664
598  tcr->save_vsp = (LispObj *) xpGPR(xp, Isp);
599  tcr->save_rbp = (LispObj *) xpGPR(xp, Irbp);
600#else
601  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
602
603  *--vsp = tcr->save0;
604  *--vsp = tcr->save1;
605  *--vsp = tcr->save2;
606  *--vsp = tcr->save3;
607  *--vsp = tcr->next_method_context;
608  xpGPR(xp, Isp) = (LispObj)vsp;
609
610  tcr->save_vsp = (LispObj *)xpGPR(xp, Isp);
611  tcr->save_ebp = (LispObj *)xpGPR(xp, Iebp);
612#endif
613
614  /* Call back.  The caller of this function may have modified stack/frame
615     pointers (and at least should have called prepare_for_callback()).
616  */
617  callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
618  UNLOCK(lisp_global(EXCEPTION_LOCK), tcr);
619  delta = ((int (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5);
620  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
621
622#ifdef X8632
623  tcr->next_method_context = *vsp++;
624  tcr->save3 = *vsp++;
625  tcr->save2 = *vsp++;
626  tcr->save1 = *vsp++;
627  tcr->save0 = *vsp++;
628  xpGPR(xp, Isp) = (LispObj)vsp;
629
630  tcr->node_regs_mask = saved_node_regs_mask;
631#endif
632  set_mxcsr(old_mxcsr);
633  return delta;
634}
635
636void
637callback_for_interrupt(TCR *tcr, ExceptionInformation *xp)
638{
639  LispObj *save_vsp = (LispObj *)xpGPR(xp,Isp),
640    word_beyond_vsp = save_vsp[-1],
641#ifdef X8664
642    save_rbp = xpGPR(xp,Irbp),
643#else
644    save_ebp = xpGPR(xp,Iebp),
645#endif
646    xcf = create_exception_callback_frame(xp, tcr);
647  int save_errno = errno;
648
649  callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0);
650#ifdef X8664
651  xpGPR(xp,Irbp) = save_rbp;
652#else
653  xpGPR(xp,Iebp) = save_ebp;
654#endif
655  xpGPR(xp,Isp) = (LispObj)save_vsp;
656  save_vsp[-1] = word_beyond_vsp;
657  errno = save_errno;
658}
659
660Boolean
661handle_error(TCR *tcr, ExceptionInformation *xp)
662{
663  pc program_counter = (pc)xpPC(xp);
664  unsigned char op0 = program_counter[0], op1 = program_counter[1];
665  LispObj rpc, errdisp = nrs_ERRDISP.vcell,
666    save_vsp = xpGPR(xp,Isp), xcf0;
667#ifdef X8664
668  LispObj save_rbp = xpGPR(xp,Irbp);
669#else
670  LispObj save_ebp = xpGPR(xp,Iebp);
671#endif
672  int skip;
673
674  if ((fulltag_of(errdisp) == fulltag_misc) &&
675      (header_subtag(header_of(errdisp)) == subtag_macptr)) {
676
677    if ((op0 == 0xcd) && (op1 >= 0xc0) && (op1 <= 0xc2)) {
678      finish_function_entry(xp);
679    }
680    xcf0 = create_exception_callback_frame(xp, tcr);
681    skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0);
682    if (skip == -1) {
683      xcf *xcf1 = (xcf *)xcf0;
684      LispObj container = xcf1->containing_uvector;
685     
686      rpc = xcf1->relative_pc >> fixnumshift;
687      if (container == lisp_nil) {
688        xpPC(xp) = rpc;
689      } else {
690        xpPC(xp) = (LispObj)(&(deref(container,
691#ifdef X8664
692                                     1
693#else
694                                     0
695#endif
696)))+rpc;
697      }
698       
699      skip = 0;
700    }
701#ifdef X8664
702    xpGPR(xp,Irbp) = save_rbp;
703#else
704    xpGPR(xp,Iebp) = save_ebp;
705#endif
706    xpGPR(xp,Isp) = save_vsp;
707    if ((op0 == 0xcd) && (op1 == 0xc7)) {
708      /* Continue after an undefined function call. The function
709         that had been undefined has already been called (in the
710         break loop), and a list of the values that it returned
711         in in the xp's %arg_z.  A function that returns those
712         values in in the xp's %fn; we just have to adjust the
713         stack (keeping the return address in the right place
714         and discarding any stack args/reserved stack frame),
715         then set nargs and the PC so that that function's
716         called when we resume.
717      */
718      LispObj *vsp =(LispObj *)save_vsp, ra = *vsp;
719#ifdef X8664
720      int nargs = (xpGPR(xp, Inargs) & 0xffff)>>fixnumshift;
721#else
722      int nargs = xpGPR(xp, Inargs)>>fixnumshift;
723#endif
724
725#ifdef X8664
726      if (nargs > 3) {
727        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3)));
728        push_on_lisp_stack(xp,ra);
729      }
730#else
731      if (nargs > 2) {
732        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 2)));
733        push_on_lisp_stack(xp,ra);
734      }
735#endif
736      xpPC(xp) = xpGPR(xp,Ifn);
737      xpGPR(xp,Inargs) = 1<<fixnumshift;
738    } else {
739      xpPC(xp) += skip;
740    }
741    return true;
742  } else {
743    return false;
744  }
745}
746
747
748protection_handler
749* protection_handlers[] = {
750  do_spurious_wp_fault,
751  do_soft_stack_overflow,
752  do_soft_stack_overflow,
753  do_soft_stack_overflow,
754  do_hard_stack_overflow,   
755  do_hard_stack_overflow,
756  do_hard_stack_overflow,
757};
758
759
760/* Maybe this'll work someday.  We may have to do something to
761   make the thread look like it's not handling an exception */
762void
763reset_lisp_process(ExceptionInformation *xp)
764{
765}
766
767Boolean
768do_hard_stack_overflow(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
769{
770  reset_lisp_process(xp);
771  return false;
772}
773
774
775Boolean
776do_spurious_wp_fault(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
777{
778
779  return false;
780}
781
782Boolean
783do_soft_stack_overflow(ExceptionInformation *xp, protected_area_ptr prot_area, BytePtr addr)
784{
785  /* Trying to write into a guard page on the vstack or tstack.
786     Allocate a new stack segment, emulate stwu and stwux for the TSP, and
787     signal an error_stack_overflow condition.
788      */
789  lisp_protection_kind which = prot_area->why;
790  Boolean on_TSP = (which == kTSPsoftguard);
791#ifdef X8664
792  LispObj save_rbp = xpGPR(xp,Irbp);
793#else
794  LispObj save_ebp = xpGPR(xp,Iebp);
795#endif
796  LispObj save_vsp = xpGPR(xp,Isp), 
797    xcf,
798    cmain = nrs_CMAIN.vcell;
799  area *a;
800  protected_area_ptr soft;
801  TCR *tcr = get_tcr(false);
802  int skip;
803
804  if ((fulltag_of(cmain) == fulltag_misc) &&
805      (header_subtag(header_of(cmain)) == subtag_macptr)) {
806    if (on_TSP) {
807      a = tcr->ts_area;
808    } else {
809      a = tcr->vs_area;
810    }
811    soft = a->softprot;
812    unprotect_area(soft);
813    xcf = create_exception_callback_frame(xp, tcr);
814    skip = callback_to_lisp(tcr, nrs_CMAIN.vcell, xp, xcf, SIGSEGV, on_TSP, 0, 0);
815#ifdef X8664
816    xpGPR(xp,Irbp) = save_rbp;
817#else
818    xpGPR(xp,Iebp) = save_ebp;
819#endif
820    xpGPR(xp,Isp) = save_vsp;
821    xpPC(xp) += skip;
822    return true;
823  }
824  return false;
825}
826
827Boolean
828is_write_fault(ExceptionInformation *xp, siginfo_t *info)
829{
830#ifdef DARWIN
831#ifdef X8664
832  return (UC_MCONTEXT(xp)->__es.__err & 0x2) != 0;
833#else
834  return (xp->uc_mcontext->__es.__err & 0x2) != 0;
835#endif
836#endif
837#if defined(LINUX) || defined(SOLARIS)
838  return (xpGPR(xp,REG_ERR) & 0x2) != 0;
839#endif
840#ifdef FREEBSD
841  return (xp->uc_mcontext.mc_err & 0x2) != 0;
842#endif
843#ifdef WINDOWS
844  return (info->ExceptionFlags == EXCEPTION_WRITE_FAULT);
845#endif
846}
847
848Boolean
849handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence)
850{
851#ifdef FREEBSD
852#ifdef X8664
853  BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr;
854#else
855  BytePtr addr = (BytePtr) info->si_addr;
856#endif
857#else
858#ifdef WINDOWS
859  BytePtr addr = (BytePtr) info->ExceptionInformation[1];
860#else
861  BytePtr addr = (BytePtr) info->si_addr;
862#endif
863#endif
864
865
866  if (addr && (addr == tcr->safe_ref_address)) {
867    xpGPR(xp,Iimm0) = 0;
868    xpPC(xp) = xpGPR(xp,Ira0);
869    return true;
870  } else {
871    protected_area *a = find_protected_area(addr);
872    protection_handler *handler;
873
874    if (a) {
875      handler = protection_handlers[a->why];
876      return handler(xp, a, addr);
877    } else {
878      if ((addr >= readonly_area->low) &&
879          (addr < readonly_area->active)) {
880        UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
881                        page_size);
882        return true;
883      }
884    }
885  }
886  if (old_valence == TCR_STATE_LISP) {
887    LispObj cmain = nrs_CMAIN.vcell,
888      xcf;
889    if ((fulltag_of(cmain) == fulltag_misc) &&
890      (header_subtag(header_of(cmain)) == subtag_macptr)) {
891      xcf = create_exception_callback_frame(xp, tcr);
892      callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0);
893    }
894  }
895  return false;
896}
897
898Boolean
899handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info)
900{
901  int code,skip;
902  LispObj  xcf, cmain = nrs_CMAIN.vcell,
903    save_vsp = xpGPR(xp,Isp);
904#ifdef X8664
905  LispObj save_rbp = xpGPR(xp,Irbp);
906#else
907  LispObj save_ebp = xpGPR(xp,Iebp);
908#endif
909#ifdef WINDOWS
910  code = info->ExceptionCode;
911#else
912  code = info->si_code;
913#endif 
914
915  if ((fulltag_of(cmain) == fulltag_misc) &&
916      (header_subtag(header_of(cmain)) == subtag_macptr)) {
917    xcf = create_exception_callback_frame(xp, tcr);
918    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0);
919    xpPC(xp) += skip;
920#ifdef X8664
921    xpGPR(xp,Irbp) = save_rbp;
922#else
923    xpGPR(xp,Iebp) = save_ebp;
924#endif
925    xpGPR(xp,Isp) = save_vsp;
926    return true;
927  } else {
928    return false;
929  }
930}
931
932
933Boolean
934extend_tcr_tlb(TCR *tcr, ExceptionInformation *xp)
935{
936  LispObj index, old_limit = tcr->tlb_limit, new_limit, new_bytes;
937  LispObj *old_tlb = tcr->tlb_pointer, *new_tlb, *work, *tos;
938
939  tos = (LispObj*)(xpGPR(xp,Isp));
940  index = *tos++;
941  (xpGPR(xp,Isp))=(LispObj)tos;
942 
943  new_limit = align_to_power_of_2(index+1,12);
944  new_bytes = new_limit-old_limit;
945  new_tlb = realloc(old_tlb, new_limit);
946
947  if (new_tlb == NULL) {
948    return false;
949  }
950  work = (LispObj *) ((BytePtr)new_tlb+old_limit);
951
952  while (new_bytes) {
953    *work++ = no_thread_local_binding_marker;
954    new_bytes -= sizeof(LispObj);
955  }
956  tcr->tlb_pointer = new_tlb;
957  tcr->tlb_limit = new_limit;
958  return true;
959}
960
961
962#if defined(FREEBSD) || defined(DARWIN)
963static
964char mxcsr_bit_to_fpe_code[] = {
965  FPE_FLTINV,                   /* ie */
966  0,                            /* de */
967  FPE_FLTDIV,                   /* ze */
968  FPE_FLTOVF,                   /* oe */
969  FPE_FLTUND,                   /* ue */
970  FPE_FLTRES                    /* pe */
971};
972
973void
974decode_vector_fp_exception(siginfo_t *info, uint32_t mxcsr)
975{
976  /* If the exception appears to be an XMM FP exception, try to
977     determine what it was by looking at bits in the mxcsr.
978  */
979  int xbit, maskbit;
980 
981  for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
982    if ((mxcsr & (1 << xbit)) &&
983        !(mxcsr & (1 << maskbit))) {
984      info->si_code = mxcsr_bit_to_fpe_code[xbit];
985      return;
986    }
987  }
988}
989
990#ifdef FREEBSD
991void
992freebsd_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
993{
994  if (info->si_code == 0) {
995#ifdef X8664
996    struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate);
997#else
998    struct ccl_savexmm *fpu = (struct ccl_savexmm *) &(xp->uc_mcontext.mc_fpstate);
999#endif
1000    uint32_t mxcsr = fpu->sv_env.en_mxcsr;
1001
1002    decode_vector_fp_exception(info, mxcsr);
1003  }
1004}
1005#endif
1006
1007#ifdef DARWIN
1008void
1009darwin_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
1010{
1011  if (info->si_code == EXC_I386_SSEEXTERR) {
1012    uint32_t mxcsr = UC_MCONTEXT(xp)->__fs.__fpu_mxcsr;
1013
1014    decode_vector_fp_exception(info, mxcsr);
1015  }
1016}
1017
1018#endif
1019
1020#endif
1021
1022void
1023get_lisp_string(LispObj lisp_string, char *c_string, natural max)
1024{
1025  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(lisp_string + misc_data_offset));
1026  natural i, n = header_element_count(header_of(lisp_string));
1027
1028  if (n > max) {
1029    n = max;
1030  }
1031
1032  for (i = 0; i < n; i++) {
1033    c_string[i] = 0xff & (src[i]);
1034  }
1035  c_string[n] = 0;
1036}
1037
1038Boolean
1039handle_exception(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1040{
1041  pc program_counter = (pc)xpPC(context);
1042
1043  switch (signum) {
1044  case SIGNUM_FOR_INTN_TRAP:
1045    if (IS_MAYBE_INT_TRAP(info,context)) {
1046      /* Something mapped to SIGSEGV/SIGBUS that has nothing to do with
1047         a memory fault.  On x86, an "int n" instruction that's
1048         not otherwise implemented causes a "protecton fault".  Of
1049         course that has nothing to do with accessing protected
1050         memory; of course, most Unices act as if it did.*/
1051      if ((program_counter != NULL) &&
1052          (*program_counter == INTN_OPCODE)) {
1053        program_counter++;
1054        switch (*program_counter) {
1055        case UUO_ALLOC_TRAP:
1056          if (handle_alloc_trap(context, tcr)) {
1057            xpPC(context) += 2; /* we might have GCed. */
1058            return true;
1059          }
1060          break;
1061        case UUO_GC_TRAP:
1062          if (handle_gc_trap(context, tcr)) {
1063            xpPC(context) += 2;
1064            return true;
1065          }
1066          break;
1067           
1068        case UUO_DEBUG_TRAP:
1069          xpPC(context) = (natural) (program_counter+1);
1070          lisp_Debugger(context, info, debug_entry_dbg, false, "Lisp Breakpoint");
1071          return true;
1072           
1073        case UUO_DEBUG_TRAP_WITH_STRING:
1074          xpPC(context) = (natural) (program_counter+1);
1075          {
1076            char msg[512];
1077
1078            get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1);
1079            lisp_Debugger(context, info, debug_entry_dbg, false, msg);
1080          }
1081          return true;
1082         
1083        default:
1084          return handle_error(tcr, context);
1085        }
1086      } else {
1087        return false;
1088      }
1089
1090    } else {
1091      return handle_fault(tcr, context, info, old_valence);
1092    }
1093    break;
1094
1095  case SIGNAL_FOR_PROCESS_INTERRUPT:
1096    tcr->interrupt_pending = 0;
1097    callback_for_interrupt(tcr, context);
1098    return true;
1099    break;
1100
1101
1102  case SIGILL:
1103    if ((program_counter[0] == XUUO_OPCODE_0) &&
1104        (program_counter[1] == XUUO_OPCODE_1)) {
1105      TCR *target = (TCR *)xpGPR(context, Iarg_z);
1106
1107      switch (program_counter[2]) {
1108      case XUUO_TLB_TOO_SMALL:
1109        if (extend_tcr_tlb(tcr,context)) {
1110          xpPC(context)+=3;
1111          return true;
1112        }
1113        break;
1114       
1115      case XUUO_INTERRUPT_NOW:
1116        callback_for_interrupt(tcr,context);
1117        xpPC(context)+=3;
1118        return true;
1119
1120      case XUUO_SUSPEND_NOW:
1121        xpPC(context)+=3;
1122        return true;
1123
1124      case XUUO_INTERRUPT:
1125        raise_thread_interrupt(target);
1126        xpPC(context)+=3;
1127        return true;
1128
1129      case XUUO_SUSPEND:
1130        xpGPR(context,Iimm0) = (LispObj) lisp_suspend_tcr(target);
1131        xpPC(context)+=3;
1132        return true;
1133
1134      case XUUO_SUSPEND_ALL:
1135        lisp_suspend_other_threads();
1136        xpPC(context)+=3;
1137        return true;
1138
1139
1140      case XUUO_RESUME:
1141        xpGPR(context,Iimm0) = (LispObj) lisp_resume_tcr(target);
1142        xpPC(context)+=3;
1143        return true;
1144       
1145      case XUUO_RESUME_ALL:
1146        lisp_resume_other_threads();
1147        xpPC(context)+=3;
1148        return true;
1149       
1150      case XUUO_KILL:
1151        xpGPR(context,Iimm0) = (LispObj)kill_tcr(target);
1152        xpPC(context)+=3;
1153        return true;
1154
1155      case XUUO_ALLOCATE_LIST:
1156        allocate_list(context,tcr);
1157        xpPC(context)+=3;
1158        return true;
1159
1160      default:
1161        return false;
1162      }
1163    } else {
1164      return false;
1165    }
1166    break;
1167   
1168  case SIGFPE:
1169#ifdef FREEBSD
1170    /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable
1171       with this newfangled XMM business (and therefore info->si_code
1172       is often 0 on an XMM FP exception.
1173       Try to figure out what really happened by decoding mxcsr
1174       bits.
1175    */
1176    freebsd_decode_vector_fp_exception(info,context);
1177#endif
1178#ifdef DARWIN
1179    /* Same general problem with Darwin as of 8.7.2 */
1180    darwin_decode_vector_fp_exception(info,context);
1181#endif
1182
1183    return handle_floating_point_exception(tcr, context, info);
1184
1185#if SIGBUS != SIGNUM_FOR_INTN_TRAP
1186  case SIGBUS:
1187    return handle_fault(tcr, context, info, old_valence);
1188#endif
1189   
1190#if SIGSEGV != SIGNUM_FOR_INTN_TRAP
1191  case SIGSEGV:
1192    return handle_fault(tcr, context, info, old_valence);
1193#endif   
1194   
1195  default:
1196    return false;
1197  }
1198}
1199
1200
1201/*
1202   Current thread has all signals masked.  Before unmasking them,
1203   make it appear that the current thread has been suspended.
1204   (This is to handle the case where another thread is trying
1205   to GC before this thread is able to seize the exception lock.)
1206*/
1207int
1208prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context)
1209{
1210  int old_valence = tcr->valence;
1211
1212  tcr->pending_exception_context = context;
1213  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
1214
1215#ifdef WINDOWS
1216  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1217    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1218    SEM_RAISE(tcr->suspend);
1219    SEM_WAIT_FOREVER(tcr->resume);
1220  }
1221#else
1222  ALLOW_EXCEPTIONS(context);
1223#endif
1224  return old_valence;
1225} 
1226
1227void
1228wait_for_exception_lock_in_handler(TCR *tcr, 
1229                                   ExceptionInformation *context,
1230                                   xframe_list *xf)
1231{
1232
1233  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
1234#if 0
1235  fprintf(stderr, "0x" LISP " has exception lock\n", tcr);
1236#endif
1237  xf->curr = context;
1238#ifdef X8632
1239  xf->node_regs_mask = tcr->node_regs_mask;
1240#endif
1241  xf->prev = tcr->xframe;
1242  tcr->xframe =  xf;
1243  tcr->pending_exception_context = NULL;
1244  tcr->valence = TCR_STATE_FOREIGN; 
1245}
1246
1247void
1248unlock_exception_lock_in_handler(TCR *tcr)
1249{
1250  tcr->pending_exception_context = tcr->xframe->curr;
1251#ifdef X8632
1252  tcr->node_regs_mask = tcr->xframe->node_regs_mask;
1253#endif
1254  tcr->xframe = tcr->xframe->prev;
1255  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
1256  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
1257#if 0
1258  fprintf(stderr, "0x" LISP " released exception lock\n", tcr);
1259#endif
1260}
1261
1262/*
1263   If an interrupt is pending on exception exit, try to ensure
1264   that the thread sees it as soon as it's able to run.
1265*/
1266#ifdef WINDOWS
1267void
1268raise_pending_interrupt(TCR *tcr)
1269{
1270}
1271void
1272exit_signal_handler(TCR *tcr, int old_valence)
1273{
1274}
1275void
1276signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1277{
1278}
1279#else
1280void
1281raise_pending_interrupt(TCR *tcr)
1282{
1283  if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) &&
1284      (tcr->interrupt_pending)) {
1285    pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT);
1286  }
1287}
1288
1289void
1290exit_signal_handler(TCR *tcr, int old_valence)
1291{
1292  sigset_t mask;
1293  sigfillset(&mask);
1294#ifdef FREEBSD
1295  sigdelset(&mask,SIGTRAP);
1296#endif
1297 
1298  pthread_sigmask(SIG_SETMASK,&mask, NULL);
1299  tcr->valence = old_valence;
1300  tcr->pending_exception_context = NULL;
1301}
1302
1303void
1304signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context
1305#ifdef DARWIN
1306               , TCR *tcr, int old_valence
1307#endif
1308)
1309{
1310#ifdef DARWIN_GS_HACK
1311  Boolean gs_was_tcr = ensure_gs_pthread();
1312#endif
1313  xframe_list xframe_link;
1314#ifndef DARWIN
1315  TCR *tcr = get_tcr(false);
1316
1317  int old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1318#endif
1319  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1320    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1321    pthread_kill(pthread_self(), thread_suspend_signal);
1322  }
1323  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
1324
1325
1326  if (! handle_exception(signum, info, context, tcr, old_valence)) {
1327    char msg[512];
1328    Boolean foreign = (old_valence != TCR_STATE_LISP);
1329
1330    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x" LISP ", context->regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context));
1331   
1332    if (lisp_Debugger(context, info, signum,  foreign, msg)) {
1333      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1334    }
1335  }
1336  unlock_exception_lock_in_handler(tcr);
1337#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1338  exit_signal_handler(tcr, old_valence);
1339#endif
1340  /* raise_pending_interrupt(tcr); */
1341#ifdef DARWIN_GS_HACK
1342  if (gs_was_tcr) {
1343    set_gs_address(tcr);
1344  }
1345#endif
1346#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1347  SIGRETURN(context);
1348#endif
1349}
1350#endif
1351
1352#ifdef DARWIN
1353void
1354pseudo_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1355{
1356  sigset_t mask;
1357
1358  sigfillset(&mask);
1359
1360  pthread_sigmask(SIG_SETMASK,&mask,&(context->uc_sigmask));
1361  signal_handler(signum, info, context, tcr, old_valence);
1362}
1363#endif
1364
1365
1366
1367#ifdef LINUX
1368/* type of pointer to saved fp state */
1369#ifdef X8664
1370typedef fpregset_t FPREGS;
1371#else
1372typedef struct _fpstate *FPREGS;
1373#endif
1374LispObj *
1375copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1376{
1377  FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest;
1378 
1379  if (src) {
1380    dest = ((FPREGS)current)-1;
1381    *dest = *src;
1382    *destptr = dest;
1383    current = (LispObj *) dest;
1384  }
1385  return current;
1386}
1387#endif
1388
1389#ifdef DARWIN
1390LispObj *
1391copy_darwin_mcontext(MCONTEXT_T context, 
1392                     LispObj *current, 
1393                     MCONTEXT_T *out)
1394{
1395  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1396  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1397
1398  *dest = *context;
1399  *out = dest;
1400  return (LispObj *)dest;
1401}
1402#endif
1403
1404LispObj *
1405copy_siginfo(siginfo_t *info, LispObj *current)
1406{
1407  siginfo_t *dest = ((siginfo_t *)current) - 1;
1408#if !defined(LINUX) || !defined(X8632)
1409  dest = (siginfo_t *) (((LispObj)dest)&~15);
1410#endif
1411  *dest = *info;
1412  return (LispObj *)dest;
1413}
1414
1415#ifdef LINUX
1416typedef FPREGS copy_ucontext_last_arg_t;
1417#else
1418typedef void * copy_ucontext_last_arg_t;
1419#endif
1420
1421#ifndef WINDOWS
1422LispObj *
1423copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1424{
1425  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1426#if !defined(LINUX) || !defined(X8632)
1427  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1428#endif
1429
1430  *dest = *context;
1431  /* Fix it up a little; where's the signal mask allocated, if indeed
1432     it is "allocated" ? */
1433#ifdef LINUX
1434  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1435#endif
1436  dest->uc_stack.ss_sp = 0;
1437  dest->uc_stack.ss_size = 0;
1438  dest->uc_stack.ss_flags = 0;
1439  dest->uc_link = NULL;
1440  return (LispObj *)dest;
1441}
1442#endif
1443
1444
1445LispObj *
1446find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1447{
1448
1449  if (((BytePtr)rsp < foreign_area->low) ||
1450      ((BytePtr)rsp > foreign_area->high)) {
1451    rsp = (LispObj)(tcr->foreign_sp);
1452  }
1453  return (LispObj *) (((rsp-128) & ~15));
1454}
1455
1456#ifdef X8632
1457#ifdef LINUX
1458/* This is here for debugging.  On entry to a signal handler that
1459   receives info and context arguments, the stack should look exactly
1460   like this.  The "pretcode field" of the structure is the address
1461   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1462   %esp at the time of that syscall to be pointing just past the
1463   pretcode field.
1464   handle_signal_on_foreign_stack() and helpers have to be very
1465   careful to duplicate this "structure" exactly.
1466   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1467   be on top of the stack (with a siginfo_t underneath it.)
1468   It sort of half-works to do sigreturn via setcontext() on
1469   x8632 Linux, but (a) it may not be available on some distributions
1470   and (b) even a relatively modern version of it uses "fldenv" to
1471   restore FP context, and "fldenv" isn't nearly good enough.
1472*/
1473
1474struct rt_sigframe {
1475        char *pretcode;
1476        int sig;
1477        siginfo_t  *pinfo;
1478        void  *puc;
1479        siginfo_t info;
1480        struct ucontext uc;
1481        struct _fpstate fpstate;
1482        char retcode[8];
1483};
1484struct rt_sigframe *rtsf = 0;
1485
1486#endif
1487#endif
1488
1489#ifdef DARWIN
1490void
1491bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1492{
1493  if (signum == SIGSYS) {
1494    return;                     /* Leopard lossage */
1495  }
1496}
1497#endif
1498
1499#ifndef WINDOWS
1500/* x8632 Linux requires that the stack-allocated siginfo is nearer
1501   the top of stack than the stack-allocated ucontext.  If other
1502   platforms care, they expect the ucontext to be nearer the top
1503   of stack.
1504*/
1505
1506#if defined(LINUX) && defined(X8632)
1507#define UCONTEXT_ON_TOP_OF_STACK 0
1508#else
1509#define UCONTEXT_ON_TOP_OF_STACK 1
1510#endif
1511void
1512handle_signal_on_foreign_stack(TCR *tcr,
1513                               void *handler, 
1514                               int signum, 
1515                               siginfo_t *info, 
1516                               ExceptionInformation *context,
1517                               LispObj return_address
1518#ifdef DARWIN_GS_HACK
1519                               , Boolean gs_was_tcr
1520#endif
1521                               )
1522{
1523#ifdef LINUX
1524  FPREGS fpregs = NULL;
1525#else
1526  void *fpregs = NULL;
1527#endif
1528#ifdef DARWIN
1529  MCONTEXT_T mcontextp = NULL;
1530#endif
1531  siginfo_t *info_copy = NULL;
1532  ExceptionInformation *xp = NULL;
1533  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1534
1535#ifdef LINUX
1536  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1537#endif
1538#ifdef DARWIN
1539  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1540#endif
1541#if UCONTEXT_ON_TOP_OF_STACK
1542  /* copy info first */
1543  foreign_rsp = copy_siginfo(info, foreign_rsp);
1544  info_copy = (siginfo_t *)foreign_rsp;
1545  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1546  xp = (ExceptionInformation *)foreign_rsp;
1547#else
1548  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1549  xp = (ExceptionInformation *)foreign_rsp;
1550  foreign_rsp = copy_siginfo(info, foreign_rsp);
1551  info_copy = (siginfo_t *)foreign_rsp;
1552#endif
1553#ifdef DARWIN
1554  UC_MCONTEXT(xp) = mcontextp;
1555#endif
1556  *--foreign_rsp = return_address;
1557#ifdef DARWIN_GS_HACK
1558  if (gs_was_tcr) {
1559    set_gs_address(tcr);
1560  }
1561#endif
1562  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1563}
1564#endif
1565
1566
1567#ifndef WINDOWS
1568#ifndef USE_SIGALTSTACK
1569void
1570arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1571{
1572  TCR *tcr = get_interrupt_tcr(false);
1573#if 1
1574  if (tcr->valence != TCR_STATE_LISP) {
1575    FBug(context, "exception in foreign context");
1576  }
1577#endif
1578  {
1579    area *vs = tcr->vs_area;
1580    BytePtr current_sp = (BytePtr) current_stack_pointer();
1581
1582
1583    if ((current_sp >= vs->low) &&
1584        (current_sp < vs->high)) {
1585      handle_signal_on_foreign_stack(tcr,
1586                                     signal_handler,
1587                                     signum,
1588                                     info,
1589                                     context,
1590                                     (LispObj)__builtin_return_address(0)
1591#ifdef DARWIN_GS_HACK
1592                                     , false
1593#endif
1594
1595                                     );
1596    } else {
1597      signal_handler(signum, info, context, tcr, 0);
1598    }
1599  }
1600}
1601
1602#else
1603void
1604altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1605{
1606  TCR* tcr = get_tcr(true);
1607#if 1
1608  if (tcr->valence != TCR_STATE_LISP) {
1609    FBug(context, "exception in foreign context");
1610  }
1611#endif
1612  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1613#ifdef DARWIN_GS_HACK
1614                                 , false
1615#endif
1616);
1617}
1618#endif
1619#endif
1620
1621Boolean
1622stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1623{
1624  area *a = tcr->vs_area;
1625 
1626  return (((BytePtr)stack_pointer <= a->high) &&
1627          ((BytePtr)stack_pointer > a->low));
1628}
1629
1630
1631#ifdef WINDOWS
1632extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1633#endif
1634
1635void
1636interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1637{
1638#ifdef DARWIN_GS_HACK
1639  Boolean gs_was_tcr = ensure_gs_pthread();
1640#endif
1641  TCR *tcr = get_interrupt_tcr(false);
1642  int old_valence = tcr->valence;
1643
1644  if (tcr) {
1645    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1646        (tcr->valence != TCR_STATE_LISP) ||
1647        (tcr->unwinding != 0) ||
1648        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1649#ifdef X8664
1650        ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) {
1651#else
1652        ! stack_pointer_on_vstack_p(xpGPR(context,Iebp), tcr)) {
1653#endif
1654      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1655    } else {
1656      LispObj cmain = nrs_CMAIN.vcell;
1657
1658      if ((fulltag_of(cmain) == fulltag_misc) &&
1659          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1660        /*
1661           This thread can (allegedly) take an interrupt now.
1662        */
1663
1664        xframe_list xframe_link;
1665        signed_natural alloc_displacement = 0;
1666        LispObj
1667          *next_tsp = tcr->next_tsp,
1668          *save_tsp = tcr->save_tsp,
1669          *p,
1670          q;
1671        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1672
1673        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1674           
1675        if (next_tsp != save_tsp) {
1676          tcr->next_tsp = save_tsp;
1677        } else {
1678          next_tsp = NULL;
1679        }
1680        /* have to do this before allowing interrupts */
1681        pc_luser_xp(context, tcr, &alloc_displacement);
1682        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1683        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1684        handle_exception(signum, info, context, tcr, old_valence);
1685        if (alloc_displacement) {
1686          tcr->save_allocptr -= alloc_displacement;
1687        }
1688        if (next_tsp) {
1689          tcr->next_tsp = next_tsp;
1690          p = next_tsp;
1691          while (p != save_tsp) {
1692            *p++ = 0;
1693          }
1694          q = (LispObj)save_tsp;
1695          *next_tsp = q;
1696        }
1697        tcr->flags |= old_foreign_exception;
1698        unlock_exception_lock_in_handler(tcr);
1699#ifndef WINDOWS
1700        exit_signal_handler(tcr, old_valence);
1701#endif
1702      }
1703    }
1704  }
1705#ifdef DARWIN_GS_HACK
1706  if (gs_was_tcr) {
1707    set_gs_address(tcr);
1708  }
1709#endif
1710#ifdef WINDOWS
1711  restore_windows_context(context,tcr,old_valence);
1712#else
1713  SIGRETURN(context);
1714#endif
1715}
1716
1717
1718#ifndef WINDOWS
1719#ifndef USE_SIGALTSTACK
1720void
1721arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1722{
1723#ifdef DARWIN_GS_HACK
1724  Boolean gs_was_tcr = ensure_gs_pthread();
1725#endif
1726  TCR *tcr = get_interrupt_tcr(false);
1727  area *vs = tcr->vs_area;
1728  BytePtr current_sp = (BytePtr) current_stack_pointer();
1729
1730  if ((current_sp >= vs->low) &&
1731      (current_sp < vs->high)) {
1732    handle_signal_on_foreign_stack(tcr,
1733                                   interrupt_handler,
1734                                   signum,
1735                                   info,
1736                                   context,
1737                                   (LispObj)__builtin_return_address(0)
1738#ifdef DARWIN_GS_HACK
1739                                   ,gs_was_tcr
1740#endif
1741                                   );
1742  } else {
1743    /* If we're not on the value stack, we pretty much have to be on
1744       the C stack.  Just run the handler. */
1745#ifdef DARWIN_GS_HACK
1746    if (gs_was_tcr) {
1747      set_gs_address(tcr);
1748    }
1749#endif
1750    interrupt_handler(signum, info, context);
1751  }
1752}
1753
1754#else /* altstack works */
1755 
1756void
1757altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1758{
1759#ifdef DARWIN_GS_HACK
1760  Boolean gs_was_tcr = ensure_gs_pthread();
1761#endif
1762  TCR *tcr = get_interrupt_tcr(false);
1763  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1764#ifdef DARWIN_GS_HACK
1765                                 ,gs_was_tcr
1766#endif
1767                                 );
1768}
1769
1770#endif
1771#endif
1772
1773#ifndef WINDOWS
1774void
1775install_signal_handler(int signo, void * handler)
1776{
1777  struct sigaction sa;
1778 
1779  sa.sa_sigaction = (void *)handler;
1780  sigfillset(&sa.sa_mask);
1781#ifdef FREEBSD
1782  /* Strange FreeBSD behavior wrt synchronous signals */
1783  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1784#endif
1785  sa.sa_flags = 
1786    0 /* SA_RESTART */
1787#ifdef USE_SIGALTSTACK
1788    | SA_ONSTACK
1789#endif
1790    | SA_SIGINFO;
1791
1792  sigaction(signo, &sa, NULL);
1793}
1794#endif
1795
1796#ifdef WINDOWS
1797BOOL
1798CALLBACK ControlEventHandler(DWORD event)
1799{
1800  switch(event) {
1801  case CTRL_C_EVENT:
1802    lisp_global(INTFLAG) = (1 << fixnumshift);
1803    return TRUE;
1804    break;
1805  default:
1806    return FALSE;
1807  }
1808}
1809
1810int
1811map_windows_exception_code_to_posix_signal(DWORD code)
1812{
1813  switch (code) {
1814  case EXCEPTION_ACCESS_VIOLATION:
1815    return SIGSEGV;
1816  case EXCEPTION_FLT_DENORMAL_OPERAND:
1817  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1818  case EXCEPTION_FLT_INEXACT_RESULT:
1819  case EXCEPTION_FLT_INVALID_OPERATION:
1820  case EXCEPTION_FLT_OVERFLOW:
1821  case EXCEPTION_FLT_STACK_CHECK:
1822  case EXCEPTION_FLT_UNDERFLOW:
1823  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1824  case EXCEPTION_INT_OVERFLOW:
1825    return SIGFPE;
1826  case EXCEPTION_PRIV_INSTRUCTION:
1827  case EXCEPTION_ILLEGAL_INSTRUCTION:
1828    return SIGILL;
1829  case EXCEPTION_IN_PAGE_ERROR:
1830    return SIGBUS;
1831  default:
1832    return -1;
1833  }
1834}
1835
1836
1837LONG
1838windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
1839{
1840  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1841  int old_valence, signal_number;
1842  ExceptionInformation *context = exception_pointers->ContextRecord;
1843  siginfo_t *info = exception_pointers->ExceptionRecord;
1844  xframe_list xframes;
1845
1846  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1847  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1848
1849  signal_number = map_windows_exception_code_to_posix_signal(code);
1850 
1851  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
1852    char msg[512];
1853    Boolean foreign = (old_valence != TCR_STATE_LISP);
1854
1855    snprintf(msg, sizeof(msg), "Unhandled exception %d (windows code 0x%x) at 0x%Ix, context->regs at 0x%Ix", signal_number, code, xpPC(context), (natural)xpGPRvector(context));
1856   
1857    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1858      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1859    }
1860  }
1861  unlock_exception_lock_in_handler(tcr);
1862  return restore_windows_context(context, tcr, old_valence);
1863}
1864
1865void
1866setup_exception_handler_call(CONTEXT *context,
1867                             LispObj new_sp,
1868                             void *handler,
1869                             EXCEPTION_POINTERS *new_ep,
1870                             TCR *tcr)
1871{
1872  extern void windows_halt(void);
1873  LispObj *p = (LispObj *)new_sp;
1874#ifdef WIN_64
1875  p-=4;                         /* win64 abi argsave nonsense */
1876  *(--p) = (LispObj)windows_halt;
1877  context->Rsp = (DWORD64)p;
1878  context->Rip = (DWORD64)handler;
1879  context->Rcx = (DWORD64)new_ep;
1880  context->Rdx = (DWORD64)tcr;
1881#else
1882  p-=4;                          /* args on stack, stack aligned */
1883  p[0] = (LispObj)new_ep;
1884  p[1] = (LispObj)tcr;
1885  *(--p) = (LispObj)windows_halt;
1886  context->Esp = (DWORD)p;
1887  context->Eip = (DWORD)handler;
1888#ifdef WIN32_ES_HACK
1889  context->SegEs = context->SegDs;
1890#endif
1891#endif
1892  context->EFlags &= ~0x400;  /* clear direction flag */
1893}
1894
1895void
1896prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
1897                                                     CONTEXT *context,
1898                                                     void *handler,
1899                                                     EXCEPTION_POINTERS *original_ep)
1900{
1901  LispObj foreign_rsp = 
1902    (LispObj) (tcr->foreign_sp - 128) & ~15;
1903  CONTEXT *new_context;
1904  siginfo_t *new_info;
1905  EXCEPTION_POINTERS *new_ep;
1906
1907  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
1908  *new_context = *context;
1909  foreign_rsp = (LispObj)new_context;
1910  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
1911  *new_info = *original_ep->ExceptionRecord;
1912  foreign_rsp = (LispObj)new_info;
1913  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
1914  foreign_rsp = (LispObj)new_ep & ~15;
1915  new_ep->ContextRecord = new_context;
1916  new_ep->ExceptionRecord = new_info;
1917  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
1918}
1919
1920LONG CALLBACK
1921windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
1922{
1923  extern void ensure_safe_for_string_operations(void);
1924  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1925
1926
1927 
1928  if ((code & 0x80000000L) == 0) {
1929    return EXCEPTION_CONTINUE_SEARCH;
1930  } else {
1931    TCR *tcr = get_interrupt_tcr(false);
1932    area *cs = tcr->cs_area;
1933    BytePtr current_sp = (BytePtr) current_stack_pointer();
1934    CONTEXT *context = exception_pointers->ContextRecord;
1935   
1936    ensure_safe_for_string_operations();
1937
1938    if ((current_sp >= cs->low) &&
1939        (current_sp < cs->high)) {
1940      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
1941      FBug(context, "Exception on foreign stack\n");
1942      return EXCEPTION_CONTINUE_EXECUTION;
1943    }
1944
1945    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
1946                                                         context,
1947                                                         windows_exception_handler,
1948                                                         exception_pointers);
1949    return EXCEPTION_CONTINUE_EXECUTION;
1950  }
1951}
1952
1953
1954void
1955install_pmcl_exception_handlers()
1956{
1957  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
1958}
1959#else
1960void
1961install_pmcl_exception_handlers()
1962{
1963#ifndef DARWIN 
1964  void *handler = (void *)
1965#ifdef USE_SIGALTSTACK
1966    altstack_signal_handler
1967#else
1968    arbstack_signal_handler;
1969#endif
1970  ;
1971  install_signal_handler(SIGILL, handler);
1972 
1973  install_signal_handler(SIGBUS, handler);
1974  install_signal_handler(SIGSEGV,handler);
1975  install_signal_handler(SIGFPE, handler);
1976#else
1977  install_signal_handler(SIGTRAP,bogus_signal_handler);
1978  install_signal_handler(SIGILL, bogus_signal_handler);
1979 
1980  install_signal_handler(SIGBUS, bogus_signal_handler);
1981  install_signal_handler(SIGSEGV,bogus_signal_handler);
1982  install_signal_handler(SIGFPE, bogus_signal_handler);
1983  /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
1984  install_signal_handler(SIGSYS, bogus_signal_handler);
1985#endif
1986 
1987  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1988#ifdef USE_SIGALTSTACK
1989                         altstack_interrupt_handler
1990#else
1991                         arbstack_interrupt_handler
1992#endif
1993);
1994  signal(SIGPIPE, SIG_IGN);
1995}
1996#endif
1997
1998#ifndef WINDOWS
1999#ifndef USE_SIGALTSTACK
2000void
2001arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2002{
2003#ifdef DARWIN_GS_HACK
2004  Boolean gs_was_tcr = ensure_gs_pthread();
2005#endif
2006  TCR *tcr = get_interrupt_tcr(false);
2007  area *vs = tcr->vs_area;
2008  BytePtr current_sp = (BytePtr) current_stack_pointer();
2009
2010  if ((current_sp >= vs->low) &&
2011      (current_sp < vs->high)) {
2012    handle_signal_on_foreign_stack(tcr,
2013                                   suspend_resume_handler,
2014                                   signum,
2015                                   info,
2016                                   context,
2017                                   (LispObj)__builtin_return_address(0)
2018#ifdef DARWIN_GS_HACK
2019                                   ,gs_was_tcr
2020#endif
2021                                   );
2022  } else {
2023    /* If we're not on the value stack, we pretty much have to be on
2024       the C stack.  Just run the handler. */
2025#ifdef DARWIN_GS_HACK
2026    if (gs_was_tcr) {
2027      set_gs_address(tcr);
2028    }
2029#endif
2030    suspend_resume_handler(signum, info, context);
2031  }
2032}
2033
2034
2035#else /* altstack works */
2036void
2037altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2038{
2039#ifdef DARWIN_GS_HACK
2040  Boolean gs_was_tcr = ensure_gs_pthread();
2041#endif
2042  TCR* tcr = get_tcr(true);
2043  handle_signal_on_foreign_stack(tcr,
2044                                 suspend_resume_handler,
2045                                 signum,
2046                                 info,
2047                                 context,
2048                                 (LispObj)__builtin_return_address(0)
2049#ifdef DARWIN_GS_HACK
2050                                 ,gs_was_tcr
2051#endif
2052                                 );
2053}
2054#endif
2055#endif
2056
2057
2058/* This should only be called when the tcr_area_lock is held */
2059void
2060empty_tcr_stacks(TCR *tcr)
2061{
2062  if (tcr) {
2063    area *a;
2064
2065    tcr->valence = TCR_STATE_FOREIGN;
2066    a = tcr->vs_area;
2067    if (a) {
2068      a->active = a->high;
2069    }
2070    a = tcr->ts_area;
2071    if (a) {
2072      a->active = a->high;
2073    }
2074    a = tcr->cs_area;
2075    if (a) {
2076      a->active = a->high;
2077    }
2078  }
2079}
2080
2081#ifdef WINDOWS
2082void
2083thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2084{
2085}
2086#else
2087void
2088thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2089{
2090#ifdef DARWIN_GS_HACK
2091  Boolean gs_was_tcr = ensure_gs_pthread();
2092#endif
2093  TCR *tcr = get_tcr(false);
2094  sigset_t mask;
2095
2096  sigemptyset(&mask);
2097
2098  empty_tcr_stacks(tcr);
2099
2100  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2101  pthread_exit(NULL);
2102}
2103#endif
2104
2105#ifndef WINDOWS
2106#ifndef USE_SIGALTSTACK
2107void
2108arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2109{
2110#ifdef DARWIN_GS_HACK
2111  Boolean gs_was_tcr = ensure_gs_pthread();
2112#endif
2113  TCR *tcr = get_interrupt_tcr(false);
2114  area *vs = tcr->vs_area;
2115  BytePtr current_sp = (BytePtr) current_stack_pointer();
2116
2117  if ((current_sp >= vs->low) &&
2118      (current_sp < vs->high)) {
2119    handle_signal_on_foreign_stack(tcr,
2120                                   thread_kill_handler,
2121                                   signum,
2122                                   info,
2123                                   context,
2124                                   (LispObj)__builtin_return_address(0)
2125#ifdef DARWIN_GS_HACK
2126                                   ,gs_was_tcr
2127#endif
2128                                   );
2129  } else {
2130    /* If we're not on the value stack, we pretty much have to be on
2131       the C stack.  Just run the handler. */
2132#ifdef DARWIN_GS_HACK
2133    if (gs_was_tcr) {
2134      set_gs_address(tcr);
2135    }
2136#endif
2137    thread_kill_handler(signum, info, context);
2138  }
2139}
2140
2141
2142#else
2143void
2144altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2145{
2146#ifdef DARWIN_GS_HACK
2147  Boolean gs_was_tcr = ensure_gs_pthread();
2148#endif
2149  TCR* tcr = get_tcr(true);
2150  handle_signal_on_foreign_stack(tcr,
2151                                 thread_kill_handler,
2152                                 signum,
2153                                 info,
2154                                 context,
2155                                 (LispObj)__builtin_return_address(0)
2156#ifdef DARWIN_GS_HACK
2157                                 ,gs_was_tcr
2158#endif
2159                                 );
2160}
2161#endif
2162#endif
2163
2164#ifdef USE_SIGALTSTACK
2165#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
2166#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2167#else
2168#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
2169#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2170#endif
2171
2172#ifdef WINDOWS
2173void
2174thread_signal_setup()
2175{
2176}
2177#else
2178void
2179thread_signal_setup()
2180{
2181  thread_suspend_signal = SIG_SUSPEND_THREAD;
2182  thread_kill_signal = SIG_KILL_THREAD;
2183
2184  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
2185  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER);
2186}
2187#endif
2188
2189void
2190enable_fp_exceptions()
2191{
2192}
2193
2194void
2195exception_init()
2196{
2197  install_pmcl_exception_handlers();
2198}
2199
2200void
2201adjust_exception_pc(ExceptionInformation *xp, int delta)
2202{
2203  xpPC(xp) += delta;
2204}
2205
2206/*
2207  Lower (move toward 0) the "end" of the soft protected area associated
2208  with a by a page, if we can.
2209*/
2210
2211void
2212
2213adjust_soft_protection_limit(area *a)
2214{
2215  char *proposed_new_soft_limit = a->softlimit - 4096;
2216  protected_area_ptr p = a->softprot;
2217 
2218  if (proposed_new_soft_limit >= (p->start+16384)) {
2219    p->end = proposed_new_soft_limit;
2220    p->protsize = p->end-p->start;
2221    a->softlimit = proposed_new_soft_limit;
2222  }
2223  protect_area(p);
2224}
2225
2226void
2227restore_soft_stack_limit(unsigned restore_tsp)
2228{
2229  TCR *tcr = get_tcr(false);
2230  area *a;
2231 
2232  if (restore_tsp) {
2233    a = tcr->ts_area;
2234  } else {
2235    a = tcr->vs_area;
2236  }
2237  adjust_soft_protection_limit(a);
2238}
2239
2240
2241#ifdef USE_SIGALTSTACK
2242void
2243setup_sigaltstack(area *a)
2244{
2245  stack_t stack;
2246  stack.ss_sp = a->low;
2247  a->low += SIGSTKSZ*8;
2248  stack.ss_size = SIGSTKSZ*8;
2249  stack.ss_flags = 0;
2250  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2251  if (sigaltstack(&stack, NULL) != 0) {
2252    perror("sigaltstack");
2253    exit(-1);
2254  }
2255}
2256#endif
2257
2258extern opcode egc_write_barrier_start, egc_write_barrier_end,
2259  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2260  egc_store_node_conditional_success_end,
2261  egc_store_node_conditional_success_test,egc_store_node_conditional,
2262  egc_set_hash_key, egc_gvset, egc_rplacd;
2263
2264/* We use (extremely) rigidly defined instruction sequences for consing,
2265   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2266   while consing.
2267
2268   Note that we can usually identify which of these instructions is about
2269   to be executed by a stopped thread without comparing all of the bytes
2270   to those at the stopped program counter, but we generally need to
2271   know the sizes of each of these instructions.
2272*/
2273
2274#ifdef X8664
2275opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2276#ifdef WINDOWS
2277  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2278#else
2279  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2280#endif
2281;
2282opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2283#ifdef WINDOWS
2284  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2285#else
2286  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2287#endif
2288
2289;
2290opcode branch_around_alloc_trap_instruction[] =
2291  {0x7f,0x02};
2292opcode alloc_trap_instruction[] =
2293  {0xcd,0xc5};
2294opcode clear_tcr_save_allocptr_tag_instruction[] =
2295#ifdef WINDOWS
2296  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2297#else
2298  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2299#endif
2300;
2301opcode set_allocptr_header_instruction[] =
2302  {0x48,0x89,0x43,0xf3};
2303
2304
2305alloc_instruction_id
2306recognize_alloc_instruction(pc program_counter)
2307{
2308  switch(program_counter[0]) {
2309  case 0xcd: return ID_alloc_trap_instruction;
2310  case 0x7f: return ID_branch_around_alloc_trap_instruction;
2311  case 0x48: return ID_set_allocptr_header_instruction;
2312#ifdef WINDOWS
2313  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2314  case 0x49:
2315    switch(program_counter[1]) {
2316    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2317    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2318    }
2319#else
2320  case 0x65: 
2321    switch(program_counter[1]) {
2322    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2323    case 0x48:
2324      switch(program_counter[2]) {
2325      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2326      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2327      }
2328    }
2329#endif
2330  default: break;
2331  }
2332  return ID_unrecognized_alloc_instruction;
2333}
2334#endif
2335#ifdef X8632
2336opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2337  {0x64,0x8b,0x0d,0x84,0x00,0x00,0x00};
2338opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2339  {0x64,0x3b,0x0d,0x88,0x00,0x00,0x00};
2340opcode branch_around_alloc_trap_instruction[] =
2341  {0x7f,0x02};
2342opcode alloc_trap_instruction[] =
2343  {0xcd,0xc5};
2344opcode clear_tcr_save_allocptr_tag_instruction[] =
2345  {0x64,0x80,0x25,0x84,0x00,0x00,0x00,0xf8};
2346opcode set_allocptr_header_instruction[] =
2347  {0x0f,0x7e,0x41,0xfa};
2348
2349alloc_instruction_id
2350recognize_alloc_instruction(pc program_counter)
2351{
2352  switch(program_counter[0]) {
2353  case 0xcd: return ID_alloc_trap_instruction;
2354  case 0x7f: return ID_branch_around_alloc_trap_instruction;
2355  case 0x0f: return ID_set_allocptr_header_instruction;
2356  case 0x64: 
2357    switch(program_counter[1]) {
2358    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2359    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2360    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2361    }
2362  }
2363  return ID_unrecognized_alloc_instruction;
2364}
2365#endif     
2366
2367void
2368pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2369{
2370  pc program_counter = (pc)xpPC(xp);
2371  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2372
2373  if (allocptr_tag != 0) {
2374    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2375    signed_natural
2376      disp = (allocptr_tag == fulltag_cons) ?
2377      sizeof(cons) - fulltag_cons :
2378#ifdef X8664
2379      xpGPR(xp,Iimm1);
2380#else
2381      xpGPR(xp,Iimm0);
2382#endif
2383    LispObj new_vector;
2384
2385    if ((state == ID_unrecognized_alloc_instruction) ||
2386        ((state == ID_set_allocptr_header_instruction) &&
2387         (allocptr_tag != fulltag_misc))) {
2388      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2389    }
2390    switch(state) {
2391    case ID_set_allocptr_header_instruction:
2392      /* We were consing a vector and we won.  Set the header of the new vector
2393         (in the allocptr register) to the header in %rax and skip over this
2394         instruction, then fall into the next case. */
2395      new_vector = xpGPR(xp,Iallocptr);
2396      deref(new_vector,0) = xpGPR(xp,Iimm0);
2397
2398      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2399      /* Fall thru */
2400    case ID_clear_tcr_save_allocptr_tag_instruction:
2401      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2402      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2403      break;
2404    case ID_alloc_trap_instruction:
2405      /* If we're looking at another thread, we're pretty much committed to
2406         taking the trap.  We don't want the allocptr register to be pointing
2407         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2408         was determined above.
2409      */
2410      if (interrupt_displacement == NULL) {
2411        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2412        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2413      } else {
2414        /* Back out, and tell the caller how to resume the allocation attempt */
2415        *interrupt_displacement = disp;
2416        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2417        tcr->save_allocptr += disp;
2418        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2419                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2420                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2421      }
2422      break;
2423    case ID_branch_around_alloc_trap_instruction:
2424      /* If we'd take the branch - which is a "jg" - around the alloc trap,
2425         we might as well finish the allocation.  Otherwise, back out of the
2426         attempt. */
2427      {
2428        int flags = (int)eflags_register(xp);
2429       
2430        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2431            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
2432             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
2433          /* The branch (jg) would have been taken.  Emulate taking it. */
2434          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2435                       sizeof(alloc_trap_instruction));
2436          if (allocptr_tag == fulltag_misc) {
2437            /* Slap the header on the new uvector */
2438            new_vector = xpGPR(xp,Iallocptr);
2439            deref(new_vector,0) = xpGPR(xp,Iimm0);
2440            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2441          }
2442          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2443          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2444        } else {
2445          /* Back up */
2446          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2447                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2448          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2449          if (interrupt_displacement) {
2450            *interrupt_displacement = disp;
2451            tcr->save_allocptr += disp;
2452          } else {
2453            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2454          }
2455        }
2456      }
2457      break;
2458    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2459      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2460      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2461      /* Fall through */
2462    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2463      if (interrupt_displacement) {
2464        tcr->save_allocptr += disp;
2465        *interrupt_displacement = disp;
2466      } else {
2467        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2468      }
2469      break;
2470    default: 
2471      break;
2472    }
2473    return;
2474  }
2475  if ((program_counter >= &egc_write_barrier_start) &&
2476      (program_counter < &egc_write_barrier_end)) {
2477    LispObj *ea = 0, val, root = 0;
2478    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2479    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2480
2481    if (program_counter >= &egc_set_hash_key_conditional) {
2482      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2483          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2484           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2485        /* Back up the PC, try again */
2486        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional;
2487        return;
2488      }
2489      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2490      val = xpGPR(xp,Iarg_z);
2491#ifdef X8664
2492      root = xpGPR(xp,Iarg_x);
2493      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2494#else
2495      root = xpGPR(xp,Itemp1);
2496      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2497#endif
2498      need_memoize_root = true;
2499      need_store = false;
2500      xpGPR(xp,Iarg_z) = t_value;
2501    } else if (program_counter >= &egc_store_node_conditional) {
2502      if ((program_counter < &egc_store_node_conditional_success_test) ||
2503          ((program_counter == &egc_store_node_conditional_success_test) &&
2504           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2505        /* Back up the PC, try again */
2506        xpPC(xp) = (LispObj) &egc_store_node_conditional;
2507        return;
2508      }
2509      if (program_counter >= &egc_store_node_conditional_success_end) {
2510        return;
2511      }
2512
2513      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2514      val = xpGPR(xp,Iarg_z);
2515#ifdef X8664
2516      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2517                                                       xpGPR(xp,Itemp0))));
2518#else
2519      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2520#endif
2521      xpGPR(xp,Iarg_z) = t_value;
2522      need_store = false;
2523    } else if (program_counter >= &egc_set_hash_key) {
2524#ifdef X8664
2525      root = xpGPR(xp,Iarg_x);
2526#else
2527      root = xpGPR(xp,Itemp0);
2528#endif
2529      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2530      val = xpGPR(xp,Iarg_z);
2531      need_memoize_root = true;
2532    } else if (program_counter >= &egc_gvset) {
2533#ifdef X8664
2534      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2535#else
2536      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2537#endif
2538      val = xpGPR(xp,Iarg_z);
2539    } else if (program_counter >= &egc_rplacd) {
2540      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2541      val = xpGPR(xp,Iarg_z);
2542    } else {                      /* egc_rplaca */
2543      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2544      val = xpGPR(xp,Iarg_z);
2545    }
2546    if (need_store) {
2547      *ea = val;
2548    }
2549    if (need_check_memo) {
2550      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
2551      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2552          ((LispObj)ea < val)) {
2553        atomic_set_bit(refbits, bitnumber);
2554        if (need_memoize_root) {
2555          bitnumber = area_dnode(root, lisp_global(HEAP_START));
2556          atomic_set_bit(refbits, bitnumber);
2557        }
2558      }
2559    }
2560    {
2561      /* These subprimitives are called via CALL/RET; need
2562         to pop the return address off the stack and set
2563         the PC there. */
2564      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2565      xpPC(xp) = ra;
2566      xpGPR(xp,Isp)=(LispObj)sp;
2567    }
2568    return;
2569  }
2570}
2571
2572
2573void
2574normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2575{
2576  void *cur_allocptr = (void *)(tcr->save_allocptr);
2577  LispObj lisprsp;
2578  area *a;
2579
2580  if (xp) {
2581    if (is_other_tcr) {
2582      pc_luser_xp(xp, tcr, NULL);
2583    }
2584    a = tcr->vs_area;
2585    lisprsp = xpGPR(xp, Isp);
2586    if (((BytePtr)lisprsp >= a->low) &&
2587        ((BytePtr)lisprsp < a->high)) {
2588      a->active = (BytePtr)lisprsp;
2589    } else {
2590      a->active = (BytePtr) tcr->save_vsp;
2591    }
2592    a = tcr->ts_area;
2593    a->active = (BytePtr) tcr->save_tsp;
2594  } else {
2595    /* In ff-call; get area active pointers from tcr */
2596    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2597    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2598  }
2599  if (cur_allocptr) {
2600    update_bytes_allocated(tcr, cur_allocptr);
2601  }
2602  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2603  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2604    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2605  }
2606}
2607
2608
2609/* Suspend and "normalize" other tcrs, then call a gc-like function
2610   in that context.  Resume the other tcrs, then return what the
2611   function returned */
2612
2613TCR *gc_tcr = NULL;
2614
2615
2616signed_natural
2617gc_like_from_xp(ExceptionInformation *xp, 
2618                signed_natural(*fun)(TCR *, signed_natural), 
2619                signed_natural param)
2620{
2621  TCR *tcr = get_tcr(false), *other_tcr;
2622  int result;
2623  signed_natural inhibit;
2624
2625  suspend_other_threads(true);
2626  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2627  if (inhibit != 0) {
2628    if (inhibit > 0) {
2629      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2630    }
2631    resume_other_threads(true);
2632    gc_deferred++;
2633    return 0;
2634  }
2635  gc_deferred = 0;
2636
2637  gc_tcr = tcr;
2638
2639  /* This is generally necessary if the current thread invoked the GC
2640     via an alloc trap, and harmless if the GC was invoked via a GC
2641     trap.  (It's necessary in the first case because the "allocptr"
2642     register - %rbx - may be pointing into the middle of something
2643     below tcr->save_allocbase, and we wouldn't want the GC to see
2644     that bogus pointer.) */
2645  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2646
2647  normalize_tcr(xp, tcr, false);
2648
2649
2650  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2651    if (other_tcr->pending_exception_context) {
2652      other_tcr->gc_context = other_tcr->pending_exception_context;
2653    } else if (other_tcr->valence == TCR_STATE_LISP) {
2654      other_tcr->gc_context = other_tcr->suspend_context;
2655    } else {
2656      /* no pending exception, didn't suspend in lisp state:
2657         must have executed a synchronous ff-call.
2658      */
2659      other_tcr->gc_context = NULL;
2660    }
2661    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2662  }
2663   
2664
2665
2666  result = fun(tcr, param);
2667
2668  other_tcr = tcr;
2669  do {
2670    other_tcr->gc_context = NULL;
2671    other_tcr = other_tcr->next;
2672  } while (other_tcr != tcr);
2673
2674  gc_tcr = NULL;
2675
2676  resume_other_threads(true);
2677
2678  return result;
2679
2680}
2681
2682signed_natural
2683purify_from_xp(ExceptionInformation *xp, signed_natural param)
2684{
2685  return gc_like_from_xp(xp, purify, param);
2686}
2687
2688signed_natural
2689impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2690{
2691  return gc_like_from_xp(xp, impurify, param);
2692}
2693
2694/* Returns #bytes freed by invoking GC */
2695
2696signed_natural
2697gc_from_tcr(TCR *tcr, signed_natural param)
2698{
2699  area *a;
2700  BytePtr oldfree, newfree;
2701  BytePtr oldend, newend;
2702
2703#if 0
2704  fprintf(stderr, "Start GC  in 0x" LISP "\n", tcr);
2705#endif
2706  a = active_dynamic_area;
2707  oldend = a->high;
2708  oldfree = a->active;
2709  gc(tcr, param);
2710  newfree = a->active;
2711  newend = a->high;
2712#if 0
2713  fprintf(stderr, "End GC  in 0x" LISP "\n", tcr);
2714#endif
2715  return ((oldfree-newfree)+(newend-oldend));
2716}
2717
2718signed_natural
2719gc_from_xp(ExceptionInformation *xp, signed_natural param)
2720{
2721  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2722
2723  freeGCptrs();
2724  return status;
2725}
2726
2727#ifdef DARWIN
2728
2729#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2730#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2731
2732extern void pseudo_sigreturn(void);
2733
2734
2735
2736#define LISP_EXCEPTIONS_HANDLED_MASK \
2737 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2738
2739/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2740#define NUM_LISP_EXCEPTIONS_HANDLED 4
2741
2742typedef struct {
2743  int foreign_exception_port_count;
2744  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2745  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2746  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2747  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2748} MACH_foreign_exception_state;
2749
2750
2751
2752
2753/*
2754  Mach's exception mechanism works a little better than its signal
2755  mechanism (and, not incidentally, it gets along with GDB a lot
2756  better.
2757
2758  Initially, we install an exception handler to handle each native
2759  thread's exceptions.  This process involves creating a distinguished
2760  thread which listens for kernel exception messages on a set of
2761  0 or more thread exception ports.  As threads are created, they're
2762  added to that port set; a thread's exception port is destroyed
2763  (and therefore removed from the port set) when the thread exits.
2764
2765  A few exceptions can be handled directly in the handler thread;
2766  others require that we resume the user thread (and that the
2767  exception thread resumes listening for exceptions.)  The user
2768  thread might eventually want to return to the original context
2769  (possibly modified somewhat.)
2770
2771  As it turns out, the simplest way to force the faulting user
2772  thread to handle its own exceptions is to do pretty much what
2773  signal() does: the exception handlng thread sets up a sigcontext
2774  on the user thread's stack and forces the user thread to resume
2775  execution as if a signal handler had been called with that
2776  context as an argument.  We can use a distinguished UUO at a
2777  distinguished address to do something like sigreturn(); that'll
2778  have the effect of resuming the user thread's execution in
2779  the (pseudo-) signal context.
2780
2781  Since:
2782    a) we have miles of code in C and in Lisp that knows how to
2783    deal with Linux sigcontexts
2784    b) Linux sigcontexts contain a little more useful information
2785    (the DAR, DSISR, etc.) than their Darwin counterparts
2786    c) we have to create a sigcontext ourselves when calling out
2787    to the user thread: we aren't really generating a signal, just
2788    leveraging existing signal-handling code.
2789
2790  we create a Linux sigcontext struct.
2791
2792  Simple ?  Hopefully from the outside it is ...
2793
2794  We want the process of passing a thread's own context to it to
2795  appear to be atomic: in particular, we don't want the GC to suspend
2796  a thread that's had an exception but has not yet had its user-level
2797  exception handler called, and we don't want the thread's exception
2798  context to be modified by a GC while the Mach handler thread is
2799  copying it around.  On Linux (and on Jaguar), we avoid this issue
2800  because (a) the kernel sets up the user-level signal handler and
2801  (b) the signal handler blocks signals (including the signal used
2802  by the GC to suspend threads) until tcr->xframe is set up.
2803
2804  The GC and the Mach server thread therefore contend for the lock
2805  "mach_exception_lock".  The Mach server thread holds the lock
2806  when copying exception information between the kernel and the
2807  user thread; the GC holds this lock during most of its execution
2808  (delaying exception processing until it can be done without
2809  GC interference.)
2810
2811*/
2812
2813#ifdef PPC64
2814#define C_REDZONE_LEN           320
2815#define C_STK_ALIGN             32
2816#else
2817#define C_REDZONE_LEN           224
2818#define C_STK_ALIGN             16
2819#endif
2820#define C_PARAMSAVE_LEN         64
2821#define C_LINKAGE_LEN           48
2822
2823#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2824
2825void
2826fatal_mach_error(char *format, ...);
2827
2828#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2829
2830
2831void
2832restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2833{
2834  kern_return_t kret;
2835#if WORD_SIZE == 64
2836  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2837#else
2838  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
2839#endif
2840
2841  /* Set the thread's FP state from the pseudosigcontext */
2842#if WORD_SIZE == 64
2843  kret = thread_set_state(thread,
2844                          x86_FLOAT_STATE64,
2845                          (thread_state_t)&(mc->__fs),
2846                          x86_FLOAT_STATE64_COUNT);
2847#else
2848  kret = thread_set_state(thread,
2849                          x86_FLOAT_STATE32,
2850                          (thread_state_t)&(mc->__fs),
2851                          x86_FLOAT_STATE32_COUNT);
2852#endif
2853  MACH_CHECK_ERROR("setting thread FP state", kret);
2854
2855  /* The thread'll be as good as new ... */
2856#if WORD_SIZE == 64
2857  kret = thread_set_state(thread,
2858                          x86_THREAD_STATE64,
2859                          (thread_state_t)&(mc->__ss),
2860                          x86_THREAD_STATE64_COUNT);
2861#else
2862  kret = thread_set_state(thread, 
2863                          x86_THREAD_STATE32,
2864                          (thread_state_t)&(mc->__ss),
2865                          x86_THREAD_STATE32_COUNT);
2866#endif
2867  MACH_CHECK_ERROR("setting thread state", kret);
2868} 
2869
2870/* This code runs in the exception handling thread, in response
2871   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2872   in response to a call to pseudo_sigreturn() from the specified
2873   user thread.
2874   Find that context (the user thread's R3 points to it), then
2875   use that context to set the user thread's state.  When this
2876   function's caller returns, the Mach kernel will resume the
2877   user thread.
2878*/
2879
2880kern_return_t
2881do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2882{
2883  ExceptionInformation *xp;
2884
2885#ifdef DEBUG_MACH_EXCEPTIONS
2886  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2887#endif
2888  xp = tcr->pending_exception_context;
2889  if (xp) {
2890    tcr->pending_exception_context = NULL;
2891    tcr->valence = TCR_STATE_LISP;
2892    restore_mach_thread_state(thread, xp);
2893    raise_pending_interrupt(tcr);
2894  } else {
2895    Bug(NULL, "no xp here!\n");
2896  }
2897#ifdef DEBUG_MACH_EXCEPTIONS
2898  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2899#endif
2900  return KERN_SUCCESS;
2901} 
2902
2903ExceptionInformation *
2904create_thread_context_frame(mach_port_t thread, 
2905                            natural *new_stack_top,
2906                            siginfo_t **info_ptr,
2907                            TCR *tcr,
2908#ifdef X8664
2909                            x86_thread_state64_t *ts
2910#else
2911                            x86_thread_state32_t *ts
2912#endif
2913                            )
2914{
2915  mach_msg_type_number_t thread_state_count;
2916  ExceptionInformation *pseudosigcontext;
2917#ifdef X8664
2918  MCONTEXT_T mc;
2919#else
2920  mcontext_t mc;
2921#endif
2922  natural stackp;
2923
2924#ifdef X8664 
2925  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2926  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2927#else
2928  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
2929#endif
2930  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2931  if (info_ptr) {
2932    *info_ptr = (siginfo_t *)stackp;
2933  }
2934  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2935  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2936
2937  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2938  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2939 
2940  memmove(&(mc->__ss),ts,sizeof(*ts));
2941
2942#ifdef X8664
2943  thread_state_count = x86_FLOAT_STATE64_COUNT;
2944  thread_get_state(thread,
2945                   x86_FLOAT_STATE64,
2946                   (thread_state_t)&(mc->__fs),
2947                   &thread_state_count);
2948
2949  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2950  thread_get_state(thread,
2951                   x86_EXCEPTION_STATE64,
2952                   (thread_state_t)&(mc->__es),
2953                   &thread_state_count);
2954#else
2955  thread_state_count = x86_FLOAT_STATE32_COUNT;
2956  thread_get_state(thread,
2957                   x86_FLOAT_STATE32,
2958                   (thread_state_t)&(mc->__fs),
2959                   &thread_state_count);
2960
2961  thread_state_count = x86_EXCEPTION_STATE32_COUNT;
2962  thread_get_state(thread,
2963                   x86_EXCEPTION_STATE32,
2964                   (thread_state_t)&(mc->__es),
2965                   &thread_state_count);
2966#endif
2967
2968
2969  UC_MCONTEXT(pseudosigcontext) = mc;
2970  if (new_stack_top) {
2971    *new_stack_top = stackp;
2972  }
2973  return pseudosigcontext;
2974}
2975
2976/*
2977  This code sets up the user thread so that it executes a "pseudo-signal
2978  handler" function when it resumes.  Create a fake ucontext struct
2979  on the thread's stack and pass it as an argument to the pseudo-signal
2980  handler.
2981
2982  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2983  which will restore the thread's context.
2984
2985  If the handler invokes code that throws (or otherwise never sigreturn()'s
2986  to the context), that's fine.
2987
2988  Actually, check that: throw (and variants) may need to be careful and
2989  pop the tcr's xframe list until it's younger than any frame being
2990  entered.
2991*/
2992
2993int
2994setup_signal_frame(mach_port_t thread,
2995                   void *handler_address,
2996                   int signum,
2997                   int code,
2998                   TCR *tcr,
2999#ifdef X8664
3000                   x86_thread_state64_t *ts
3001#else
3002                   x86_thread_state32_t *ts
3003#endif
3004                   )
3005{
3006#ifdef X8664
3007  x86_thread_state64_t new_ts;
3008#else
3009  x86_thread_state32_t new_ts;
3010#endif
3011  ExceptionInformation *pseudosigcontext;
3012  int  old_valence = tcr->valence;
3013  natural stackp, *stackpp;
3014  siginfo_t *info;
3015
3016#ifdef DEBUG_MACH_EXCEPTIONS
3017  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
3018#endif
3019  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
3020  bzero(info, sizeof(*info));
3021  info->si_code = code;
3022  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
3023  info->si_signo = signum;
3024  pseudosigcontext->uc_onstack = 0;
3025  pseudosigcontext->uc_sigmask = (sigset_t) 0;
3026  pseudosigcontext->uc_stack.ss_sp = 0;
3027  pseudosigcontext->uc_stack.ss_size = 0;
3028  pseudosigcontext->uc_stack.ss_flags = 0;
3029  pseudosigcontext->uc_link = NULL;
3030  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
3031  tcr->pending_exception_context = pseudosigcontext;
3032  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
3033 
3034
3035  /*
3036     It seems like we've created a  sigcontext on the thread's
3037     stack.  Set things up so that we call the handler (with appropriate
3038     args) when the thread's resumed.
3039  */
3040
3041#ifdef X8664
3042  new_ts.__rip = (natural) handler_address;
3043  stackpp = (natural *)stackp;
3044  *--stackpp = (natural)pseudo_sigreturn;
3045  stackp = (natural)stackpp;
3046  new_ts.__rdi = signum;
3047  new_ts.__rsi = (natural)info;
3048  new_ts.__rdx = (natural)pseudosigcontext;
3049  new_ts.__rcx = (natural)tcr;
3050  new_ts.__r8 = (natural)old_valence;
3051  new_ts.__rsp = stackp;
3052  new_ts.__rflags = ts->__rflags;
3053#else
3054#define USER_CS 0x17
3055#define USER_DS 0x1f
3056  bzero(&new_ts, sizeof(new_ts));
3057  new_ts.__cs = ts->__cs;
3058  new_ts.__ss = ts->__ss;
3059  new_ts.__ds = ts->__ds;
3060  new_ts.__es = ts->__es;
3061  new_ts.__fs = ts->__fs;
3062  new_ts.__gs = ts->__gs;
3063
3064  new_ts.__eip = (natural)handler_address;
3065  stackpp = (natural *)stackp;
3066  *--stackpp = 0;               /* alignment */
3067  *--stackpp = 0;
3068  *--stackpp = 0;
3069  *--stackpp = (natural)old_valence;
3070  *--stackpp = (natural)tcr;
3071  *--stackpp = (natural)pseudosigcontext;
3072  *--stackpp = (natural)info;
3073  *--stackpp = (natural)signum;
3074  *--stackpp = (natural)pseudo_sigreturn;
3075  stackp = (natural)stackpp;
3076  new_ts.__esp = stackp;
3077  new_ts.__eflags = ts->__eflags;
3078#endif
3079
3080#ifdef X8664
3081  thread_set_state(thread,
3082                   x86_THREAD_STATE64,
3083                   (thread_state_t)&new_ts,
3084                   x86_THREAD_STATE64_COUNT);
3085#else
3086  thread_set_state(thread, 
3087                   x86_THREAD_STATE32,
3088                   (thread_state_t)&new_ts,
3089                   x86_THREAD_STATE32_COUNT);
3090#endif
3091#ifdef DEBUG_MACH_EXCEPTIONS
3092  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3093#endif
3094  return 0;
3095}
3096
3097
3098
3099
3100
3101
3102/*
3103  This function runs in the exception handling thread.  It's
3104  called (by this precise name) from the library function "exc_server()"
3105  when the thread's exception ports are set up.  (exc_server() is called
3106  via mach_msg_server(), which is a function that waits for and dispatches
3107  on exception messages from the Mach kernel.)
3108
3109  This checks to see if the exception was caused by a pseudo_sigreturn()
3110  UUO; if so, it arranges for the thread to have its state restored
3111  from the specified context.
3112
3113  Otherwise, it tries to map the exception to a signal number and
3114  arranges that the thread run a "pseudo signal handler" to handle
3115  the exception.
3116
3117  Some exceptions could and should be handled here directly.
3118*/
3119
3120/* We need the thread's state earlier on x86_64 than we did on PPC;
3121   the PC won't fit in code_vector[1].  We shouldn't try to get it
3122   lazily (via catch_exception_raise_state()); until we own the
3123   exception lock, we shouldn't have it in userspace (since a GCing
3124   thread wouldn't know that we had our hands on it.)
3125*/
3126
3127#ifdef X8664
3128#define ts_pc(t) t.__rip
3129#else
3130#define ts_pc(t) t.__eip
3131#endif
3132
3133#ifdef DARWIN_USE_PSEUDO_SIGRETURN
3134#define DARWIN_EXCEPTION_HANDLER signal_handler
3135#else
3136#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
3137#endif
3138
3139
3140kern_return_t
3141catch_exception_raise(mach_port_t exception_port,
3142                      mach_port_t thread,
3143                      mach_port_t task, 
3144                      exception_type_t exception,
3145                      exception_data_t code_vector,
3146                      mach_msg_type_number_t code_count)
3147{
3148  int signum = 0, code = *code_vector;
3149  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3150  kern_return_t kret, call_kret;
3151#ifdef X8664
3152  x86_thread_state64_t ts;
3153#else
3154  x86_thread_state32_t ts;
3155#endif
3156  mach_msg_type_number_t thread_state_count;
3157
3158
3159
3160#ifdef DEBUG_MACH_EXCEPTIONS
3161  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
3162#endif
3163
3164
3165  if (1) {
3166#ifdef X8664
3167    do {
3168      thread_state_count = x86_THREAD_STATE64_COUNT;
3169      call_kret = thread_get_state(thread,
3170                                   x86_THREAD_STATE64,
3171                                   (thread_state_t)&ts,
3172                                   &thread_state_count);
3173    } while (call_kret == KERN_ABORTED);
3174  MACH_CHECK_ERROR("getting thread state",call_kret);
3175#else
3176    thread_state_count = x86_THREAD_STATE32_COUNT;
3177    call_kret = thread_get_state(thread,
3178                                 x86_THREAD_STATE32,
3179                                 (thread_state_t)&ts,
3180                                 &thread_state_count);
3181    MACH_CHECK_ERROR("getting thread state",call_kret);
3182#endif
3183    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3184      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3185    } 
3186    if ((code == EXC_I386_GPFLT) &&
3187        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3188      kret = do_pseudo_sigreturn(thread, tcr);
3189#if 0
3190      fprintf(stderr, "Exception return in 0x%x\n",tcr);
3191#endif
3192    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3193      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3194      kret = 17;
3195    } else {
3196      switch (exception) {
3197      case EXC_BAD_ACCESS:
3198        if (code == EXC_I386_GPFLT) {
3199          signum = SIGSEGV;
3200        } else {
3201          signum = SIGBUS;
3202        }
3203        break;
3204       
3205      case EXC_BAD_INSTRUCTION:
3206        if (code == EXC_I386_GPFLT) {
3207          signum = SIGSEGV;
3208        } else {
3209          signum = SIGILL;
3210        }
3211        break;
3212         
3213      case EXC_SOFTWARE:
3214        signum = SIGILL;
3215        break;
3216       
3217      case EXC_ARITHMETIC:
3218        signum = SIGFPE;
3219        break;
3220       
3221      default:
3222        break;
3223      }
3224      if (signum) {
3225        kret = setup_signal_frame(thread,
3226                                  (void *)DARWIN_EXCEPTION_HANDLER,
3227                                  signum,
3228                                  code,
3229                                  tcr, 
3230                                  &ts);
3231#if 0
3232        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
3233#endif
3234       
3235      } else {
3236        kret = 17;
3237      }
3238    }
3239  }
3240  return kret;
3241}
3242
3243
3244
3245
3246static mach_port_t mach_exception_thread = (mach_port_t)0;
3247
3248
3249/*
3250  The initial function for an exception-handling thread.
3251*/
3252
3253void *
3254exception_handler_proc(void *arg)
3255{
3256  extern boolean_t exc_server();
3257  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3258
3259  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3260  mach_msg_server(exc_server, 256, p, 0);
3261  /* Should never return. */
3262  abort();
3263}
3264
3265
3266
3267void
3268mach_exception_thread_shutdown()
3269{
3270  kern_return_t kret;
3271
3272  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
3273  kret = thread_terminate(mach_exception_thread);
3274  if (kret != KERN_SUCCESS) {
3275    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
3276  }
3277}
3278
3279
3280mach_port_t
3281mach_exception_port_set()
3282{
3283  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3284  kern_return_t kret; 
3285  if (__exception_port_set == MACH_PORT_NULL) {
3286
3287    kret = mach_port_allocate(mach_task_self(),
3288                              MACH_PORT_RIGHT_PORT_SET,
3289                              &__exception_port_set);
3290    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3291    create_system_thread(0,
3292                         NULL,
3293                         exception_handler_proc, 
3294                         (void *)((natural)__exception_port_set));
3295  }
3296  return __exception_port_set;
3297}
3298
3299/*
3300  Setup a new thread to handle those exceptions specified by
3301  the mask "which".  This involves creating a special Mach
3302  message port, telling the Mach kernel to send exception
3303  messages for the calling thread to that port, and setting
3304  up a handler thread which listens for and responds to
3305  those messages.
3306
3307*/
3308
3309/*
3310  Establish the lisp thread's TCR as its exception port, and determine
3311  whether any other ports have been established by foreign code for
3312  exceptions that lisp cares about.
3313
3314  If this happens at all, it should happen on return from foreign
3315  code and on entry to lisp code via a callback.
3316
3317  This is a lot of trouble (and overhead) to support Java, or other
3318  embeddable systems that clobber their caller's thread exception ports.
3319 
3320*/
3321kern_return_t
3322tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3323{
3324  kern_return_t kret;
3325  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3326  int i;
3327  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3328  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3329  exception_mask_t mask = 0;
3330
3331  kret = thread_swap_exception_ports(thread,
3332                                     LISP_EXCEPTIONS_HANDLED_MASK,
3333                                     lisp_port,
3334                                     EXCEPTION_DEFAULT,
3335                                     THREAD_STATE_NONE,
3336                                     fxs->masks,
3337                                     &n,
3338                                     fxs->ports,
3339                                     fxs->behaviors,
3340                                     fxs->flavors);
3341  if (kret == KERN_SUCCESS) {
3342    fxs->foreign_exception_port_count = n;
3343    for (i = 0; i < n; i ++) {
3344      foreign_port = fxs->ports[i];
3345
3346      if ((foreign_port != lisp_port) &&
3347          (foreign_port != MACH_PORT_NULL)) {
3348        mask |= fxs->masks[i];
3349      }
3350    }
3351    tcr->foreign_exception_status = (int) mask;
3352  }
3353  return kret;
3354}
3355
3356kern_return_t
3357tcr_establish_lisp_exception_port(TCR *tcr)
3358{
3359  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3360}
3361
3362/*
3363  Do this when calling out to or returning from foreign code, if
3364  any conflicting foreign exception ports were established when we
3365  last entered lisp code.
3366*/
3367kern_return_t
3368restore_foreign_exception_ports(TCR *tcr)
3369{
3370  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3371 
3372  if (m) {
3373    MACH_foreign_exception_state *fxs  = 
3374      (MACH_foreign_exception_state *) tcr->native_thread_info;
3375    int i, n = fxs->foreign_exception_port_count;
3376    exception_mask_t tm;
3377
3378    for (i = 0; i < n; i++) {
3379      if ((tm = fxs->masks[i]) & m) {
3380        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3381                                   tm,
3382                                   fxs->ports[i],
3383                                   fxs->behaviors[i],
3384                                   fxs->flavors[i]);
3385      }
3386    }
3387  }
3388}
3389                                   
3390
3391/*
3392  This assumes that a Mach port (to be used as the thread's exception port) whose
3393  "name" matches the TCR's 32-bit address has already been allocated.
3394*/
3395
3396kern_return_t
3397setup_mach_exception_handling(TCR *tcr)
3398{
3399  mach_port_t
3400    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3401    task_self = mach_task_self();
3402  kern_return_t kret;
3403
3404  kret = mach_port_insert_right(task_self,
3405                                thread_exception_port,
3406                                thread_exception_port,
3407                                MACH_MSG_TYPE_MAKE_SEND);
3408  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3409
3410  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3411  if (kret == KERN_SUCCESS) {
3412    mach_port_t exception_port_set = mach_exception_port_set();
3413
3414    kret = mach_port_move_member(task_self,
3415                                 thread_exception_port,
3416                                 exception_port_set);
3417  }
3418  return kret;
3419}
3420
3421void
3422darwin_exception_init(TCR *tcr)
3423{
3424  void tcr_monitor_exception_handling(TCR*, Boolean);
3425  kern_return_t kret;
3426  MACH_foreign_exception_state *fxs = 
3427    calloc(1, sizeof(MACH_foreign_exception_state));
3428 
3429  tcr->native_thread_info = (void *) fxs;
3430
3431  if ((kret = setup_mach_exception_handling(tcr))
3432      != KERN_SUCCESS) {
3433    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
3434    terminate_lisp();
3435  }
3436  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
3437  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
3438}
3439
3440/*
3441  The tcr is the "name" of the corresponding thread's exception port.
3442  Destroying the port should remove it from all port sets of which it's
3443  a member (notably, the exception port set.)
3444*/
3445void
3446darwin_exception_cleanup(TCR *tcr)
3447{
3448  void *fxs = tcr->native_thread_info;
3449  extern Boolean use_mach_exception_handling;
3450
3451  if (fxs) {
3452    tcr->native_thread_info = NULL;
3453    free(fxs);
3454  }
3455  if (use_mach_exception_handling) {
3456    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3457    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3458  }
3459}
3460
3461
3462Boolean
3463suspend_mach_thread(mach_port_t mach_thread)
3464{
3465  kern_return_t status;
3466  Boolean aborted = false;
3467 
3468  do {
3469    aborted = false;
3470    status = thread_suspend(mach_thread);
3471    if (status == KERN_SUCCESS) {
3472      status = thread_abort_safely(mach_thread);
3473      if (status == KERN_SUCCESS) {
3474        aborted = true;
3475      } else {
3476        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
3477        thread_resume(mach_thread);
3478      }
3479    } else {
3480      return false;
3481    }
3482  } while (! aborted);
3483  return true;
3484}
3485
3486/*
3487  Only do this if pthread_kill indicated that the pthread isn't
3488  listening to signals anymore, as can happen as soon as pthread_exit()
3489  is called on Darwin.  The thread could still call out to lisp as it
3490  is exiting, so we need another way to suspend it in this case.
3491*/
3492Boolean
3493mach_suspend_tcr(TCR *tcr)
3494{
3495  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
3496  ExceptionInformation *pseudosigcontext;
3497  Boolean result = false;
3498 
3499  result = suspend_mach_thread(mach_thread);
3500  if (result) {
3501    mach_msg_type_number_t thread_state_count;
3502#ifdef X8664
3503    x86_thread_state64_t ts;
3504    thread_state_count = x86_THREAD_STATE64_COUNT;
3505    thread_get_state(mach_thread,
3506                     x86_THREAD_STATE64,
3507                     (thread_state_t)&ts,
3508                     &thread_state_count);
3509#else
3510    x86_thread_state32_t ts;
3511    thread_state_count = x86_THREAD_STATE_COUNT;
3512    thread_get_state(mach_thread,
3513                     x86_THREAD_STATE,
3514                     (thread_state_t)&ts,
3515                     &thread_state_count);
3516#endif
3517
3518    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
3519    pseudosigcontext->uc_onstack = 0;
3520    pseudosigcontext->uc_sigmask = (sigset_t) 0;
3521    tcr->suspend_context = pseudosigcontext;
3522  }
3523  return result;
3524}
3525
3526void
3527mach_resume_tcr(TCR *tcr)
3528{
3529  ExceptionInformation *xp;
3530  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3531 
3532  xp = tcr->suspend_context;
3533#ifdef DEBUG_MACH_EXCEPTIONS
3534  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3535          tcr, tcr->pending_exception_context);
3536#endif
3537  tcr->suspend_context = NULL;
3538  restore_mach_thread_state(mach_thread, xp);
3539#ifdef DEBUG_MACH_EXCEPTIONS
3540  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3541          tcr, tcr->pending_exception_context);
3542#endif
3543  thread_resume(mach_thread);
3544}
3545
3546void
3547fatal_mach_error(char *format, ...)
3548{
3549  va_list args;
3550  char s[512];
3551 
3552
3553  va_start(args, format);
3554  vsnprintf(s, sizeof(s),format, args);
3555  va_end(args);
3556
3557  Fatal("Mach error", s);
3558}
3559
3560
3561
3562
3563#endif
Note: See TracBrowser for help on using the repository browser.