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

Last change on this file since 14873 was 14873, checked in by rme, 8 years ago

Change signature of install_signal_handler() and update
callers.

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