source: branches/arm/lisp-kernel/x86-exceptions.c @ 13923

Last change on this file since 13923 was 13431, checked in by gb, 10 years ago

Try to address ticket:649 by clearly distinguishing between UnMapMemory?()
(which completely deallocates an entire memory region created by MapMemory?()
or MapMemoryForStack?()) from UnCommitMemory?() (which leaves a previously
mapped and accessible range of pages mapped but inaccessible/uncommitted.)

Follow Alexander Gavrilov's suggestions (and use his patch) to ensure
that thread handles are closed on Windows. Make create_system_thread()
return a Boolean, since no callers care about the exact value and the
value that was returned on Windows was a handle that needed to be closed.

Ensure that create_system_thread() observes its stack_size argument.
Make the size of vstack soft protected area ("the yellow zone") larger.

Use a readable/writable PAGE_GUARD page at the bottom of the
cstack/tstack yellow zone and handle the Windows exception that's
raised when a PAGE_GUARD page is written to, so that stack overflow
detection has a prayer of working on Windows.

UNTESTED ANYWHERE BUT WIN32.

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