Context Navigation

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

Visit:

Last change on this file since 10094 was 10094, checked in by rme, 12 years ago
Conditionalize for x8632.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 85.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: