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

Last change on this file since 11556 was 11556, checked in by rme, 11 years ago

Change the x86 consing sequence to use ja (instead of jg) after comparing
tcr.save_allocptr and tcr.save_allocbase. (If we can manage to reserve
a bigger chunk of heap space, it might happen that these two values differ
in sign, i.e., tcr.save_allocptr might be above #x80000000 and
tcr.save_allocbase below. Of course, it may be a few years yet
before we have to start worrying about crossing #x8000000000000000 on
the x86-64 port...)

Update %ALLOCATE-UVECTOR and CONS vinsns, the Cons and Misc_Alloc_Internal
macros used in subprims, and the %WALK-DYNAMIC-AREA LAP function.

Also change pc_luser_xp() to recognize the ja instruction. (It still
recognizes the jg too, but treats it as ja when emulating it.)

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