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

Last change on this file since 10565 was 10565, checked in by gb, 12 years ago

Merge changes from branches/win64.

As well as the expected low-level exception/suspend/interrupt stuff,
these changes also include changes to [f]printf format strings. Note
that on win64, a 'long' is 32-bits wide, which complicates matters:

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long, and so can't be printed with %l.

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long long, and so can't be printed with %ll.

  • an address (viewed as an integer) or a natural-sized integer can be

portably printed with '%p', but implementations differ as to whether
or not '%p' prepends a gratuitous '0x' to the hex address. (Linux
does, other current platforms seem not to.)

The approach that seems to work is to cast arguments to natural, then
to u64_t, then use %ll. That approach probably isn't taken consistently
(yet), so some debugging information printed by the kernel may be
incorrect.

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