From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Mon, 20 Nov 1989 23:19:36 +0000 (+0000)
Subject: Simple changes:
X-Git-Tag: 20090517-FFI~11685
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d55d0034702acdab5151efcb88ae897b34e070c4;p=mit-scheme.git

Simple changes:

- Fix a bug: interface_to_C was not restoring the registers saved by
C_to_interface.

- Add scheme_to_interface_jsr entry point.

- Add a temporary patch to lexpr_apply to prevent the dynamic link
register from being clobbered.

- Add some conditionally assembled code to keep a limited history of
calls from compiled code to the interface.
---

diff --git a/v7/src/microcode/cmpauxmd/mc68k.m4 b/v7/src/microcode/cmpauxmd/mc68k.m4
index 1ec00367e..01350716c 100644
--- a/v7/src/microcode/cmpauxmd/mc68k.m4
+++ b/v7/src/microcode/cmpauxmd/mc68k.m4
@@ -1,6 +1,6 @@
 ### -*-Midas-*-
 ###
-###	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.2 1989/11/06 17:35:29 jinx Exp $
+###	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.3 1989/11/20 23:19:36 jinx Exp $
 ###
 ###	Copyright (c) 1989 Massachusetts Institute of Technology
 ###
@@ -73,10 +73,10 @@
 
 ####	Utility macros and definitions
 
-define(reference_external,
-	`')		# Declare desire to reference an external
-define(extern_c_label,`_$1')
-			# The actual reference
+define(KEEP_HISTORY,0)			# Debugging switch
+
+define(reference_external,`')		# Declare desire to use an external
+define(extern_c_label,`_$1')		# The actual reference
 
 define(define_c_label,
 `	global	extern_c_label($1)
@@ -86,11 +86,11 @@ define(define_debugging_label,
 `	global	$1
 $1:')
 
-define(dlink, %a4)	# Dynamic link register (contains a pointer to
-			# a return address) 
-define(rfree, %a5)	# Free pointer
-define(regs, %a6)	# Pointer to Registers[0]
-define(rmask, %d7)	# Mask to clear type code
+define(dlink, %a4)			# Dynamic link register (contains a
+					# pointer to a return address) 
+define(rfree, %a5)			# Free pointer
+define(regs, %a6)			# Pointer to Registers[0]
+define(rmask, %d7)			# Mask to clear type code
 
 # Implementation constants -- Must match object.h
 
@@ -129,7 +129,24 @@ define(switch_to_C_registers,
 
 define_debugging_label(c_save_stack)
 	space	4
-
+ifelse(KEEP_HISTORY, 1,
+`define_debugging_label(ring_pointer)
+	long	ring_block_1
+define_debugging_label(ring_block_1)
+	long	ring_block_2
+	space	28
+define_debugging_label(ring_block_2)
+	long	ring_block_3
+	space	28
+define_debugging_label(ring_block_3)
+	long	ring_block_4
+	space	28
+define_debugging_label(ring_block_4)
+	long	ring_block_5
+	space	28
+define_debugging_label(ring_block_5)
+	long	ring_block_1
+	space	28')
 	text
 
 ### Callable by C conventions.  Swaps to Scheme register set and jumps
@@ -141,6 +158,16 @@ define_c_label(C_to_interface)
 	mov.l	8(%a6),%a0		# Argument: entry point
 	bra.b	interface_to_scheme_internal
 
+### Called by Scheme through a jump instruction in the register block.
+### It is a special version of scheme_to_interface below, used when
+### a return address is stored in the Scheme stack.
+
+define_debugging_label(comentry_scheme_to_interface_jsr)
+define_debugging_label(scheme_to_interface_jsr)
+	mov.l	(%sp)+,%d1              # Return addr -> d1
+	addq.l	&4,%d1			# Skip format info.
+	bra.b	scheme_to_interface
+
 ### Called by linker-generated trampolines to invoke the appropriate
 ### C-written handler.  The return address on the stack is the address
 ### of the trampoline storage area, passed to the C handler as the
@@ -158,6 +185,21 @@ reference_external(utility_table)
 
 define_debugging_label(comentry_scheme_to_interface)
 define_debugging_label(scheme_to_interface)
+	ifelse(KEEP_HISTORY, 1,
+	`lea	ring_pointer,%a1
+	mov.l	(%a1),%a0
+	mov.l	(%a0),(%a1)
+	mov.l	%sp,4(%a0)
+	mov.l	%a5,8(%a0)
+	mov.l	%d0,12(%a0)
+	mov.l	%d1,16(%a0)
+	mov.l	%d2,20(%a0)
+	mov.l	%d3,24(%a0)
+	mov.l	%d4,28(%a0)
+	cmp.l	%sp,%a5
+	bgt.b	scheme_to_interface_proceed
+	nop
+define_debugging_label(scheme_to_interface_proceed)')
 	switch_to_C_registers()
 	mov.l	%d4,-(%sp)		# Push arguments to scheme utility
 	mov.l	%d3,-(%sp)
@@ -199,6 +241,7 @@ define_debugging_label(interface_to_scheme_internal)
 
 define_c_label(interface_to_C)
 	mov.l	%d1,%d0			# C return value location
+	movm.l	4(%sp),%d2-%d7/%a2-%a5
 	unlk	%a6
 	rts	
 
@@ -324,6 +367,7 @@ define_debugging_label(comentry_lexpr_apply)
 	mov.l	%a0,%d1
 	mov.w	%d0,%d2
 	ext.l	%d2
+	mov.l	dlink,regblock_val(regs)
 	call_utility(lexpr_apply)
 
 ### comentry_primitive_apply
@@ -611,6 +655,7 @@ define_c_label(asm_reset_hook)
 	setup_register(negative)			# 22	1f8
 	setup_register(scheme_to_interface)		# 23	1fe
 	setup_register(trampoline_to_interface)		# 24	204
+	setup_register(scheme_to_interface_jsr)		# 25	20a
 							# free to 31 incl.
 
 	unlk	%a6