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

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

Don't define or reference 'bogus_signal_handler()' on Darwin, which
was only defined to catch some long-forgotten bug.

With no signal handler in place for synchronous, thread-targeted
signals (traps/faults) on Darwin, Apple's crash reporting mechanism
can be invoked if catch_exception_raise() returns something non-zero.
(Apple's crash reporting mechanism is very likely to be even more
useless for lisp debugging, but it may be easier to let people discover
that for themselves than to keep explaining why the crash reporting
mechanism isn't invoked.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 95.1 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, Boolean);
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, egc_was_enabled);
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
1353
1354
1355#ifdef LINUX
1356/* type of pointer to saved fp state */
1357#ifdef X8664
1358typedef fpregset_t FPREGS;
1359#else
1360typedef struct _fpstate *FPREGS;
1361#endif
1362LispObj *
1363copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1364{
1365  FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest;
1366 
1367  if (src) {
1368    dest = ((FPREGS)current)-1;
1369    *dest = *src;
1370    *destptr = dest;
1371    current = (LispObj *) dest;
1372  }
1373  return current;
1374}
1375#endif
1376
1377#ifdef DARWIN
1378LispObj *
1379copy_darwin_mcontext(MCONTEXT_T context, 
1380                     LispObj *current, 
1381                     MCONTEXT_T *out)
1382{
1383  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1384  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1385
1386  *dest = *context;
1387  *out = dest;
1388  return (LispObj *)dest;
1389}
1390#endif
1391
1392LispObj *
1393copy_siginfo(siginfo_t *info, LispObj *current)
1394{
1395  siginfo_t *dest = ((siginfo_t *)current) - 1;
1396#if !defined(LINUX) || !defined(X8632)
1397  dest = (siginfo_t *) (((LispObj)dest)&~15);
1398#endif
1399  *dest = *info;
1400  return (LispObj *)dest;
1401}
1402
1403#ifdef LINUX
1404typedef FPREGS copy_ucontext_last_arg_t;
1405#else
1406typedef void * copy_ucontext_last_arg_t;
1407#endif
1408
1409#ifndef WINDOWS
1410LispObj *
1411copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1412{
1413  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1414#if !defined(LINUX) || !defined(X8632)
1415  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1416#endif
1417
1418  *dest = *context;
1419  /* Fix it up a little; where's the signal mask allocated, if indeed
1420     it is "allocated" ? */
1421#ifdef LINUX
1422  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1423#endif
1424  dest->uc_stack.ss_sp = 0;
1425  dest->uc_stack.ss_size = 0;
1426  dest->uc_stack.ss_flags = 0;
1427  dest->uc_link = NULL;
1428  return (LispObj *)dest;
1429}
1430#endif
1431
1432
1433LispObj *
1434find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1435{
1436
1437  if (((BytePtr)rsp < foreign_area->low) ||
1438      ((BytePtr)rsp > foreign_area->high)) {
1439    rsp = (LispObj)(tcr->foreign_sp);
1440  }
1441  return (LispObj *) (((rsp-128) & ~15));
1442}
1443
1444#ifdef X8632
1445#ifdef LINUX
1446/* This is here for debugging.  On entry to a signal handler that
1447   receives info and context arguments, the stack should look exactly
1448   like this.  The "pretcode field" of the structure is the address
1449   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1450   %esp at the time of that syscall to be pointing just past the
1451   pretcode field.
1452   handle_signal_on_foreign_stack() and helpers have to be very
1453   careful to duplicate this "structure" exactly.
1454   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1455   be on top of the stack (with a siginfo_t underneath it.)
1456   It sort of half-works to do sigreturn via setcontext() on
1457   x8632 Linux, but (a) it may not be available on some distributions
1458   and (b) even a relatively modern version of it uses "fldenv" to
1459   restore FP context, and "fldenv" isn't nearly good enough.
1460*/
1461
1462struct rt_sigframe {
1463        char *pretcode;
1464        int sig;
1465        siginfo_t  *pinfo;
1466        void  *puc;
1467        siginfo_t info;
1468        struct ucontext uc;
1469        struct _fpstate fpstate;
1470        char retcode[8];
1471};
1472struct rt_sigframe *rtsf = 0;
1473
1474#endif
1475#endif
1476
1477
1478#ifndef WINDOWS
1479/* x8632 Linux requires that the stack-allocated siginfo is nearer
1480   the top of stack than the stack-allocated ucontext.  If other
1481   platforms care, they expect the ucontext to be nearer the top
1482   of stack.
1483*/
1484
1485#if defined(LINUX) && defined(X8632)
1486#define UCONTEXT_ON_TOP_OF_STACK 0
1487#else
1488#define UCONTEXT_ON_TOP_OF_STACK 1
1489#endif
1490void
1491handle_signal_on_foreign_stack(TCR *tcr,
1492                               void *handler, 
1493                               int signum, 
1494                               siginfo_t *info, 
1495                               ExceptionInformation *context,
1496                               LispObj return_address
1497#ifdef DARWIN_GS_HACK
1498                               , Boolean gs_was_tcr
1499#endif
1500                               )
1501{
1502#ifdef LINUX
1503  FPREGS fpregs = NULL;
1504#else
1505  void *fpregs = NULL;
1506#endif
1507#ifdef DARWIN
1508  MCONTEXT_T mcontextp = NULL;
1509#endif
1510  siginfo_t *info_copy = NULL;
1511  ExceptionInformation *xp = NULL;
1512  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1513
1514#ifdef LINUX
1515  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1516#endif
1517#ifdef DARWIN
1518  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1519#endif
1520#if UCONTEXT_ON_TOP_OF_STACK
1521  /* copy info first */
1522  foreign_rsp = copy_siginfo(info, foreign_rsp);
1523  info_copy = (siginfo_t *)foreign_rsp;
1524  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1525  xp = (ExceptionInformation *)foreign_rsp;
1526#else
1527  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1528  xp = (ExceptionInformation *)foreign_rsp;
1529  foreign_rsp = copy_siginfo(info, foreign_rsp);
1530  info_copy = (siginfo_t *)foreign_rsp;
1531#endif
1532#ifdef DARWIN
1533  UC_MCONTEXT(xp) = mcontextp;
1534#endif
1535  *--foreign_rsp = return_address;
1536#ifdef DARWIN_GS_HACK
1537  if (gs_was_tcr) {
1538    set_gs_address(tcr);
1539  }
1540#endif
1541  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1542}
1543#endif
1544
1545
1546#ifndef WINDOWS
1547#ifndef USE_SIGALTSTACK
1548void
1549arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1550{
1551  TCR *tcr = get_interrupt_tcr(false);
1552#if 1
1553  if (tcr->valence != TCR_STATE_LISP) {
1554    FBug(context, "exception in foreign context");
1555  }
1556#endif
1557  {
1558    area *vs = tcr->vs_area;
1559    BytePtr current_sp = (BytePtr) current_stack_pointer();
1560
1561
1562    if ((current_sp >= vs->low) &&
1563        (current_sp < vs->high)) {
1564      handle_signal_on_foreign_stack(tcr,
1565                                     signal_handler,
1566                                     signum,
1567                                     info,
1568                                     context,
1569                                     (LispObj)__builtin_return_address(0)
1570#ifdef DARWIN_GS_HACK
1571                                     , false
1572#endif
1573
1574                                     );
1575    } else {
1576      signal_handler(signum, info, context, tcr, 0);
1577    }
1578  }
1579}
1580
1581#else
1582void
1583altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1584{
1585  TCR* tcr = get_tcr(true);
1586#if 1
1587  if (tcr->valence != TCR_STATE_LISP) {
1588    FBug(context, "exception in foreign context");
1589  }
1590#endif
1591  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1592#ifdef DARWIN_GS_HACK
1593                                 , false
1594#endif
1595);
1596}
1597#endif
1598#endif
1599
1600Boolean
1601stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1602{
1603  area *a = tcr->vs_area;
1604 
1605  return (((BytePtr)stack_pointer <= a->high) &&
1606          ((BytePtr)stack_pointer > a->low));
1607}
1608
1609
1610#ifdef WINDOWS
1611extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1612#endif
1613
1614void
1615interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1616{
1617#ifdef DARWIN_GS_HACK
1618  Boolean gs_was_tcr = ensure_gs_pthread();
1619#endif
1620  TCR *tcr = get_interrupt_tcr(false);
1621  int old_valence = tcr->valence;
1622
1623  if (tcr) {
1624    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1625        (tcr->valence != TCR_STATE_LISP) ||
1626        (tcr->unwinding != 0) ||
1627        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1628#ifdef X8664
1629        ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) {
1630#else
1631        ! stack_pointer_on_vstack_p(xpGPR(context,Iebp), tcr)) {
1632#endif
1633      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1634    } else {
1635      LispObj cmain = nrs_CMAIN.vcell;
1636
1637      if ((fulltag_of(cmain) == fulltag_misc) &&
1638          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1639        /*
1640           This thread can (allegedly) take an interrupt now.
1641        */
1642
1643        xframe_list xframe_link;
1644        signed_natural alloc_displacement = 0;
1645        LispObj
1646          *next_tsp = tcr->next_tsp,
1647          *save_tsp = tcr->save_tsp,
1648          *p,
1649          q;
1650        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1651
1652        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1653           
1654        if (next_tsp != save_tsp) {
1655          tcr->next_tsp = save_tsp;
1656        } else {
1657          next_tsp = NULL;
1658        }
1659        /* have to do this before allowing interrupts */
1660        pc_luser_xp(context, tcr, &alloc_displacement);
1661        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1662        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1663        handle_exception(signum, info, context, tcr, old_valence);
1664        if (alloc_displacement) {
1665          tcr->save_allocptr -= alloc_displacement;
1666        }
1667        if (next_tsp) {
1668          tcr->next_tsp = next_tsp;
1669          p = next_tsp;
1670          while (p != save_tsp) {
1671            *p++ = 0;
1672          }
1673          q = (LispObj)save_tsp;
1674          *next_tsp = q;
1675        }
1676        tcr->flags |= old_foreign_exception;
1677        unlock_exception_lock_in_handler(tcr);
1678#ifndef WINDOWS
1679        exit_signal_handler(tcr, old_valence);
1680#endif
1681      }
1682    }
1683  }
1684#ifdef DARWIN_GS_HACK
1685  if (gs_was_tcr) {
1686    set_gs_address(tcr);
1687  }
1688#endif
1689#ifdef WINDOWS
1690  restore_windows_context(context,tcr,old_valence);
1691#else
1692  SIGRETURN(context);
1693#endif
1694}
1695
1696
1697#ifndef WINDOWS
1698#ifndef USE_SIGALTSTACK
1699void
1700arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1701{
1702#ifdef DARWIN_GS_HACK
1703  Boolean gs_was_tcr = ensure_gs_pthread();
1704#endif
1705  TCR *tcr = get_interrupt_tcr(false);
1706  area *vs = tcr->vs_area;
1707  BytePtr current_sp = (BytePtr) current_stack_pointer();
1708
1709  if ((current_sp >= vs->low) &&
1710      (current_sp < vs->high)) {
1711    handle_signal_on_foreign_stack(tcr,
1712                                   interrupt_handler,
1713                                   signum,
1714                                   info,
1715                                   context,
1716                                   (LispObj)__builtin_return_address(0)
1717#ifdef DARWIN_GS_HACK
1718                                   ,gs_was_tcr
1719#endif
1720                                   );
1721  } else {
1722    /* If we're not on the value stack, we pretty much have to be on
1723       the C stack.  Just run the handler. */
1724#ifdef DARWIN_GS_HACK
1725    if (gs_was_tcr) {
1726      set_gs_address(tcr);
1727    }
1728#endif
1729    interrupt_handler(signum, info, context);
1730  }
1731}
1732
1733#else /* altstack works */
1734 
1735void
1736altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1737{
1738#ifdef DARWIN_GS_HACK
1739  Boolean gs_was_tcr = ensure_gs_pthread();
1740#endif
1741  TCR *tcr = get_interrupt_tcr(false);
1742  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1743#ifdef DARWIN_GS_HACK
1744                                 ,gs_was_tcr
1745#endif
1746                                 );
1747}
1748
1749#endif
1750#endif
1751
1752#ifndef WINDOWS
1753void
1754install_signal_handler(int signo, void * handler)
1755{
1756  struct sigaction sa;
1757 
1758  sa.sa_sigaction = (void *)handler;
1759  sigfillset(&sa.sa_mask);
1760#ifdef FREEBSD
1761  /* Strange FreeBSD behavior wrt synchronous signals */
1762  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1763#endif
1764  sa.sa_flags = 
1765    0 /* SA_RESTART */
1766#ifdef USE_SIGALTSTACK
1767    | SA_ONSTACK
1768#endif
1769    | SA_SIGINFO;
1770
1771  sigaction(signo, &sa, NULL);
1772}
1773#endif
1774
1775#ifdef WINDOWS
1776BOOL
1777CALLBACK ControlEventHandler(DWORD event)
1778{
1779  switch(event) {
1780  case CTRL_C_EVENT:
1781    lisp_global(INTFLAG) = (1 << fixnumshift);
1782    return TRUE;
1783    break;
1784  default:
1785    return FALSE;
1786  }
1787}
1788
1789int
1790map_windows_exception_code_to_posix_signal(DWORD code)
1791{
1792  switch (code) {
1793  case EXCEPTION_ACCESS_VIOLATION:
1794    return SIGSEGV;
1795  case EXCEPTION_FLT_DENORMAL_OPERAND:
1796  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1797  case EXCEPTION_FLT_INEXACT_RESULT:
1798  case EXCEPTION_FLT_INVALID_OPERATION:
1799  case EXCEPTION_FLT_OVERFLOW:
1800  case EXCEPTION_FLT_STACK_CHECK:
1801  case EXCEPTION_FLT_UNDERFLOW:
1802  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1803  case EXCEPTION_INT_OVERFLOW:
1804    return SIGFPE;
1805  case EXCEPTION_PRIV_INSTRUCTION:
1806  case EXCEPTION_ILLEGAL_INSTRUCTION:
1807    return SIGILL;
1808  case EXCEPTION_IN_PAGE_ERROR:
1809    return SIGBUS;
1810  default:
1811    return -1;
1812  }
1813}
1814
1815
1816LONG
1817windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
1818{
1819  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1820  int old_valence, signal_number;
1821  ExceptionInformation *context = exception_pointers->ContextRecord;
1822  siginfo_t *info = exception_pointers->ExceptionRecord;
1823  xframe_list xframes;
1824
1825  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1826  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1827
1828  signal_number = map_windows_exception_code_to_posix_signal(code);
1829 
1830  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
1831    char msg[512];
1832    Boolean foreign = (old_valence != TCR_STATE_LISP);
1833
1834    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));
1835   
1836    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1837      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1838    }
1839  }
1840  unlock_exception_lock_in_handler(tcr);
1841  return restore_windows_context(context, tcr, old_valence);
1842}
1843
1844void
1845setup_exception_handler_call(CONTEXT *context,
1846                             LispObj new_sp,
1847                             void *handler,
1848                             EXCEPTION_POINTERS *new_ep,
1849                             TCR *tcr)
1850{
1851  extern void windows_halt(void);
1852  LispObj *p = (LispObj *)new_sp;
1853#ifdef WIN_64
1854  p-=4;                         /* win64 abi argsave nonsense */
1855  *(--p) = (LispObj)windows_halt;
1856  context->Rsp = (DWORD64)p;
1857  context->Rip = (DWORD64)handler;
1858  context->Rcx = (DWORD64)new_ep;
1859  context->Rdx = (DWORD64)tcr;
1860#else
1861  p-=4;                          /* args on stack, stack aligned */
1862  p[0] = (LispObj)new_ep;
1863  p[1] = (LispObj)tcr;
1864  *(--p) = (LispObj)windows_halt;
1865  context->Esp = (DWORD)p;
1866  context->Eip = (DWORD)handler;
1867#ifdef WIN32_ES_HACK
1868  context->SegEs = context->SegDs;
1869#endif
1870#endif
1871  context->EFlags &= ~0x400;  /* clear direction flag */
1872}
1873
1874void
1875prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
1876                                                     CONTEXT *context,
1877                                                     void *handler,
1878                                                     EXCEPTION_POINTERS *original_ep)
1879{
1880  LispObj foreign_rsp = 
1881    (LispObj) (tcr->foreign_sp - 128) & ~15;
1882  CONTEXT *new_context;
1883  siginfo_t *new_info;
1884  EXCEPTION_POINTERS *new_ep;
1885
1886  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
1887  *new_context = *context;
1888  foreign_rsp = (LispObj)new_context;
1889  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
1890  *new_info = *original_ep->ExceptionRecord;
1891  foreign_rsp = (LispObj)new_info;
1892  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
1893  foreign_rsp = (LispObj)new_ep & ~15;
1894  new_ep->ContextRecord = new_context;
1895  new_ep->ExceptionRecord = new_info;
1896  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
1897}
1898
1899LONG CALLBACK
1900windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
1901{
1902  extern void ensure_safe_for_string_operations(void);
1903  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1904
1905
1906 
1907  if ((code & 0x80000000L) == 0) {
1908    return EXCEPTION_CONTINUE_SEARCH;
1909  } else {
1910    TCR *tcr = get_interrupt_tcr(false);
1911    area *cs = tcr->cs_area;
1912    BytePtr current_sp = (BytePtr) current_stack_pointer();
1913    CONTEXT *context = exception_pointers->ContextRecord;
1914   
1915    ensure_safe_for_string_operations();
1916
1917    if ((current_sp >= cs->low) &&
1918        (current_sp < cs->high)) {
1919      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
1920      FBug(context, "Exception on foreign stack\n");
1921      return EXCEPTION_CONTINUE_EXECUTION;
1922    }
1923
1924    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
1925                                                         context,
1926                                                         windows_exception_handler,
1927                                                         exception_pointers);
1928    return EXCEPTION_CONTINUE_EXECUTION;
1929  }
1930}
1931
1932
1933void
1934install_pmcl_exception_handlers()
1935{
1936  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
1937}
1938#else
1939void
1940install_pmcl_exception_handlers()
1941{
1942#ifndef DARWIN 
1943  void *handler = (void *)
1944#ifdef USE_SIGALTSTACK
1945    altstack_signal_handler
1946#else
1947    arbstack_signal_handler;
1948#endif
1949  ;
1950  install_signal_handler(SIGILL, handler);
1951 
1952  install_signal_handler(SIGBUS, handler);
1953  install_signal_handler(SIGSEGV,handler);
1954  install_signal_handler(SIGFPE, handler);
1955#endif
1956 
1957  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1958#ifdef USE_SIGALTSTACK
1959                         altstack_interrupt_handler
1960#else
1961                         arbstack_interrupt_handler
1962#endif
1963);
1964  signal(SIGPIPE, SIG_IGN);
1965}
1966#endif
1967
1968#ifndef WINDOWS
1969#ifndef USE_SIGALTSTACK
1970void
1971arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1972{
1973#ifdef DARWIN_GS_HACK
1974  Boolean gs_was_tcr = ensure_gs_pthread();
1975#endif
1976  TCR *tcr = get_interrupt_tcr(false);
1977  area *vs = tcr->vs_area;
1978  BytePtr current_sp = (BytePtr) current_stack_pointer();
1979
1980  if ((current_sp >= vs->low) &&
1981      (current_sp < vs->high)) {
1982    handle_signal_on_foreign_stack(tcr,
1983                                   suspend_resume_handler,
1984                                   signum,
1985                                   info,
1986                                   context,
1987                                   (LispObj)__builtin_return_address(0)
1988#ifdef DARWIN_GS_HACK
1989                                   ,gs_was_tcr
1990#endif
1991                                   );
1992  } else {
1993    /* If we're not on the value stack, we pretty much have to be on
1994       the C stack.  Just run the handler. */
1995#ifdef DARWIN_GS_HACK
1996    if (gs_was_tcr) {
1997      set_gs_address(tcr);
1998    }
1999#endif
2000    suspend_resume_handler(signum, info, context);
2001  }
2002}
2003
2004
2005#else /* altstack works */
2006void
2007altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2008{
2009#ifdef DARWIN_GS_HACK
2010  Boolean gs_was_tcr = ensure_gs_pthread();
2011#endif
2012  TCR* tcr = get_tcr(true);
2013  handle_signal_on_foreign_stack(tcr,
2014                                 suspend_resume_handler,
2015                                 signum,
2016                                 info,
2017                                 context,
2018                                 (LispObj)__builtin_return_address(0)
2019#ifdef DARWIN_GS_HACK
2020                                 ,gs_was_tcr
2021#endif
2022                                 );
2023}
2024#endif
2025#endif
2026
2027
2028/* This should only be called when the tcr_area_lock is held */
2029void
2030empty_tcr_stacks(TCR *tcr)
2031{
2032  if (tcr) {
2033    area *a;
2034
2035    tcr->valence = TCR_STATE_FOREIGN;
2036    a = tcr->vs_area;
2037    if (a) {
2038      a->active = a->high;
2039    }
2040    a = tcr->ts_area;
2041    if (a) {
2042      a->active = a->high;
2043    }
2044    a = tcr->cs_area;
2045    if (a) {
2046      a->active = a->high;
2047    }
2048  }
2049}
2050
2051#ifdef WINDOWS
2052void
2053thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2054{
2055}
2056#else
2057void
2058thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2059{
2060#ifdef DARWIN_GS_HACK
2061  Boolean gs_was_tcr = ensure_gs_pthread();
2062#endif
2063  TCR *tcr = get_tcr(false);
2064  sigset_t mask;
2065
2066  sigemptyset(&mask);
2067
2068  empty_tcr_stacks(tcr);
2069
2070  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2071  pthread_exit(NULL);
2072}
2073#endif
2074
2075#ifndef WINDOWS
2076#ifndef USE_SIGALTSTACK
2077void
2078arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2079{
2080#ifdef DARWIN_GS_HACK
2081  Boolean gs_was_tcr = ensure_gs_pthread();
2082#endif
2083  TCR *tcr = get_interrupt_tcr(false);
2084  area *vs = tcr->vs_area;
2085  BytePtr current_sp = (BytePtr) current_stack_pointer();
2086
2087  if ((current_sp >= vs->low) &&
2088      (current_sp < vs->high)) {
2089    handle_signal_on_foreign_stack(tcr,
2090                                   thread_kill_handler,
2091                                   signum,
2092                                   info,
2093                                   context,
2094                                   (LispObj)__builtin_return_address(0)
2095#ifdef DARWIN_GS_HACK
2096                                   ,gs_was_tcr
2097#endif
2098                                   );
2099  } else {
2100    /* If we're not on the value stack, we pretty much have to be on
2101       the C stack.  Just run the handler. */
2102#ifdef DARWIN_GS_HACK
2103    if (gs_was_tcr) {
2104      set_gs_address(tcr);
2105    }
2106#endif
2107    thread_kill_handler(signum, info, context);
2108  }
2109}
2110
2111
2112#else
2113void
2114altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2115{
2116#ifdef DARWIN_GS_HACK
2117  Boolean gs_was_tcr = ensure_gs_pthread();
2118#endif
2119  TCR* tcr = get_tcr(true);
2120  handle_signal_on_foreign_stack(tcr,
2121                                 thread_kill_handler,
2122                                 signum,
2123                                 info,
2124                                 context,
2125                                 (LispObj)__builtin_return_address(0)
2126#ifdef DARWIN_GS_HACK
2127                                 ,gs_was_tcr
2128#endif
2129                                 );
2130}
2131#endif
2132#endif
2133
2134#ifdef USE_SIGALTSTACK
2135#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
2136#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2137#else
2138#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
2139#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2140#endif
2141
2142#ifdef WINDOWS
2143void
2144thread_signal_setup()
2145{
2146}
2147#else
2148void
2149thread_signal_setup()
2150{
2151  thread_suspend_signal = SIG_SUSPEND_THREAD;
2152  thread_kill_signal = SIG_KILL_THREAD;
2153
2154  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
2155  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER);
2156}
2157#endif
2158
2159void
2160enable_fp_exceptions()
2161{
2162}
2163
2164void
2165exception_init()
2166{
2167  install_pmcl_exception_handlers();
2168}
2169
2170void
2171adjust_exception_pc(ExceptionInformation *xp, int delta)
2172{
2173  xpPC(xp) += delta;
2174}
2175
2176/*
2177  Lower (move toward 0) the "end" of the soft protected area associated
2178  with a by a page, if we can.
2179*/
2180
2181void
2182
2183adjust_soft_protection_limit(area *a)
2184{
2185  char *proposed_new_soft_limit = a->softlimit - 4096;
2186  protected_area_ptr p = a->softprot;
2187 
2188  if (proposed_new_soft_limit >= (p->start+16384)) {
2189    p->end = proposed_new_soft_limit;
2190    p->protsize = p->end-p->start;
2191    a->softlimit = proposed_new_soft_limit;
2192  }
2193  protect_area(p);
2194}
2195
2196void
2197restore_soft_stack_limit(unsigned restore_tsp)
2198{
2199  TCR *tcr = get_tcr(false);
2200  area *a;
2201 
2202  if (restore_tsp) {
2203    a = tcr->ts_area;
2204  } else {
2205    a = tcr->vs_area;
2206  }
2207  adjust_soft_protection_limit(a);
2208}
2209
2210
2211#ifdef USE_SIGALTSTACK
2212void
2213setup_sigaltstack(area *a)
2214{
2215  stack_t stack;
2216  stack.ss_sp = a->low;
2217  a->low += SIGSTKSZ*8;
2218  stack.ss_size = SIGSTKSZ*8;
2219  stack.ss_flags = 0;
2220  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2221  if (sigaltstack(&stack, NULL) != 0) {
2222    perror("sigaltstack");
2223    exit(-1);
2224  }
2225}
2226#endif
2227
2228extern opcode egc_write_barrier_start, egc_write_barrier_end,
2229  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2230  egc_store_node_conditional_success_end,
2231  egc_store_node_conditional_success_test,egc_store_node_conditional,
2232  egc_set_hash_key, egc_gvset, egc_rplacd;
2233
2234/* We use (extremely) rigidly defined instruction sequences for consing,
2235   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2236   while consing.
2237
2238   Note that we can usually identify which of these instructions is about
2239   to be executed by a stopped thread without comparing all of the bytes
2240   to those at the stopped program counter, but we generally need to
2241   know the sizes of each of these instructions.
2242*/
2243
2244#ifdef X8664
2245opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2246#ifdef WINDOWS
2247  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2248#else
2249  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2250#endif
2251;
2252opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2253#ifdef WINDOWS
2254  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2255#else
2256  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2257#endif
2258
2259;
2260opcode branch_around_alloc_trap_instruction[] =
2261  {0x77,0x02};
2262opcode alloc_trap_instruction[] =
2263  {0xcd,0xc5};
2264opcode clear_tcr_save_allocptr_tag_instruction[] =
2265#ifdef WINDOWS
2266  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2267#else
2268  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2269#endif
2270;
2271opcode set_allocptr_header_instruction[] =
2272  {0x48,0x89,0x43,0xf3};
2273
2274
2275alloc_instruction_id
2276recognize_alloc_instruction(pc program_counter)
2277{
2278  switch(program_counter[0]) {
2279  case 0xcd: return ID_alloc_trap_instruction;
2280  /* 0x7f is jg, which we used to use here instead of ja */
2281  case 0x7f:
2282  case 0x77: return ID_branch_around_alloc_trap_instruction;
2283  case 0x48: return ID_set_allocptr_header_instruction;
2284#ifdef WINDOWS
2285  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2286  case 0x49:
2287    switch(program_counter[1]) {
2288    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2289    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2290    }
2291#else
2292  case 0x65: 
2293    switch(program_counter[1]) {
2294    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2295    case 0x48:
2296      switch(program_counter[2]) {
2297      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2298      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2299      }
2300    }
2301#endif
2302  default: break;
2303  }
2304  return ID_unrecognized_alloc_instruction;
2305}
2306#endif
2307#ifdef X8632
2308#ifdef WIN32_ES_HACK
2309/* Win32 keeps the TCR in %es */
2310#define TCR_SEG_PREFIX 0x26     /* %es: */
2311#else
2312/* Other platfroms use %fs */
2313#define TCR_SEG_PREFIX 0x64     /* %fs: */
2314#endif
2315opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2316  {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00};
2317opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2318  {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00};
2319opcode branch_around_alloc_trap_instruction[] =
2320  {0x77,0x02};
2321opcode alloc_trap_instruction[] =
2322  {0xcd,0xc5};
2323opcode clear_tcr_save_allocptr_tag_instruction[] =
2324  {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8};
2325opcode set_allocptr_header_instruction[] =
2326  {0x0f,0x7e,0x41,0xfa};
2327
2328alloc_instruction_id
2329recognize_alloc_instruction(pc program_counter)
2330{
2331  switch(program_counter[0]) {
2332  case 0xcd: return ID_alloc_trap_instruction;
2333  /* 0x7f is jg, which we used to use here instead of ja */
2334  case 0x7f:
2335  case 0x77: return ID_branch_around_alloc_trap_instruction;
2336  case 0x0f: return ID_set_allocptr_header_instruction;
2337  case TCR_SEG_PREFIX: 
2338    switch(program_counter[1]) {
2339    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2340    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2341    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2342    }
2343  }
2344  return ID_unrecognized_alloc_instruction;
2345}
2346#endif     
2347
2348void
2349pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2350{
2351  pc program_counter = (pc)xpPC(xp);
2352  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2353
2354  if (allocptr_tag != 0) {
2355    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2356    signed_natural
2357      disp = (allocptr_tag == fulltag_cons) ?
2358      sizeof(cons) - fulltag_cons :
2359#ifdef X8664
2360      xpGPR(xp,Iimm1);
2361#else
2362      xpGPR(xp,Iimm0);
2363#endif
2364    LispObj new_vector;
2365
2366    if ((state == ID_unrecognized_alloc_instruction) ||
2367        ((state == ID_set_allocptr_header_instruction) &&
2368         (allocptr_tag != fulltag_misc))) {
2369      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2370    }
2371    switch(state) {
2372    case ID_set_allocptr_header_instruction:
2373      /* We were consing a vector and we won.  Set the header of the
2374         new vector (in the allocptr register) to the header in %rax
2375         (%mm0 on ia32) and skip over this instruction, then fall into
2376         the next case. */
2377      new_vector = xpGPR(xp,Iallocptr);
2378      deref(new_vector,0) = 
2379#ifdef X8664
2380        xpGPR(xp,Iimm0)
2381#else
2382        xpMMXreg(xp,Imm0)
2383#endif
2384        ;
2385
2386      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2387      /* Fall thru */
2388    case ID_clear_tcr_save_allocptr_tag_instruction:
2389      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2390      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2391      break;
2392    case ID_alloc_trap_instruction:
2393      /* If we're looking at another thread, we're pretty much committed to
2394         taking the trap.  We don't want the allocptr register to be pointing
2395         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2396         was determined above.
2397      */
2398      if (interrupt_displacement == NULL) {
2399        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2400        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2401      } else {
2402        /* Back out, and tell the caller how to resume the allocation attempt */
2403        *interrupt_displacement = disp;
2404        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2405        tcr->save_allocptr += disp;
2406        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2407                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2408                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2409      }
2410      break;
2411    case ID_branch_around_alloc_trap_instruction:
2412      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2413         we might as well finish the allocation.  Otherwise, back out of the
2414         attempt. */
2415      {
2416        int flags = (int)eflags_register(xp);
2417       
2418        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2419            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2420          /* The branch (ja) would have been taken.  Emulate taking it. */
2421          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2422                       sizeof(alloc_trap_instruction));
2423          if (allocptr_tag == fulltag_misc) {
2424            /* Slap the header on the new uvector */
2425            new_vector = xpGPR(xp,Iallocptr);
2426            deref(new_vector,0) = xpGPR(xp,Iimm0);
2427            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2428          }
2429          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2430          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2431        } else {
2432          /* Back up */
2433          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2434                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2435          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2436          if (interrupt_displacement) {
2437            *interrupt_displacement = disp;
2438            tcr->save_allocptr += disp;
2439          } else {
2440            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2441          }
2442        }
2443      }
2444      break;
2445    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2446      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2447      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2448      /* Fall through */
2449    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2450      if (interrupt_displacement) {
2451        tcr->save_allocptr += disp;
2452        *interrupt_displacement = disp;
2453      } else {
2454        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2455      }
2456      break;
2457    default: 
2458      break;
2459    }
2460    return;
2461  }
2462  if ((program_counter >= &egc_write_barrier_start) &&
2463      (program_counter < &egc_write_barrier_end)) {
2464    LispObj *ea = 0, val, root = 0;
2465    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2466    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2467
2468    if (program_counter >= &egc_set_hash_key_conditional) {
2469      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2470          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2471           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2472        /* Back up the PC, try again */
2473        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional;
2474        return;
2475      }
2476      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2477      val = xpGPR(xp,Iarg_z);
2478#ifdef X8664
2479      root = xpGPR(xp,Iarg_x);
2480      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2481#else
2482      root = xpGPR(xp,Itemp1);
2483      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2484#endif
2485      need_memoize_root = true;
2486      need_store = false;
2487      xpGPR(xp,Iarg_z) = t_value;
2488    } else if (program_counter >= &egc_store_node_conditional) {
2489      if ((program_counter < &egc_store_node_conditional_success_test) ||
2490          ((program_counter == &egc_store_node_conditional_success_test) &&
2491           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2492        /* Back up the PC, try again */
2493        xpPC(xp) = (LispObj) &egc_store_node_conditional;
2494        return;
2495      }
2496      if (program_counter >= &egc_store_node_conditional_success_end) {
2497        return;
2498      }
2499
2500      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2501      val = xpGPR(xp,Iarg_z);
2502#ifdef X8664
2503      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2504                                                       xpGPR(xp,Itemp0))));
2505#else
2506      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2507#endif
2508      xpGPR(xp,Iarg_z) = t_value;
2509      need_store = false;
2510    } else if (program_counter >= &egc_set_hash_key) {
2511#ifdef X8664
2512      root = xpGPR(xp,Iarg_x);
2513#else
2514      root = xpGPR(xp,Itemp0);
2515#endif
2516      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2517      val = xpGPR(xp,Iarg_z);
2518      need_memoize_root = true;
2519    } else if (program_counter >= &egc_gvset) {
2520#ifdef X8664
2521      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2522#else
2523      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2524#endif
2525      val = xpGPR(xp,Iarg_z);
2526    } else if (program_counter >= &egc_rplacd) {
2527      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2528      val = xpGPR(xp,Iarg_z);
2529    } else {                      /* egc_rplaca */
2530      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2531      val = xpGPR(xp,Iarg_z);
2532    }
2533    if (need_store) {
2534      *ea = val;
2535    }
2536    if (need_check_memo) {
2537      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
2538      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2539          ((LispObj)ea < val)) {
2540        atomic_set_bit(refbits, bitnumber);
2541        if (need_memoize_root) {
2542          bitnumber = area_dnode(root, lisp_global(HEAP_START));
2543          atomic_set_bit(refbits, bitnumber);
2544        }
2545      }
2546    }
2547    {
2548      /* These subprimitives are called via CALL/RET; need
2549         to pop the return address off the stack and set
2550         the PC there. */
2551      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2552      xpPC(xp) = ra;
2553      xpGPR(xp,Isp)=(LispObj)sp;
2554    }
2555    return;
2556  }
2557}
2558
2559
2560void
2561normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2562{
2563  void *cur_allocptr = (void *)(tcr->save_allocptr);
2564  LispObj lisprsp;
2565  area *a;
2566
2567  if (xp) {
2568    if (is_other_tcr) {
2569      pc_luser_xp(xp, tcr, NULL);
2570    }
2571    a = tcr->vs_area;
2572    lisprsp = xpGPR(xp, Isp);
2573    if (((BytePtr)lisprsp >= a->low) &&
2574        ((BytePtr)lisprsp < a->high)) {
2575      a->active = (BytePtr)lisprsp;
2576    } else {
2577      a->active = (BytePtr) tcr->save_vsp;
2578    }
2579    a = tcr->ts_area;
2580    a->active = (BytePtr) tcr->save_tsp;
2581  } else {
2582    /* In ff-call; get area active pointers from tcr */
2583    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2584    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2585  }
2586  if (cur_allocptr) {
2587    update_bytes_allocated(tcr, cur_allocptr);
2588  }
2589  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2590  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2591    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2592  }
2593}
2594
2595
2596/* Suspend and "normalize" other tcrs, then call a gc-like function
2597   in that context.  Resume the other tcrs, then return what the
2598   function returned */
2599
2600TCR *gc_tcr = NULL;
2601
2602
2603signed_natural
2604gc_like_from_xp(ExceptionInformation *xp, 
2605                signed_natural(*fun)(TCR *, signed_natural), 
2606                signed_natural param)
2607{
2608  TCR *tcr = get_tcr(false), *other_tcr;
2609  int result;
2610  signed_natural inhibit;
2611
2612  suspend_other_threads(true);
2613  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2614  if (inhibit != 0) {
2615    if (inhibit > 0) {
2616      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2617    }
2618    resume_other_threads(true);
2619    gc_deferred++;
2620    return 0;
2621  }
2622  gc_deferred = 0;
2623
2624  gc_tcr = tcr;
2625
2626  /* This is generally necessary if the current thread invoked the GC
2627     via an alloc trap, and harmless if the GC was invoked via a GC
2628     trap.  (It's necessary in the first case because the "allocptr"
2629     register - %rbx - may be pointing into the middle of something
2630     below tcr->save_allocbase, and we wouldn't want the GC to see
2631     that bogus pointer.) */
2632  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2633
2634  normalize_tcr(xp, tcr, false);
2635
2636
2637  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2638    if (other_tcr->pending_exception_context) {
2639      other_tcr->gc_context = other_tcr->pending_exception_context;
2640    } else if (other_tcr->valence == TCR_STATE_LISP) {
2641      other_tcr->gc_context = other_tcr->suspend_context;
2642    } else {
2643      /* no pending exception, didn't suspend in lisp state:
2644         must have executed a synchronous ff-call.
2645      */
2646      other_tcr->gc_context = NULL;
2647    }
2648    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2649  }
2650   
2651
2652
2653  result = fun(tcr, param);
2654
2655  other_tcr = tcr;
2656  do {
2657    other_tcr->gc_context = NULL;
2658    other_tcr = other_tcr->next;
2659  } while (other_tcr != tcr);
2660
2661  gc_tcr = NULL;
2662
2663  resume_other_threads(true);
2664
2665  return result;
2666
2667}
2668
2669signed_natural
2670purify_from_xp(ExceptionInformation *xp, signed_natural param)
2671{
2672  return gc_like_from_xp(xp, purify, param);
2673}
2674
2675signed_natural
2676impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2677{
2678  return gc_like_from_xp(xp, impurify, param);
2679}
2680
2681/* Returns #bytes freed by invoking GC */
2682
2683signed_natural
2684gc_from_tcr(TCR *tcr, signed_natural param)
2685{
2686  area *a;
2687  BytePtr oldfree, newfree;
2688  BytePtr oldend, newend;
2689
2690#if 0
2691  fprintf(stderr, "Start GC  in 0x" LISP "\n", tcr);
2692#endif
2693  a = active_dynamic_area;
2694  oldend = a->high;
2695  oldfree = a->active;
2696  gc(tcr, param);
2697  newfree = a->active;
2698  newend = a->high;
2699#if 0
2700  fprintf(stderr, "End GC  in 0x" LISP "\n", tcr);
2701#endif
2702  return ((oldfree-newfree)+(newend-oldend));
2703}
2704
2705signed_natural
2706gc_from_xp(ExceptionInformation *xp, signed_natural param)
2707{
2708  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2709
2710  freeGCptrs();
2711  return status;
2712}
2713
2714#ifdef DARWIN
2715
2716#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2717#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2718
2719extern void pseudo_sigreturn(void);
2720
2721
2722
2723#define LISP_EXCEPTIONS_HANDLED_MASK \
2724 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2725
2726/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2727#define NUM_LISP_EXCEPTIONS_HANDLED 4
2728
2729typedef struct {
2730  int foreign_exception_port_count;
2731  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2732  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2733  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2734  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2735} MACH_foreign_exception_state;
2736
2737
2738
2739
2740/*
2741  Mach's exception mechanism works a little better than its signal
2742  mechanism (and, not incidentally, it gets along with GDB a lot
2743  better.
2744
2745  Initially, we install an exception handler to handle each native
2746  thread's exceptions.  This process involves creating a distinguished
2747  thread which listens for kernel exception messages on a set of
2748  0 or more thread exception ports.  As threads are created, they're
2749  added to that port set; a thread's exception port is destroyed
2750  (and therefore removed from the port set) when the thread exits.
2751
2752  A few exceptions can be handled directly in the handler thread;
2753  others require that we resume the user thread (and that the
2754  exception thread resumes listening for exceptions.)  The user
2755  thread might eventually want to return to the original context
2756  (possibly modified somewhat.)
2757
2758  As it turns out, the simplest way to force the faulting user
2759  thread to handle its own exceptions is to do pretty much what
2760  signal() does: the exception handlng thread sets up a sigcontext
2761  on the user thread's stack and forces the user thread to resume
2762  execution as if a signal handler had been called with that
2763  context as an argument.  We can use a distinguished UUO at a
2764  distinguished address to do something like sigreturn(); that'll
2765  have the effect of resuming the user thread's execution in
2766  the (pseudo-) signal context.
2767
2768  Since:
2769    a) we have miles of code in C and in Lisp that knows how to
2770    deal with Linux sigcontexts
2771    b) Linux sigcontexts contain a little more useful information
2772    (the DAR, DSISR, etc.) than their Darwin counterparts
2773    c) we have to create a sigcontext ourselves when calling out
2774    to the user thread: we aren't really generating a signal, just
2775    leveraging existing signal-handling code.
2776
2777  we create a Linux sigcontext struct.
2778
2779  Simple ?  Hopefully from the outside it is ...
2780
2781  We want the process of passing a thread's own context to it to
2782  appear to be atomic: in particular, we don't want the GC to suspend
2783  a thread that's had an exception but has not yet had its user-level
2784  exception handler called, and we don't want the thread's exception
2785  context to be modified by a GC while the Mach handler thread is
2786  copying it around.  On Linux (and on Jaguar), we avoid this issue
2787  because (a) the kernel sets up the user-level signal handler and
2788  (b) the signal handler blocks signals (including the signal used
2789  by the GC to suspend threads) until tcr->xframe is set up.
2790
2791  The GC and the Mach server thread therefore contend for the lock
2792  "mach_exception_lock".  The Mach server thread holds the lock
2793  when copying exception information between the kernel and the
2794  user thread; the GC holds this lock during most of its execution
2795  (delaying exception processing until it can be done without
2796  GC interference.)
2797
2798*/
2799
2800#ifdef PPC64
2801#define C_REDZONE_LEN           320
2802#define C_STK_ALIGN             32
2803#else
2804#define C_REDZONE_LEN           224
2805#define C_STK_ALIGN             16
2806#endif
2807#define C_PARAMSAVE_LEN         64
2808#define C_LINKAGE_LEN           48
2809
2810#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2811
2812void
2813fatal_mach_error(char *format, ...);
2814
2815#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2816
2817
2818void
2819restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2820{
2821  kern_return_t kret;
2822#if WORD_SIZE == 64
2823  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2824#else
2825  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
2826#endif
2827
2828  /* Set the thread's FP state from the pseudosigcontext */
2829#if WORD_SIZE == 64
2830  kret = thread_set_state(thread,
2831                          x86_FLOAT_STATE64,
2832                          (thread_state_t)&(mc->__fs),
2833                          x86_FLOAT_STATE64_COUNT);
2834#else
2835  kret = thread_set_state(thread,
2836                          x86_FLOAT_STATE32,
2837                          (thread_state_t)&(mc->__fs),
2838                          x86_FLOAT_STATE32_COUNT);
2839#endif
2840  MACH_CHECK_ERROR("setting thread FP state", kret);
2841
2842  /* The thread'll be as good as new ... */
2843#if WORD_SIZE == 64
2844  kret = thread_set_state(thread,
2845                          x86_THREAD_STATE64,
2846                          (thread_state_t)&(mc->__ss),
2847                          x86_THREAD_STATE64_COUNT);
2848#else
2849  kret = thread_set_state(thread, 
2850                          x86_THREAD_STATE32,
2851                          (thread_state_t)&(mc->__ss),
2852                          x86_THREAD_STATE32_COUNT);
2853#endif
2854  MACH_CHECK_ERROR("setting thread state", kret);
2855} 
2856
2857/* This code runs in the exception handling thread, in response
2858   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2859   in response to a call to pseudo_sigreturn() from the specified
2860   user thread.
2861   Find that context (the user thread's R3 points to it), then
2862   use that context to set the user thread's state.  When this
2863   function's caller returns, the Mach kernel will resume the
2864   user thread.
2865*/
2866
2867kern_return_t
2868do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2869{
2870  ExceptionInformation *xp;
2871
2872#ifdef DEBUG_MACH_EXCEPTIONS
2873  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2874#endif
2875  xp = tcr->pending_exception_context;
2876  if (xp) {
2877    tcr->pending_exception_context = NULL;
2878    tcr->valence = TCR_STATE_LISP;
2879    restore_mach_thread_state(thread, xp);
2880    raise_pending_interrupt(tcr);
2881  } else {
2882    Bug(NULL, "no xp here!\n");
2883  }
2884#ifdef DEBUG_MACH_EXCEPTIONS
2885  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2886#endif
2887  return KERN_SUCCESS;
2888} 
2889
2890ExceptionInformation *
2891create_thread_context_frame(mach_port_t thread, 
2892                            natural *new_stack_top,
2893                            siginfo_t **info_ptr,
2894                            TCR *tcr,
2895#ifdef X8664
2896                            x86_thread_state64_t *ts
2897#else
2898                            x86_thread_state32_t *ts
2899#endif
2900                            )
2901{
2902  mach_msg_type_number_t thread_state_count;
2903  ExceptionInformation *pseudosigcontext;
2904#ifdef X8664
2905  MCONTEXT_T mc;
2906#else
2907  mcontext_t mc;
2908#endif
2909  natural stackp;
2910
2911#ifdef X8664 
2912  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2913  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2914#else
2915  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
2916#endif
2917  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2918  if (info_ptr) {
2919    *info_ptr = (siginfo_t *)stackp;
2920  }
2921  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2922  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2923
2924  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2925  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2926 
2927  memmove(&(mc->__ss),ts,sizeof(*ts));
2928
2929#ifdef X8664
2930  thread_state_count = x86_FLOAT_STATE64_COUNT;
2931  thread_get_state(thread,
2932                   x86_FLOAT_STATE64,
2933                   (thread_state_t)&(mc->__fs),
2934                   &thread_state_count);
2935
2936  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2937  thread_get_state(thread,
2938                   x86_EXCEPTION_STATE64,
2939                   (thread_state_t)&(mc->__es),
2940                   &thread_state_count);
2941#else
2942  thread_state_count = x86_FLOAT_STATE32_COUNT;
2943  thread_get_state(thread,
2944                   x86_FLOAT_STATE32,
2945                   (thread_state_t)&(mc->__fs),
2946                   &thread_state_count);
2947
2948  thread_state_count = x86_EXCEPTION_STATE32_COUNT;
2949  thread_get_state(thread,
2950                   x86_EXCEPTION_STATE32,
2951                   (thread_state_t)&(mc->__es),
2952                   &thread_state_count);
2953#endif
2954
2955
2956  UC_MCONTEXT(pseudosigcontext) = mc;
2957  if (new_stack_top) {
2958    *new_stack_top = stackp;
2959  }
2960  return pseudosigcontext;
2961}
2962
2963/*
2964  This code sets up the user thread so that it executes a "pseudo-signal
2965  handler" function when it resumes.  Create a fake ucontext struct
2966  on the thread's stack and pass it as an argument to the pseudo-signal
2967  handler.
2968
2969  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2970  which will restore the thread's context.
2971
2972  If the handler invokes code that throws (or otherwise never sigreturn()'s
2973  to the context), that's fine.
2974
2975  Actually, check that: throw (and variants) may need to be careful and
2976  pop the tcr's xframe list until it's younger than any frame being
2977  entered.
2978*/
2979
2980int
2981setup_signal_frame(mach_port_t thread,
2982                   void *handler_address,
2983                   int signum,
2984                   int code,
2985                   TCR *tcr,
2986#ifdef X8664
2987                   x86_thread_state64_t *ts
2988#else
2989                   x86_thread_state32_t *ts
2990#endif
2991                   )
2992{
2993#ifdef X8664
2994  x86_thread_state64_t new_ts;
2995#else
2996  x86_thread_state32_t new_ts;
2997#endif
2998  ExceptionInformation *pseudosigcontext;
2999  int  old_valence = tcr->valence;
3000  natural stackp, *stackpp;
3001  siginfo_t *info;
3002
3003#ifdef DEBUG_MACH_EXCEPTIONS
3004  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
3005#endif
3006  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
3007  bzero(info, sizeof(*info));
3008  info->si_code = code;
3009  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
3010  info->si_signo = signum;
3011  pseudosigcontext->uc_onstack = 0;
3012  pseudosigcontext->uc_sigmask = (sigset_t) 0;
3013  pseudosigcontext->uc_stack.ss_sp = 0;
3014  pseudosigcontext->uc_stack.ss_size = 0;
3015  pseudosigcontext->uc_stack.ss_flags = 0;
3016  pseudosigcontext->uc_link = NULL;
3017  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
3018  tcr->pending_exception_context = pseudosigcontext;
3019  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
3020 
3021
3022  /*
3023     It seems like we've created a  sigcontext on the thread's
3024     stack.  Set things up so that we call the handler (with appropriate
3025     args) when the thread's resumed.
3026  */
3027
3028#ifdef X8664
3029  new_ts.__rip = (natural) handler_address;
3030  stackpp = (natural *)stackp;
3031  *--stackpp = (natural)pseudo_sigreturn;
3032  stackp = (natural)stackpp;
3033  new_ts.__rdi = signum;
3034  new_ts.__rsi = (natural)info;
3035  new_ts.__rdx = (natural)pseudosigcontext;
3036  new_ts.__rcx = (natural)tcr;
3037  new_ts.__r8 = (natural)old_valence;
3038  new_ts.__rsp = stackp;
3039  new_ts.__rflags = ts->__rflags;
3040#else
3041#define USER_CS 0x17
3042#define USER_DS 0x1f
3043  bzero(&new_ts, sizeof(new_ts));
3044  new_ts.__cs = ts->__cs;
3045  new_ts.__ss = ts->__ss;
3046  new_ts.__ds = ts->__ds;
3047  new_ts.__es = ts->__es;
3048  new_ts.__fs = ts->__fs;
3049  new_ts.__gs = ts->__gs;
3050
3051  new_ts.__eip = (natural)handler_address;
3052  stackpp = (natural *)stackp;
3053  *--stackpp = 0;               /* alignment */
3054  *--stackpp = 0;
3055  *--stackpp = 0;
3056  *--stackpp = (natural)old_valence;
3057  *--stackpp = (natural)tcr;
3058  *--stackpp = (natural)pseudosigcontext;
3059  *--stackpp = (natural)info;
3060  *--stackpp = (natural)signum;
3061  *--stackpp = (natural)pseudo_sigreturn;
3062  stackp = (natural)stackpp;
3063  new_ts.__esp = stackp;
3064  new_ts.__eflags = ts->__eflags;
3065#endif
3066
3067#ifdef X8664
3068  thread_set_state(thread,
3069                   x86_THREAD_STATE64,
3070                   (thread_state_t)&new_ts,
3071                   x86_THREAD_STATE64_COUNT);
3072#else
3073  thread_set_state(thread, 
3074                   x86_THREAD_STATE32,
3075                   (thread_state_t)&new_ts,
3076                   x86_THREAD_STATE32_COUNT);
3077#endif
3078#ifdef DEBUG_MACH_EXCEPTIONS
3079  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3080#endif
3081  return 0;
3082}
3083
3084
3085
3086
3087
3088
3089/*
3090  This function runs in the exception handling thread.  It's
3091  called (by this precise name) from the library function "exc_server()"
3092  when the thread's exception ports are set up.  (exc_server() is called
3093  via mach_msg_server(), which is a function that waits for and dispatches
3094  on exception messages from the Mach kernel.)
3095
3096  This checks to see if the exception was caused by a pseudo_sigreturn()
3097  UUO; if so, it arranges for the thread to have its state restored
3098  from the specified context.
3099
3100  Otherwise, it tries to map the exception to a signal number and
3101  arranges that the thread run a "pseudo signal handler" to handle
3102  the exception.
3103
3104  Some exceptions could and should be handled here directly.
3105*/
3106
3107/* We need the thread's state earlier on x86_64 than we did on PPC;
3108   the PC won't fit in code_vector[1].  We shouldn't try to get it
3109   lazily (via catch_exception_raise_state()); until we own the
3110   exception lock, we shouldn't have it in userspace (since a GCing
3111   thread wouldn't know that we had our hands on it.)
3112*/
3113
3114#ifdef X8664
3115#define ts_pc(t) t.__rip
3116#else
3117#define ts_pc(t) t.__eip
3118#endif
3119
3120
3121#define DARWIN_EXCEPTION_HANDLER signal_handler
3122
3123
3124kern_return_t
3125catch_exception_raise(mach_port_t exception_port,
3126                      mach_port_t thread,
3127                      mach_port_t task, 
3128                      exception_type_t exception,
3129                      exception_data_t code_vector,
3130                      mach_msg_type_number_t code_count)
3131{
3132  int signum = 0, code = *code_vector;
3133  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3134  kern_return_t kret, call_kret;
3135#ifdef X8664
3136  x86_thread_state64_t ts;
3137#else
3138  x86_thread_state32_t ts;
3139#endif
3140  mach_msg_type_number_t thread_state_count;
3141
3142
3143
3144
3145#ifdef DEBUG_MACH_EXCEPTIONS
3146  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
3147#endif
3148
3149
3150  if (1) {
3151#ifdef X8664
3152    do {
3153      thread_state_count = x86_THREAD_STATE64_COUNT;
3154      call_kret = thread_get_state(thread,
3155                                   x86_THREAD_STATE64,
3156                                   (thread_state_t)&ts,
3157                                   &thread_state_count);
3158    } while (call_kret == KERN_ABORTED);
3159  MACH_CHECK_ERROR("getting thread state",call_kret);
3160#else
3161    thread_state_count = x86_THREAD_STATE32_COUNT;
3162    call_kret = thread_get_state(thread,
3163                                 x86_THREAD_STATE32,
3164                                 (thread_state_t)&ts,
3165                                 &thread_state_count);
3166    MACH_CHECK_ERROR("getting thread state",call_kret);
3167#endif
3168    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3169      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3170    } 
3171    if ((code == EXC_I386_GPFLT) &&
3172        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3173      kret = do_pseudo_sigreturn(thread, tcr);
3174#if 0
3175      fprintf(stderr, "Exception return in 0x%x\n",tcr);
3176#endif
3177    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3178      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3179      kret = 17;
3180    } else {
3181      switch (exception) {
3182      case EXC_BAD_ACCESS:
3183        if (code == EXC_I386_GPFLT) {
3184          signum = SIGSEGV;
3185        } else {
3186          signum = SIGBUS;
3187        }
3188        break;
3189       
3190      case EXC_BAD_INSTRUCTION:
3191        if (code == EXC_I386_GPFLT) {
3192          signum = SIGSEGV;
3193        } else {
3194          signum = SIGILL;
3195        }
3196        break;
3197         
3198      case EXC_SOFTWARE:
3199        signum = SIGILL;
3200        break;
3201       
3202      case EXC_ARITHMETIC:
3203        signum = SIGFPE;
3204        break;
3205       
3206      default:
3207        break;
3208      }
3209      if (signum) {
3210        kret = setup_signal_frame(thread,
3211                                  (void *)DARWIN_EXCEPTION_HANDLER,
3212                                  signum,
3213                                  code,
3214                                  tcr, 
3215                                  &ts);
3216#if 0
3217        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
3218#endif
3219       
3220      } else {
3221        kret = 17;
3222      }
3223    }
3224  }
3225  return kret;
3226}
3227
3228
3229
3230
3231static mach_port_t mach_exception_thread = (mach_port_t)0;
3232
3233
3234/*
3235  The initial function for an exception-handling thread.
3236*/
3237
3238void *
3239exception_handler_proc(void *arg)
3240{
3241  extern boolean_t exc_server();
3242  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3243
3244  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3245  mach_msg_server(exc_server, 256, p, 0);
3246  /* Should never return. */
3247  abort();
3248}
3249
3250
3251
3252void
3253mach_exception_thread_shutdown()
3254{
3255  kern_return_t kret;
3256
3257  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
3258  kret = thread_terminate(mach_exception_thread);
3259  if (kret != KERN_SUCCESS) {
3260    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
3261  }
3262}
3263
3264
3265mach_port_t
3266mach_exception_port_set()
3267{
3268  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3269  kern_return_t kret; 
3270  if (__exception_port_set == MACH_PORT_NULL) {
3271
3272    kret = mach_port_allocate(mach_task_self(),
3273                              MACH_PORT_RIGHT_PORT_SET,
3274                              &__exception_port_set);
3275    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3276    create_system_thread(0,
3277                         NULL,
3278                         exception_handler_proc, 
3279                         (void *)((natural)__exception_port_set));
3280  }
3281  return __exception_port_set;
3282}
3283
3284/*
3285  Setup a new thread to handle those exceptions specified by
3286  the mask "which".  This involves creating a special Mach
3287  message port, telling the Mach kernel to send exception
3288  messages for the calling thread to that port, and setting
3289  up a handler thread which listens for and responds to
3290  those messages.
3291
3292*/
3293
3294/*
3295  Establish the lisp thread's TCR as its exception port, and determine
3296  whether any other ports have been established by foreign code for
3297  exceptions that lisp cares about.
3298
3299  If this happens at all, it should happen on return from foreign
3300  code and on entry to lisp code via a callback.
3301
3302  This is a lot of trouble (and overhead) to support Java, or other
3303  embeddable systems that clobber their caller's thread exception ports.
3304 
3305*/
3306kern_return_t
3307tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3308{
3309  kern_return_t kret;
3310  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3311  int i;
3312  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3313  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3314  exception_mask_t mask = 0;
3315
3316  kret = thread_swap_exception_ports(thread,
3317                                     LISP_EXCEPTIONS_HANDLED_MASK,
3318                                     lisp_port,
3319                                     EXCEPTION_DEFAULT,
3320                                     THREAD_STATE_NONE,
3321                                     fxs->masks,
3322                                     &n,
3323                                     fxs->ports,
3324                                     fxs->behaviors,
3325                                     fxs->flavors);
3326  if (kret == KERN_SUCCESS) {
3327    fxs->foreign_exception_port_count = n;
3328    for (i = 0; i < n; i ++) {
3329      foreign_port = fxs->ports[i];
3330
3331      if ((foreign_port != lisp_port) &&
3332          (foreign_port != MACH_PORT_NULL)) {
3333        mask |= fxs->masks[i];
3334      }
3335    }
3336    tcr->foreign_exception_status = (int) mask;
3337  }
3338  return kret;
3339}
3340
3341kern_return_t
3342tcr_establish_lisp_exception_port(TCR *tcr)
3343{
3344  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3345}
3346
3347/*
3348  Do this when calling out to or returning from foreign code, if
3349  any conflicting foreign exception ports were established when we
3350  last entered lisp code.
3351*/
3352kern_return_t
3353restore_foreign_exception_ports(TCR *tcr)
3354{
3355  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3356 
3357  if (m) {
3358    MACH_foreign_exception_state *fxs  = 
3359      (MACH_foreign_exception_state *) tcr->native_thread_info;
3360    int i, n = fxs->foreign_exception_port_count;
3361    exception_mask_t tm;
3362
3363    for (i = 0; i < n; i++) {
3364      if ((tm = fxs->masks[i]) & m) {
3365        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3366                                   tm,
3367                                   fxs->ports[i],
3368                                   fxs->behaviors[i],
3369                                   fxs->flavors[i]);
3370      }
3371    }
3372  }
3373}
3374                                   
3375
3376/*
3377  This assumes that a Mach port (to be used as the thread's exception port) whose
3378  "name" matches the TCR's 32-bit address has already been allocated.
3379*/
3380
3381kern_return_t
3382setup_mach_exception_handling(TCR *tcr)
3383{
3384  mach_port_t
3385    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3386    task_self = mach_task_self();
3387  kern_return_t kret;
3388
3389  kret = mach_port_insert_right(task_self,
3390                                thread_exception_port,
3391                                thread_exception_port,
3392                                MACH_MSG_TYPE_MAKE_SEND);
3393  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3394
3395  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3396  if (kret == KERN_SUCCESS) {
3397    mach_port_t exception_port_set = mach_exception_port_set();
3398
3399    kret = mach_port_move_member(task_self,
3400                                 thread_exception_port,
3401                                 exception_port_set);
3402  }
3403  return kret;
3404}
3405
3406void
3407darwin_exception_init(TCR *tcr)
3408{
3409  void tcr_monitor_exception_handling(TCR*, Boolean);
3410  kern_return_t kret;
3411  MACH_foreign_exception_state *fxs = 
3412    calloc(1, sizeof(MACH_foreign_exception_state));
3413 
3414  tcr->native_thread_info = (void *) fxs;
3415
3416  if ((kret = setup_mach_exception_handling(tcr))
3417      != KERN_SUCCESS) {
3418    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
3419    terminate_lisp();
3420  }
3421  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
3422  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
3423}
3424
3425/*
3426  The tcr is the "name" of the corresponding thread's exception port.
3427  Destroying the port should remove it from all port sets of which it's
3428  a member (notably, the exception port set.)
3429*/
3430void
3431darwin_exception_cleanup(TCR *tcr)
3432{
3433  void *fxs = tcr->native_thread_info;
3434  extern Boolean use_mach_exception_handling;
3435
3436  if (fxs) {
3437    tcr->native_thread_info = NULL;
3438    free(fxs);
3439  }
3440  if (use_mach_exception_handling) {
3441    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3442    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3443  }
3444}
3445
3446
3447Boolean
3448suspend_mach_thread(mach_port_t mach_thread)
3449{
3450  kern_return_t status;
3451  Boolean aborted = false;
3452 
3453  do {
3454    aborted = false;
3455    status = thread_suspend(mach_thread);
3456    if (status == KERN_SUCCESS) {
3457      status = thread_abort_safely(mach_thread);
3458      if (status == KERN_SUCCESS) {
3459        aborted = true;
3460      } else {
3461        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
3462        thread_resume(mach_thread);
3463      }
3464    } else {
3465      return false;
3466    }
3467  } while (! aborted);
3468  return true;
3469}
3470
3471/*
3472  Only do this if pthread_kill indicated that the pthread isn't
3473  listening to signals anymore, as can happen as soon as pthread_exit()
3474  is called on Darwin.  The thread could still call out to lisp as it
3475  is exiting, so we need another way to suspend it in this case.
3476*/
3477Boolean
3478mach_suspend_tcr(TCR *tcr)
3479{
3480  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
3481  ExceptionInformation *pseudosigcontext;
3482  Boolean result = false;
3483 
3484  result = suspend_mach_thread(mach_thread);
3485  if (result) {
3486    mach_msg_type_number_t thread_state_count;
3487#ifdef X8664
3488    x86_thread_state64_t ts;
3489    thread_state_count = x86_THREAD_STATE64_COUNT;
3490    thread_get_state(mach_thread,
3491                     x86_THREAD_STATE64,
3492                     (thread_state_t)&ts,
3493                     &thread_state_count);
3494#else
3495    x86_thread_state32_t ts;
3496    thread_state_count = x86_THREAD_STATE_COUNT;
3497    thread_get_state(mach_thread,
3498                     x86_THREAD_STATE,
3499                     (thread_state_t)&ts,
3500                     &thread_state_count);
3501#endif
3502
3503    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
3504    pseudosigcontext->uc_onstack = 0;
3505    pseudosigcontext->uc_sigmask = (sigset_t) 0;
3506    tcr->suspend_context = pseudosigcontext;
3507  }
3508  return result;
3509}
3510
3511void
3512mach_resume_tcr(TCR *tcr)
3513{
3514  ExceptionInformation *xp;
3515  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3516 
3517  xp = tcr->suspend_context;
3518#ifdef DEBUG_MACH_EXCEPTIONS
3519  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3520          tcr, tcr->pending_exception_context);
3521#endif
3522  tcr->suspend_context = NULL;
3523  restore_mach_thread_state(mach_thread, xp);
3524#ifdef DEBUG_MACH_EXCEPTIONS
3525  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3526          tcr, tcr->pending_exception_context);
3527#endif
3528  thread_resume(mach_thread);
3529}
3530
3531void
3532fatal_mach_error(char *format, ...)
3533{
3534  va_list args;
3535  char s[512];
3536 
3537
3538  va_start(args, format);
3539  vsnprintf(s, sizeof(s),format, args);
3540  va_end(args);
3541
3542  Fatal("Mach error", s);
3543}
3544
3545
3546
3547
3548#endif
Note: See TracBrowser for help on using the repository browser.