Context Navigation

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

Visit:

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

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

Download in other formats: