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

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

Remove a debugging fprintf.

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