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

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

Need to be careful about pc-lusring in .SPstore-node-conditional too;
need a new label to restart reliably.

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