source: branches/qres/ccl/lisp-kernel/x86-exceptions.c @ 14049

Last change on this file since 14049 was 14049, checked in by gz, 10 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

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