From 04c91358aac845093bb287142ca8b33ee039aad7 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 11 Mar 1992 21:26:52 +0000
Subject: [PATCH] Added FDEFN changes.

---
 compiler/ir1tran.lisp        |  30 +++++++--
 compiler/ir2tran.lisp        |  84 ++++++++---------------
 compiler/ltn.lisp            |   6 +-
 compiler/mips/alloc.lisp     |  27 +++-----
 compiler/mips/call.lisp      |  11 ++-
 compiler/mips/cell.lisp      | 127 +++++++++++------------------------
 compiler/mips/parms.lisp     |  28 ++++----
 compiler/mips/static-fn.lisp |  10 +--
 compiler/mips/type-vops.lisp |  68 ++-----------------
 9 files changed, 134 insertions(+), 257 deletions(-)

diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index add30c087..21dc8a555 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.66 1992/02/24 01:25:35 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.67 1992/03/11 21:23:26 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2470,14 +2470,30 @@
 ;;; user policy settings.
 ;;;
 
-(def-source-transform funcall (function &rest args)
-  `(%funcall ,function ,@args))
+(deftransform funcall ((function &rest args))
+  (collect ((arg-names))
+    (dolist (arg args)
+      (declare (ignore arg))
+      (arg-names (gensym "FUNCALL-ARG-")))
+    `(lambda (function ,@(arg-names))
+       (%funcall ,(if (csubtypep (continuation-type function)
+				 (specifier-type 'function))
+		      'function
+		      '(if (functionp function)
+			   function
+			   (%coerce-to-function function)))
+		 ,@(arg-names)))))
 
 (def-ir1-translator %funcall ((function &rest args) start cont)
   (let ((fun-cont (make-continuation)))
     (ir1-convert start fun-cont function)
+    (assert-continuation-type fun-cont (specifier-type 'function))
     (ir1-convert-combination-args fun-cont cont args)))
 
+(deftransform %coerce-to-function ((thing))
+  (give-up "Might be a symbol, so must call FDEFINITION at runtime."))
+
+
 
 ;;;; Symbol macros:
 
@@ -3106,7 +3122,13 @@
 	 (node (if args
 		   (make-mv-combination fun-cont)
 		   (make-combination fun-cont))))
-    (ir1-convert start fun-cont fun)
+    (ir1-convert start fun-cont
+		 (if (and (consp fun) (eq (car fun) 'function))
+		     fun
+		     (once-only ((fun fun))
+		       `(if (functionp ,fun)
+			    ,fun
+			    (%coerce-to-function ,fun)))))
     (setf (continuation-dest fun-cont) node)
     (assert-continuation-type fun-cont
 			      (specifier-type '(or function symbol)))
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
index 1c0bfe484..4f154b711 100644
--- a/compiler/ir2tran.lisp
+++ b/compiler/ir2tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.40 1991/12/19 22:11:50 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.41 1992/03/11 21:23:41 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,6 +21,9 @@
 (export '(%caller-frame-and-pc))
 (in-package "C")
 
+(export '(safe-fdefn-function))
+
+
 
 ;;;; Moves and type checks:
 
@@ -122,26 +125,6 @@
   (constant-tn (find-constant value)))
 
 
-;;; IR2-Convert-Hairy-Function-Ref  --  Internal
-;;;
-;;;    Handle a function Ref that can't be converted to a symbol access.  We
-;;; convert a call to FDEFINITION with Name as the argument.
-;;;
-(defun ir2-convert-hairy-function-ref (node block name)
-  (declare (type ref node) (type ir2-block block) (type tn name))
-  (when (policy node (> speed brevity))
-    (let ((*compiler-error-context* node))
-      (compiler-note "Compiling a full call to FDEFINITION.")))
-  (let* ((arg (standard-argument-location 0))
-	 (res (standard-argument-location 0))
-	 (fun (emit-constant 'fdefinition))
-	 (fp (make-stack-pointer-tn)))
-    (vop allocate-full-call-frame node block 1 fp)
-    (vop* call-named node block (fp fun name nil) (res nil) (list arg) 1 1)
-    (move-continuation-result node block (list res) (node-cont node)))
-  (undefined-value))
-
-
 ;;; IR2-Convert-Ref  --  Internal
 ;;;
 ;;;    Convert a Ref node.  The reference must not be delayed.
@@ -170,22 +153,19 @@
       (functional
        (ir2-convert-closure node block leaf res))
       (global-var
-       (let ((name-tn (emit-constant name))
-	     (unsafe (policy node (zerop safety))))
+       (let ((unsafe (policy node (zerop safety))))
 	 (ecase (global-var-kind leaf)
 	   ((:special :global :constant)
 	    (assert (symbolp name))
-	    (if unsafe
-		(vop fast-symbol-value node block name-tn res)
-		(vop symbol-value node block name-tn res)))
+	    (let ((name-tn (emit-constant name)))
+	      (if unsafe
+		  (vop fast-symbol-value node block name-tn res)
+		  (vop symbol-value node block name-tn res))))
 	   (:global-function
-	    (unless (symbolp name)
-	      (ir2-convert-hairy-function-ref node block name-tn)
-	      (return-from ir2-convert-ref (undefined-value)))
-
-	    (if unsafe
-		(vop fast-symbol-function node block name-tn res)
-		(vop symbol-function node block name-tn res)))))))
+	    (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
+	      (if unsafe
+		  (vop fdefn-function node block fdefn-tn res)
+		  (vop safe-fdefn-function node block fdefn-tn res))))))))
 
     (move-continuation-result node block locs cont))
   (undefined-value))
@@ -924,23 +904,19 @@
 
 ;;; Function-Continuation-TN  --  Internal
 ;;;
-;;;    Given a function continuation Fun, return as values a TN holding the
-;;; thing that we call and true if the thing is a symbol (false if it is a
-;;; function).  There are three interesting non-symbol cases:
+;;; Given a function continuation Fun, return as values a TN holding the
+;;; thing that we call and true if the thing is named (false if it is a
+;;; function).  There are two interesting non-named cases:
 ;;; -- Known to be a function, no check needed: return the continuation loc.
-;;; -- Known to be a function or a symbol, may need to be coerced.
 ;;; -- Not known what it is.
 ;;;
 (defun function-continuation-tn (node block cont)
   (declare (type continuation cont))
-  (let* ((2cont (continuation-info cont))
-	 (name (if (eq (ir2-continuation-kind 2cont) :delayed)
-		   (let ((res (continuation-function-name cont t)))
-		     (assert res)
-		     res)
-		   nil)))
-    (if name
-	(values (emit-constant name) t)
+  (let ((2cont (continuation-info cont)))
+    (if (eq (ir2-continuation-kind 2cont) :delayed)
+	(let ((name (continuation-function-name cont t)))
+	  (assert name)
+	  (values (make-load-time-constant-tn :fdefinition name) t))
 	(let* ((locs (ir2-continuation-locs 2cont))
 	       (loc (first locs))
 	       (check (continuation-type-check cont))
@@ -958,17 +934,7 @@
 			  (emit-type-check node block loc temp
 					   (specifier-type 'function)))
 			 (t
-			  (when (policy node (> speed brevity))
-			    (let ((*compiler-error-context* node))
-			      (compiler-note
-			       "Called function might be a ~
-			       symbol, so must coerce at run-time.")))
-
-			  (if (eq check t)
-			      (vop coerce-to-function node block loc temp)
-			      (vop fast-safe-coerce-to-function node block
-				   loc temp))))
-
+			  (error "This shouldn't happen.")))
 		   (values temp nil))))))))
 
 
@@ -1728,7 +1694,11 @@
 		     (vop nil-function-returned-error last 2block
 			  (if name
 			      (emit-constant name)
-			      (function-continuation-tn last 2block fun)))))))
+			      (multiple-value-bind
+				  (tn named)
+				  (function-continuation-tn last 2block fun)
+				(assert (not named))
+				tn)))))))
 	      ((not (eq (ir2-block-next 2block) (block-info target)))
 	       (vop branch last 2block (block-label target)))))))
   
diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp
index 14a0cbfc7..28e3b26fb 100644
--- a/compiler/ltn.lisp
+++ b/compiler/ltn.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.30 1992/02/13 09:30:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.31 1992/03/11 21:23:48 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -153,7 +153,7 @@
 ;;; Annotate-Function-Continuation  --  Internal
 ;;;
 ;;;    Annotate the function continuation for a full call.  If the only
-;;; reference is to a global symbol function and Delay is true, then we delay
+;;; reference is to a global function and Delay is true, then we delay
 ;;; the reference, otherwise we annotate for a single value.
 ;;;
 ;;;   Unlike for an argument, we only clear the type check flag when the policy
@@ -170,7 +170,7 @@
 	 (info (make-ir2-continuation ptype)))
     (setf (continuation-info cont) info)
     (let ((name (continuation-function-name cont t)))
-      (if (and delay name (symbolp name))
+      (if (and delay name)
 	  (setf (ir2-continuation-kind info) :delayed)
 	  (setf (ir2-continuation-locs info) (list (make-normal-tn ptype))))))
   (undefined-value))
diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp
index 06116d147..e8c033c4f 100644
--- a/compiler/mips/alloc.lisp
+++ b/compiler/mips/alloc.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: C -*-
+;;; -*- Package: MIPS -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.15 1991/03/20 03:06:34 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.15 1991/03/20 03:06:34 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $
 ;;;
 ;;; Allocation VOPs for the MIPS port.
 ;;;
@@ -108,24 +108,18 @@
       (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type)
       (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type))))
 
-(define-vop (make-symbol)
+(define-vop (make-fdefn)
+  (:policy :fast-safe)
+  (:translate make-fdefn)
   (:args (name :scs (descriptor-reg) :to :eval))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (result :scs (descriptor-reg) :from :argument))
-  (:policy :fast-safe)
-  (:translate make-symbol)
   (:generator 37
-    (with-fixed-allocation (result temp vm:symbol-header-type vm:symbol-size)
-      (inst li temp vm:unbound-marker-type)
-      (storew temp result vm:symbol-value-slot vm:other-pointer-type)
-      (storew temp result vm:symbol-function-slot vm:other-pointer-type)
-      (storew temp result vm:symbol-setf-function-slot vm:other-pointer-type)
+    (with-fixed-allocation (result temp fdefn-type fdefn-size)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew null-tn result fdefn-function-slot other-pointer-type)
       (inst li temp (make-fixup "undefined_tramp" :foreign))
-      (storew temp result vm:symbol-raw-function-addr-slot
-	      vm:other-pointer-type)
-      (storew null-tn result vm:symbol-plist-slot vm:other-pointer-type)
-      (storew name result vm:symbol-name-slot vm:other-pointer-type)
-      (storew null-tn result vm:symbol-package-slot vm:other-pointer-type))))
+      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
 
 
 ;;;; Automatic allocators for primitive objects.
@@ -133,7 +127,6 @@
 (vm:define-for-each-primitive-object (obj)
   (collect ((forms))
     (let* ((options (vm:primitive-object-options obj))
-	   (obj-type (getf options :type t))
 	   (alloc-trans (getf options :alloc-trans))
 	   (alloc-vop (getf options :alloc-vop alloc-trans))
 	   (header (vm:primitive-object-header obj))
diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp
index 7d58fb822..29975bde3 100644
--- a/compiler/mips/call.lisp
+++ b/compiler/mips/call.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.41 1991/11/09 20:52:53 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.42 1992/03/11 21:26:19 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.41 1991/11/09 20:52:53 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.42 1992/03/11 21:26:19 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition of function call for the MIPS.
 ;;;
@@ -805,17 +805,14 @@ default-value-8
 		      (inst lw name-pass fp-tn
 			    (ash (tn-offset name) vm:word-shift))
 		      (do-next-filler))
-		     (random-immediate
-		      (load-symbol name-pass (tn-value name)))
 		     (constant
 		      (inst lw name-pass code-tn
 			    (- (ash (tn-offset name) vm:word-shift)
 			       vm:other-pointer-type))
 		      (do-next-filler)))
 		   (inst lw lip name-pass
-			 (- (ash vm:symbol-raw-function-addr-slot
-				 vm:word-shift)
-			    vm:other-pointer-type))
+			 (- (ash fdefn-raw-addr-slot word-shift)
+			    other-pointer-type))
 		   (do-next-filler))
 		 `((sc-case arg-fun
 		     (descriptor-reg (move lexenv arg-fun))
diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp
index 471580f57..9d19c1902 100644
--- a/compiler/mips/cell.lisp
+++ b/compiler/mips/cell.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.56 1992/02/24 00:43:42 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.57 1992/03/11 21:26:25 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.56 1992/02/24 00:43:42 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.57 1992/03/11 21:26:25 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition of various primitive memory access
 ;;; VOPs for the MIPS.
@@ -105,27 +105,6 @@
       (inst beq temp zero-tn err-lab)
       (inst nop))))
 
-;;; With Symbol-Function, we check that the result is a function, so NIL is
-;;; always un-fbound.
-;;;
-(define-vop (symbol-function checked-cell-ref)
-  (:translate symbol-function)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp symbol-function-slot other-pointer-type)
-    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
-      (test-simple-type value temp err-lab t function-pointer-type))))
-
-#+nil
-(define-vop (symbol-setf-function checked-cell-ref)
-  (:translate symbol-setf-function)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp symbol-setf-function-slot other-pointer-type)
-    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
-      (test-simple-type value temp err-lab t function-pointer-type))))
-
-
 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
 (define-vop (boundp-frob)
   (:args (object :scs (descriptor-reg)))
@@ -145,55 +124,37 @@
 	(inst bne temp zero-tn target))
     (inst nop)))
 
-
-;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
-;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
-
-(defknown fboundp/symbol (t) boolean (flushable))
-;;;
-(deftransform fboundp ((x) (symbol))
-  '(fboundp/symbol x))
-;;;
-(define-vop (fboundp/symbol boundp-frob)
-  (:translate fboundp/symbol)
-  (:generator 10
-    (loadw value object symbol-function-slot other-pointer-type)
-    (test-simple-type value temp target not-p function-pointer-type)))
-
-#+nil(progn
-(defknown fboundp/setf (t) boolean (flushable))
-;;;
-(deftransform fboundp ((x) (cons))
-  '(fboundp/setf (cadr x)))
-;;;
-(define-vop (fboundp/setf boundp-frob)
-  (:translate fboundp/setf)
-  (:generator 10
-    (loadw value object symbol-setf-function-slot other-pointer-type)
-    (test-simple-type value temp target not-p function-pointer-type)))
-)
-
 (define-vop (fast-symbol-value cell-ref)
   (:variant symbol-value-slot other-pointer-type)
   (:policy :fast)
   (:translate symbol-value))
 
-(define-vop (fast-symbol-function cell-ref)
-  (:variant symbol-function-slot other-pointer-type)
-  (:policy :fast)
-  (:translate symbol-function))
 
-(define-vop (set-symbol-function)
-  (:translate %set-symbol-function)
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (safe-fdefn-function)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
+  (:generator 10
+    (move obj-temp object)
+    (loadw value obj-temp fdefn-function-slot other-pointer-type)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+      (inst beq value null-tn err-lab))
+    (inst nop)))
+
+(define-vop (set-fdefn-function)
   (:policy :fast-safe)
-  (:args (symbol :scs (descriptor-reg))
-	 (function :scs (descriptor-reg) :target result))
-  (:results (result :scs (descriptor-reg)))
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:scs (interior-reg)) lip)
   (:temporary (:scs (non-descriptor-reg)) type)
-  (:temporary (:scs (any-reg)) temp)
-  (:save-p :compute-only)
-  (:vop-var vop)
-  (:generator 30
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
     (let ((closure (gen-label))
 	  (normal-fn (gen-label)))
       (load-type type function (- function-pointer-type))
@@ -205,40 +166,32 @@
       (inst beq type zero-tn closure)
       (inst xor type (logxor funcallable-instance-header-type
 			     function-header-type))
-      (inst beq type zero-tn normal-fn)
-      (inst addu temp function
+      (inst bne type zero-tn normal-fn)
+      (inst addu lip function
 	    (- (ash function-header-code-offset word-shift)
 	       function-pointer-type))
-      (error-call vop kernel:object-not-function-error function)
       (emit-label closure)
-      (inst li temp (make-fixup "closure_tramp" :foreign))
+      (inst li lip (make-fixup "closure_tramp" :foreign))
       (emit-label normal-fn)
-      (storew function symbol symbol-function-slot other-pointer-type)
-      (storew temp symbol symbol-raw-function-addr-slot other-pointer-type)
+      (storew function fdefn fdefn-function-slot other-pointer-type)
+      (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
       (move result function))))
 
-
-(defknown fmakunbound/symbol (symbol) symbol (unsafe))
-;;;
-(deftransform fmakunbound ((symbol) (symbol))
-  '(when symbol
-     (fmakunbound/symbol symbol)))
-;;;
-(define-vop (fmakunbound/symbol)
-  (:translate fmakunbound/symbol)
+(define-vop (fdefn-makunbound)
   (:policy :fast-safe)
-  (:args (symbol :scs (descriptor-reg) :target result))
-  (:results (result :scs (descriptor-reg)))
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
   (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (inst li temp unbound-marker-type)
-    (storew temp symbol symbol-function-slot other-pointer-type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew null-tn fdefn fdefn-function-slot other-pointer-type)
     (inst li temp (make-fixup "undefined_tramp" :foreign))
-    (storew temp symbol symbol-raw-function-addr-slot other-pointer-type)
-    (move result symbol)))
+    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
 
 
-;;; Binding and Unbinding.
+
+;;;; Binding and Unbinding.
 
 ;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
 ;;; the symbol on the binding stack and stuff the new value into the
diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
index d547b4cd5..7412f58b2 100644
--- a/compiler/mips/parms.lisp
+++ b/compiler/mips/parms.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.100 1992/03/11 21:26:44 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.100 1992/03/11 21:26:44 wlott Exp $
 ;;;
 ;;;    This file contains some parameterizations of various VM
 ;;; attributes for the MIPS.  This file is separate from other stuff so 
@@ -42,7 +42,7 @@
 (setf (backend-fasl-file-type *target-backend*) "pmaxf")
 (setf (backend-fasl-file-implementation *target-backend*)
       pmax-fasl-file-implementation)
-(setf (backend-fasl-file-version *target-backend*) 3)
+(setf (backend-fasl-file-version *target-backend*) 4)
 (setf (backend-register-save-penalty *target-backend*) 3)
 (setf (backend-byte-order *target-backend*) :little-endian)
 
@@ -152,14 +152,15 @@
 
 ;;;; Static symbols.
 
-(export '(static-symbols exported-static-symbols))
+(export '(static-symbols static-functions))
 
-;;; These symbols are loaded into static space directly after NIL so
+;;; Static symbols are loaded into static space directly after NIL so
 ;;; that the system can compute their address by adding a constant
 ;;; amount to NIL.
 ;;;
-;;; The exported static symbols are a subset of the static symbols that get
-;;; exported to the C header file.
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols.  That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
 ;;;
 (defparameter static-symbols
   '(t
@@ -167,12 +168,14 @@
     ;; Random stuff needed for initialization.
     lisp::lisp-environment-list
     lisp::lisp-command-line-list
+    lisp::*initial-fdefn-objects*
 
     ;; Functions that the C code needs to call
     lisp::%initial-function
     lisp::maybe-gc
     kernel::internal-error
     di::handle-breakpoint
+    lisp::fdefinition-object
 
     ;; Free Pointers
     lisp::*read-only-space-free-pointer*
@@ -188,13 +191,10 @@
     lisp::*free-interrupt-context-index*
     unix::*interrupts-enabled*
     unix::*interrupt-pending*
+    ))
 
-    ;; Static functions.
-    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
+(defparameter static-functions
+  '(two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
     two-arg-<= two-arg->= two-arg-/= eql %negate
     two-arg-and two-arg-ior two-arg-xor
-    length two-arg-gcd two-arg-lcm
-    ))
-
-(defparameter exported-static-symbols
-  (subseq static-symbols 0 (position 'two-arg-+ static-symbols)))
+    length two-arg-gcd two-arg-lcm))
diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp
index 8ac396194..b3658aef1 100644
--- a/compiler/mips/static-fn.lisp
+++ b/compiler/mips/static-fn.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.15 1991/07/14 03:46:41 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.16 1992/03/11 21:26:48 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.15 1991/07/14 03:46:41 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.16 1992/03/11 21:26:48 wlott Exp $
 ;;;
 ;;; This file contains the VOPs and macro magic necessary to call static
 ;;; functions.
@@ -30,7 +30,6 @@
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg)) move-temp)
   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:sc descriptor-reg :offset cname-offset) cname)
   (:temporary (:scs (interior-reg) :type interior) lip)
   (:temporary (:sc any-reg :offset nargs-offset) nargs)
   (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
@@ -92,10 +91,7 @@
 		 (cur-nfp (current-nfp-tn vop)))
 	     ,@(moves (temp-names) (arg-names))
 	     (inst li nargs (fixnum ,num-args))
-	     (load-symbol cname symbol)
-	     (inst lw lip cname
-		   (- (ash vm:symbol-raw-function-addr-slot vm:word-shift)
-		      vm:other-pointer-type))
+	     (inst lw lip null-tn (static-function-offset symbol))
 	     (when cur-nfp
 	       (store-stack-tn nfp-save cur-nfp))
 	     (inst move old-fp cfp-tn)
diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp
index fef2cd2f6..a55cc50de 100644
--- a/compiler/mips/type-vops.lisp
+++ b/compiler/mips/type-vops.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.32 1991/11/09 02:37:45 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.33 1992/03/11 21:26:52 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -150,12 +150,18 @@
   (:variant-cost 9)
   (:translate lra-p))
 
+(define-vop (fdefn-p simple-type-predicate)
+  (:variant fdefn-type)
+  (:variant-cost 9)
+  (:translate fdefn-p))
+
 (define-vop (scavenger-hook-p simple-type-predicate)
   (:variant 0)
   (:variant-cost 9)
   (:translate scavenger-hook-p))
 
 
+
 ;;; Slightly tenser versions for FIXNUM's
 ;;; 
 (define-vop (check-fixnum check-simple-type)
@@ -469,63 +475,3 @@
       (test-simple-type obj temp target not-p vm:list-pointer-type)
       (emit-label drop-thru))))
 
-
-;;;; Function Coercion
-
-;;; If not a function, get the symbol value and test for that being a
-;;; function.  Since we test for a function rather than the unbound
-;;; marker, this works on NIL.
-;;;
-(define-vop (coerce-to-function)
-  (:args (object :scs (descriptor-reg)
-		:target result))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
-  (:temporary (:scs (descriptor-reg)) saved-object)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (let ((not-function-label (gen-label))
-	  (not-coercable-label (gen-label))
-	  (done-label (gen-label)))
-      (test-simple-type object nd-temp not-function-label t
-			vm:function-pointer-type)
-      (move result object)
-      (emit-label done-label)
-
-      (assemble (*elsewhere*)
-	(emit-label not-function-label)
-	(test-simple-type object nd-temp not-coercable-label t
-			  vm:symbol-header-type)
-	(move saved-object object)
-	(loadw result object vm:symbol-function-slot vm:other-pointer-type)
-	(test-simple-type result nd-temp done-label nil
-			  vm:function-pointer-type)
-	(error-call vop undefined-symbol-error saved-object)
-	
-	(emit-label not-coercable-label)
-	(error-call vop object-not-coercable-to-function-error object)))))
-
-(define-vop (fast-safe-coerce-to-function)
-  (:args (object :scs (descriptor-reg)
-		:target result))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
-  (:temporary (:scs (descriptor-reg)) saved-object)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (let ((not-function-label (gen-label))
-	  (done-label (gen-label)))
-      (test-simple-type object nd-temp not-function-label t
-			vm:function-pointer-type)
-      (move result object)
-      (emit-label done-label)
-
-      (assemble (*elsewhere*)
-	(emit-label not-function-label)
-	(move saved-object object)
-	(loadw result object vm:symbol-function-slot vm:other-pointer-type)
-	(test-simple-type result nd-temp done-label nil
-			  vm:function-pointer-type)
-	(error-call vop undefined-symbol-error saved-object)))))
-- 
GitLab