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

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

Windows portability fixes.

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