source: branches/rme-fpe/lisp-kernel/x86-exceptions.c @ 13949

Last change on this file since 13949 was 13949, checked in by rme, 10 years ago

Handler support for SIGFPE while in foreign code.

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