diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b6e73bebf6c662d2b86468727e96ccc3a13b4928
--- /dev/null
+++ b/src/code/alien-callback.lisp
@@ -0,0 +1,417 @@
+;;; -*- Package: ALIEN -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/code/alieneval.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains any the part of the Alien implementation that
+;;; is not part of the compiler.
+;;;
+(in-package "ALIEN")
+(use-package "EXT")
+(use-package "SYSTEM")
+
+(intl:textdomain "cmucl")
+
+(export '(alien * array struct union enum function integer signed unsigned
+	  boolean values single-float double-float long-float
+	  system-area-pointer def-alien-type def-alien-variable sap-alien
+	  extern-alien with-alien slot deref addr cast alien-sap alien-size
+	  alien-funcall def-alien-routine make-alien free-alien
+	  null-alien
+	  def-callback callback
+	  callback-funcall))
+
+(in-package "ALIEN-INTERNALS")
+(in-package "ALIEN")
+
+(import '(alien alien-value alien-value-type parse-alien-type
+	  unparse-alien-type alien-type-= alien-subtype-p alien-typep
+
+	  def-alien-type-class def-alien-type-translator def-alien-type-method
+	  invoke-alien-type-method
+
+	  alien-type alien-type-p alien-type-bits alien-type-alignment
+	  alien-integer-type alien-integer-type-p alien-integer-type-signed
+	  alien-boolean-type alien-boolean-type-p
+	  alien-enum-type alien-enum-type-p
+	  alien-float-type alien-float-type-p
+	  alien-single-float-type alien-single-float-type-p
+	  alien-double-float-type alien-double-float-type-p
+	  alien-long-float-type alien-long-float-type-p
+	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
+	  make-alien-pointer-type
+	  alien-array-type alien-array-type-p alien-array-type-element-type
+	  alien-array-type-dimensions	  
+	  alien-record-type alien-record-type-p alien-record-type-fields
+	  alien-record-field alien-record-field-p alien-record-field-name
+	  alien-record-field-type alien-record-field-offset
+	  alien-function-type alien-function-type-p make-alien-function-type
+	  alien-function-type-result-type alien-function-type-arg-types
+	  alien-values-type alien-values-type-p alien-values-type-values
+	  *values-type-okay*
+
+	  %set-slot %slot-addr %set-deref %deref-addr
+
+	  %heap-alien %set-heap-alien %heap-alien-addr
+	  heap-alien-info heap-alien-info-p heap-alien-info-type
+	  heap-alien-info-sap-form
+
+	  local-alien %set-local-alien %local-alien-addr
+	  local-alien-info local-alien-info-p local-alien-info-type
+	  local-alien-info-force-to-memory-p
+	  %local-alien-forced-to-memory-p
+	  make-local-alien dispose-local-alien note-local-alien-type
+
+	  %cast %sap-alien align-offset
+
+	  extract-alien-value deposit-alien-value naturalize deport
+	  compute-lisp-rep-type compute-alien-rep-type
+	  compute-extract-lambda compute-deposit-lambda
+	  compute-naturalize-lambda compute-deport-lambda)
+	"ALIEN-INTERNALS")
+
+(export '(alien alien-value alien-value-type parse-alien-type
+	  unparse-alien-type alien-type-= alien-subtype-p alien-typep
+
+	  def-alien-type-class def-alien-type-translator def-alien-type-method
+	  invoke-alien-type-method
+
+	  alien-type alien-type-p alien-type-bits alien-type-alignment
+	  alien-integer-type alien-integer-type-p alien-integer-type-signed
+	  alien-boolean-type alien-boolean-type-p
+	  alien-enum-type alien-enum-type-p
+	  alien-float-type alien-float-type-p
+	  alien-single-float-type alien-single-float-type-p
+	  alien-double-float-type alien-double-float-type-p
+	  alien-long-float-type alien-long-float-type-p
+	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
+	  make-alien-pointer-type
+	  alien-array-type alien-array-type-p alien-array-type-element-type
+	  alien-array-type-dimensions	  
+	  alien-record-type alien-record-type-p alien-record-type-fields
+	  alien-record-field alien-record-field-p alien-record-field-name
+	  alien-record-field-type alien-record-field-offset
+	  alien-function-type alien-function-type-p make-alien-function-type
+	  alien-function-type-result-type alien-function-type-arg-types
+	  alien-values-type alien-values-type-p alien-values-type-values
+	  *values-type-okay*
+
+	  %set-slot %slot-addr %set-deref %deref-addr
+
+	  %heap-alien %set-heap-alien %heap-alien-addr
+	  heap-alien-info heap-alien-info-p heap-alien-info-type
+	  heap-alien-info-sap-form
+
+	  local-alien %set-local-alien %local-alien-addr
+	  local-alien-info local-alien-info-p local-alien-info-type
+	  local-alien-info-force-to-memory-p
+	  %local-alien-forced-to-memory-p
+	  make-local-alien dispose-local-alien note-local-alien-type
+
+	  %cast %sap-alien align-offset
+
+	  extract-alien-value deposit-alien-value naturalize deport
+	  compute-lisp-rep-type compute-alien-rep-type
+	  compute-extract-lambda compute-deposit-lambda
+	  compute-naturalize-lambda compute-deport-lambda)
+	"ALIEN-INTERNALS")
+
+
+;;;; Alien callback support
+;;;;
+;;;; This is basically the implementation posted by Helmut Eller,
+;;;; posted to cmucl-imp on 04/13/2003.  It has been modified to live
+;;;; in the ALIEN package and to fit the same style as the ALIEN
+;;;; package.
+
+;;; This package provides a mechanism for defining callbacks: lisp
+;;; functions which can be called from foreign code.  The user
+;;; interface consists of the macros DEFCALLBACK and CALLBACK.  (See
+;;; the doc-strings for details.)
+;;;
+;;; Below are two examples.  The first example defines a callback FOO
+;;; and calls it with alien-funcall.  The second illustrates the use
+;;; of the libc qsort function.
+;;;
+;;; The implementation generates a piece machine code -- a
+;;; "trampoline" -- for each callback function.  A pointer to this
+;;; trampoline can then be passed to foreign code.  The trampoline is
+;;; allocated with malloc and is not moved by the GC.
+;;;
+;;; When called, the trampoline passes a pointer to the arguments
+;;; (essentially the stack pointer) together with an index to
+;;; CALL-CALLBACK.  CALL-CALLBACK uses the index to find the
+;;; corresponding lisp function and calls this function with the
+;;; argument pointer.  The lisp function uses the pointer to copy the
+;;; arguments from the stack to local variables.  On return, the lisp
+;;; function stores the result into the location given by the argument
+;;; pointer, and the trampoline code copies the return value from
+;;; there into the right return register.
+;;;
+;;; The address of CALL-CALLBACK is used in every trampoline and must
+;;; not be moved by the gc.  It is therefore necessary to either
+;;; include this package into the image (core) or to purify before
+;;; creating any trampolines (or to invent some other trick).
+;;;
+;;; Examples: 
+
+#||
+;;; Example 1:
+
+(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int))
+  (format t "~&foo: ~S, ~S~%" arg1 arg2)
+  (+ arg1 arg2))
+
+(alien:alien-funcall (alien:sap-alien (alien:callback foo)
+				      (function c-call:int c-call:int c-call:int))
+	       555 444444)
+
+;;; Example 2:
+
+(alien:def-alien-routine qsort c-call:void
+  (base (* t))
+  (nmemb c-call:int)
+  (size c-call:int)
+  (compar (* (function c-call:int (* t) (* t)))))
+
+(alien:def-callback my< (c-call:int (arg1 (* c-call:double))
+		      (arg2 (* c-call:double)))
+  (let ((a1 (alien:deref arg1))
+	(a2 (alien:deref arg2)))
+    (cond ((= a1 a2)  0)
+	  ((< a1 a2) -1)
+	  (t         +1))))
+
+(let ((a (make-array 10 :element-type 'double-float
+		     :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
+					 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0))))
+  (print a)
+  (qsort (sys:vector-sap a)
+	 (length a)
+	 (alien:alien-size c-call:double :bytes)
+	 (alien:callback my<))
+  (print a))
+
+||#
+
+(defstruct (callback
+	     (:constructor make-callback (trampoline lisp-fn function-type)))
+  "A callback consists of a piece assembly code -- the trampoline --
+and a lisp function.  We store the function type (including return
+type and arg types), so we can detect incompatible redefinitions."
+  (trampoline (required-argument) :type system-area-pointer)
+  (lisp-fn (required-argument) :type (function (fixnum fixnum) (values)))
+  (function-type (required-argument) :type alien::alien-function-type))
+
+(declaim (type (vector callback) *callbacks*))
+(defvar *callbacks* (make-array 10 :element-type 'callback
+				:fill-pointer 0 :adjustable t)
+  "Vector of all callbacks.")
+
+(defun call-callback (index sp-fixnum ret-addr)
+  (declare (type fixnum index sp-fixnum ret-addr)
+	   (optimize speed))
+  (funcall (callback-lisp-fn (aref *callbacks* index))
+	   sp-fixnum ret-addr))
+
+(defun create-callback (lisp-fn fn-type)
+  (let* ((index (fill-pointer *callbacks*))
+	 (tramp (vm:make-callback-trampoline index fn-type))
+	 (cb (make-callback tramp lisp-fn fn-type)))
+    (vector-push-extend cb *callbacks*)
+    cb))
+
+(defun address-of-call-callback ()
+  (kernel:get-lisp-obj-address #'call-callback))
+
+(defun address-of-funcall3 ()
+  (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t))))))
+
+;;; Some abbreviations for alien-type classes.  The $ suffix is there
+;;; to prevent name clashes.
+
+(deftype void$ () '(satisfies alien-void-type-p))
+(deftype integer$ () 'alien-integer-type)
+(deftype integer-64$ () '(satisfies alien-integer-64-type-p))
+(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p))
+(deftype pointer$ () 'alien-pointer-type)
+(deftype single$ () 'alien-single-float-type)
+(deftype double$ () 'alien-double-float-type)
+(deftype sap$ () '(satisfies alien-sap-type=))
+
+(defun alien-sap-type= (type)
+  (alien-type-= type (parse-alien-type 'system-area-pointer)))
+
+(defun alien-void-type-p (type)
+  (and (alien-values-type-p type)
+       (null (alien-values-type-values type))))
+
+(defun alien-integer-64-type-p (type)
+  (and (alien-integer-type-p type)
+       (= (alien-type-bits type) 64)))
+
+(defun alien-signed-integer-type-p (type)
+  (and (alien-integer-type-p type)
+       (alien-integer-type-signed type)))
+
+(defun segment-to-trampoline (segment length)
+  (let* ((code (alien-funcall 
+		(extern-alien "malloc" (function system-area-pointer unsigned))
+		length))
+	 (fill-pointer code))
+    ;; Make sure the malloc'ed area is executable.  
+    (let* ((page-size (get-page-size))
+	   ;; mprotect wants address on a page boundary, so round down
+	   ;; the address and round up the length
+	   (code-base (sys:int-sap (* page-size
+				      (floor (sys:sap-int code) page-size))))
+	   (len (* page-size (ceiling length page-size))))
+      (unless (unix::unix-mprotect code-base len
+				   (logior unix:prot_exec unix:prot_read unix:prot_write))
+	(warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S).  Callbacks may not work.")
+	      len length code-base code)))
+    (new-assem:segment-map-output segment
+      (lambda (sap length)
+	(kernel:system-area-copy sap 0 fill-pointer 0
+				 (* length vm:byte-bits))
+	(setf fill-pointer (sys:sap+ fill-pointer length))))
+    code))
+
+(defun symbol-trampoline (symbol)
+  (callback-trampoline (symbol-value symbol)))
+
+(defmacro callback (name)
+  "Return the trampoline pointer for the callback NAME."
+  `(symbol-trampoline ',name))
+
+;; Convenience macro to make it easy to call callbacks.
+(defmacro callback-funcall (name &rest args)
+  `(alien-funcall (sap-alien (callback ,name)
+			     ,(unparse-alien-type
+			       (callback-function-type (symbol-value name))))
+		  ,@args))
+
+(defun define-callback-function (name lisp-fn fn-type)
+  (declare (type symbol name)
+	   (type function lisp-fn))
+  (flet ((register-new-callback () 
+	   (setf (symbol-value name)
+		 (create-callback lisp-fn fn-type))))
+    (if (and (boundp name)
+	     (callback-p (symbol-value name)))
+	;; try do redefine the existing callback
+	(let ((callback (find (symbol-trampoline name) *callbacks*
+			      :key #'callback-trampoline :test #'sys:sap=)))
+	  (cond (callback
+		 (let ((old-type (callback-function-type callback)))
+		   (cond ((vm::compatible-function-types-p old-type fn-type)
+			  ;; (format t "~&; Redefining callback ~A~%" name)
+			  (setf (callback-lisp-fn callback) lisp-fn)
+			  (setf (callback-function-type callback) fn-type)
+			  callback)
+			 (t
+			  (let ((e (format nil (intl:gettext "~
+Attempt to redefine callback with incompatible return type.
+   Old type was: ~A 
+    New type is: ~A") old-type fn-type))
+				(c (format nil (intl:gettext "~
+Create new trampoline (old trampoline calls old lisp function)."))))
+			    (cerror c e)
+			    (register-new-callback))))))
+		(t (register-new-callback))))
+	(register-new-callback))))
+
+(defun word-aligned-bits (type)
+  (align-offset (alien-type-bits type) vm:word-bits))
+
+(defun argument-size (spec)
+  (let ((type (parse-alien-type spec)))
+    (typecase type
+      ((or integer$ single$ double$ pointer$ sap$)
+       (ceiling (word-aligned-bits type) vm:byte-bits))
+      (t (error (intl:gettext "Unsupported argument type: ~A") spec)))))
+
+(defun parse-return-type (spec)
+  (let ((*values-type-okay* t))
+    (parse-alien-type spec)))
+
+(defun parse-function-type (return-type arg-specs)
+  (parse-alien-type
+   `(function ,return-type ,@(mapcar #'second arg-specs))))
+
+(defun return-exp (spec sap body)
+  (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body)))
+    (let ((type (parse-return-type spec)))
+      (typecase type
+	(void$ body)
+	(signed-integer$ 
+	 (store `(signed ,(word-aligned-bits type))))
+	(integer$
+	 (store `(unsigned ,(word-aligned-bits type))))
+	((or single$ double$ pointer$ sap$)
+	 (store spec))
+	(t (error (intl:gettext "Unsupported return type: ~A") spec))))))
+
+(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc))
+  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*)
+     {doc-string} {decls}* {FORM}*)
+
+Define a function which can be called by foreign code.  The pointer
+returned by (callback NAME), when called by foreign code, invokes the
+lisp function.  The lisp function expects alien arguments of the
+specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
+
+If (callback NAME) is already a callback function pointer, its value
+is not changed (though it's arranged that an updated version of the
+lisp callback function will be called).  This feature allows for
+incremental redefinition of callback functions."
+  (let ((sp-fixnum (gensym (string :sp-fixnum-)))
+	(ret-addr (gensym (string :ret-addr-)))
+	(sp (gensym (string :sp-)))
+	(ret (gensym (string :ret-))))
+    `(progn
+      (defun ,name (,sp-fixnum ,ret-addr)
+	,@(when doc (list doc))
+	(declare (type fixnum ,sp-fixnum ,ret-addr))
+	,@decls
+	;; We assume sp-fixnum is word aligned and pass it untagged to
+	;; this function.  The shift compensates this.
+ 	(let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum)
+ 					      2)))
+ 	      (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr)
+ 					       2))))
+	  (declare (ignorable ,sp ,ret))
+	  ;; Copy all arguments to local variables.
+	  (with-alien ,(loop for offset = 0 then (+ offset 
+						    (argument-size type))
+			     for (name type) in arg-specs
+			     collect `(,name ,type
+				       :local ,(vm:callback-accessor-form type sp offset)))
+	    ,(return-exp return-type ret `(progn ,@body))
+	    (values))))
+      (define-callback-function 
+	  ',name #',name ',(parse-function-type return-type arg-specs)))))
+
+;;; dumping support
+
+(defun restore-callbacks ()
+  ;; Create new trampolines on reload.
+  (loop for cb across *callbacks*
+	for i from 0
+	do (setf (callback-trampoline cb)
+		 (vm:make-callback-trampoline i (callback-function-type cb)))))
+
+;; *after-save-initializations* contains
+;; new-assem::forget-output-blocks, and the assembler may not work
+;; before forget-output-blocks was called.  We add 'restore-callback at
+;; the end of *after-save-initializations* to sidestep this problem.
+(setf *after-save-initializations*
+      (append *after-save-initializations* (list 'restore-callbacks)))
+
+;;; callback.lisp ends here
diff --git a/src/code/alieneval.lisp b/src/code/alieneval.lisp
index c8f0fb8de486b33b634fbc224312097f5ae3b97c..124f74ea00c4b83d46731b7283c4fc03ab1572d3 100644
--- a/src/code/alieneval.lisp
+++ b/src/code/alieneval.lisp
@@ -2078,296 +2078,3 @@ If so return true; otherwise call ALTERNATIVE."
 		       (values ,@temps ,@(results))))
 		  `(values (alien-funcall ,lisp-name ,@(alien-args))
 			   ,@(results))))))))
-
-;;;; Alien callback support
-;;;;
-;;;; This is basically the implementation posted by Helmut Eller,
-;;;; posted to cmucl-imp on 04/13/2003.  It has been modified to live
-;;;; in the ALIEN package and to fit the same style as the ALIEN
-;;;; package.
-
-;;; This package provides a mechanism for defining callbacks: lisp
-;;; functions which can be called from foreign code.  The user
-;;; interface consists of the macros DEFCALLBACK and CALLBACK.  (See
-;;; the doc-strings for details.)
-;;;
-;;; Below are two examples.  The first example defines a callback FOO
-;;; and calls it with alien-funcall.  The second illustrates the use
-;;; of the libc qsort function.
-;;;
-;;; The implementation generates a piece machine code -- a
-;;; "trampoline" -- for each callback function.  A pointer to this
-;;; trampoline can then be passed to foreign code.  The trampoline is
-;;; allocated with malloc and is not moved by the GC.
-;;;
-;;; When called, the trampoline passes a pointer to the arguments
-;;; (essentially the stack pointer) together with an index to
-;;; CALL-CALLBACK.  CALL-CALLBACK uses the index to find the
-;;; corresponding lisp function and calls this function with the
-;;; argument pointer.  The lisp function uses the pointer to copy the
-;;; arguments from the stack to local variables.  On return, the lisp
-;;; function stores the result into the location given by the argument
-;;; pointer, and the trampoline code copies the return value from
-;;; there into the right return register.
-;;;
-;;; The address of CALL-CALLBACK is used in every trampoline and must
-;;; not be moved by the gc.  It is therefore necessary to either
-;;; include this package into the image (core) or to purify before
-;;; creating any trampolines (or to invent some other trick).
-;;;
-;;; Examples: 
-
-#||
-;;; Example 1:
-
-(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int))
-  (format t "~&foo: ~S, ~S~%" arg1 arg2)
-  (+ arg1 arg2))
-
-(alien:alien-funcall (alien:sap-alien (alien:callback foo)
-				      (function c-call:int c-call:int c-call:int))
-	       555 444444)
-
-;;; Example 2:
-
-(alien:def-alien-routine qsort c-call:void
-  (base (* t))
-  (nmemb c-call:int)
-  (size c-call:int)
-  (compar (* (function c-call:int (* t) (* t)))))
-
-(alien:def-callback my< (c-call:int (arg1 (* c-call:double))
-		      (arg2 (* c-call:double)))
-  (let ((a1 (alien:deref arg1))
-	(a2 (alien:deref arg2)))
-    (cond ((= a1 a2)  0)
-	  ((< a1 a2) -1)
-	  (t         +1))))
-
-(let ((a (make-array 10 :element-type 'double-float
-		     :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
-					 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0))))
-  (print a)
-  (qsort (sys:vector-sap a)
-	 (length a)
-	 (alien:alien-size c-call:double :bytes)
-	 (alien:callback my<))
-  (print a))
-
-||#
-
-(defstruct (callback
-	     (:constructor make-callback (trampoline lisp-fn function-type)))
-  "A callback consists of a piece assembly code -- the trampoline --
-and a lisp function.  We store the function type (including return
-type and arg types), so we can detect incompatible redefinitions."
-  (trampoline (required-argument) :type system-area-pointer)
-  (lisp-fn (required-argument) :type (function (fixnum fixnum) (values)))
-  (function-type (required-argument) :type alien::alien-function-type))
-
-(declaim (type (vector callback) *callbacks*))
-(defvar *callbacks* (make-array 10 :element-type 'callback
-				:fill-pointer 0 :adjustable t)
-  "Vector of all callbacks.")
-
-(defun call-callback (index sp-fixnum ret-addr)
-  (declare (type fixnum index sp-fixnum ret-addr)
-	   (optimize speed))
-  (funcall (callback-lisp-fn (aref *callbacks* index))
-	   sp-fixnum ret-addr))
-
-(defun create-callback (lisp-fn fn-type)
-  (let* ((index (fill-pointer *callbacks*))
-	 (tramp (vm:make-callback-trampoline index fn-type))
-	 (cb (make-callback tramp lisp-fn fn-type)))
-    (vector-push-extend cb *callbacks*)
-    cb))
-
-(defun address-of-call-callback ()
-  (kernel:get-lisp-obj-address #'call-callback))
-
-(defun address-of-funcall3 ()
-  (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t))))))
-
-;;; Some abbreviations for alien-type classes.  The $ suffix is there
-;;; to prevent name clashes.
-
-(deftype void$ () '(satisfies alien-void-type-p))
-(deftype integer$ () 'alien-integer-type)
-(deftype integer-64$ () '(satisfies alien-integer-64-type-p))
-(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p))
-(deftype pointer$ () 'alien-pointer-type)
-(deftype single$ () 'alien-single-float-type)
-(deftype double$ () 'alien-double-float-type)
-(deftype sap$ () '(satisfies alien-sap-type=))
-
-(defun alien-sap-type= (type)
-  (alien-type-= type (parse-alien-type 'system-area-pointer)))
-
-(defun alien-void-type-p (type)
-  (and (alien-values-type-p type)
-       (null (alien-values-type-values type))))
-
-(defun alien-integer-64-type-p (type)
-  (and (alien-integer-type-p type)
-       (= (alien-type-bits type) 64)))
-
-(defun alien-signed-integer-type-p (type)
-  (and (alien-integer-type-p type)
-       (alien-integer-type-signed type)))
-
-(defun segment-to-trampoline (segment length)
-  (let* ((code (alien-funcall 
-		(extern-alien "malloc" (function system-area-pointer unsigned))
-		length))
-	 (fill-pointer code))
-    ;; Make sure the malloc'ed area is executable.  
-    (let* ((page-size (get-page-size))
-	   ;; mprotect wants address on a page boundary, so round down
-	   ;; the address and round up the length
-	   (code-base (sys:int-sap (* page-size
-				      (floor (sys:sap-int code) page-size))))
-	   (len (* page-size (ceiling length page-size))))
-      (unless (unix::unix-mprotect code-base len
-				   (logior unix:prot_exec unix:prot_read unix:prot_write))
-	(warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S).  Callbacks may not work.")
-	      len length code-base code)))
-    (new-assem:segment-map-output segment
-      (lambda (sap length)
-	(kernel:system-area-copy sap 0 fill-pointer 0
-				 (* length vm:byte-bits))
-	(setf fill-pointer (sys:sap+ fill-pointer length))))
-    code))
-
-(defun symbol-trampoline (symbol)
-  (callback-trampoline (symbol-value symbol)))
-
-(defmacro callback (name)
-  "Return the trampoline pointer for the callback NAME."
-  `(symbol-trampoline ',name))
-
-;; Convenience macro to make it easy to call callbacks.
-(defmacro callback-funcall (name &rest args)
-  `(alien-funcall (sap-alien (callback ,name)
-			     ,(unparse-alien-type
-			       (callback-function-type (symbol-value name))))
-		  ,@args))
-
-(defun define-callback-function (name lisp-fn fn-type)
-  (declare (type symbol name)
-	   (type function lisp-fn))
-  (flet ((register-new-callback () 
-	   (setf (symbol-value name)
-		 (create-callback lisp-fn fn-type))))
-    (if (and (boundp name)
-	     (callback-p (symbol-value name)))
-	;; try do redefine the existing callback
-	(let ((callback (find (symbol-trampoline name) *callbacks*
-			      :key #'callback-trampoline :test #'sys:sap=)))
-	  (cond (callback
-		 (let ((old-type (callback-function-type callback)))
-		   (cond ((vm::compatible-function-types-p old-type fn-type)
-			  ;; (format t "~&; Redefining callback ~A~%" name)
-			  (setf (callback-lisp-fn callback) lisp-fn)
-			  (setf (callback-function-type callback) fn-type)
-			  callback)
-			 (t
-			  (let ((e (format nil (intl:gettext "~
-Attempt to redefine callback with incompatible return type.
-   Old type was: ~A 
-    New type is: ~A") old-type fn-type))
-				(c (format nil (intl:gettext "~
-Create new trampoline (old trampoline calls old lisp function)."))))
-			    (cerror c e)
-			    (register-new-callback))))))
-		(t (register-new-callback))))
-	(register-new-callback))))
-
-(defun word-aligned-bits (type)
-  (align-offset (alien-type-bits type) vm:word-bits))
-
-(defun argument-size (spec)
-  (let ((type (parse-alien-type spec)))
-    (typecase type
-      ((or integer$ single$ double$ pointer$ sap$)
-       (ceiling (word-aligned-bits type) vm:byte-bits))
-      (t (error (intl:gettext "Unsupported argument type: ~A") spec)))))
-
-(defun parse-return-type (spec)
-  (let ((*values-type-okay* t))
-    (parse-alien-type spec)))
-
-(defun parse-function-type (return-type arg-specs)
-  (parse-alien-type
-   `(function ,return-type ,@(mapcar #'second arg-specs))))
-
-(defun return-exp (spec sap body)
-  (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body)))
-    (let ((type (parse-return-type spec)))
-      (typecase type
-	(void$ body)
-	(signed-integer$ 
-	 (store `(signed ,(word-aligned-bits type))))
-	(integer$
-	 (store `(unsigned ,(word-aligned-bits type))))
-	((or single$ double$ pointer$ sap$)
-	 (store spec))
-	(t (error (intl:gettext "Unsupported return type: ~A") spec))))))
-
-(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc))
-  "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*)
-     {doc-string} {decls}* {FORM}*)
-
-Define a function which can be called by foreign code.  The pointer
-returned by (callback NAME), when called by foreign code, invokes the
-lisp function.  The lisp function expects alien arguments of the
-specified ARG-TYPEs and returns an alien of type RETURN-TYPE.
-
-If (callback NAME) is already a callback function pointer, its value
-is not changed (though it's arranged that an updated version of the
-lisp callback function will be called).  This feature allows for
-incremental redefinition of callback functions."
-  (let ((sp-fixnum (gensym (string :sp-fixnum-)))
-	(ret-addr (gensym (string :ret-addr-)))
-	(sp (gensym (string :sp-)))
-	(ret (gensym (string :ret-))))
-    `(progn
-      (defun ,name (,sp-fixnum ,ret-addr)
-	,@(when doc (list doc))
-	(declare (type fixnum ,sp-fixnum ,ret-addr))
-	,@decls
-	;; We assume sp-fixnum is word aligned and pass it untagged to
-	;; this function.  The shift compensates this.
- 	(let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum)
- 					      2)))
- 	      (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr)
- 					       2))))
-	  (declare (ignorable ,sp ,ret))
-	  ;; Copy all arguments to local variables.
-	  (with-alien ,(loop for offset = 0 then (+ offset 
-						    (argument-size type))
-			     for (name type) in arg-specs
-			     collect `(,name ,type
-				       :local ,(vm:callback-accessor-form type sp offset)))
-	    ,(return-exp return-type ret `(progn ,@body))
-	    (values))))
-      (define-callback-function 
-	  ',name #',name ',(parse-function-type return-type arg-specs)))))
-
-;;; dumping support
-
-(defun restore-callbacks ()
-  ;; Create new trampolines on reload.
-  (loop for cb across *callbacks*
-	for i from 0
-	do (setf (callback-trampoline cb)
-		 (vm:make-callback-trampoline i (callback-function-type cb)))))
-
-;; *after-save-initializations* contains
-;; new-assem::forget-output-blocks, and the assembler may not work
-;; before forget-output-blocks was called.  We add 'restore-callback at
-;; the end of *after-save-initializations* to sidestep this problem.
-(setf *after-save-initializations*
-      (append *after-save-initializations* (list 'restore-callbacks)))
-
-;;; callback.lisp ends here
diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp
index 4fd20b685f8d60943b94d4040a3b119a453ffde3..1d08a2eb784ab61cc26349f5bdd2fb401b28618d 100644
--- a/src/compiler/ppc/c-call.lisp
+++ b/src/compiler/ppc/c-call.lisp
@@ -386,250 +386,3 @@
 	       (inst addi nsp-tn nsp-tn delta))
 	      (t
 	       (inst lwz nsp-tn nsp-tn 0)))))))
-
-
-(export '(make-callback-trampoline callback-accessor-form
-	  compatible-function-types-p))
-
-(defun callback-accessor-form (type sp offset)
-  (let ((parsed-type (alien::parse-alien-type type)))
-    (typecase parsed-type
-      (alien::integer-64$
-       ;; Get both words of a 64-bit integer and combine together, in
-       ;; a big-endian fashion.
-       `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset)
-					  ,(if (alien-integer-type-signed parsed-type)
-					       '(* c-call:int)
-					       '(* c-call:unsigned-int)))))
-	      (lo (alien:deref (sap-alien (sys:sap+ ,sp
-						    (+ ,offset vm:word-bytes))
-					  (* c-call:unsigned-int)))))
-	     (+ (ash hi vm:word-bits) lo)))
-      (alien::integer$
-       ;; We can access machine integers directly, but we need to get
-       ;; the offset right, since the offset we're given is the start
-       ;; of the object, and we're a big-endian machine.
-       (let ((byte-offset
-	      (- vm:word-bytes
-		 (ceiling (alien::alien-integer-type-bits parsed-type)
-			  vm:byte-bits))))
-	 `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset))
-			    (* ,type)))))
-      (t
-       ;; This should work for everything else.
-       `(deref (sap-alien (sys:sap+ ,sp ,offset)
-			  (* ,type)))))))
-
-(defun compatible-function-types-p (fun-type1 fun-type2)
-  (labels ((type-words (type)
-             (ceiling (alien-type-bits type) vm:word-bits))
-           (compatible-type-p (type1 type2)
-             (let ((float1 (alien-float-type-p type1))
-                   (float2 (alien-float-type-p type2)))
-               (and (if float1
-			float2
-			(not float2))
-                    (= (type-words type1) (type-words type2))))))
-    (let ((args1 (alien-function-type-arg-types fun-type1))
-          (args2 (alien-function-type-arg-types fun-type2))
-          (ret1 (alien-function-type-result-type fun-type1))
-          (ret2 (alien-function-type-result-type fun-type2)))
-      (and (= (length args1) (length args2))
-           (every #'compatible-type-p args1 args2)
-           (compatible-type-p ret1 ret2)))))
-
-(defun make-callback-trampoline (index fn-type)
-  (let ((return-type (alien-function-type-result-type fn-type))
-	(arg-types (alien::alien-function-type-arg-types fn-type)))
-    (make-callback-trampoline-segment index arg-types return-type)))
-
-(defun make-callback-trampoline-segment (index argument-types return-type)
-  "Return an sb-assem:segment which calls call-callback with INDEX and
-a pointer to the arguments."
-  (declare (type (unsigned-byte 16) index)
-	   (optimize (debug 3)))
-  (flet ((make-gpr (n)
-	   (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
-	 (make-fpr (n)
-	   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
-			   :offset n))
-	 (round-up-16 (n)
-	   ;; Round up to a multiple of 16.  Darwin wants that for the
-	   ;; stack pointer.
-	   (* 16 (ceiling n 16))))
-
-    ;; The "Mach-O Runtime Conventions" document for OS X almost specifies
-    ;; the calling convention (it neglects to mention that the linkage area
-    ;; is 24 bytes).
-    (let* ((segment (make-segment))
-	   (save-gprs (mapcar #'make-gpr '(13 24)))
-	   
-	   (argument-words
-	    (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits))
-		    argument-types))
-	   (linkage-area-size 24))
-      (assemble (segment)
-
-	(let ((sp (make-gpr 1)))
-	  
-	  ;; To save our arguments, we follow the algorithm sketched in the
-	  ;; "PowerPC Calling Conventions" section of that document.
-	  (let ((words-processed 0)
-		(gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
-		(fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13))))
-	    (flet ((handle-arg (type words)
-		     (let ((integerp (not (alien-float-type-p type)))
-			   (offset (+ (* words-processed vm:word-bytes)
-				      linkage-area-size)))
-		       (cond
-			 (integerp
-			  (dotimes (k words)
-			    (let ((gpr (pop gprs)))
-			      (when gpr
-				     (inst stw gpr sp offset)
-				     (incf words-processed)
-				     (incf offset vm:word-bytes)))))
-			 ;; The handling of floats is a little ugly because we
-			 ;; hard-code the number of words for single- and
-			 ;; double-floats.
-			 ((alien-single-float-type-p type)
-			  (pop gprs)
-			  (let ((fpr (pop fprs)))
-			    (inst stfs fpr sp offset))
-			  (incf words-processed))
-			 ((alien-double-float-type-p type)
-			  (setf gprs (cddr gprs))
-			  (let ((fpr (pop fprs)))
-			    (inst stfd fpr sp offset))
-			  (incf words-processed 2))))))
-	      (mapc #'handle-arg argument-types argument-words)))
-
-	  ;; The args have been saved to memory.
-	  ;;
-	  ;; The stack frame is something like this:
-	  ;;
-	  ;; stack arg n
-	  ;; ...
-	  ;; stack arg 1
-	  ;; stack arg 0
-	  ;; save arg 7
-	  ;; save arg 6
-	  ;; save arg 5
-	  ;; save arg 4
-	  ;; save arg 3
-	  ;; save arg 2
-	  ;; save arg 1
-	  ;; save arg 0
-	  ;; 24 bytes for linkage area
-	  ;; -> sp points to the bottom of the linkage area
-	  ;;
-	  ;; Set aside space for our stack frame.  We need enough room
-	  ;; for the callback return area, some space to save the
-	  ;; non-volatile (callee-saved) registers, space to save the
-	  ;; args for the function we're calling, and the linkage
-	  ;; area.  The space is rounded up to a multiple of 16 bytes
-	  ;; because the stack should be aligned to a multiple of 16
-	  ;; bytes.
-	  ;;
-	  ;; Our stack frame will look something like this now:
-	  ;;
-	  ;; Offset    Value
-	  ;; 64        Caller's frame (see above)
-	  ;; 56/60     return area (1 or 2 words) 
-	  ;; 48        filler (unused)
-	  ;; 44        save r24
-	  ;; 40        save r13
-	  ;; 36        save arg 3
-	  ;; 32        save arg 2
-	  ;; 28        save arg 1
-	  ;; 24        save arg 0
-	  ;; 0         linkage area (24 bytes)
-	  ;;
-	  ;;
-	  ;; The return area is allocated at the top of the frame.
-	  ;; When we call funcall3, the linkage table entry is used,
-	  ;; which unconditionally uses r13 and r24.  (See
-	  ;; lisp/ppc-arch.c.)  So these need to be saved.  funcall3,
-	  ;; which calls call_into_lisp, will take care of saving all
-	  ;; the remaining registers that could be used.
-
-	  ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to
-	  ;; be because they're word-aligned.  Kinda gross, but
-	  ;; hey....
-	  
-	  (let* ((return-area-words (ceiling (or (alien-type-bits return-type)
-						0)
-					    vm:word-bits))
-		 (save-words (length save-gprs))
-		 (args-size (* 4 vm:word-bytes))
-		 (frame-size
-		  (round-up-16 (+ linkage-area-size
-				  (* return-area-words vm:word-bytes)
-				  (* save-words vm:word-bytes)
-				  args-size))))
-	    (destructuring-bind (r0 arg1 arg2 arg3 arg4)
-		(mapcar #'make-gpr '(0 3 4 5 6))
-	      ;; Setup the args for the call.  We call
-	      ;; funcall3(call-callback, index, arg-pointer,
-	      ;; return-area-address)
-	      (inst lr arg1 (alien::address-of-call-callback))
-	      (inst li arg2 (fixnumize index))
-	      (inst addi arg3 sp linkage-area-size)
-	      (inst addi arg4 sp (- (* return-area-words vm:word-bytes)))
-
-	      ;; Save sp, setup the frame
-	      (inst mflr r0)
-	      (inst stw r0 sp (* 2 vm:word-bytes))
-	      (inst stwu sp sp (- frame-size))
-
-	      ;; Save the caller-saved registers that the linkage
-	      ;; table trampoline clobbers.
-	      (let ((save-offset (+ linkage-area-size args-size)))
-		(dolist (r save-gprs)
-		  (inst stw r sp save-offset)
-		  (incf save-offset vm:word-bytes)))
-	      
-	      ;; Make the call
-	      (inst lr r0 (alien::address-of-funcall3))
-	      (inst mtlr r0)
-	      (inst blrl)
-
-	      (let ((return-offset (- frame-size
-				      (* return-area-words vm:word-bytes))))
-		(etypecase return-type
-		  ((or alien::integer$ alien::pointer$ alien::sap$
-		       alien::integer-64$)
-		   (loop repeat return-area-words
-		         with gprs = (mapcar #'make-gpr '(3 4))
-		         for gpr = (pop gprs)
-		         for offset from return-offset by vm:word-bytes
-			 do (inst lwz gpr sp offset)))
-		  (alien::single$
-		   ;; Get the FP value into F1
-		   (let ((f1 (make-fpr 1)))
-		     (inst lfs f1 sp return-offset)))
-		  (alien::double$
-		   ;; Get the FP value into F1
-		   (let ((f1 (make-fpr 1)))
-		     (inst lfd f1 sp return-offset)))
-		  (alien::void$
-		   ;; Nothing to do
-		   )))
-	      
-	      ;; Restore the GPRS we saved.
-	      (let ((save-offset (+ linkage-area-size args-size)))
-		(dolist (r save-gprs)
-		  (inst lwz r sp save-offset)
-		  (incf save-offset vm:word-bytes)))
-
-	      ;; All done.  Restore sp and lr and return.
-	      (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes)))
-	      (inst mtlr r0)
-	      (inst addic sp sp frame-size)
-	      
-	      ;; And back we go!
-	      (inst blr)))))
-
-      (let ((length (finalize-segment segment)))
-	(prog1 (alien::segment-to-trampoline segment length)
-	  (release-segment segment))))))
diff --git a/src/compiler/ppc/c-callback.lisp b/src/compiler/ppc/c-callback.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2ebd6f444f214bbd2a37196ab02e6fbd3986c52b
--- /dev/null
+++ b/src/compiler/ppc/c-callback.lisp
@@ -0,0 +1,266 @@
+;;; -*- Package: PPC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/ppc/c-call.lisp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "PPC")
+
+
+(export '(make-callback-trampoline callback-accessor-form
+	  compatible-function-types-p))
+
+(defun callback-accessor-form (type sp offset)
+  (let ((parsed-type (alien::parse-alien-type type)))
+    (typecase parsed-type
+      (alien::integer-64$
+       ;; Get both words of a 64-bit integer and combine together, in
+       ;; a big-endian fashion.
+       `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset)
+					  ,(if (alien-integer-type-signed parsed-type)
+					       '(* c-call:int)
+					       '(* c-call:unsigned-int)))))
+	      (lo (alien:deref (sap-alien (sys:sap+ ,sp
+						    (+ ,offset vm:word-bytes))
+					  (* c-call:unsigned-int)))))
+	     (+ (ash hi vm:word-bits) lo)))
+      (alien::integer$
+       ;; We can access machine integers directly, but we need to get
+       ;; the offset right, since the offset we're given is the start
+       ;; of the object, and we're a big-endian machine.
+       (let ((byte-offset
+	      (- vm:word-bytes
+		 (ceiling (alien::alien-integer-type-bits parsed-type)
+			  vm:byte-bits))))
+	 `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset))
+			    (* ,type)))))
+      (t
+       ;; This should work for everything else.
+       `(deref (sap-alien (sys:sap+ ,sp ,offset)
+			  (* ,type)))))))
+
+(defun compatible-function-types-p (fun-type1 fun-type2)
+  (labels ((type-words (type)
+             (ceiling (alien-type-bits type) vm:word-bits))
+           (compatible-type-p (type1 type2)
+             (let ((float1 (alien-float-type-p type1))
+                   (float2 (alien-float-type-p type2)))
+               (and (if float1
+			float2
+			(not float2))
+                    (= (type-words type1) (type-words type2))))))
+    (let ((args1 (alien-function-type-arg-types fun-type1))
+          (args2 (alien-function-type-arg-types fun-type2))
+          (ret1 (alien-function-type-result-type fun-type1))
+          (ret2 (alien-function-type-result-type fun-type2)))
+      (and (= (length args1) (length args2))
+           (every #'compatible-type-p args1 args2)
+           (compatible-type-p ret1 ret2)))))
+
+(defun make-callback-trampoline (index fn-type)
+  (let ((return-type (alien-function-type-result-type fn-type))
+	(arg-types (alien::alien-function-type-arg-types fn-type)))
+    (make-callback-trampoline-segment index arg-types return-type)))
+
+(defun make-callback-trampoline-segment (index argument-types return-type)
+  "Return an sb-assem:segment which calls call-callback with INDEX and
+a pointer to the arguments."
+  (declare (type (unsigned-byte 16) index)
+	   (optimize (debug 3)))
+  (flet ((make-gpr (n)
+	   (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
+	 (make-fpr (n)
+	   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+			   :offset n))
+	 (round-up-16 (n)
+	   ;; Round up to a multiple of 16.  Darwin wants that for the
+	   ;; stack pointer.
+	   (* 16 (ceiling n 16))))
+
+    ;; The "Mach-O Runtime Conventions" document for OS X almost specifies
+    ;; the calling convention (it neglects to mention that the linkage area
+    ;; is 24 bytes).
+    (let* ((segment (make-segment))
+	   (save-gprs (mapcar #'make-gpr '(13 24)))
+	   
+	   (argument-words
+	    (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits))
+		    argument-types))
+	   (linkage-area-size 24))
+      (assemble (segment)
+
+	(let ((sp (make-gpr 1)))
+	  
+	  ;; To save our arguments, we follow the algorithm sketched in the
+	  ;; "PowerPC Calling Conventions" section of that document.
+	  (let ((words-processed 0)
+		(gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
+		(fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13))))
+	    (flet ((handle-arg (type words)
+		     (let ((integerp (not (alien-float-type-p type)))
+			   (offset (+ (* words-processed vm:word-bytes)
+				      linkage-area-size)))
+		       (cond
+			 (integerp
+			  (dotimes (k words)
+			    (let ((gpr (pop gprs)))
+			      (when gpr
+				     (inst stw gpr sp offset)
+				     (incf words-processed)
+				     (incf offset vm:word-bytes)))))
+			 ;; The handling of floats is a little ugly because we
+			 ;; hard-code the number of words for single- and
+			 ;; double-floats.
+			 ((alien-single-float-type-p type)
+			  (pop gprs)
+			  (let ((fpr (pop fprs)))
+			    (inst stfs fpr sp offset))
+			  (incf words-processed))
+			 ((alien-double-float-type-p type)
+			  (setf gprs (cddr gprs))
+			  (let ((fpr (pop fprs)))
+			    (inst stfd fpr sp offset))
+			  (incf words-processed 2))))))
+	      (mapc #'handle-arg argument-types argument-words)))
+
+	  ;; The args have been saved to memory.
+	  ;;
+	  ;; The stack frame is something like this:
+	  ;;
+	  ;; stack arg n
+	  ;; ...
+	  ;; stack arg 1
+	  ;; stack arg 0
+	  ;; save arg 7
+	  ;; save arg 6
+	  ;; save arg 5
+	  ;; save arg 4
+	  ;; save arg 3
+	  ;; save arg 2
+	  ;; save arg 1
+	  ;; save arg 0
+	  ;; 24 bytes for linkage area
+	  ;; -> sp points to the bottom of the linkage area
+	  ;;
+	  ;; Set aside space for our stack frame.  We need enough room
+	  ;; for the callback return area, some space to save the
+	  ;; non-volatile (callee-saved) registers, space to save the
+	  ;; args for the function we're calling, and the linkage
+	  ;; area.  The space is rounded up to a multiple of 16 bytes
+	  ;; because the stack should be aligned to a multiple of 16
+	  ;; bytes.
+	  ;;
+	  ;; Our stack frame will look something like this now:
+	  ;;
+	  ;; Offset    Value
+	  ;; 64        Caller's frame (see above)
+	  ;; 56/60     return area (1 or 2 words) 
+	  ;; 48        filler (unused)
+	  ;; 44        save r24
+	  ;; 40        save r13
+	  ;; 36        save arg 3
+	  ;; 32        save arg 2
+	  ;; 28        save arg 1
+	  ;; 24        save arg 0
+	  ;; 0         linkage area (24 bytes)
+	  ;;
+	  ;;
+	  ;; The return area is allocated at the top of the frame.
+	  ;; When we call funcall3, the linkage table entry is used,
+	  ;; which unconditionally uses r13 and r24.  (See
+	  ;; lisp/ppc-arch.c.)  So these need to be saved.  funcall3,
+	  ;; which calls call_into_lisp, will take care of saving all
+	  ;; the remaining registers that could be used.
+
+	  ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to
+	  ;; be because they're word-aligned.  Kinda gross, but
+	  ;; hey....
+	  
+	  (let* ((return-area-words (ceiling (or (alien-type-bits return-type)
+						0)
+					    vm:word-bits))
+		 (save-words (length save-gprs))
+		 (args-size (* 4 vm:word-bytes))
+		 (frame-size
+		  (round-up-16 (+ linkage-area-size
+				  (* return-area-words vm:word-bytes)
+				  (* save-words vm:word-bytes)
+				  args-size))))
+	    (destructuring-bind (r0 arg1 arg2 arg3 arg4)
+		(mapcar #'make-gpr '(0 3 4 5 6))
+	      ;; Setup the args for the call.  We call
+	      ;; funcall3(call-callback, index, arg-pointer,
+	      ;; return-area-address)
+	      (inst lr arg1 (alien::address-of-call-callback))
+	      (inst li arg2 (fixnumize index))
+	      (inst addi arg3 sp linkage-area-size)
+	      (inst addi arg4 sp (- (* return-area-words vm:word-bytes)))
+
+	      ;; Save sp, setup the frame
+	      (inst mflr r0)
+	      (inst stw r0 sp (* 2 vm:word-bytes))
+	      (inst stwu sp sp (- frame-size))
+
+	      ;; Save the caller-saved registers that the linkage
+	      ;; table trampoline clobbers.
+	      (let ((save-offset (+ linkage-area-size args-size)))
+		(dolist (r save-gprs)
+		  (inst stw r sp save-offset)
+		  (incf save-offset vm:word-bytes)))
+	      
+	      ;; Make the call
+	      (inst lr r0 (alien::address-of-funcall3))
+	      (inst mtlr r0)
+	      (inst blrl)
+
+	      (let ((return-offset (- frame-size
+				      (* return-area-words vm:word-bytes))))
+		(etypecase return-type
+		  ((or alien::integer$ alien::pointer$ alien::sap$
+		       alien::integer-64$)
+		   (loop repeat return-area-words
+		         with gprs = (mapcar #'make-gpr '(3 4))
+		         for gpr = (pop gprs)
+		         for offset from return-offset by vm:word-bytes
+			 do (inst lwz gpr sp offset)))
+		  (alien::single$
+		   ;; Get the FP value into F1
+		   (let ((f1 (make-fpr 1)))
+		     (inst lfs f1 sp return-offset)))
+		  (alien::double$
+		   ;; Get the FP value into F1
+		   (let ((f1 (make-fpr 1)))
+		     (inst lfd f1 sp return-offset)))
+		  (alien::void$
+		   ;; Nothing to do
+		   )))
+	      
+	      ;; Restore the GPRS we saved.
+	      (let ((save-offset (+ linkage-area-size args-size)))
+		(dolist (r save-gprs)
+		  (inst lwz r sp save-offset)
+		  (incf save-offset vm:word-bytes)))
+
+	      ;; All done.  Restore sp and lr and return.
+	      (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes)))
+	      (inst mtlr r0)
+	      (inst addic sp sp frame-size)
+	      
+	      ;; And back we go!
+	      (inst blr)))))
+
+      (let ((length (finalize-segment segment)))
+	(prog1 (alien::segment-to-trampoline segment length)
+	  (release-segment segment))))))
diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp
index 042854eba186d3f5fcd9c7eec9b2b23e8b2a7cf2..c3a18becbf89abfab16597bf5802208561a4d8e8 100644
--- a/src/compiler/sparc/c-call.lisp
+++ b/src/compiler/sparc/c-call.lisp
@@ -312,205 +312,3 @@
 	      (t
 	       (inst li temp delta)
 	       (inst add nsp-tn temp)))))))
-
-;;; Support for callbacks to Lisp.
-(export '(make-callback-trampoline callback-accessor-form
-	  compatible-function-types-p))
-
-(defun callback-accessor-form (type sp offset)
-  (let ((parsed-type (alien::parse-alien-type type)))
-    (typecase parsed-type
-      (alien::double$
-       ;; Due to sparc calling conventions, a double arg doesn't have to
-       ;; be aligned on a double word boundary.  We have to get the two
-       ;; words separately and create the double from them.  Doubles are
-       ;; stored in big-endian order, naturally.
-       `(kernel:make-double-float
-	 (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int)))
-	 (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes))
-				 (* c-call:unsigned-int)))))
-      (alien::integer-64$
-       ;; Same as for double, above
-       `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset)
-					  ,(if (alien-integer-type-signed parsed-type)
-					       '(* c-call:int)
-					       '(* c-call:unsigned-int)))))
-	      (lo (alien:deref (sap-alien (sys:sap+ ,sp
-						    (+ ,offset vm:word-bytes))
-					  (* c-call:unsigned-int)))))
-	  (+ (ash hi vm:word-bits) lo)))
-      (alien::integer$
-       ;; All other objects can be accessed directly.  But we need to
-       ;; get the offset right, since the offset we're given is the
-       ;; start of the object, and we're a big-endian machine.
-       (let ((byte-offset
-	      (- vm:word-bytes
-		 (ceiling (alien::alien-integer-type-bits parsed-type)
-			  vm:byte-bits))))
-	 `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset))
-			    (* ,type)))))
-      (t
-       `(deref (sap-alien (sys:sap+ ,sp ,offset)
-			  (* ,type)))))))
-
-(defun compatible-function-types-p (type1 type2)
-  (flet ((machine-rep (type)
-	   (etypecase type
-	     (alien::integer-64$ :dword)
-	     ((or alien::integer$ alien::pointer$ alien::sap$) :word)
-	     (alien::single$ :single)
-	     (alien::double$ :double)
-	     (alien::void$ :void))))
-    (let ((type1 (alien-function-type-result-type type1))
-	  (type2 (alien-function-type-result-type type2)))
-      (eq (machine-rep type1) (machine-rep type2)))))
-
-(defun make-callback-trampoline (index fn-type)
-  "Cons up a piece of code which calls call-callback with INDEX and a
-pointer to the arguments."
-  (let ((return-type (alien-function-type-result-type fn-type)))
-    (flet ((def-reg-tn (offset)
-	     (c:make-random-tn :kind :normal
-			       :sc (c:sc-or-lose 'vm::unsigned-reg)
-			       :offset offset)))
-      (let* ((segment (make-segment))
-	     ;; Window save area (16 registers)
-	     (window-save-size (* 16 vm:word-bytes))
-	     ;; Structure return pointer area (1 register)
-	     (struct-return-size vm:word-bytes)
-	     ;; Register save area (6 registers)
-	     (reg-save-area-size (* 6 vm:word-bytes))
-	     ;; Local var.  Should be large enough to hold a double-float or long
-	     (return-value-size (* 2 vm:word-bytes))
-	     ;; Frame size: the register window, the arg save area, the
-	     ;; structure return area, and return-value-area, all
-	     ;; rounded to a multiple of eight.
-	     (framesize (* 8 (ceiling (+ window-save-size struct-return-size
-					 reg-save-area-size
-					 return-value-size)
-				      8)))
-	     ;; Offset from FP where the first arg is located.
-	     (arg0-save-offset (+ window-save-size struct-return-size))
-	     ;; Establish the registers we need
-	     (%g0 (def-reg-tn vm::zero-offset))
-	     (%o0 (def-reg-tn vm::nl0-offset))
-	     (%o1 (def-reg-tn vm::nl1-offset))
-	     (%o2 (def-reg-tn vm::nl2-offset))
-	     (%o3 (def-reg-tn vm::nl3-offset))
-	     (%o7 (def-reg-tn vm::nargs-offset))
-	     (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6
-	     (%l0 (def-reg-tn vm::a0-offset))
-	     (%i0 (def-reg-tn vm::cname-offset))
-	     (%i1 (def-reg-tn vm::lexenv-offset))
-	     (%i2 (def-reg-tn 26))
-	     (%i3 (def-reg-tn vm::nfp-offset))
-	     (%i4 (def-reg-tn vm::cfunc-offset))
-	     (%i5 (def-reg-tn vm::code-offset))
-	     (%fp (def-reg-tn 30))
-	     (%i7 (def-reg-tn vm::lip-offset))
-	     (f0-s (c:make-random-tn :kind :normal
-				     :sc (c:sc-or-lose 'vm::single-reg)
-				     :offset 0))
-	     (f0-d (c:make-random-tn :kind :normal
-				     :sc (c:sc-or-lose 'vm::double-reg)
-				     :offset 0))
-	     )
-	;; The generated assembly roughly corresponds to this C code:
-	;;
-	;;        tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...)
-	;;	{
-	;;	  double result;
-	;;	  funcall3(call-callback, <index>, &a0, &result);
-	;;	  return <cast> result;
-	;;	}
-	;;
-	;; Except, of course, the result is the appropriate result type
-	;; for the trampoline.
-	;;	       
-	(assemble (segment)
-	  ;; Save old %fp, etc. establish our call frame with local vars
-	  ;; %i contains the input args
-	  (inst save %sp %sp (- framesize))
-	  ;; The stack frame now looks like
-	  ;;
-	  ;; TOP (high memory)
-	  ;;
-	  ;; argn
-	  ;; ...
-	  ;; arg6
-	  ;; arg5
-	  ;; arg4
-	  ;; arg3
-	  ;; arg2
-	  ;; arg1
-	  ;; arg0
-	  ;; struct_return
-	  ;; window-save-area	<- %fp + 64
-	  ;;			<- %fp
-	  ;; local-vars-extra-args	(8-bytes)
-	  ;; arg5-save
-	  ;; arg4-save
-	  ;; arg3-save
-	  ;; arg2-save
-	  ;; arg1-save
-	  ;; arg0-save
-	  ;; struct_return		
-	  ;; window-save-area
-	  ;;			<- %sp
-
-	  ;; Save all %i arg register values on the stack.  (We
-	  ;; might not always need to save all, but this is safe
-	  ;; and easy.)
-	  (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes)))
-	  (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes)))
-	  (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes)))
-	  (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes)))
-	  (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes)))
-	  (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes)))
-
-	  ;; Set up our args to call funcall3
-	  ;;
-	  ;; %o0 = address of call-callback
-	  ;; %o1 = index
-	  ;; %o2 = pointer to the arguments of the caller (address
-	  ;;       of arg0 above)
-	  ;; %o3 = pointer to return area
-
-	  (inst li %o0 (alien::address-of-call-callback))
-	  (inst li %o1 (ash index vm:fixnum-tag-bits))
-	  (inst add %o2 %fp arg0-save-offset)
-	  (inst add %o3 %fp (- return-value-size))
-
-	  ;; And away we go to funcall3!
-	  (let ((addr (alien::address-of-funcall3)))
-	    (inst sethi %l0 (ldb (byte 22 10) addr))
-	    (inst jal %o7 %l0 (ldb (byte 10 0) addr))
-	    (inst nop))
-
-	  ;; Ok, we're back.  The value returned is actually
-	  ;; stored in the return area.  Need to get that into
-	  ;; the right registers for return.
-	  (etypecase return-type
-	    (alien::integer-64$
-	     ;; A 64-bit bignum, stored big-endian
-	     (inst ld %i0 %fp (- return-value-size))
-	     (inst ld %i1 %fp (- (- return-value-size vm:word-bytes))))
-	    ((or alien::integer$ alien::pointer$ alien::sap$)
-	     (inst ld %i0 %fp (- return-value-size)))
-	    (alien::single$
-	     ;; Get the FP value into F0
-	     (inst ldf f0-s %fp (- return-value-size))
-	     )
-	    (alien::double$
-	     (inst lddf f0-d %fp (- return-value-size)))
-	    (alien::void$
-	     ))
-
-	  (inst jal %g0 %i7 8)
-	  (inst restore %g0 %g0 %g0)
-	  )
-	(let ((length (finalize-segment segment)))
-	  (prog1 (alien::segment-to-trampoline segment length)
-	    (release-segment segment)))))))
-
-
diff --git a/src/compiler/sparc/c-callback.lisp b/src/compiler/sparc/c-callback.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ac97f9c26b3b74119dbcb70042737c691a2b9995
--- /dev/null
+++ b/src/compiler/sparc/c-callback.lisp
@@ -0,0 +1,215 @@
+;;; -*- Package: SPARC -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: src/compiler/sparc/c-call.lisp $")
+
+(in-package "SPARC")
+(intl:textdomain "cmucl-sparc-vm")
+(use-package "ALIEN")
+(use-package "ALIEN-INTERNALS")
+
+;;; Support for callbacks to Lisp.
+(export '(make-callback-trampoline callback-accessor-form
+	  compatible-function-types-p))
+
+(defun callback-accessor-form (type sp offset)
+  (let ((parsed-type (alien::parse-alien-type type)))
+    (typecase parsed-type
+      (alien::double$
+       ;; Due to sparc calling conventions, a double arg doesn't have to
+       ;; be aligned on a double word boundary.  We have to get the two
+       ;; words separately and create the double from them.  Doubles are
+       ;; stored in big-endian order, naturally.
+       `(kernel:make-double-float
+	 (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int)))
+	 (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes))
+				 (* c-call:unsigned-int)))))
+      (alien::integer-64$
+       ;; Same as for double, above
+       `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset)
+					  ,(if (alien-integer-type-signed parsed-type)
+					       '(* c-call:int)
+					       '(* c-call:unsigned-int)))))
+	      (lo (alien:deref (sap-alien (sys:sap+ ,sp
+						    (+ ,offset vm:word-bytes))
+					  (* c-call:unsigned-int)))))
+	  (+ (ash hi vm:word-bits) lo)))
+      (alien::integer$
+       ;; All other objects can be accessed directly.  But we need to
+       ;; get the offset right, since the offset we're given is the
+       ;; start of the object, and we're a big-endian machine.
+       (let ((byte-offset
+	      (- vm:word-bytes
+		 (ceiling (alien::alien-integer-type-bits parsed-type)
+			  vm:byte-bits))))
+	 `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset))
+			    (* ,type)))))
+      (t
+       `(deref (sap-alien (sys:sap+ ,sp ,offset)
+			  (* ,type)))))))
+
+(defun compatible-function-types-p (type1 type2)
+  (flet ((machine-rep (type)
+	   (etypecase type
+	     (alien::integer-64$ :dword)
+	     ((or alien::integer$ alien::pointer$ alien::sap$) :word)
+	     (alien::single$ :single)
+	     (alien::double$ :double)
+	     (alien::void$ :void))))
+    (let ((type1 (alien-function-type-result-type type1))
+	  (type2 (alien-function-type-result-type type2)))
+      (eq (machine-rep type1) (machine-rep type2)))))
+
+(defun make-callback-trampoline (index fn-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (let ((return-type (alien-function-type-result-type fn-type)))
+    (flet ((def-reg-tn (offset)
+	     (c:make-random-tn :kind :normal
+			       :sc (c:sc-or-lose 'vm::unsigned-reg)
+			       :offset offset)))
+      (let* ((segment (make-segment))
+	     ;; Window save area (16 registers)
+	     (window-save-size (* 16 vm:word-bytes))
+	     ;; Structure return pointer area (1 register)
+	     (struct-return-size vm:word-bytes)
+	     ;; Register save area (6 registers)
+	     (reg-save-area-size (* 6 vm:word-bytes))
+	     ;; Local var.  Should be large enough to hold a double-float or long
+	     (return-value-size (* 2 vm:word-bytes))
+	     ;; Frame size: the register window, the arg save area, the
+	     ;; structure return area, and return-value-area, all
+	     ;; rounded to a multiple of eight.
+	     (framesize (* 8 (ceiling (+ window-save-size struct-return-size
+					 reg-save-area-size
+					 return-value-size)
+				      8)))
+	     ;; Offset from FP where the first arg is located.
+	     (arg0-save-offset (+ window-save-size struct-return-size))
+	     ;; Establish the registers we need
+	     (%g0 (def-reg-tn vm::zero-offset))
+	     (%o0 (def-reg-tn vm::nl0-offset))
+	     (%o1 (def-reg-tn vm::nl1-offset))
+	     (%o2 (def-reg-tn vm::nl2-offset))
+	     (%o3 (def-reg-tn vm::nl3-offset))
+	     (%o7 (def-reg-tn vm::nargs-offset))
+	     (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6
+	     (%l0 (def-reg-tn vm::a0-offset))
+	     (%i0 (def-reg-tn vm::cname-offset))
+	     (%i1 (def-reg-tn vm::lexenv-offset))
+	     (%i2 (def-reg-tn 26))
+	     (%i3 (def-reg-tn vm::nfp-offset))
+	     (%i4 (def-reg-tn vm::cfunc-offset))
+	     (%i5 (def-reg-tn vm::code-offset))
+	     (%fp (def-reg-tn 30))
+	     (%i7 (def-reg-tn vm::lip-offset))
+	     (f0-s (c:make-random-tn :kind :normal
+				     :sc (c:sc-or-lose 'vm::single-reg)
+				     :offset 0))
+	     (f0-d (c:make-random-tn :kind :normal
+				     :sc (c:sc-or-lose 'vm::double-reg)
+				     :offset 0))
+	     )
+	;; The generated assembly roughly corresponds to this C code:
+	;;
+	;;        tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...)
+	;;	{
+	;;	  double result;
+	;;	  funcall3(call-callback, <index>, &a0, &result);
+	;;	  return <cast> result;
+	;;	}
+	;;
+	;; Except, of course, the result is the appropriate result type
+	;; for the trampoline.
+	;;	       
+	(assemble (segment)
+	  ;; Save old %fp, etc. establish our call frame with local vars
+	  ;; %i contains the input args
+	  (inst save %sp %sp (- framesize))
+	  ;; The stack frame now looks like
+	  ;;
+	  ;; TOP (high memory)
+	  ;;
+	  ;; argn
+	  ;; ...
+	  ;; arg6
+	  ;; arg5
+	  ;; arg4
+	  ;; arg3
+	  ;; arg2
+	  ;; arg1
+	  ;; arg0
+	  ;; struct_return
+	  ;; window-save-area	<- %fp + 64
+	  ;;			<- %fp
+	  ;; local-vars-extra-args	(8-bytes)
+	  ;; arg5-save
+	  ;; arg4-save
+	  ;; arg3-save
+	  ;; arg2-save
+	  ;; arg1-save
+	  ;; arg0-save
+	  ;; struct_return		
+	  ;; window-save-area
+	  ;;			<- %sp
+
+	  ;; Save all %i arg register values on the stack.  (We
+	  ;; might not always need to save all, but this is safe
+	  ;; and easy.)
+	  (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes)))
+	  (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes)))
+	  (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes)))
+	  (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes)))
+	  (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes)))
+	  (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes)))
+
+	  ;; Set up our args to call funcall3
+	  ;;
+	  ;; %o0 = address of call-callback
+	  ;; %o1 = index
+	  ;; %o2 = pointer to the arguments of the caller (address
+	  ;;       of arg0 above)
+	  ;; %o3 = pointer to return area
+
+	  (inst li %o0 (alien::address-of-call-callback))
+	  (inst li %o1 (ash index vm:fixnum-tag-bits))
+	  (inst add %o2 %fp arg0-save-offset)
+	  (inst add %o3 %fp (- return-value-size))
+
+	  ;; And away we go to funcall3!
+	  (let ((addr (alien::address-of-funcall3)))
+	    (inst sethi %l0 (ldb (byte 22 10) addr))
+	    (inst jal %o7 %l0 (ldb (byte 10 0) addr))
+	    (inst nop))
+
+	  ;; Ok, we're back.  The value returned is actually
+	  ;; stored in the return area.  Need to get that into
+	  ;; the right registers for return.
+	  (etypecase return-type
+	    (alien::integer-64$
+	     ;; A 64-bit bignum, stored big-endian
+	     (inst ld %i0 %fp (- return-value-size))
+	     (inst ld %i1 %fp (- (- return-value-size vm:word-bytes))))
+	    ((or alien::integer$ alien::pointer$ alien::sap$)
+	     (inst ld %i0 %fp (- return-value-size)))
+	    (alien::single$
+	     ;; Get the FP value into F0
+	     (inst ldf f0-s %fp (- return-value-size))
+	     )
+	    (alien::double$
+	     (inst lddf f0-d %fp (- return-value-size)))
+	    (alien::void$
+	     ))
+
+	  (inst jal %g0 %i7 8)
+	  (inst restore %g0 %g0 %g0)
+	  )
+	(let ((length (finalize-segment segment)))
+	  (prog1 (alien::segment-to-trampoline segment length)
+	    (release-segment segment)))))))
+
+
diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 7efd0b969ee29f0d75fae9913605f36ffe70fe5e..4554a0e9c509c4874aa7f1b01ddfd378f3bdbe64 100644
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -244,68 +244,3 @@
 				    (ash symbol-value-slot word-shift)
 				    (- other-pointer-type)))
 	      delta)))))
-
-;;; Support for callbacks to Lisp.
-(export '(make-callback-trampoline callback-accessor-form
-	  compatible-function-types-p))
-
-(defun callback-accessor-form (type sp offset)
-  `(alien:deref (sap-alien 
-		 (sys:sap+ ,sp ,offset)
-		 (* ,type))))
-
-(defun compatible-function-types-p (type1 type2)
-  (flet ((machine-rep (type)
-	   (etypecase type
-	     (alien::integer-64$ :dword)
-	     ((or alien::integer$ alien::pointer$ alien::sap$) :word)
-	     (alien::single$ :single)
-	     (alien::double$ :double)
-	     (alien::void$ :void))))
-    (let ((type1 (alien-function-type-result-type type1))
-	  (type2 (alien-function-type-result-type type2)))
-      (eq (machine-rep type1) (machine-rep type2)))))
-
-(defun make-callback-trampoline (index fn-type)
-  "Cons up a piece of code which calls call-callback with INDEX and a
-pointer to the arguments."
-  (let* ((return-type (alien-function-type-result-type fn-type))
-	 (segment (make-segment))
-	 (eax x86::eax-tn)
-	 (edx x86::edx-tn)
-	 (ebp x86::ebp-tn)
-	 (esp x86::esp-tn)
-	 ([ebp-8] (x86::make-ea :dword :base ebp :disp -8))
-	 ([ebp-4] (x86::make-ea :dword :base ebp :disp -4)))
-    (assemble (segment)
-	      (inst push ebp)			    ; save old frame pointer
-	      (inst mov  ebp esp)		    ; establish new frame
-	      (inst mov  eax esp)		    ; 
-	      (inst sub  eax 8)		            ; place for result 
-	      (inst push eax)			    ; arg2
-	      (inst add  eax 16)		    ; arguments  
-	      (inst push eax)			    ; arg1
-	      (inst push (ash index 2))		    ; arg0
-	      (inst push (alien::address-of-call-callback))     ; function
-	      (inst mov  eax (alien::address-of-funcall3))
-	      (inst call eax)
-	      ;; now put the result into the right register
-	      (etypecase return-type
-		(alien::integer-64$
-		 (inst mov eax [ebp-8])
-		 (inst mov edx [ebp-4]))
-		((or alien::integer$ alien::pointer$ alien::sap$)
-		 (inst mov eax [ebp-8]))
-		(alien::single$
-		 (inst fld  [ebp-8]))
-		(alien::double$
-		 (inst fldd [ebp-8]))
-		(alien::void$ ))
-	      (inst mov esp ebp)		   ; discard frame
-	      (inst pop ebp)			   ; restore frame pointer
-	      (inst ret))
-    (let* ((length (finalize-segment segment)))
-      (prog1 (alien::segment-to-trampoline segment length)
-	(release-segment segment)))))
-
-
diff --git a/src/compiler/x86/c-callback.lisp b/src/compiler/x86/c-callback.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b9e27fc687481ee20f5e08cc4df75291cd3b8cc5
--- /dev/null
+++ b/src/compiler/x86/c-callback.lisp
@@ -0,0 +1,80 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: src/compiler/x86/c-call.lisp $")
+
+(in-package :x86)
+(use-package :alien)
+(use-package :alien-internals)
+(intl:textdomain "cmucl-x86-vm")
+
+;;; Support for callbacks to Lisp.
+(export '(make-callback-trampoline callback-accessor-form
+	  compatible-function-types-p))
+
+(defun callback-accessor-form (type sp offset)
+  `(alien:deref (sap-alien 
+		 (sys:sap+ ,sp ,offset)
+		 (* ,type))))
+
+(defun compatible-function-types-p (type1 type2)
+  (flet ((machine-rep (type)
+	   (etypecase type
+	     (alien::integer-64$ :dword)
+	     ((or alien::integer$ alien::pointer$ alien::sap$) :word)
+	     (alien::single$ :single)
+	     (alien::double$ :double)
+	     (alien::void$ :void))))
+    (let ((type1 (alien-function-type-result-type type1))
+	  (type2 (alien-function-type-result-type type2)))
+      (eq (machine-rep type1) (machine-rep type2)))))
+
+(defun make-callback-trampoline (index fn-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (let* ((return-type (alien-function-type-result-type fn-type))
+	 (segment (make-segment))
+	 (eax x86::eax-tn)
+	 (edx x86::edx-tn)
+	 (ebp x86::ebp-tn)
+	 (esp x86::esp-tn)
+	 ([ebp-8] (x86::make-ea :dword :base ebp :disp -8))
+	 ([ebp-4] (x86::make-ea :dword :base ebp :disp -4)))
+    (assemble (segment)
+	      (inst push ebp)			    ; save old frame pointer
+	      (inst mov  ebp esp)		    ; establish new frame
+	      (inst mov  eax esp)		    ; 
+	      (inst sub  eax 8)		            ; place for result 
+	      (inst push eax)			    ; arg2
+	      (inst add  eax 16)		    ; arguments  
+	      (inst push eax)			    ; arg1
+	      (inst push (ash index 2))		    ; arg0
+	      (inst push (alien::address-of-call-callback))     ; function
+	      (inst mov  eax (alien::address-of-funcall3))
+	      (inst call eax)
+	      ;; now put the result into the right register
+	      (etypecase return-type
+		(alien::integer-64$
+		 (inst mov eax [ebp-8])
+		 (inst mov edx [ebp-4]))
+		((or alien::integer$ alien::pointer$ alien::sap$)
+		 (inst mov eax [ebp-8]))
+		(alien::single$
+		 (inst fld  [ebp-8]))
+		(alien::double$
+		 (inst fldd [ebp-8]))
+		(alien::void$ ))
+	      (inst mov esp ebp)		   ; discard frame
+	      (inst pop ebp)			   ; restore frame pointer
+	      (inst ret))
+    (let* ((length (finalize-segment segment)))
+      (prog1 (alien::segment-to-trampoline segment length)
+	(release-segment segment)))))
+
+
diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp
index a968506652bd3b3cf3ac6c4dd9ec5c2bf4e2594a..0953dc07d83a261bd226cc4973d10a556bf1709e 100644
--- a/src/tools/comcom.lisp
+++ b/src/tools/comcom.lisp
@@ -197,6 +197,7 @@
 	    (vmdir "target:compiler/sse2-c-call")
 	    (vmdir "target:compiler/x87-c-call"))
 	:byte-compile *byte-compile*))
+(comf (vmdir "target:compiler/c-callback"))
 (comf (vmdir "target:compiler/cell"))
 (comf (vmdir "target:compiler/values") :byte-compile *byte-compile*)
 (comf (vmdir "target:compiler/alloc"))
diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp
index fac94280ced33ec3a5ca9b2cd95ddf4ab6becce0..9a74818bd6f8d2297af9d4244edaf6ce651d784d 100644
--- a/src/tools/worldcom.lisp
+++ b/src/tools/worldcom.lisp
@@ -138,6 +138,7 @@
 (setf (fdefinition 'lisp::%deftype) *original-%deftype*)
 
 (comf "target:code/alieneval")
+(comf "target:code/alien-callback")
 (comf "target:code/c-call")
 (comf "target:code/sap")