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

Last change on this file since 7779 was 7779, checked in by gb, 13 years ago

lisp_Debugger() takes an extra Boolean "in foreign context" arg, rather
than trying to set a bit in the exception code (which might be negative.)

Add a (T)hread info command to kernel debugger.

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