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

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

x86 support for %ALLOCATE-LIST.

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