From c3ee4227e8b23e6a713ed742ac97107ca3a3ed13 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 17 May 1993 10:14:44 +0000
Subject: [PATCH] Allow fdefinition system constants.  Add some popular
 functions to system constants.  Add INTERPRETER-FUNCTION and SAFE slots to
 INLINE-FUNCTION-INFO to support type-checking inline ops.  Put inline funs in
 a hashtable.  Add %negate/fixnum, </fixnum, >/fixnum, safe-car, safe-cdr,
 length/list, cons, two-arg list and three-arg list*.  Add byte-code specific
 IR1 transforms for EQL/FIXNUM and CHAR=.  Add two-arg string=, string>,
 string<.  Flushed use of cons-unique-tag.

---
 compiler/byte-comp.lisp | 161 +++++++++++++++++++++++++++++-----------
 1 file changed, 116 insertions(+), 45 deletions(-)

diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp
index dd5acb80b..308bdd134 100644
--- a/compiler/byte-comp.lisp
+++ b/compiler/byte-comp.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/byte-comp.lisp,v 1.11 1993/05/15 18:26:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.12 1993/05/17 10:14:44 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -167,13 +167,12 @@
 
 ;;;; System constants, Xops, and inline functions.
 
-(defvar *system-constants* (make-array 256))
-(defvar *system-constant-codes* (make-hash-table :test #'eq))
+;;; If (%fdefinition-marker% . name), then the value is the fdefinition 
+(defvar *system-constant-codes* (make-hash-table :test #'equal))
 
 (eval-when (compile eval)
   (defmacro def-system-constant (index form)
     `(let ((val ,form))
-       (setf (svref *system-constants* ,index) val)
        (setf (gethash val *system-constant-codes*) ,index))))
 
 (def-system-constant 0 nil)
@@ -186,6 +185,23 @@
 (def-system-constant 7 :key)
 (def-system-constant 8 :from-end)
 (def-system-constant 9 :type)
+(def-system-constant 10 '(%fdefinition-marker% . error))
+(def-system-constant 11 '(%fdefinition-marker% . format))
+(def-system-constant 12 '(%fdefinition-marker% . %typep))
+(def-system-constant 13 '(%fdefinition-marker% . eql))
+(def-system-constant 14 '(%fdefinition-marker% . %negate))
+
+(def-system-constant 15 '(%fdefinition-marker% . %%defun))
+(def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
+(def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
+(def-system-constant 18 '(%fdefinition-marker% . length))
+(def-system-constant 19 '(%fdefinition-marker% . equal))
+(def-system-constant 20 '(%fdefinition-marker% . append))
+(def-system-constant 21 '(%fdefinition-marker% . reverse))
+(def-system-constant 22 '(%fdefinition-marker% . nreverse))
+(def-system-constant 23 '(%fdefinition-marker% . nconc))
+(def-system-constant 24 '(%fdefinition-marker% . list))
+(def-system-constant 25 '(%fdefinition-marker% . list*))
 
 (defparameter *xop-names*
   '(breakpoint; 0
@@ -212,42 +228,80 @@
 
 
 (defstruct inline-function-info
-  function
-  number
-  type)
-
-(defparameter *inline-functions*
-  (let ((number -1))
-    (mapcar #'(lambda (stuff)
-		(destructuring-bind (name arg-types result-type) stuff
-		  (make-inline-function-info
-		   :function name
-		   :number (incf number)
-		   :type (specifier-type
-			  `(function ,arg-types ,result-type)))))
-	    '((+ (fixnum fixnum) fixnum)
-	      (- (fixnum fixnum) fixnum)
-	      (make-value-cell (t) t)
-	      (value-cell-ref (t) t)
-	      (value-cell-setf (t t) t)
-	      (symbol-value (symbol) t)
-	      (setf-symbol-value (t symbol) t)
-	      (%byte-special-bind (t symbol) (values))
-	      (%byte-special-unbind () (values))
-	      (cons-unique-tag () t)))))
+  ;;
+  ;; Name of the function that we convert into calls to this.
+  (function (required-argument) :type symbol)
+  ;;
+  ;; Name of function that the interpreter should call to implement this.  May
+  ;; not be the same as above if extra safety checks are required.
+  (interpreter-function (required-argument) :type symbol)
+  ;;
+  ;; Inline operation number.
+  (number (required-argument) :type (mod 32))
+  ;;
+  ;; Type calls must statisfy.
+  (type (required-argument) :type function-type)
+  ;;
+  ;; If true, arg type checking need not be done.
+  (safe (required-argument) :type (member t nil)))
+
+(defparameter *inline-functions* (make-array 32 :initial-element nil))
+(defparameter *inline-function-table* (make-hash-table :test #'eq))
+(let ((number 0))
+  (dolist (stuff
+	   '((+ (fixnum fixnum) fixnum)
+	     (- (fixnum fixnum) fixnum)
+	     (make-value-cell (t) t)
+	     (value-cell-ref (t) t)
+	     (value-cell-setf (t t) (values))
+	     (symbol-value (symbol) t :interpreter-function %byte-symbol-value)
+	     (setf-symbol-value (t symbol) (values))
+	     (%byte-special-bind (t symbol) (values))
+	     (%byte-special-unbind () (values))
+	     (cons-unique-tag () t); obsolete...
+	     (%negate (fixnum) fixnum)
+	     (< (fixnum fixnum) t)
+	     (> (fixnum fixnum) t)
+	     (car (t) t :interpreter-function %byte-car :safe t)
+	     (cdr (t) t :interpreter-function %byte-cdr :safe t)
+	     (length (list) t)
+	     (cons (t t) t)
+	     (list (t t) t)
+	     (list* (t t t) t)))
+    (destructuring-bind (name arg-types result-type
+			      &key (interpreter-function name) alias safe)
+			stuff
+      (let ((info
+	     (make-inline-function-info
+	      :function name
+	      :number number
+	      :interpreter-function interpreter-function
+	      :type (specifier-type `(function ,arg-types ,result-type))
+	      :safe safe)))
+	(setf (svref *inline-functions* number) info)
+	(setf (gethash name *inline-function-table*) info))
+      (unless alias (incf number)))))
+
 
 (defun inline-function-number-or-lose (function)
-  (let ((info (find function *inline-functions*
-		    :key #'inline-function-info-function)))
+  (let ((info (gethash function *inline-function-table*)))
     (if info
 	(inline-function-info-number info)
 	(error "Unknown inline function: ~S" function))))
 
+
+;;;; Byte-code specific transforms:
+
+(deftransform eql ((x y) ((or fixnum character) (or fixnum character))
+		   * :when :byte)
+  '(eq x y))
+
+(deftransform char= ((x y) * * :when :byte)
+  '(eq x y))
 
 
 ;;;; Annotations hung off the IR1 while compiling.
 
-
 (defstruct byte-component-info
   (constants (make-array 10 :adjustable t :fill-pointer 0)))
 
@@ -387,21 +441,24 @@
 ;;; ANNOTATE-FULL-CALL  --  Internal
 ;;;
 ;;;    Annotate the values for any :full combination.  This includes inline
-;;; functions, multiple value calls & throw.  If a real full call, clear any
-;;; type-check annotations.  When we are done, remove jump to return for tail
-;;; calls.
+;;; functions, multiple value calls & throw.  If a real full call or a safe
+;;; inline operation, then clear any type-check annotations.  When we are done,
+;;; remove jump to return for tail calls.
 ;;;
 (defun annotate-full-call (call)
   (let* ((fun (basic-combination-fun call))
 	 (name (continuation-function-name fun))
-	 (info (find name *inline-functions*
-		     :key #'inline-function-info-function)))
+	 (info (gethash name *inline-function-table*)))
     (cond ((and info
 		(valid-function-use call (inline-function-info-type info)))
 	   (annotate-basic-combination-args call)
 	   (setf (node-tail-p call) nil)
 	   (setf (basic-combination-info call) info)
-	   (annotate-continuation fun 0))
+	   (annotate-continuation fun 0)
+	   (when (inline-function-info-safe info)
+	     (dolist (arg (basic-combination-args call))
+	       (when (continuation-type-check arg)
+		 (setf (continuation-%type-check arg) :deleted)))))
 	  ((and (mv-combination-p call) (eq name '%throw))
 	   (let ((args (basic-combination-args call)))
 	     (assert (= (length args) 2))
@@ -1015,11 +1072,24 @@
 	       (two-arg-char> char>)
 	       (two-arg-char-equal char-equal)
 	       (two-arg-char-lessp char-lessp)
-	       (two-arg-char-greaterp char-greaterp)))
+	       (two-arg-char-greaterp char-greaterp)
+	       (two-arg-string= string=)
+	       (two-arg-string< string<)
+	       (two-arg-string> string>)))
 
   (setf (gethash (second fun) *two-arg-functions*) (first fun)))
 
 
+;;; If a system constant, push that, otherwise use a load-time constant.
+;;;
+(defun output-push-fdefinition (segment name)
+  (let ((offset (gethash `(%fdefinition-marker% . ,name)
+			 *system-constant-codes*)))
+    (if offset
+	(output-byte-with-operand segment byte-push-system-constant
+				  offset)
+	(output-push-load-time-constant segment :fdefinition name))))
+
 (defun generate-byte-code-for-ref (segment ref cont)
   (declare (type new-assem:segment segment) (type ref ref)
 	   (type continuation cont))
@@ -1035,8 +1105,8 @@
 			   :global-function)))
 	  (let* ((name (global-var-name leaf))
 		 (found (gethash name *two-arg-functions*)))
-	    (output-push-load-time-constant
-	     segment :fdefinition
+	    (output-push-fdefinition
+	     segment
 	     (if (and found
 		      (= (length (combination-args (continuation-dest cont)))
 			 2))
@@ -1074,9 +1144,7 @@
 		(output-push-constant segment (global-var-name leaf))
 		(output-do-inline-function segment 'symbol-value))
 	       (:global-function
-		(output-push-load-time-constant segment
-						:fdefinition
-						(global-var-name leaf))
+		(output-push-fdefinition segment (global-var-name leaf))
 		(output-do-xop segment 'fdefn-function-or-lose)))))
 	  (checked-canonicalize-values segment cont 1))))))
   (undefined-value))
@@ -1339,7 +1407,11 @@
 	(let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
 	  (when (member kind '(:block :tagbody))
 	    ;; Generate a unique tag.
-	    (output-do-inline-function segment 'cons-unique-tag)
+	    (output-push-constant
+	     segment
+	     (format nil "Tag for ~A" (component-name *compile-component*)))
+	    (output-push-constant segment nil)
+	    (output-do-inline-function segment 'cons)
 	    ;; Save it so people can close over it.
 	    (output-do-xop segment 'dup)
 	    (output-byte-with-operand segment
@@ -2048,5 +2120,4 @@
 	      ;; inline
 	      (note "inline ~A"
 		    (inline-function-info-function
-		     (nth (ldb (byte 5 0) byte) *inline-functions*)))))))))))
-
+		     (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))
-- 
GitLab