source: release/1.7/source/lisp-kernel/x86-exceptions.c @ 15267

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

Revert r15026.

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