From d6a1a42424a25f75e3c57491cda0af3183429fed Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 11 May 1993 17:26:28 +0000
Subject: [PATCH] changed byte functions to be funcallable instances.  Added
 with-debugger-info various places.

---
 code/byte-interp.lisp | 213 ++++++++++++++++++++++--------------------
 1 file changed, 111 insertions(+), 102 deletions(-)

diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp
index 32742225f..07ab2e810 100644
--- a/code/byte-interp.lisp
+++ b/code/byte-interp.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.5 1993/05/11 13:47:41 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.6 1993/05/11 17:26:28 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -15,9 +15,13 @@
 ;;;
 ;;; Written by William Lott
 ;;;
-
 (in-package "C")
 
+(in-package "KERNEL")
+(export '(byte-function byte-function-name initialize-byte-function
+			byte-closure byte-closure-function
+			byte-closure-data byte-function-or-closure))
+(in-package "C")
 
 
 ;;;; Types.
@@ -36,18 +40,42 @@
 
 ;;;; Byte functions:
 
-(defstruct (byte-function
-	    (:print-function %print-byte-function))
+;;; Abstract class represents any type of byte-compiled function.
+;;;
+(defstruct (byte-function-or-closure
+	    (:print-function %print-byte-function)
+	    (:alternate-metaclass kernel:funcallable-instance
+				  kernel:funcallable-structure-class
+				  kernel:make-funcallable-structure-class)
+	    (:type kernel:funcallable-structure)))
+
+;;; Represents a byte-compiled closure.
+;;;
+(defstruct (byte-closure (:include byte-function-or-closure)
+			 (:constructor make-byte-closure function data))
   ;;
-  ;; Debug name of this function.
-  (name nil)
+  ;; Byte function that we call.
+  (function (required-argument) :type byte-function)
+  ;;
+  ;; Closure data vector.
+  (data (required-argument) :type simple-vector))
+
+
+;;; Any non-closure byte function (including the hidden function object for a
+;;; closure.)
+;;;
+(defstruct (byte-function (:include byte-function-or-closure))
   ;;
   ;; The component that this XEP is an entry point into.  NIL until
-  ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in.  We also allow
-  ;; cons so that the dumper can stick in a unique cons cell to
-  ;; identify what component it is trying to dump.  What a hack.
-  (component nil :type (or null kernel:code-component cons)))
+  ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in.  They count on this being
+  ;; the first slot.
+  (component nil :type (or null kernel:code-component))
+  ;;
+  ;; Debug name of this function.
+  (name nil))
 
+;;; Fixed-argument byte function.
+;;;
 (defstruct (simple-byte-function (:include byte-function))
   ;;
   ;; The number of arguments expected.
@@ -56,6 +84,9 @@
   ;; The start of the function.
   (entry-point 0 :type index))
 
+
+;;; Variable arg-count byte function.
+;;;
 (defstruct (hairy-byte-function (:include byte-function))
   ;;
   ;; The minimum and maximum number of args, ignoring &rest and &key.
@@ -89,7 +120,7 @@
   (print-unreadable-object (s stream :identity t)
     (format stream "Byte function ~S" (byte-function-name s))))
 
-(declaim (freeze-type byte-function))
+(declaim (freeze-type byte-function-or-closure))
 
 
 ;;;; The stack.
@@ -263,53 +294,32 @@
 
 ;;;; Byte compiled function constructors/extractors.
 
-(defun make-byte-compiled-function (xep)
+(defun initialize-byte-compiled-function (xep)
   (declare (type byte-function xep))
-  (set-function-subtype
-   #'(lambda (&rest args)
-       (let ((old-sp (current-stack-pointer))
-	     (num-args (length args)))
-	 (declare (type stack-pointer old-sp))
-	 (dolist (arg args)
-	   (push-eval-stack arg))
-	 (invoke-xep nil 0 old-sp 0 num-args xep)))
-   vm:byte-code-function-type))
-
-(defun byte-compiled-function-xep (function)
-  (declare (type function function)
-	   (values byte-function))
-  (or (system:find-if-in-closure #'byte-function-p function)
-      (error "Couldn't find the XEP in ~S" function)))
+  (setf (%funcallable-instance-function xep)
+	#'(lambda (&rest args)
+	    (let ((old-sp (current-stack-pointer))
+		  (num-args (length args)))
+	      (declare (type stack-pointer old-sp))
+	      (dolist (arg args)
+		(push-eval-stack arg))
+	      (invoke-xep nil 0 old-sp 0 num-args xep))))
+  xep)
 
 (defun make-byte-compiled-closure (xep closure-vars)
   (declare (type byte-function xep)
 	   (type simple-vector closure-vars))
-  (set-function-subtype
-   #'(lambda (&rest args)
-       (let ((old-sp (current-stack-pointer))
-	     (num-args (length args)))
-	 (declare (type stack-pointer old-sp))
-	 (dolist (arg args)
-	   (push-eval-stack arg))
-	 (invoke-xep nil 0 old-sp 0 num-args xep closure-vars)))
-   vm:byte-code-closure-type))
-
-(defun byte-compiled-closure-xep (closure)
-  (declare (type function closure)
-	   (values byte-function))
-  (or (system:find-if-in-closure #'byte-function-p closure)
-      (error "Couldn't find the XEP in ~S" closure)))
-
-(defun byte-compiled-closure-closure-vars (closure)
-  (declare (type function closure)
-	   (values simple-vector))
-  (or (system:find-if-in-closure #'simple-vector-p closure)
-      (error "Couldn't find the closure vars in ~S" closure)))
-
-(defun set-function-subtype (function subtype)
-  (setf (function-subtype function) subtype)
-  function)
-
+  (let ((res (make-byte-closure xep closure-vars)))
+    (setf (%funcallable-instance-function res)
+	  #'(lambda (&rest args)
+	      (let ((old-sp (current-stack-pointer))
+		    (num-args (length args)))
+		(declare (type stack-pointer old-sp))
+		(dolist (arg args)
+		  (push-eval-stack arg))
+		(invoke-xep nil 0 old-sp 0 num-args xep
+			    (byte-closure-data xep)))))
+    res))
 
 
 ;;;; Inlines.
@@ -1072,22 +1082,21 @@
     (declare (type stack-pointer old-sp)
 	     (type (or function fdefn) fun-or-fdefn)
 	     (type function function))
-    (case (function-subtype function)
-      (#.vm:byte-code-function-type
-       (invoke-xep old-component ret-pc old-sp old-fp num-args
-		   (byte-compiled-function-xep function)))
-      (#.vm:byte-code-closure-type
+    (typecase function
+      (byte-function
+       (invoke-xep old-component ret-pc old-sp old-fp num-args function))
+      (byte-closure
        (invoke-xep old-component ret-pc old-sp old-fp num-args
-		   (byte-compiled-closure-xep function)
-		   (byte-compiled-closure-closure-vars function)))
+		   (byte-closure-function function)
+		   (byte-closure-data function)))
       (t
        (cond ((minusp ret-pc)
 	      (let* ((ret-pc (- ret-pc))
 		     (results
 		      (multiple-value-list
 		       (with-debugger-info
-			(old-component ret-pc old-fp)
-			(byte-apply function num-args old-sp)))))
+			   (old-component ret-pc old-fp)
+			 (byte-apply function num-args old-sp)))))
 		(dolist (result results)
 		  (push-eval-stack result))
 		(push-eval-stack (length results))
@@ -1095,8 +1104,8 @@
 	     (t
 	      (push-eval-stack
 	       (with-debugger-info
-		(old-component ret-pc old-fp)
-		(byte-apply function num-args old-sp)))
+		   (old-component ret-pc old-fp)
+		 (byte-apply function num-args old-sp)))
 	      (byte-interpret old-component ret-pc old-fp)))))))
 
 
@@ -1123,39 +1132,39 @@
 	     (type (or fdefn function) fun-or-fdefn)
 	     (type function function))
     (case (function-subtype function)
-      (#.vm:byte-code-function-type
+      (byte-function
        (stack-copy old-sp start-of-args num-args)
-       (invoke-xep old-component old-pc old-sp old-fp num-args
-		   (byte-compiled-function-xep function)))
-      (#.vm:byte-code-closure-type
+       (invoke-xep old-component old-pc old-sp old-fp num-args function))
+      (byte-closure
        (stack-copy old-sp start-of-args num-args)
        (invoke-xep old-component old-pc old-sp old-fp num-args
-		   (byte-compiled-closure-xep function)
-		   (byte-compiled-closure-closure-vars function)))
+		   (byte-closure-function function)
+		   (byte-closure-data function)))
       (t
        ;; We are tail-calling native code.
-	 (cond ((null old-component)
-		;; We were called by native code.
-		(byte-apply function num-args old-sp))
-	       ((minusp old-pc)
-		;; We were called for multiple values.  So return multiple
-		;; values.
-		(let ((results
-		       (multiple-value-list
-			(with-debugger-info
-			    (old-component old-pc old-fp)
-			  (byte-apply function num-args old-sp)))))
-		  (dolist (result results)
-		    (push-eval-stack result))
-		  (push-eval-stack (length results)))
-		(byte-interpret old-component old-pc old-fp))
-	       (t
-		;; We were called for one value.  So return one value.
-		(push-eval-stack
-		 (with-debugger-info
-		     (old-component old-pc old-fp)
-		   (byte-apply function num-args old-sp)))
-		(byte-interpret old-component old-pc old-fp)))))))
+       (cond ((null old-component)
+	      ;; We were called by native code.
+	      (byte-apply function num-args old-sp))
+	     ((minusp old-pc)
+	      ;; We were called for multiple values.  So return multiple
+	      ;; values.
+	      (let ((results
+		     (multiple-value-list
+		      (with-debugger-info
+		       (old-component old-pc old-fp)
+		       (byte-apply function num-args old-sp)))))
+		(dolist (result results)
+		  (push-eval-stack result))
+		(push-eval-stack (length results)))
+	      (byte-interpret old-component old-pc old-fp))
+	     (t
+	      ;; We were called for one value.  So return one value.
+	      (push-eval-stack
+	       (with-debugger-info
+		   (old-component old-pc old-fp)
+		 (byte-apply function num-args old-sp)))
+	      (byte-interpret old-component old-pc old-fp)))))))
+
 
 (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
 				 &optional closure-vars)
@@ -1169,21 +1178,21 @@
 	 (cond
 	  ((typep xep 'simple-byte-function)
 	   (unless (eql (simple-byte-function-num-args xep) num-args)
-	     ;;; ### flame out point.
-	     (error "Wrong number of arguments."))
+	     (with-debugger-info (old-component ret-pc old-fp)
+	       (error "Wrong number of arguments.")))
 	   (simple-byte-function-entry-point xep))
 	  (t
 	   (let ((min (hairy-byte-function-min-args xep))
 		 (max (hairy-byte-function-max-args xep)))
 	     (cond
 	      ((< num-args min)
-	       ;; ### Flame out point.
-	       (error "Not enough arguments."))
+	       (with-debugger-info (old-component ret-pc old-fp)
+		 (error "Not enough arguments.")))
 	      ((<= num-args max)
 	       (nth (- num-args min) (hairy-byte-function-entry-points xep)))
 	      ((null (hairy-byte-function-more-args-entry-point xep))
-	       ;; ### Flame out point.
-	       (error "Too many arguments."))
+	       (with-debugger-info (old-component ret-pc old-fp)
+		 (error "Too many arguments.")))
 	      (t
 	       (let* ((more-args-supplied (- num-args max))
 		      (sp (current-stack-pointer))
@@ -1205,8 +1214,8 @@
 		   (setf (eval-stack-ref more-args-start) rest))
 		  (t
 		   (unless (evenp more-args-supplied)
-		     ;; ### Flame out.
-		     (error "Odd number of keyword arguments."))
+		     (with-debugger-info (old-component ret-pc old-fp)
+		       (error "Odd number of keyword arguments.")))
 		   (let* ((num-more-args (hairy-byte-function-num-more-args xep))
 			  (new-sp (+ more-args-start num-more-args))
 			  (temp (max sp new-sp))
@@ -1255,8 +1264,8 @@
 					 (t
 					  (incf target))))))))
 		       (when (and bogus-key-p (not allow))
-			 ;; ### Flame out.
-			 (error "Unknown keyword: ~S" bogus-key)))
+			 (with-debugger-info (old-component ret-pc old-fp)
+			   (error "Unknown keyword: ~S" bogus-key))))
 		     (setf (current-stack-pointer) new-sp)))))
 	       (hairy-byte-function-more-args-entry-point xep))))))))
     (declare (type pc entry-point))
-- 
GitLab