From cfb9e3640e34706acdfccd26236024de259f3b4f Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 1 Jan 2001 19:02:10 +0000 Subject: [PATCH] 0.6.9.16: Happy New Year! May all your projects be on schedule.:-| renamed POLICIES to LTN-POLICY removed some inlining in ltn.lisp simplified LTN-ANALYZE-BLOCK in ltn.lisp (removing caching) added code to catch bogus full calls tweaked PROFILE so it accepts (SETF FOO)-style names tweaked DEFPRINTER to conserve whitespace moved DEFPRINTER to SB-INT, since it's not compiler-specific --- package-data-list.lisp-expr | 29 +- src/code/debug-int.lisp | 39 ++- src/code/early-extensions.lisp | 99 +++++- src/code/fop.lisp | 18 +- src/code/macros.lisp | 22 +- src/code/profile.lisp | 12 +- src/compiler/aliencomp.lisp | 6 +- src/compiler/checkgen.lisp | 6 +- src/compiler/ir1opt.lisp | 2 +- src/compiler/ir1tran.lisp | 3 +- src/compiler/ir2tran.lisp | 61 +++- src/compiler/ltn.lisp | 647 ++++++++++++++++++++-------------------- src/compiler/macros.lisp | 79 +---- src/compiler/meta-vmdef.lisp | 339 +++++++++++---------- src/compiler/node.lisp | 14 +- src/compiler/policy.lisp | 4 +- src/compiler/stack.lisp | 28 +- src/compiler/vop.lisp | 83 +++--- src/compiler/x86/arith.lisp | 2 - src/compiler/x86/array.lisp | 25 +- src/pcl/braid.lisp | 12 +- src/pcl/defclass.lisp | 25 +- src/pcl/low.lisp | 2 +- src/pcl/macros.lisp | 61 +--- src/pcl/std-class.lisp | 2 +- version.lisp-expr | 2 +- 26 files changed, 826 insertions(+), 796 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5595415..7888052 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -673,21 +673,33 @@ retained, possibly temporariliy, because it might be used internally." ;; rid of FDEFINITIONs entirely later. "*SETF-FDEFINITION-HOOK*" - ;; useful but non-standard user-level functions.. + ;; non-standard but widely useful user-level functions.. "ASSQ" "DELQ" "MEMQ" "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" "SANE-PACKAGE" "CIRCULAR-LIST-P" - ;; ..and macros + ;; ..and macros.. "COLLECT" "DO-ANONYMOUS" "DOHASH" "DOVECTOR" "ITERATE" "LETF" "LETF*" "ONCE-ONLY" "DEFENUM" + "DEFPRINTER" "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE" + ;; ..and DEFTYPEs.. + "INDEX" + + ;; ..and type predicates + "INSTANCEP" + "DOUBLE-FLOATP" + "LOGICAL-PATHNAME-P" + "LONG-FLOATP" + "SHORT-FLOATP" + "SINGLE-FLOATP" + ;; encapsulation "ARGUMENT-LIST" "BASIC-DEFINITION" @@ -698,17 +710,6 @@ retained, possibly temporariliy, because it might be used internally." "BELL-CHAR-CODE" "ESCAPE-CHAR-CODE" "FORM-FEED-CHAR-CODE" "RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE" - ;; handy user-level/basically-portable DEFTYPEs - "INDEX" - - ;; nonstandard type predicates - "INSTANCEP" - "DOUBLE-FLOATP" - "LOGICAL-PATHNAME-P" - "LONG-FLOATP" - "SHORT-FLOATP" - "SINGLE-FLOATP" - ;; symbol-hacking idioms "CONCAT-PNAMES" "KEYWORDICATE" "SYMBOLICATE" @@ -724,7 +725,7 @@ retained, possibly temporariliy, because it might be used internally." ;; FIXME: Maybe this isn't used any more? And if it is, ;; it probably needs a better name, since SPECIAL things - ;; are so obnoxious in Common Lisp. + ;; are such a nice source of sneaky bugs. "E" ;; various internal defaults diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 52703f2..e066ee8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -2067,14 +2067,14 @@ (coerce (cdr (res)) 'simple-vector)))) -;;; This variable maps minimal debug-info function maps to an unpacked -;;; version thereof. +;;; a map from minimal DEBUG-INFO function maps to unpacked +;;; versions thereof (defvar *uncompacted-function-maps* (make-hash-table :test 'eq)) -;;; Return a function-map for a given compiled-debug-info object. If +;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If ;;; the info is minimal, and has not been parsed, then parse it. ;;; -;;; FIXME: Now that we no longer use the minimal-debug-function +;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUNCTION ;;; representation, calls to this function can be replaced by calls to ;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function, ;;; and this function and everything it calls become dead code which @@ -2090,17 +2090,14 @@ ;;;; CODE-LOCATIONs -;;; If we're sure of whether code-location is known, return t or nil. -;;; If we're :unsure, then try to fill in the code-location's slots. +;;; If we're sure of whether code-location is known, return T or NIL. +;;; If we're :UNSURE, then try to fill in the code-location's slots. ;;; This determines whether there is any debug-block information, and ;;; if code-location is known. ;;; ;;; ??? IF this conses closures every time it's called, then break off the -;;; :unsure part to get the HANDLER-CASE into another function. +;;; :UNSURE part to get the HANDLER-CASE into another function. (defun code-location-unknown-p (basic-code-location) - #!+sb-doc - "Returns whether basic-code-location is unknown. It returns nil when the - code-location is known." (ecase (code-location-%unknown-p basic-code-location) ((t) t) ((nil) nil) @@ -2109,11 +2106,10 @@ (handler-case (not (fill-in-code-location basic-code-location)) (no-debug-blocks () t)))))) +;;; Return the DEBUG-BLOCK containing code-location if it is available. +;;; Some debug policies inhibit debug-block information, and if none +;;; is available, then this signals a NO-DEBUG-BLOCKS condition. (defun code-location-debug-block (basic-code-location) - #!+sb-doc - "Returns the debug-block containing code-location if it is available. Some - debug policies inhibit debug-block information, and if none is available, - then this signals a no-debug-blocks condition." (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) (etypecase basic-code-location @@ -2126,10 +2122,10 @@ (interpreted-code-location-ir1-node basic-code-location)))))) block))) -;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It -;;; determines the correct one using the code-location's pc. This uses +;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines +;;; the correct one using the code-location's pc. We use ;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information -;;; or signal a 'no-debug-blocks condition. The blocks are sorted by +;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by ;;; their first code-location's pc, in ascending order. Therefore, as ;;; soon as we find a block that starts with a pc greater than ;;; basic-code-location's pc, we know the previous block contains the @@ -2280,8 +2276,8 @@ (let ((live-set (compiled-code-location-%live-set code-location))) (cond ((eq live-set :unparsed) (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. ;; ;; FIXME: This error and comment happen over and over again. ;; Make them a shared function. @@ -2289,9 +2285,8 @@ (compiled-code-location-%live-set code-location)) (t live-set))))) +;;; true if OBJ1 and OBJ2 are the same place in the code (defun code-location= (obj1 obj2) - #!+sb-doc - "Returns whether obj1 and obj2 are the same place in the code." (etypecase obj1 (compiled-code-location (etypecase obj2 @@ -2312,7 +2307,7 @@ (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) -;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil +;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL ;;; depending on whether the code-location was known in its ;;; debug-function's debug-block information. This may signal a ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 857e0a0..7b2f0c5 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -321,8 +321,8 @@ (symbolp (cadr name)) (null (cddr name))))) -;;; Given a function name, return the name for the BLOCK which encloses its -;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). +;;; Given a function name, return the name for the BLOCK which +;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name)) (defun function-name-block-name (function-name) (cond ((symbolp function-name) @@ -368,6 +368,101 @@ ;; value.) )) +;;;; DEFPRINTER + +;;; These functions are called by the expansion of the DEFPRINTER +;;; macro to do the actual printing. +(declaim (ftype (function (symbol t stream &optional t) (values)) + defprinter-prin1 defprinter-princ)) +(defun defprinter-prin1 (name value stream &optional indent) + (declare (ignore indent)) + (defprinter-prinx #'prin1 name value stream)) +(defun defprinter-princ (name value stream &optional indent) + (declare (ignore indent)) + (defprinter-prinx #'princ name value stream)) +(defun defprinter-prinx (prinx name value stream) + (declare (type function prinx)) + (when *print-pretty* + (pprint-newline :linear stream)) + (format stream ":~A " name) + (funcall prinx value stream) + (values)) +(defun defprinter-print-space (stream) + (write-char #\space stream)) + +;;; Define some kind of reasonable PRINT-OBJECT method for a +;;; STRUCTURE-OBJECT class. +;;; +;;; NAME is the name of the structure class, and CONC-NAME is the same +;;; as in DEFSTRUCT. +;;; +;;; The SLOT-DESCS describe how each slot should be printed. Each +;;; SLOT-DESC can be a slot name, indicating that the slot should +;;; simply be printed. A SLOT-DESC may also be a list of a slot name +;;; and other stuff. The other stuff is composed of keywords followed +;;; by expressions. The expressions are evaluated with the variable +;;; which is the slot name bound to the value of the slot. These +;;; keywords are defined: +;;; +;;; :PRIN1 Print the value of the expression instead of the slot value. +;;; :PRINC Like :PRIN1, only princ the value +;;; :TEST Only print something if the test is true. +;;; +;;; If no printing thing is specified then the slot value is printed +;;; as if by PRIN1. +;;; +;;; The structure being printed is bound to STRUCTURE and the stream +;;; is bound to STREAM. +(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string + (symbol-name name) + "-"))) + &rest slot-descs) + (let ((first? t) + maybe-print-space + (reversed-prints nil) + (stream (gensym "STREAM"))) + (flet ((sref (slot-name) + `(,(symbolicate conc-name slot-name) structure))) + (dolist (slot-desc slot-descs) + (if first? + (setf maybe-print-space nil + first? nil) + (setf maybe-print-space `(defprinter-print-space ,stream))) + (cond ((atom slot-desc) + (push maybe-print-space reversed-prints) + (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream) + reversed-prints)) + (t + (let ((sname (first slot-desc)) + (test t)) + (collect ((stuff)) + (do ((option (rest slot-desc) (cddr option))) + ((null option) + (push `(let ((,sname ,(sref sname))) + (when ,test + ,maybe-print-space + ,@(or (stuff) + `((defprinter-prin1 + ',sname ,sname ,stream))))) + reversed-prints)) + (case (first option) + (:prin1 + (stuff `(defprinter-prin1 + ',sname ,(second option) ,stream))) + (:princ + (stuff `(defprinter-princ + ',sname ,(second option) ,stream))) + (:test (setq test (second option))) + (t + (error "bad option: ~S" (first option))))))))))) + `(def!method print-object ((structure ,name) ,stream) + ;; FIXME: should probably be byte-compiled + (pprint-logical-block (,stream nil) + (print-unreadable-object (structure ,stream :type t) + (when *print-pretty* + (pprint-indent :block 2 ,stream)) + ,@(nreverse reversed-prints)))))) + #| ;;; REMOVEME when done testing byte cross-compiler (defun byte-compiled-foo (x y) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index b47aa4e..6f8cb3b 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -72,9 +72,10 @@ (macrolet ((clone-arg () '(read-arg 1))) (define-fop (,small-name ,small-code ,pushp) ,@forms)))) -;;; a helper function for reading string values from FASL files: sort of like -;;; READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8), with an automatic -;;; conversion from (UNSIGNED-BYTE 8) into CHARACTER for each element read +;;; a helper function for reading string values from FASL files: sort +;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8), +;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER +;;; for each element read (declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes)) (defun read-string-as-bytes (stream string &optional (length (length string))) (dotimes (i length) @@ -99,11 +100,12 @@ #!+sb-show (defvar *show-fop-nop4-p* nil) -;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 occurs -;;; disproportionately often in fasl files for other reasons, FOP-NOP is less -;;; than ideal for writing human-readable patterns into fasl files for -;;; debugging purposes. There's no shortage of unused fop codes, so we add this -;;; second NOP, which reads 4 arbitrary bytes and discards them. +;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 +;;; occurs disproportionately often in fasl files for other reasons, +;;; FOP-NOP is less than ideal for writing human-readable patterns +;;; into fasl files for debugging purposes. There's no shortage of +;;; unused fop codes, so we add this second NOP, which reads 4 +;;; arbitrary bytes and discards them. (define-fop (fop-nop4 137 :nope) (let ((arg (read-arg 4))) (declare (ignorable arg)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index e11812d..46865dd 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -92,8 +92,8 @@ (defmacro-mundanely defconstant (name value &optional documentation) #!+sb-doc - "For defining global constants. The DEFCONSTANT says that the value - is constant and may be compiled into code. If the variable already has + "For defining global constants. DEFCONSTANT says that the value is + constant and may be compiled into code. If the variable already has a value, and this is not EQL to the init, the code is not portable (undefined behavior). The third argument is an optional documentation string for the variable." @@ -102,22 +102,20 @@ ;;; the guts of DEFCONSTANT (defun sb!c::%defconstant (name value doc) - (/show "doing %DEFCONSTANT" name value doc) (unless (symbolp name) (error "constant name not a symbol: ~S" name)) (about-to-modify name) (let ((kind (info :variable :kind name))) (case kind (:constant - ;; Note 1: This behavior (discouraging any non-EQL - ;; modification) is unpopular, but it is specified by ANSI - ;; (i.e. ANSI says a non-EQL change has undefined - ;; consequences). If people really want bindings which are - ;; constant in some sense other than EQL, I suggest either just - ;; using DEFVAR (which is usually appropriate, despite the - ;; un-mnemonic name), or defining something like - ;; SB-INT:DEFCONSTANT-EQX (which is occasionally more - ;; appropriate). -- WHN 2000-11-03 + ;; Note: This behavior (discouraging any non-EQL modification) + ;; is unpopular, but it is specified by ANSI (i.e. ANSI says a + ;; non-EQL change has undefined consequences). If people really + ;; want bindings which are constant in some sense other than + ;; EQL, I suggest either just using DEFVAR (which is usually + ;; appropriate, despite the un-mnemonic name), or defining + ;; something like SB-INT:DEFCONSTANT-EQX (which is occasionally + ;; more appropriate). -- WHN 2000-11-03 (unless (eql value (info :variable :constant-value name)) (cerror "Go ahead and change the value." diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 6efe9b7..ecaaa1a 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -187,7 +187,7 @@ ;;; CLEAR-STATS-FUN clears the statistics. ;;; ;;; (The reason for implementing this as coupled closures, with the -;;; counts built into the lexical environment, is that we hopes this +;;; counts built into the lexical environment, is that we hope this ;;; will minimize profiling overhead.) (defun profile-encapsulation-lambdas (encapsulated-fun) (declare (type function encapsulated-fun)) @@ -260,12 +260,18 @@ ;;; interfaces -;;; A symbol names a function, a string names all the functions named -;;; by symbols in the named package. +;;; A symbol or (SETF FOO) list names a function, a string names all +;;; the functions named by symbols in the named package. (defun mapc-on-named-functions (function names) (dolist (name names) (etypecase name (symbol (funcall function name)) + (list + ;; We call this just for the side effect of checking that + ;; NAME is a legal function name: + (function-name-block-name name) + ;; Then we map onto it. + (funcall function name)) (string (let ((package (find-undeleted-package-or-lose name))) (do-symbols (symbol package) (when (eq (symbol-package symbol) package) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index a10adbb..7018c33 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -643,12 +643,12 @@ (alien-function-type-result-type type))))) (defoptimizer (%alien-funcall ltn-annotate) - ((function type &rest args) node policy) + ((function type &rest args) node ltn-policy) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation function policy) + (annotate-ordinary-continuation function ltn-policy) (dolist (arg args) - (annotate-ordinary-continuation arg policy))) + (annotate-ordinary-continuation arg ltn-policy))) (defoptimizer (%alien-funcall ir2-convert) ((function type &rest args) call block) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 373ba9f..89a6cc4 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -249,7 +249,9 @@ ;;; We must only return NIL when it is *certain* that a check will not ;;; be done, since if we pass up this chance to do the check, it will ;;; be too late. The penalty for being too conservative is duplicated -;;; type checks. +;;; type checks. The penalty for erring by being too speculative is +;;; much nastier, e.g. falling through without ever being able to find +;;; an appropriate VOP. ;;; ;;; If there is a compile-time type error, then we always return true ;;; unless the DEST is a full call. With a full call, the theory is @@ -278,7 +280,7 @@ ((function-info-ir2-convert kind) t) (t (dolist (template (function-info-templates kind) nil) - (when (eq (template-policy template) :fast-safe) + (when (eq (template-ltn-policy template) :fast-safe) (multiple-value-bind (val win) (valid-function-use dest (template-type template)) (when (or val (not win)) (return t))))))))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 3170104..3c99417 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -639,7 +639,7 @@ #!+sb-show (defvar *show-transforms-p* nil) -;;; Do IR1 optimizations on a Combination node. +;;; Do IR1 optimizations on a COMBINATION node. (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) (when (continuation-reoptimize (basic-combination-fun node)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 7427325..c15321e 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1025,7 +1025,8 @@ (dynamic-extent (when (policy nil (> speed inhibit-warnings)) (compiler-note - "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) + "compiler limitation:~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) res) (t (unless (info :declaration :recognized (first spec)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 0c8e696..e1c85a9 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -476,7 +476,7 @@ (declare (type combination call) (type continuation cont) (type template template) (list rtypes)) (let* ((dtype (node-derived-type call)) - (type (if (and (or (eq (template-policy template) :safe) + (type (if (and (or (eq (template-ltn-policy template) :safe) (policy call (= safety 0))) (continuation-type-check cont)) (values-type-intersection @@ -904,6 +904,29 @@ arg-locs nargs))))) (values)) +;;; stuff to check in CHECK-FULL-CALL +;;; +;;; There are some things which are intended always to be optimized +;;; away by DEFTRANSFORMs and such, and so never compiled into full +;;; calls. This has been a source of bugs so many times that it seems +;;; worth listing some of them here so that we can check the list +;;; whenever we compile a full call. +;;; +;;; FIXME: It might be better to represent this property by setting a +;;; flag in DEFKNOWN, instead of representing it by membership in this +;;; list. +(defvar *always-optimized-away* + '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug + ;; reported to cmucl-imp@cons.org 2000-06-20. + %instance-ref + ;; These should always turn into VOPs, but wasn't in a bug which + ;; appeared when LTN-POLICY stuff was being tweaked in + ;; sbcl-0.6.9.16. in sbcl-0.6.0 + data-vector-set + data-vector-ref)) + +;;; more stuff to check in CHECK-FULL-CALL +;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and ;;; VOPs and stuff got attached to the wrong symbol, so that @@ -914,13 +937,12 @@ #!+sb-show (defvar *show-full-called-fnames-p* nil) #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal)) -;;; If the call is in a tail recursive position and the return -;;; convention is standard, then do a tail full call. If one or fewer -;;; values are desired, then use a single-value call, otherwise use a -;;; multiple-values call. -(defun ir2-convert-full-call (node block) - (declare (type combination node) (type ir2-block block)) - +;;; Do some checks on a full call: +;;; * Is this a full call to something we have reason to know should +;;; never be full called? +;;; * Is this a full call to (SETF FOO) which might conflict with +;;; a DEFSETF or some such thing elsewhere in the program? +(defun check-full-call (node) (let* ((cont (basic-combination-fun node)) (fname (continuation-function-name cont t))) (declare (type (or symbol cons) fname)) @@ -930,6 +952,8 @@ #!+sb-show (when *show-full-called-fnames-p* (/show "converting full call to named function" fname) (/show (basic-combination-args node)) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) (let ((arg-types (mapcar (lambda (maybe-continuation) (when maybe-continuation (type-specifier @@ -938,11 +962,23 @@ (basic-combination-args node)))) (/show arg-types))) + (when (memq fname *always-optimized-away*) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (error "internal error: full call to ~S" fname)) + (when (consp fname) (destructuring-bind (setf stem) fname (assert (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t)))) + (setf (gethash stem *setf-assumed-fboundp*) t))))) +;;; If the call is in a tail recursive position and the return +;;; convention is standard, then do a tail full call. If one or fewer +;;; values are desired, then use a single-value call, otherwise use a +;;; multiple-values call. +(defun ir2-convert-full-call (node block) + (declare (type combination node) (type ir2-block block)) + (check-full-call node) (let ((2cont (continuation-info (node-cont node)))) (cond ((node-tail-p node) (ir2-convert-tail-full-call node block)) @@ -951,7 +987,6 @@ (ir2-convert-multiple-full-call node block)) (t (ir2-convert-fixed-full-call node block)))) - (values)) ;;;; entering functions @@ -1405,7 +1440,7 @@ ;;;; n-argument functions -(macrolet ((frob (name) +(macrolet ((def-frob (name) `(defoptimizer (,name ir2-convert) ((&rest args) node block) (let* ((refs (move-tail-full-call-args node block)) (cont (node-cont node)) @@ -1415,8 +1450,8 @@ (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) - (frob list) - (frob list*)) + (def-frob list) + (def-frob list*)) ;;;; structure accessors ;;;; diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 708c446..9a2570a 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -15,8 +15,30 @@ ;;;; utilities -;;; Return the policies keyword indicated by the node policy. -(defun translation-policy (node) +;;; Return the LTN-POLICY indicated by the node policy. +;;; +;;; FIXME: It would be tidier to use an LTN-POLICY object (an instance +;;; of DEFSTRUCT LTN-POLICY) instead of a keyword, and have queries +;;; like LTN-POLICY-SAFE-P become slot accessors. If we do this, +;;; grep for and carefully review use of literal keywords, so that +;;; things like +;;; (EQ (TEMPLATE-LTN-POLICY TEMPLATE) :SAFE) +;;; don't get overlooked. +;;; +;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY +;;; values in LTN-ANALYZE so that they didn't have to be recomputed on +;;; every block. I stripped that out (the whole DEFMACRO FROB thing) +;;; because I found it too confusing. Thus, it might be that the +;;; new uncached code spends an unreasonable amount of time in +;;; this lookup function. This function should be profiled, and if +;;; it's a significant contributor to runtime, we can cache it in +;;; some more local way, e.g. by adding a CACHED-LTN-POLICY slot to +;;; the NODE structure, and doing something like +;;; (DEFUN NODE-LTN-POLICY (NODE) +;;; (OR (NODE-CACHED-LTN-POLICY NODE) +;;; (SETF (NODE-CACHED-LTN-POLICY NODE) +;;; (NODE-UNCACHED-LTN-POLICY NODE))) +(defun node-ltn-policy (node) (declare (type node node)) (policy node (let ((eff-space (max space @@ -30,23 +52,22 @@ (if (>= speed eff-space) :fast :small) (if (>= speed eff-space) :fast-safe :safe))))) -;;; Return true if POLICY is a safe policy. -#!-sb-fluid (declaim (inline policy-safe-p)) -(defun policy-safe-p (policy) - (declare (type policies policy)) - (or (eq policy :safe) (eq policy :fast-safe))) +;;; Return true if LTN-POLICY is a safe policy. +(defun ltn-policy-safe-p (ltn-policy) + (ecase ltn-policy + ((:safe :fast-safe) t) + ((:small :fast) nil))) ;;; Called when an unsafe policy indicates that no type check should ;;; be done on CONT. We delete the type check unless it is :ERROR ;;; (indicating a compile-time type error.) -#!-sb-fluid (declaim (inline flush-type-check)) (defun flush-type-check (cont) (declare (type continuation cont)) (when (member (continuation-type-check cont) '(t :no-check)) (setf (continuation-%type-check cont) :deleted)) (values)) -;;; An annotated continuation's primitive-type. +;;; an annotated continuation's primitive-type #!-sb-fluid (declaim (inline continuation-ptype)) (defun continuation-ptype (cont) (declare (type continuation cont)) @@ -101,27 +122,27 @@ ;;; Make an IR2-CONTINUATION corresponding to the continuation type ;;; and then do ANNOTATE-1-VALUE-CONTINUATION. If POLICY-KEYWORD isn't ;;; a safe policy keyword, then we clear the TYPE-CHECK flag. -(defun annotate-ordinary-continuation (cont policy-keyword) +(defun annotate-ordinary-continuation (cont ltn-policy) (declare (type continuation cont) - (type policies policy-keyword)) + (type ltn-policy ltn-policy)) (let ((info (make-ir2-continuation (primitive-type (continuation-type cont))))) (setf (continuation-info cont) info) - (unless (policy-safe-p policy-keyword) + (unless (ltn-policy-safe-p ltn-policy) (flush-type-check cont)) (annotate-1-value-continuation cont)) (values)) ;;; Annotate the function continuation for a full call. If the only -;;; reference is to a global 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 is unsafe, since the check for a valid function object must -;;; be done before the call. -(defun annotate-function-continuation (cont policy &optional (delay t)) - (declare (type continuation cont) (type policies policy)) - (unless (policy-safe-p policy) +;;; LTN-POLICY is unsafe, since the check for a valid function +;;; object must be done before the call. +(defun annotate-function-continuation (cont ltn-policy &optional (delay t)) + (declare (type continuation cont) (type ltn-policy ltn-policy)) + (unless (ltn-policy-safe-p ltn-policy) (flush-type-check cont)) (let* ((ptype (primitive-type (continuation-type cont))) (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil)) @@ -164,15 +185,15 @@ ;;; since IR2tran might decide to call after all. ;;; ;;; If not funny, we always flush arg type checks, but do it after -;;; annotation when the policy is safe, since we don't want to choose the TNs -;;; according to a type assertions that may not hold. +;;; annotation when the LTN-POLICY is safe, since we don't want to +;;; choose the TNs according to a type assertions that may not hold. ;;; ;;; Note that args may already be annotated because template selection can ;;; bail out to here. -(defun ltn-default-call (call policy) - (declare (type combination call) (type policies policy)) +(defun ltn-default-call (call ltn-policy) + (declare (type combination call) (type ltn-policy ltn-policy)) (let ((kind (basic-combination-kind call))) - (annotate-function-continuation (basic-combination-fun call) policy) + (annotate-function-continuation (basic-combination-fun call) ltn-policy) (cond ((and (function-info-p kind) @@ -187,7 +208,7 @@ (continuation-type arg))))) (annotate-1-value-continuation arg))) (t - (let ((safe-p (policy-safe-p policy))) + (let ((safe-p (ltn-policy-safe-p ltn-policy))) (dolist (arg (basic-combination-args call)) (unless safe-p (flush-type-check arg)) (unless (continuation-info arg) @@ -205,26 +226,28 @@ (values)) ;;; Annotate a continuation for unknown multiple values: -;;; -- Delete any type check, regardless of policy, since we IR2 conversion -;;; isn't prepared to check unknown-values continuations. If we delete a -;;; type check when the policy is safe, then we emit a warning. -;;; -- Add the continuation to the IR2-Block-Popped if it is used across a -;;; block boundary. -;;; -- Assign a :Unknown IR2-Continuation. +;;; -- Delete any type check, regardless of LTN-POLICY, since IR2 +;;; conversion isn't prepared to check unknown-values continuations. +;;; If we delete a type check when the policy is safe, then we emit +;;; a warning. +;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used +;;; across a block boundary. +;;; -- Assign an :UNKNOWN IR2-CONTINUATION. ;;; -;;; Note: it is critical that this be called only during LTN analysis of Cont's -;;; DEST, and called in the order that the continuations are received. -;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all -;;; messed up. -(defun annotate-unknown-values-continuation (cont policy) - (declare (type continuation cont) (type policies policy)) +;;; Note: it is critical that this be called only during LTN analysis +;;; of CONT's DEST, and called in the order that the continuations are +;;; received. Otherwise the IR2-BLOCK-POPPED and +;;; IR2-COMPONENT-VALUES-FOO would get all messed up. +(defun annotate-unknown-values-continuation (cont ltn-policy) + (declare (type continuation cont) (type ltn-policy ltn-policy)) (when (eq (continuation-type-check cont) t) (let* ((dest (continuation-dest cont)) (*compiler-error-context* dest)) - (when (and (policy-safe-p policy) + (when (and (ltn-policy-safe-p ltn-policy) (policy dest (>= safety inhibit-warnings))) - (compiler-note "unable to check type assertion in unknown-values ~ - context:~% ~S" + (compiler-note "compiler limitation: ~ + unable to check type assertion in ~ + unknown-values context:~% ~S" (continuation-asserted-type cont)))) (setf (continuation-%type-check cont) :deleted)) @@ -242,14 +265,14 @@ (values)) -;;; Annotate Cont for a fixed, but arbitrary number of values, of the -;;; specified primitive Types. If the continuation has a type check, we -;;; annotate for the number of values indicated by Types, but only use proven -;;; type information. -(defun annotate-fixed-values-continuation (cont policy types) - (declare (type continuation cont) (type policies policy) (list types)) - (unless (policy-safe-p policy) (flush-type-check cont)) - +;;; Annotate CONT for a fixed, but arbitrary number of values, of the +;;; specified primitive TYPES. If the continuation has a type check, +;;; we annotate for the number of values indicated by TYPES, but only +;;; use proven type information. +(defun annotate-fixed-values-continuation (cont ltn-policy types) + (declare (continuation cont) (ltn-policy ltn-policy) (list types)) + (unless (ltn-policy-safe-p ltn-policy) + (flush-type-check cont)) (let ((res (make-ir2-continuation nil))) (if (member (continuation-type-check cont) '(:deleted nil)) (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types)) @@ -270,31 +293,32 @@ (t proven))))) (setf (continuation-info cont) res)) - (values)) ;;;; node-specific analysis functions -;;; Annotate the result continuation for a function. We use the Return-Info -;;; computed by GTN to determine how to represent the return values within the -;;; function: -;;; -- If the tail-set has a fixed values count, then use that many values. -;;; -- If the actual uses of the result continuation in this function have a -;;; fixed number of values (after intersection with the assertion), then use -;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know -;;; they will truly end up as TR calls. We can use the -;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since -;;; the initial value NIL doesn't look like a TR call. -;;; -;;; If there are *no* non-tail-call uses, then it falls out that we annotate -;;; for one value (type is NIL), but the return will end up being deleted. -;;; -;;; In non-perverse code, the DFO walk will reach all uses of the result -;;; continuation before it reaches the RETURN. In perverse code, we may -;;; annotate for unknown values when we didn't have to. -;;; -- Otherwise, we must annotate the continuation for unknown values. -(defun ltn-analyze-return (node policy) - (declare (type creturn node) (type policies policy)) +;;; Annotate the result continuation for a function. We use the +;;; RETURN-INFO computed by GTN to determine how to represent the +;;; return values within the function: +;;; ---- If the tail-set has a fixed values count, then use that +;;; many values. +;;; ---- If the actual uses of the result continuation in this function +;;; have a fixed number of values (after intersection with the +;;; assertion), then use that number. We throw out TAIL-P :FULL +;;; and :LOCAL calls, since we know they will truly end up as TR +;;; calls. We can use the BASIC-COMBINATION-INFO even though it +;;; is assigned by this phase, since the initial value NIL doesn't +;;; look like a TR call. +;;; If there are *no* non-tail-call uses, then it falls out +;;; that we annotate for one value (type is NIL), but the return +;;; will end up being deleted. +;;; In non-perverse code, the DFO walk will reach all uses of +;;; the result continuation before it reaches the RETURN. In +;;; perverse code, we may annotate for unknown values when we +;;; didn't have to. +;;; ---- Otherwise, we must annotate the continuation for unknown values. +(defun ltn-analyze-return (node ltn-policy) + (declare (type creturn node) (type ltn-policy ltn-policy)) (let* ((cont (return-result node)) (fun (return-lambda node)) (returns (tail-set-info (lambda-tail-set fun))) @@ -313,27 +337,27 @@ (multiple-value-bind (types kind) (values-types (if (eq int *empty-type*) (res) int)) (if (eq kind :unknown) - (annotate-unknown-values-continuation cont policy) + (annotate-unknown-values-continuation cont ltn-policy) (annotate-fixed-values-continuation - cont policy - (mapcar #'primitive-type types)))))) - (annotate-fixed-values-continuation cont policy types))) + cont ltn-policy (mapcar #'primitive-type types)))))) + (annotate-fixed-values-continuation cont ltn-policy types))) (values)) ;;; Annotate the single argument continuation as a fixed-values -;;; continuation. We look at the called lambda to determine number and type of -;;; return values desired. It is assumed that only a function that -;;; Looks-Like-An-MV-Bind will be converted to a local call. -(defun ltn-analyze-mv-bind (call policy) +;;; continuation. We look at the called lambda to determine number and +;;; type of return values desired. It is assumed that only a function +;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call. +(defun ltn-analyze-mv-bind (call ltn-policy) (declare (type mv-combination call) - (type policies policy)) + (type ltn-policy ltn-policy)) (setf (basic-combination-kind call) :local) (setf (node-tail-p call) nil) (annotate-fixed-values-continuation - (first (basic-combination-args call)) policy - (mapcar #'(lambda (var) - (primitive-type (basic-var-type var))) + (first (basic-combination-args call)) + ltn-policy + (mapcar (lambda (var) + (primitive-type (basic-var-type var))) (lambda-vars (ref-leaf (continuation-use @@ -341,48 +365,48 @@ (values)) ;;; We force all the argument continuations to use the unknown values -;;; convention. The continuations are annotated in reverse order, since the -;;; last argument is on top, thus must be popped first. We disallow delayed -;;; evaluation of the function continuation to simplify IR2 conversion of MV -;;; call. +;;; convention. The continuations are annotated in reverse order, +;;; since the last argument is on top, thus must be popped first. We +;;; disallow delayed evaluation of the function continuation to +;;; simplify IR2 conversion of MV call. ;;; -;;; We could be cleverer when we know the number of values returned by the -;;; continuations, but optimizations of MV-Call are probably unworthwhile. +;;; We could be cleverer when we know the number of values returned by +;;; the continuations, but optimizations of MV call are probably +;;; unworthwhile. ;;; -;;; We are also responsible for handling THROW, which is represented in IR1 -;;; as an mv-call to the %THROW funny function. We annotate the tag -;;; continuation for a single value and the values continuation for unknown -;;; values. -(defun ltn-analyze-mv-call (call policy) - (declare (type mv-combination call)) +;;; We are also responsible for handling THROW, which is represented +;;; in IR1 as an MV call to the %THROW funny function. We annotate the +;;; tag continuation for a single value and the values continuation +;;; for unknown values. +(defun ltn-analyze-mv-call (call ltn-policy) + (declare (type mv-combination call) (type ltn-policy ltn-policy)) (let ((fun (basic-combination-fun call)) (args (basic-combination-args call))) (cond ((eq (continuation-function-name fun) '%throw) (setf (basic-combination-info call) :funny) - (annotate-ordinary-continuation (first args) policy) - (annotate-unknown-values-continuation (second args) policy) + (annotate-ordinary-continuation (first args) ltn-policy) + (annotate-unknown-values-continuation (second args) ltn-policy) (setf (node-tail-p call) nil)) (t (setf (basic-combination-info call) :full) (annotate-function-continuation (basic-combination-fun call) - policy nil) + ltn-policy + nil) (dolist (arg (reverse args)) - (annotate-unknown-values-continuation arg policy)) + (annotate-unknown-values-continuation arg ltn-policy)) (flush-full-call-tail-transfer call)))) (values)) -;;; Annotate the arguments as ordinary single-value continuations. And check -;;; the successor. -(defun ltn-analyze-local-call (call policy) +;;; Annotate the arguments as ordinary single-value continuations. And +;;; check the successor. +(defun ltn-analyze-local-call (call ltn-policy) (declare (type combination call) - (type policies policy)) + (type ltn-policy ltn-policy)) (setf (basic-combination-info call) :local) - (dolist (arg (basic-combination-args call)) (when arg - (annotate-ordinary-continuation arg policy))) - + (annotate-ordinary-continuation arg ltn-policy))) (when (node-tail-p call) (set-tail-local-call-successor call)) (values)) @@ -404,20 +428,21 @@ (values)) ;;; Annotate the value continuation. -(defun ltn-analyze-set (node policy) - (declare (type cset node) (type policies policy)) +(defun ltn-analyze-set (node ltn-policy) + (declare (type cset node) (type ltn-policy ltn-policy)) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation (set-value node) policy) + (annotate-ordinary-continuation (set-value node) ltn-policy) (values)) -;;; If the only use of the Test continuation is a combination annotated with -;;; a conditional template, then don't annotate the continuation so that IR2 -;;; conversion knows not to emit any code, otherwise annotate as an ordinary -;;; continuation. Since we only use a conditional template if the call -;;; immediately precedes the IF node in the same block, we know that any -;;; predicate will already be annotated. -(defun ltn-analyze-if (node policy) - (declare (type cif node) (type policies policy)) +;;; If the only use of the TEST continuation is a combination +;;; annotated with a conditional template, then don't annotate the +;;; continuation so that IR2 conversion knows not to emit any code, +;;; otherwise annotate as an ordinary continuation. Since we only use +;;; a conditional template if the call immediately precedes the IF +;;; node in the same block, we know that any predicate will already be +;;; annotated. +(defun ltn-analyze-if (node ltn-policy) + (declare (type cif node) (type ltn-policy ltn-policy)) (setf (node-tail-p node) nil) (let* ((test (if-test node)) (use (continuation-use test))) @@ -425,57 +450,61 @@ (let ((info (basic-combination-info use))) (and (template-p info) (eq (template-result-types info) :conditional)))) - (annotate-ordinary-continuation test policy))) + (annotate-ordinary-continuation test ltn-policy))) (values)) -;;; If there is a value continuation, then annotate it for unknown values. -;;; In this case, the exit is non-local, since all other exits are deleted or -;;; degenerate by this point. -(defun ltn-analyze-exit (node policy) +;;; If there is a value continuation, then annotate it for unknown +;;; values. In this case, the exit is non-local, since all other exits +;;; are deleted or degenerate by this point. +(defun ltn-analyze-exit (node ltn-policy) (setf (node-tail-p node) nil) (let ((value (exit-value node))) (when value - (annotate-unknown-values-continuation value policy))) + (annotate-unknown-values-continuation value ltn-policy))) (values)) -;;; We need a special method for %Unwind-Protect that ignores the cleanup -;;; function. We don't annotate either arg, since we don't need them at -;;; run-time. +;;; We need a special method for %UNWIND-PROTECT that ignores the +;;; cleanup function. We don't annotate either arg, since we don't +;;; need them at run-time. ;;; -;;; [The default is o.k. for %Catch, since environment analysis converted the -;;; reference to the escape function into a constant reference to the -;;; NLX-Info.] -(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy) - policy ; Ignore... +;;; (The default is o.k. for %CATCH, since environment analysis +;;; converted the reference to the escape function into a constant +;;; reference to the NLX-INFO.) +(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) + node + ltn-policy) + (declare (ignore ltn-policy)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) -;;; Both of these functions need special LTN-annotate methods, since we only -;;; want to clear the Type-Check in unsafe policies. If we allowed the call to -;;; be annotated as a full call, then no type checking would be done. +;;; Both of these functions need special LTN-annotate methods, since +;;; we only want to clear the TYPE-CHECK in unsafe policies. If we +;;; allowed the call to be annotated as a full call, then no type +;;; checking would be done. ;;; -;;; We also need a special LTN annotate method for %Slot-Setter so that the -;;; function is ignored. This is because the reference to a SETF function -;;; can't be delayed, so IR2 conversion would have already emitted a call to -;;; FDEFINITION by the time the IR2 convert method got control. -(defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy) +;;; We also need a special LTN annotate method for %SLOT-SETTER so +;;; that the function is ignored. This is because the reference to a +;;; SETF function can't be delayed, so IR2 conversion would have +;;; already emitted a call to FDEFINITION by the time the IR2 convert +;;; method got control. +(defoptimizer (%slot-accessor ltn-annotate) ((struct) node ltn-policy) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct policy)) -(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy) + (annotate-ordinary-continuation struct ltn-policy)) +(defoptimizer (%slot-setter ltn-annotate) ((struct value) node ltn-policy) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) - (annotate-ordinary-continuation struct policy) - (annotate-ordinary-continuation value policy)) + (annotate-ordinary-continuation struct ltn-policy) + (annotate-ordinary-continuation value ltn-policy)) ;;;; known call annotation -;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T -;;; restriction allows any operand type. This is also called by IR2tran when -;;; it determines whether a result temporary needs to be made, and by -;;; representation selection when it is deciding which move VOP to use. -;;; Cont and TN are used to test for constant arguments. -#!-sb-fluid (declaim (inline operand-restriction-ok)) +;;; Return true if RESTR is satisfied by TYPE. If T-OK is true, then a +;;; T restriction allows any operand type. This is also called by IR2 +;;; translation when it determines whether a result temporary needs to +;;; be made, and by representation selection when it is deciding which +;;; move VOP to use. CONT and TN are used to test for constant +;;; arguments. (defun operand-restriction-ok (restr type &key cont tn (t-ok t)) (declare (type (or (member *) cons) restr) (type primitive-type type) @@ -499,9 +528,9 @@ (t (error "Neither CONT nor TN supplied."))))))) -;;; Check that the argument type restriction for Template are satisfied in -;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe, -;;; then only :SAFE templates are o.k. +;;; Check that the argument type restriction for TEMPLATE are +;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and +;;; our policy is safe, then only :SAFE templates are OK. (defun template-args-ok (template call safe-p) (declare (type template template) (type combination call)) @@ -521,19 +550,20 @@ (type (car types))) (when (and (eq (continuation-type-check arg) :no-check) safe-p - (not (eq (template-policy template) :safe))) + (not (eq (template-ltn-policy template) :safe))) (return nil)) (unless (operand-restriction-ok type (continuation-ptype arg) :cont arg) (return nil)))))) -;;; Check that Template can be used with the specifed Result-Type. Result -;;; type checking is pretty different from argument type checking due to the -;;; relaxed rules for values count. We succeed if for each required result, -;;; there is a positional restriction on the value that is at least as good. -;;; If we run out of result types before we run out of restrictions, then we -;;; only succeed if the leftover restrictions are *. If we run out of -;;; restrictions before we run out of result types, then we always win. +;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE. +;;; Result type checking is pretty different from argument type +;;; checking due to the relaxed rules for values count. We succeed if +;;; for each required result, there is a positional restriction on the +;;; value that is at least as good. If we run out of result types +;;; before we run out of restrictions, then we only succeed if the +;;; leftover restrictions are *. If we run out of restrictions before +;;; we run out of result types, then we always win. (defun template-results-ok (template result-type) (declare (type template template) (type ctype result-type)) @@ -559,22 +589,22 @@ (operand-restriction-ok (first types) (primitive-type result-type))) (t t)))) -;;; Return true if Call is an ok use of Template according to Safe-P. -;;; -- If the template has a Guard that isn't true, then we ignore the +;;; Return true if CALL is an ok use of TEMPLATE according to SAFE-P. +;;; -- If the template has a GUARD that isn't true, then we ignore the ;;; template, not even considering it to be rejected. -;;; -- If the argument type restrictions aren't satisfied, then we reject the -;;; template. -;;; -- If the template is :Conditional, then we accept it only when the +;;; -- If the argument type restrictions aren't satisfied, then we +;;; reject the template. +;;; -- If the template is :CONDITIONAL, then we accept it only when the ;;; destination of the value is an immediately following IF node. -;;; -- If either the template is safe or the policy is unsafe (i.e. we can -;;; believe output assertions), then we test against the intersection of the -;;; node derived type and the continuation asserted type. Otherwise, we -;;; just use the node type. If TYPE-CHECK is null, there is no point in -;;; doing the intersection, since the node type must be a subtype of the -;;; assertion. +;;; -- If either the template is safe or the policy is unsafe (i.e. we +;;; can believe output assertions), then we test against the +;;; intersection of the node derived type and the continuation +;;; asserted type. Otherwise, we just use the node type. If +;;; TYPE-CHECK is null, there is no point in doing the intersection, +;;; since the node type must be a subtype of the assertion. ;;; -;;; If the template is *not* ok, then the second value is a keyword indicating -;;; which aspect failed. +;;; If the template is *not* ok, then the second value is a keyword +;;; indicating which aspect failed. (defun is-ok-template-use (template call safe-p) (declare (type template template) (type combination call)) (let* ((guard (template-guard template)) @@ -596,7 +626,7 @@ (values nil :conditional)))) ((template-results-ok template - (if (and (or (eq (template-policy template) :safe) + (if (and (or (eq (template-ltn-policy template) :safe) (not safe-p)) (continuation-type-check cont)) (values-type-intersection dtype atype) @@ -606,7 +636,7 @@ (values nil :result-types))))) ;;; Use operand type information to choose a template from the list -;;; Templates for a known Call. We return three values: +;;; TEMPLATES for a known CALL. We return three values: ;;; 1. The template we found. ;;; 2. Some template that we rejected due to unsatisfied type restrictions, or ;;; NIL if none. @@ -624,30 +654,31 @@ (return (values template rejected (rest templates)))) (setq rejected template)))) -;;; Given a partially annotated known call and a translation policy, return -;;; the appropriate template, or NIL if none can be found. We scan the -;;; templates (ordered by increasing cost) looking for a template whose -;;; restrictions are satisfied and that has our policy. +;;; Given a partially annotated known call and a translation policy, +;;; return the appropriate template, or NIL if none can be found. We +;;; scan the templates (ordered by increasing cost) looking for a +;;; template whose restrictions are satisfied and that has our policy. ;;; -;;; If we find a template that doesn't have our policy, but has a legal -;;; alternate policy, then we also record that to return as a last resort. If -;;; our policy is safe, then only safe policies are O.K., otherwise anything -;;; goes. +;;; If we find a template that doesn't have our policy, but has a +;;; legal alternate policy, then we also record that to return as a +;;; last resort. If our policy is safe, then only safe policies are +;;; O.K., otherwise anything goes. ;;; -;;; If we find a template with :SAFE policy, then we return it, or any cheaper -;;; fallback template. The theory behind this is that if it is cheapest, small -;;; and safe, we can't lose. If it is not cheapest, then we use the fallback, -;;; which won't have the desired policy, but :SAFE isn't desired either, so we -;;; might as well go with the cheaper one. The main reason for doing this is -;;; to make sure that cheap safe templates are used when they apply and the -;;; current policy is something else. This is useful because :SAFE has the -;;; additional semantics of implicit argument type checking, so we may be -;;; forced to define a template with :SAFE policy when it is really small and -;;; fast as well. -(defun find-template-for-policy (call policy) +;;; If we find a template with :SAFE policy, then we return it, or any +;;; cheaper fallback template. The theory behind this is that if it is +;;; cheapest, small and safe, we can't lose. If it is not cheapest, +;;; then we use the fallback, which won't have the desired policy, but +;;; :SAFE isn't desired either, so we might as well go with the +;;; cheaper one. The main reason for doing this is to make sure that +;;; cheap safe templates are used when they apply and the current +;;; policy is something else. This is useful because :SAFE has the +;;; additional semantics of implicit argument type checking, so we may +;;; be forced to define a template with :SAFE policy when it is really +;;; small and fast as well. +(defun find-template-for-ltn-policy (call ltn-policy) (declare (type combination call) - (type policies policy)) - (let ((safe-p (policy-safe-p policy)) + (type ltn-policy ltn-policy)) + (let ((safe-p (ltn-policy-safe-p ltn-policy)) (current (function-info-templates (basic-combination-kind call))) (fallback nil) (rejected nil)) @@ -659,13 +690,12 @@ (setq current more) (unless template (return (values fallback rejected))) - - (let ((tpolicy (template-policy template))) - (cond ((eq tpolicy policy) + (let ((tcpolicy (template-ltn-policy template))) + (cond ((eq tcpolicy ltn-policy) (return (values template rejected))) - ((eq tpolicy :safe) + ((eq tcpolicy :safe) (return (values (or fallback template) rejected))) - ((or (not safe-p) (eq tpolicy :fast-safe)) + ((or (not safe-p) (eq tcpolicy :fast-safe)) (unless fallback (setq fallback template))))))))) @@ -681,16 +711,16 @@ the next alternative that justifies an efficiency note.") (declaim (type index *efficiency-note-cost-threshold*)) -;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure -;;; out any reason why Template was rejected. Users should never see these -;;; messages, but they can happen in situations where the VM definition is -;;; messed up somehow. -(defun strange-template-failure (template call policy frob) +;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't +;;; figure out any reason why TEMPLATE was rejected. Users should +;;; never see these messages, but they can happen in situations where +;;; the VM definition is messed up somehow. +(defun strange-template-failure (template call ltn-policy frob) (declare (type template template) (type combination call) - (type policies policy) (type function frob)) + (type ltn-policy ltn-policy) (type function frob)) (funcall frob "This shouldn't happen! Bug?") (multiple-value-bind (win why) - (is-ok-template-use template call (policy-safe-p policy)) + (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) (assert (not win)) (ecase why (:guard @@ -718,43 +748,47 @@ (:result-types (funcall frob "result types invalid"))))) -;;; This function emits efficiency notes describing all of the templates -;;; better (faster) than Template that we might have been able to use if there -;;; were better type declarations. Template is null when we didn't find any -;;; template, and thus must do a full call. +;;; This function emits efficiency notes describing all of the +;;; templates better (faster) than TEMPLATE that we might have been +;;; able to use if there were better type declarations. Template is +;;; null when we didn't find any template, and thus must do a full +;;; call. ;;; ;;; In order to be worth complaining about, a template must: ;;; -- be allowed by its guard, ;;; -- be safe if the current policy is safe, -;;; -- have argument/result type restrictions consistent with the known type -;;; information, e.g. we don't consider float templates when an operand is -;;; known to be an integer, -;;; -- be disallowed by the stricter operand subtype test (which resembles, but -;;; is not identical to the test done by Find-Template.) +;;; -- have argument/result type restrictions consistent with the +;;; known type information, e.g. we don't consider float templates +;;; when an operand is known to be an integer, +;;; -- be disallowed by the stricter operand subtype test (which +;;; resembles, but is not identical to the test done by +;;; FIND-TEMPLATE.) ;;; -;;; Note that there may not be any possibly applicable templates, since we are -;;; called whenever any template is rejected. That template might have the -;;; wrong policy or be inconsistent with the known type. +;;; Note that there may not be any possibly applicable templates, +;;; since we are called whenever any template is rejected. That +;;; template might have the wrong policy or be inconsistent with the +;;; known type. ;;; -;;; We go to some trouble to make the whole multi-line output into a single -;;; call to Compiler-Note so that repeat messages are suppressed, etc. -(defun note-rejected-templates (call policy template) - (declare (type combination call) (type policies policy) +;;; We go to some trouble to make the whole multi-line output into a +;;; single call to COMPILER-NOTE so that repeat messages are +;;; suppressed, etc. +(defun note-rejected-templates (call ltn-policy template) + (declare (type combination call) (type ltn-policy ltn-policy) (type (or template null) template)) (collect ((losers)) - (let ((safe-p (policy-safe-p policy)) + (let ((safe-p (ltn-policy-safe-p ltn-policy)) (verbose-p (policy call (= inhibit-warnings 0))) (max-cost (- (template-cost (or template (template-or-lose 'call-named))) *efficiency-note-cost-threshold*))) (dolist (try (function-info-templates (basic-combination-kind call))) - (when (> (template-cost try) max-cost) (return)) + (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner. (let ((guard (template-guard try))) (when (and (or (not guard) (funcall guard)) (or (not safe-p) - (policy-safe-p (template-policy try))) + (ltn-policy-safe-p (template-ltn-policy try))) (or verbose-p (and (template-note try) (valid-function-use @@ -783,13 +817,13 @@ (template-cost loser)) (cond ((and valid strict-valid) - (strange-template-failure loser call policy #'frob)) + (strange-template-failure loser call ltn-policy #'frob)) ((not valid) (assert (not (valid-function-use call type :error-function #'frob :warning-function #'frob)))) (t - (assert (policy-safe-p policy)) + (assert (ltn-policy-safe-p ltn-policy)) (frob "can't trust output type assertion under safe policy"))) (count 1)))) @@ -814,31 +848,32 @@ ;;; the policy is safe because the selection of template for results ;;; readers assumes the type check is done (uses the derived type ;;; which is the intersection of the proven and asserted types). -(defun flush-type-checks-according-to-policy (call policy template) - (declare (type combination call) (type policies policy) +(defun flush-type-checks-according-to-ltn-policy (call ltn-policy template) + (declare (type combination call) (type ltn-policy ltn-policy) (type template template)) - (let ((safe-op (eq (template-policy template) :safe))) - (when (or (not (policy-safe-p policy)) safe-op) + (let ((safe-op (eq (template-ltn-policy template) :safe))) + (when (or (not (ltn-policy-safe-p ltn-policy)) safe-op) (dolist (arg (basic-combination-args call)) (flush-type-check arg))) (when safe-op (let ((cont (node-cont call))) (when (and (eq (continuation-use cont) call) - (not (policy-safe-p policy))) + (not (ltn-policy-safe-p ltn-policy))) (flush-type-check cont))))) (values)) -;;; If a function has a special-case annotation method use that, otherwise -;;; annotate the argument continuations and try to find a template -;;; corresponding to the type signature. If there is none, convert a full call. -(defun ltn-analyze-known-call (call policy) +;;; If a function has a special-case annotation method use that, +;;; otherwise annotate the argument continuations and try to find a +;;; template corresponding to the type signature. If there is none, +;;; convert a full call. +(defun ltn-analyze-known-call (call ltn-policy) (declare (type combination call) - (type policies policy)) + (type ltn-policy ltn-policy)) (let ((method (function-info-ltn-annotate (basic-combination-kind call))) (args (basic-combination-args call))) (when method - (funcall method call policy) + (funcall method call ltn-policy) (return-from ltn-analyze-known-call (values))) (dolist (arg args) @@ -846,13 +881,13 @@ (make-ir2-continuation (primitive-type (continuation-type arg))))) (multiple-value-bind (template rejected) - (find-template-for-policy call policy) - ;; If we are unable to use some templates due to unsatisfied operand type - ;; restrictions and our policy enables efficiency notes, then we call - ;; Note-Rejected-Templates. + (find-template-for-ltn-policy call ltn-policy) + ;; If we are unable to use some templates due to unsatisfied + ;; operand type restrictions and our policy enables efficiency + ;; notes, then we call NOTE-REJECTED-TEMPLATES. (when (and rejected (policy call (> speed inhibit-warnings))) - (note-rejected-templates call policy template)) + (note-rejected-templates call ltn-policy template)) ;; If we are forced to do a full call, we check to see whether the ;; function called is the same as the current function. If so, we ;; give a warning, as this is probably a botched interpreter stub. @@ -867,12 +902,12 @@ recursive))))) (let ((*compiler-error-context* call)) (compiler-warning "recursive known function definition"))) - (ltn-default-call call policy) + (ltn-default-call call ltn-policy) (return-from ltn-analyze-known-call (values))) (setf (basic-combination-info call) template) (setf (node-tail-p call) nil) - (flush-type-checks-according-to-policy call policy template) + (flush-type-checks-according-to-ltn-policy call ltn-policy template) (dolist (arg args) (annotate-1-value-continuation arg)))) @@ -881,94 +916,74 @@ ;;;; interfaces -;;; We make the main per-block code in for LTN into a macro so that it can -;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy -;;; across blocks in the normal (full component) case. +;;; most of the guts of the two interface functions: Compute the +;;; policy and dispatch to the appropriate node-specific function. ;;; -;;; This code computes the policy and then dispatches to the appropriate -;;; node-specific function. -;;; -;;; Note: we deliberately don't use the DO-NODES macro, since the block can be -;;; split out from underneath us, and DO-NODES would scan past the block end in that -;;; case. -(macrolet ((frob () - '(do* ((node (continuation-next (block-start block)) - (continuation-next cont)) - (cont (node-cont node) (node-cont node)) - ;; KLUDGE: Since LEXENV and POLICY seem to be only used - ;; inside this FROB, why not define them in here instead of - ;; requiring them to be defined externally both in - ;; LTN-ANALYZE and LTN-ANALYZE-BLOCK? Or perhaps just - ;; define this whole FROB as an inline function? (Right now - ;; I don't want to make even a small unnecessary change - ;; like this, but'd prefer to wait until the system runs so - ;; that I can test it immediately after the change.) - ;; -- WHN 19990808 - ) - (()) - (unless (eq (node-lexenv node) lexenv) - (setq policy (translation-policy node)) - (setq lexenv (node-lexenv node))) - - (etypecase node - (ref) - (combination - (case (basic-combination-kind node) - (:local (ltn-analyze-local-call node policy)) - ((:full :error) (ltn-default-call node policy)) - (t - (ltn-analyze-known-call node policy)))) - (cif - (ltn-analyze-if node policy)) - (creturn - (ltn-analyze-return node policy)) - ((or bind entry)) - (exit - (ltn-analyze-exit node policy)) - (cset (ltn-analyze-set node policy)) - (mv-combination - (ecase (basic-combination-kind node) - (:local (ltn-analyze-mv-bind node policy)) - ((:full :error) (ltn-analyze-mv-call node policy))))) - - (when (eq node (block-last block)) - (return))))) - -;;; Loop over the blocks in Component, doing stuff to nodes that receive -;;; values. In addition to the stuff done by FROB, we also see whether there -;;; are any unknown values receivers, making notations in the components -;;; Generators and Receivers as appropriate. +;;; Note: we deliberately don't use the DO-NODES macro, since the +;;; block can be split out from underneath us, and DO-NODES would scan +;;; past the block end in that case. +(defun ltn-analyze-block (block) + (do* ((node (continuation-next (block-start block)) + (continuation-next cont)) + (cont (node-cont node) (node-cont node)) + (ltn-policy (node-ltn-policy node) (node-ltn-policy node))) + (nil) + (etypecase node + (ref) + (combination + (case (basic-combination-kind node) + (:local (ltn-analyze-local-call node ltn-policy)) + ((:full :error) (ltn-default-call node ltn-policy)) + (t + (ltn-analyze-known-call node ltn-policy)))) + (cif + (ltn-analyze-if node ltn-policy)) + (creturn + (ltn-analyze-return node ltn-policy)) + ((or bind entry)) + (exit + (ltn-analyze-exit node ltn-policy)) + (cset (ltn-analyze-set node ltn-policy)) + (mv-combination + (ecase (basic-combination-kind node) + (:local + (ltn-analyze-mv-bind node ltn-policy)) + ((:full :error) + (ltn-analyze-mv-call node ltn-policy))))) + (when (eq node (block-last block)) + (return)))) + +;;; Loop over the blocks in COMPONENT, doing stuff to nodes that +;;; receive values. In addition to the stuff done by FROB, we also see +;;; whether there are any unknown values receivers, making notations +;;; in the components Generators and Receivers as appropriate. ;;; ;;; If any unknown-values continations are received by this block (as -;;; indicated by IR2-Block-Popped, then we add the block to the -;;; IR2-Component-Values-Receivers. +;;; indicated by IR2-BLOCK-POPPED), then we add the block to the +;;; IR2-COMPONENT-VALUES-RECEIVERS. ;;; -;;; This is where we allocate IR2 blocks because it is the first place we -;;; need them. +;;; This is where we allocate IR2 blocks because it is the first place +;;; we need them. (defun ltn-analyze (component) (declare (type component component)) - (let ((2comp (component-info component)) - (lexenv nil) - policy) + (let ((2comp (component-info component))) (do-blocks (block component) (assert (not (block-info block))) (let ((2block (make-ir2-block block))) (setf (block-info block) 2block) - (frob) + (ltn-analyze-block block) (let ((popped (ir2-block-popped 2block))) (when popped (push block (ir2-component-values-receivers 2comp))))))) (values)) -;;; This function is used to analyze blocks that must be added to the flow -;;; graph after the normal LTN phase runs. Such code is constrained not to -;;; use weird unknown values (and probably in lots of other ways). -(defun ltn-analyze-block (block) +;;; This function is used to analyze blocks that must be added to the +;;; flow graph after the normal LTN phase runs. Such code is +;;; constrained not to use weird unknown values (and probably in lots +;;; of other ways). +(defun ltn-analyze-belated-block (block) (declare (type cblock block)) - (let ((lexenv nil) - policy) - (frob)) + (ltn-analyze-block block) (assert (not (ir2-block-popped (block-info block)))) (values)) -) ; MACROLET FROB diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 1ea2355..713f224 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -737,84 +737,7 @@ (values (cdr ,n-res) t) (values nil nil)))) -;;; These functions are called by the expansion of the DEFPRINTER -;;; macro to do the actual printing. -(declaim (ftype (function (symbol t stream &optional t) (values)) - defprinter-prin1 defprinter-princ)) -(defun defprinter-prin1 (name value stream &optional indent) - (declare (ignore indent)) - (defprinter-prinx #'prin1 name value stream)) -(defun defprinter-princ (name value stream &optional indent) - (declare (ignore indent)) - (defprinter-prinx #'princ name value stream)) -(defun defprinter-prinx (prinx name value stream) - (declare (type function prinx)) - (write-char #\space stream) - (when *print-pretty* - (pprint-newline :linear stream)) - (format stream ":~A " name) - (funcall prinx value stream) - (values)) - -;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT. -;; -;; NAME is the name of the structure class, and CONC-NAME is the same as in -;; DEFSTRUCT. -;; -;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can -;; be a slot name, indicating that the slot should simply be printed. A -;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff -;; is composed of keywords followed by expressions. The expressions are -;; evaluated with the variable which is the slot name bound to the value of the -;; slot. These keywords are defined: -;; -;; :PRIN1 Print the value of the expression instead of the slot value. -;; :PRINC Like :PRIN1, only princ the value -;; :TEST Only print something if the test is true. -;; -;; If no printing thing is specified then the slot value is printed as PRIN1. -;; -;; The structure being printed is bound to STRUCTURE and the stream is bound to -;; STREAM. -(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string - (symbol-name name) - "-"))) - &rest slot-descs) - (flet ((sref (slot-name) - `(,(symbolicate conc-name slot-name) structure))) - (collect ((prints)) - (dolist (slot-desc slot-descs) - (if (atom slot-desc) - (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream)) - (let ((sname (first slot-desc)) - (test t)) - (collect ((stuff)) - (do ((option (rest slot-desc) (cddr option))) - ((null option) - (prints - `(let ((,sname ,(sref sname))) - (when ,test - ,@(or (stuff) - `((defprinter-prin1 ',sname ,sname - stream))))))) - (case (first option) - (:prin1 - (stuff `(defprinter-prin1 ',sname ,(second option) - stream))) - (:princ - (stuff `(defprinter-princ ',sname ,(second option) - stream))) - (:test (setq test (second option))) - (t - (error "bad DEFPRINTER option: ~S" (first option))))))))) - - `(def!method print-object ((structure ,name) stream) - (print-unreadable-object (structure stream :type t) - (pprint-logical-block (stream nil) - ;;(pprint-indent :current 2 stream) - ,@(prints))))))) - -;;;; the Event statistics/trace utility +;;;; the EVENT statistics/trace utility ;;; FIXME: This seems to be useful for troubleshooting and ;;; experimentation, not for ordinary use, so it should probably diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 8c542f9..61a3079 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -63,10 +63,11 @@ (make-array ',size :initial-element #-(or sb-xc sb-xc-host) #* - ;; The cross-compiler isn't very good at - ;; dumping specialized arrays; we work around - ;; that by postponing generation of the - ;; specialized array 'til runtime. + ;; The cross-compiler isn't very good + ;; at dumping specialized arrays; we + ;; work around that by postponing + ;; generation of the specialized + ;; array 'til runtime. #+(or sb-xc sb-xc-host) (make-array 0 :element-type 'bit))) (/show0 "doing second SETF") @@ -278,8 +279,9 @@ (or (gethash name *backend-meta-primitive-type-names*) (error "~S is not a defined primitive type." name)))) -;;; If the primitive-type structure already exists, we destructively modify -;;; it so that existing references in templates won't be invalidated. +;;; If the PRIMITIVE-TYPE structure already exists, we destructively +;;; modify it so that existing references in templates won't be +;;; invalidated. (defmacro def-primitive-type (name scs &key (type name)) #!+sb-doc "Def-Primitive-Type Name (SC*) {Key Value}* @@ -365,70 +367,72 @@ ;;;; VOP definition structures ;;;; -;;;; Define-VOP uses some fairly complex data structures at meta-compile -;;;; time, both to hold the results of parsing the elaborate syntax and to -;;;; retain the information so that it can be inherited by other VOPs. +;;;; DEFINE-VOP uses some fairly complex data structures at +;;;; meta-compile time, both to hold the results of parsing the +;;;; elaborate syntax and to retain the information so that it can be +;;;; inherited by other VOPs. -;;; The VOP-Parse structure holds everything we need to know about a VOP at +;;; A VOP-PARSE object holds everything we need to know about a VOP at ;;; meta-compile time. (def!struct (vop-parse (:make-load-form-fun just-dump-it-normally) #-sb-xc-host (:pure t)) - ;; The name of this VOP. + ;; the name of this VOP (name nil :type symbol) ;; If true, then the name of the VOP we inherit from. (inherits nil :type (or symbol null)) - ;; Lists of Operand-Parse structures describing the arguments, results and - ;; temporaries of the VOP. + ;; lists of OPERAND-PARSE structures describing the arguments, + ;; results and temporaries of the VOP (args nil :type list) (results nil :type list) (temps nil :type list) - ;; Operand-Parse structures containing information about more args and - ;; results. If null, then there there are no more operands of that kind. + ;; OPERAND-PARSE structures containing information about more args + ;; and results. If null, then there there are no more operands of + ;; that kind (more-args nil :type (or operand-parse null)) (more-results nil :type (or operand-parse null)) - ;; A list of all the above together. + ;; a list of all the above together (operands nil :type list) - ;; Names of variables that should be declared ignore. + ;; names of variables that should be declared IGNORE (ignores () :type list) - ;; True if this is a :Conditional VOP. + ;; true if this is a :CONDITIONAL VOP (conditional-p nil) - ;; Argument and result primitive types. These are pulled out of the - ;; operands, since we often want to change them without respecifying the - ;; operands. + ;; argument and result primitive types. These are pulled out of the + ;; operands, since we often want to change them without respecifying + ;; the operands. (arg-types :unspecified :type (or (member :unspecified) list)) (result-types :unspecified :type (or (member :unspecified) list)) - ;; The guard expression specified, or NIL if none. + ;; the guard expression specified, or NIL if none (guard nil) - ;; The cost of and body code for the generator. + ;; the cost of and body code for the generator (cost 0 :type unsigned-byte) (body :unspecified :type (or (member :unspecified) list)) - ;; Info for VOP variants. The list of forms to be evaluated to get the - ;; variant args for this VOP, and the list of variables to be bound to the - ;; variant args. + ;; info for VOP variants. The list of forms to be evaluated to get + ;; the variant args for this VOP, and the list of variables to be + ;; bound to the variant args. (variant () :type list) (variant-vars () :type list) - ;; Variables bound to the VOP and Vop-Node when in the generator body. + ;; variables bound to the VOP and Vop-Node when in the generator body (vop-var (gensym) :type symbol) (node-var nil :type (or symbol null)) - ;; A list of the names of the codegen-info arguments to this VOP. + ;; a list of the names of the codegen-info arguments to this VOP (info-args () :type list) - ;; An efficiency note associated with this VOP. + ;; an efficiency note associated with this VOP (note nil :type (or string null)) - ;; A list of the names of the Effects and Affected attributes for this VOP. + ;; a list of the names of the Effects and Affected attributes for + ;; this VOP (effects '(any) :type list) (affected '(any) :type list) - ;; A list of the names of functions this VOP is a translation of and the - ;; policy that allows this translation to be done. :Fast is a safe default, - ;; since it isn't a safe policy. + ;; a list of the names of functions this VOP is a translation of and + ;; the policy that allows this translation to be done. :Fast is a + ;; safe default, since it isn't a safe policy. (translate () :type list) - (policy :fast :type policies) - ;; Stuff used by life analysis. + (ltn-policy :fast :type ltn-policy) + ;; stuff used by life analysis (save-p nil :type (member t nil :compute-only :force-to-stack)) - ;; Info about how to emit move-argument VOPs for the more operand in - ;; call/return VOPs. + ;; info about how to emit move-argument VOPs for the more operand in + ;; call/return VOPs (move-args nil :type (member nil :local-call :full-call :known-return))) - (defprinter (vop-parse) name (inherits :test inherits) @@ -450,47 +454,48 @@ effects affected translate - policy + ltn-policy (save-p :test save-p) (move-args :test move-args)) -;;; An OPERAND-PARSE object contains stuff we need to know about an operand or -;;; temporary at meta-compile time. Besides the obvious stuff, we also store -;;; the names of per-operand temporaries here. +;;; An OPERAND-PARSE object contains stuff we need to know about an +;;; operand or temporary at meta-compile time. Besides the obvious +;;; stuff, we also store the names of per-operand temporaries here. (def!struct (operand-parse (:make-load-form-fun just-dump-it-normally) #-sb-xc-host (:pure t)) - ;; Name of the operand (which we bind to the TN). + ;; name of the operand (which we bind to the TN) (name nil :type symbol) - ;; The way this operand is used: + ;; the way this operand is used: (kind (required-argument) :type (member :argument :result :temporary :more-argument :more-result)) - ;; If true, the name of an operand that this operand is targeted to. This is - ;; only meaningful in :Argument and :Temporary operands. + ;; If true, the name of an operand that this operand is targeted to. + ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands. (target nil :type (or symbol null)) - ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the - ;; write reference that begins a temporary's lifetime. + ;; TEMP is a temporary that holds the TN-REF for this operand. + ;; TEMP-TEMP holds the write reference that begins a temporary's + ;; lifetime. (temp (gensym) :type symbol) (temp-temp nil :type (or symbol null)) - ;; The time that this operand is first live and the time at which it becomes - ;; dead again. These are time-specs, as returned by parse-time-spec. + ;; the time that this operand is first live and the time at which it + ;; becomes dead again. These are TIME-SPECs, as returned by + ;; PARSE-TIME-SPEC. born dies - ;; A list of the names of the SCs that this operand is allowed into. If - ;; false, there is no restriction. + ;; a list of the names of the SCs that this operand is allowed into. + ;; If false, there is no restriction. (scs nil :type list) ;; Variable that is bound to the load TN allocated for this operand, or to ;; NIL if no load-TN was allocated. (load-tn (gensym) :type symbol) - ;; An expression that tests whether to do automatic operand loading. + ;; an expression that tests whether to do automatic operand loading (load t) - ;; In a wired or restricted temporary this is the SC the TN is to be packed - ;; in. Null otherwise. + ;; In a wired or restricted temporary this is the SC the TN is to be + ;; packed in. Null otherwise. (sc nil :type (or symbol null)) ;; If non-null, we are a temp wired to this offset in SC. (offset nil :type (or unsigned-byte null))) - (defprinter (operand-parse) name kind @@ -504,10 +509,10 @@ ;;;; miscellaneous utilities -;;; Find the operand or temporary with the specifed Name in the VOP Parse. -;;; If there is no such operand, signal an error. Also error if the operand -;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL -;;; if there is no such operand. +;;; Find the operand or temporary with the specifed Name in the VOP +;;; Parse. If there is no such operand, signal an error. Also error if +;;; the operand kind isn't one of the specified Kinds. If Error-P is +;;; NIL, just return NIL if there is no such operand. (defun find-operand (name parse &optional (kinds '(:argument :result :temporary)) (error-p t)) @@ -522,17 +527,17 @@ found)) ;;; Get the VOP-Parse structure for NAME or die trying. For all -;;; meta-compile time uses, the VOP-Parse should be used instead of the -;;; VOP-Info. +;;; meta-compile time uses, the VOP-Parse should be used instead of +;;; the VOP-Info. (defun vop-parse-or-lose (name) (the vop-parse (or (gethash name *backend-parsed-vops*) (error "~S is not the name of a defined VOP." name)))) -;;; Return a list of let-forms to parse a tn-ref list into a the temps -;;; specified by the operand-parse structures. More-Operand is the -;;; Operand-Parse describing any more operand, or NIL if none. Refs is an -;;; expression that evaluates into the first tn-ref. +;;; Return a list of LET-forms to parse a TN-REF list into the temps +;;; specified by the operand-parse structures. MORE-OPERAND is the +;;; Operand-Parse describing any more operand, or NIL if none. REFS is +;;; an expression that evaluates into the first tn-ref. (defun access-operands (operands more-operand refs) (declare (list operands)) (collect ((res)) @@ -546,9 +551,9 @@ (res `(,(operand-parse-name more-operand) ,prev)))) (res))) -;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used -;;; by some particular function. It returns the name of the last operand, or -;;; NIL if Operands is NIL. +;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-Ref +;;; temps not used by some particular function. It returns the name of +;;; the last operand, or NIL if Operands is NIL. (defun ignore-unreferenced-temps (operands) (when operands (operand-parse-temp (car (last operands))))) @@ -567,10 +572,11 @@ ;;;; time specs -;;; Return a time spec describing a time during the evaluation of a VOP, -;;; used to delimit operand and temporary lifetimes. The representation is a -;;; cons whose CAR is the number of the evaluation phase and the CDR is the -;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases. +;;; Return a time spec describing a time during the evaluation of a +;;; VOP, used to delimit operand and temporary lifetimes. The +;;; representation is a cons whose CAR is the number of the evaluation +;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the +;;; :LOAD and :SAVE phases. (defun parse-time-spec (spec) (let ((dspec (if (atom spec) (list spec 0) spec))) (unless (and (= (length dspec) 2) @@ -616,13 +622,14 @@ (ash (meta-sc-number-or-lose sc) 1)))) (incf index)) ;; KLUDGE: As in the other COERCEs wrapped around with - ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, this - ;; coercion could be removed by a sufficiently smart compiler, but I - ;; dunno whether Python is that smart. It would be good to check this - ;; and help it if it's not smart enough to remove it for itself. - ;; However, it's probably not urgent, since the overhead of an extra - ;; no-op conversion is unlikely to be large compared to consing and - ;; corresponding GC. -- WHN ca. 19990701 + ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, + ;; this coercion could be removed by a sufficiently smart + ;; compiler, but I dunno whether Python is that smart. It + ;; would be good to check this and help it if it's not smart + ;; enough to remove it for itself. However, it's probably not + ;; urgent, since the overhead of an extra no-op conversion is + ;; unlikely to be large compared to consing and corresponding + ;; GC. -- WHN ca. 19990701 `(coerce ,results '(specializable-vector ,element-type)))))) (defun compute-ref-ordering (parse) @@ -687,22 +694,25 @@ (incf index))) `(:num-args ,num-args :num-results ,num-results - ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper here - ;; around the result returned by MAKE-SPECIALIZABLE-ARRAY above was - ;; of course added to help with cross-compilation. "A sufficiently - ;; smart compiler" should be able to optimize all this away in the - ;; final target Lisp, leaving a single MAKE-ARRAY with no subsequent - ;; coercion. However, I don't know whether Python is that smart. (Can - ;; it figure out the return type of MAKE-ARRAY? Does it know that - ;; COERCE can be optimized away if the input type is known to be the - ;; same as the COERCEd-to type?) At some point it would be good to - ;; test to see whether this construct is in fact causing run-time - ;; overhead, and fix it if so. (Some declarations of the types - ;; returned by MAKE-ARRAY might be enough to fix it.) However, it's - ;; probably not urgent to fix this, since it's hard to imagine that - ;; any overhead caused by calling COERCE and letting it decide to - ;; bail out could be large compared to the cost of consing and GCing - ;; the vectors in the first place. -- WHN ca. 19990701 + ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper + ;; here around the result returned by + ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to + ;; help with cross-compilation. "A sufficiently smart + ;; compiler" should be able to optimize all this away in the + ;; final target Lisp, leaving a single MAKE-ARRAY with no + ;; subsequent coercion. However, I don't know whether Python + ;; is that smart. (Can it figure out the return type of + ;; MAKE-ARRAY? Does it know that COERCE can be optimized + ;; away if the input type is known to be the same as the + ;; COERCEd-to type?) At some point it would be good to test + ;; to see whether this construct is in fact causing run-time + ;; overhead, and fix it if so. (Some declarations of the + ;; types returned by MAKE-ARRAY might be enough to fix it.) + ;; However, it's probably not urgent to fix this, since it's + ;; hard to imagine that any overhead caused by calling + ;; COERCE and letting it decide to bail out could be large + ;; compared to the cost of consing and GCing the vectors in + ;; the first place. -- WHN ca. 19990701 :ref-ordering (coerce ',ordering '(specializable-vector ,oe-type)) ,@(when (targets) @@ -716,10 +726,10 @@ ;;;; generator functions -;;; Return an alist that translates from lists of SCs we can load OP from to -;;; the move function used for loading those SCs. We quietly ignore -;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't -;;; load into those SCs. +;;; Return an alist that translates from lists of SCs we can load OP +;;; from to the move function used for loading those SCs. We quietly +;;; ignore restrictions to :non-packed (constant) and :unbounded SCs, +;;; since we don't load into those SCs. (defun find-move-functions (op load-p) (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) @@ -758,12 +768,12 @@ sc-name load-p (operand-parse-name op)))))) (funs))) -;;; Return a form to load/save the specified operand when it has a load TN. -;;; For any given SC that we can load from, there must be a unique load -;;; function. If all SCs we can load from have the same move function, then we -;;; just call that when there is a load TN. If there are multiple possible -;;; move functions, then we dispatch off of the operand TN's type to see which -;;; move function to use. +;;; Return a form to load/save the specified operand when it has a +;;; load TN. For any given SC that we can load from, there must be a +;;; unique load function. If all SCs we can load from have the same +;;; move function, then we just call that when there is a load TN. If +;;; there are multiple possible move functions, then we dispatch off +;;; of the operand TN's type to see which move function to use. (defun call-move-function (parse op load-p) (let ((funs (find-move-functions op load-p)) (load-tn (operand-parse-load-tn op))) @@ -792,8 +802,9 @@ (error "load TN allocated, but no move function?~@ VM definition is inconsistent, recompile and try again."))))) -;;; Return the TN that we should bind to the operand's var in the generator -;;; body. In general, this involves evaluating the :LOAD-IF test expression. +;;; Return the TN that we should bind to the operand's var in the +;;; generator body. In general, this involves evaluating the :LOAD-IF +;;; test expression. (defun decide-to-load (parse op) (let ((load (operand-parse-load op)) (load-tn (operand-parse-load-tn op)) @@ -869,10 +880,11 @@ ,@(vop-parse-body parse)) ,@(saves)))))) -;;; Given a list of operand specifications as given to Define-VOP, return a -;;; list of Operand-Parse structures describing the fixed operands, and a -;;; single Operand-Parse describing any more operand. If we are inheriting a -;;; VOP, we default attributes to the inherited operand of the same name. +;;; Given a list of operand specifications as given to DEFINE-VOP, +;;; return a list of OPERAND-PARSE structures describing the fixed +;;; operands, and a single OPERAND-PARSE describing any more operand. +;;; If we are inheriting a VOP, we default attributes to the inherited +;;; operand of the same name. (defun parse-operands (parse specs kind) (declare (list specs) (type (member :argument :result) kind)) @@ -955,8 +967,8 @@ (error "cannot specify :LOAD-IF in a :MORE operand"))))) (values (the list (operands)) more)))) -;;; Parse a temporary specification, entering the Operand-Parse structures -;;; in the Parse structure. +;;; Parse a temporary specification, putting the OPERAND-PARSE +;;; structures in the PARSE structure. (defun parse-temporary (spec parse) (declare (list spec) (type vop-parse parse)) @@ -1019,7 +1031,8 @@ :key #'operand-parse-name)))))) (values)) -;;; Top-level parse function. Clobber Parse to represent the specified options. +;;; the top-level parse function: clobber PARSE to represent the +;;; specified options. (defun parse-define-vop (parse specs) (declare (type vop-parse parse) (list specs)) (dolist (spec specs) @@ -1085,8 +1098,13 @@ (setf (vop-parse-translate parse) (rest spec))) (:guard (setf (vop-parse-guard parse) (vop-spec-arg spec t))) + ;; FIXME: :LTN-POLICY would be a better name for this. It would + ;; probably be good to leave it unchanged for a while, though, + ;; at least until the first port to some other architecture, + ;; since the renaming would be a change to the interface between (:policy - (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies))) + (setf (vop-parse-ltn-policy parse) + (vop-spec-arg spec 'ltn-policy))) (:save-p (setf (vop-parse-save-p parse) (vop-spec-arg spec @@ -1095,16 +1113,16 @@ (error "unknown option specifier: ~S" (first spec))))) (values)) -;;;; make costs and restrictions +;;;; making costs and restrictions ;;; Given an operand, returns two values: -;;; 1. A SC-vector of the cost for the operand being in that SC, including both -;;; the costs for move functions and coercion VOPs. -;;; 2. A SC-vector holding the SC that we load into, for any SC that we can -;;; directly load from. +;;; 1. A SC-vector of the cost for the operand being in that SC, +;;; including both the costs for move functions and coercion VOPs. +;;; 2. A SC-vector holding the SC that we load into, for any SC +;;; that we can directly load from. ;;; -;;; In both vectors, unused entries are NIL. Load-P specifies the direction: -;;; if true, we are loading, if false we are saving. +;;; In both vectors, unused entries are NIL. LOAD-P specifies the +;;; direction: if true, we are loading, if false we are saving. (defun compute-loading-costs (op load-p) (declare (type operand-parse op)) (let ((scs (operand-parse-scs op)) @@ -1153,7 +1171,7 @@ (defparameter *no-loads* (make-array sc-number-limit :initial-element 't)) -;;; Pick off the case of operands with no restrictions. +;;; Pick off the case of operands with no restrictions. (defun compute-loading-costs-if-any (op load-p) (declare (type operand-parse op)) (if (operand-parse-scs op) @@ -1244,13 +1262,13 @@ (mapcar #'parse-operand-type specs))) ;;; Check the consistency of Op's Sc restrictions with the specified -;;; primitive-type restriction. :CONSTANT operands have already been filtered -;;; out, so only :OR and * restrictions are left. +;;; primitive-type restriction. :CONSTANT operands have already been +;;; filtered out, so only :OR and * restrictions are left. ;;; -;;; We check that every representation allowed by the type can be directly -;;; loaded into some SC in the restriction, and that the type allows every SC -;;; in the restriction. With *, we require that T satisfy the first test, and -;;; omit the second. +;;; We check that every representation allowed by the type can be +;;; directly loaded into some SC in the restriction, and that the type +;;; allows every SC in the restriction. With *, we require that T +;;; satisfy the first test, and omit the second. (defun check-operand-type-scs (parse op type load-p) (declare (type vop-parse parse) (type operand-parse op)) (let ((ptypes (if (eq type '*) (list 't) (rest type))) @@ -1350,11 +1368,11 @@ ;;;; function translation stuff -;;; Return forms to establish this VOP as a IR2 translation template for the -;;; :Translate functions specified in the VOP-Parse. We also set the -;;; Predicate attribute for each translated function when the VOP is -;;; conditional, causing IR1 conversion to ensure that a call to the translated -;;; is always used in a predicate position. +;;; Return forms to establish this VOP as a IR2 translation template +;;; for the :TRANSLATE functions specified in the VOP-Parse. We also +;;; set the Predicate attribute for each translated function when the +;;; VOP is conditional, causing IR1 conversion to ensure that a call +;;; to the translated is always used in a predicate position. (defun set-up-function-translation (parse n-template) (declare (type vop-parse parse)) (mapcar #'(lambda (name) @@ -1392,9 +1410,9 @@ types)) ;;; Return a list of forms to use as keyword args to Make-VOP-Info for -;;; setting up the template argument and result types. Here we make an initial -;;; dummy Template-Type, since it is awkward to compute the type until the -;;; template has been made. +;;; setting up the template argument and result types. Here we make an +;;; initial dummy Template-Type, since it is awkward to compute the +;;; type until the template has been made. (defun make-vop-info-types (parse) (let* ((more-args (vop-parse-more-args parse)) (all-args (specify-operand-types (vop-parse-arg-types parse) @@ -1427,12 +1445,13 @@ '((:generator-function . vop-info-generator-function)))) ;;; Something to help with inheriting VOP-Info slots. We return a -;;; keyword/value pair that can be passed to the constructor. Slot is the -;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse -;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If -;;; the Test form evaluates to true, then we return a form that selects the -;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise, -;;; we return the Form so that the slot is recomputed. +;;; keyword/value pair that can be passed to the constructor. SLOT is +;;; the keyword name of the slot, Parse is a form that evaluates to +;;; the VOP-Parse structure for the VOP inherited. If PARSE is NIL, +;;; then we do nothing. If the TEST form evaluates to true, then we +;;; return a form that selects the named slot from the VOP-Info +;;; structure corresponding to PARSE. Otherwise, we return the FORM so +;;; that the slot is recomputed. (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) @@ -1462,7 +1481,7 @@ `#'(lambda () ,(vop-parse-guard parse))) :note ',(vop-parse-note parse) :info-arg-count ,(length (vop-parse-info-args parse)) - :policy ',(vop-parse-policy parse) + :ltn-policy ',(vop-parse-ltn-policy parse) :save-p ',(vop-parse-save-p parse) :move-args ',(vop-parse-move-args parse) :effects (vop-attributes ,@(vop-parse-effects parse)) @@ -1476,9 +1495,10 @@ (make-generator-function parse))) :variant (list ,@variant)))) -;;; Parse the syntax into a VOP-Parse structure, and then expand into code -;;; that creates the appropriate VOP-Info structure at load time. We implement -;;; inheritance by copying the VOP-Parse structure for the inherited structure. +;;; Parse the syntax into a VOP-Parse structure, and then expand into +;;; code that creates the appropriate VOP-Info structure at load time. +;;; We implement inheritance by copying the VOP-Parse structure for +;;; the inherited structure. (def!macro define-vop ((name &optional inherits) &rest specs) #!+sb-doc "Define-VOP (Name [Inherits]) Spec* @@ -1633,10 +1653,10 @@ frame." (check-type name symbol) - (let* ((iparse (when inherits - (vop-parse-or-lose inherits))) + (let* ((inherited-parse (when inherits + (vop-parse-or-lose inherits))) (parse (if inherits - (copy-vop-parse iparse) + (copy-vop-parse inherited-parse) (make-vop-parse))) (n-res (gensym))) (setf (vop-parse-name parse) name) @@ -1650,7 +1670,7 @@ (setf (gethash ',name *backend-parsed-vops*) ',parse)) - (let ((,n-res ,(set-up-vop-info iparse parse))) + (let ((,n-res ,(set-up-vop-info inherited-parse parse))) (setf (gethash ',name *backend-template-names*) ,n-res) (setf (template-type ,n-res) (specifier-type (template-type-specifier ,n-res))) @@ -1660,13 +1680,14 @@ ;;;; emission macros ;;; Return code to make a list of VOP arguments or results, linked by -;;; TN-Ref-Across. The first value is code, the second value is LET* forms, -;;; and the third value is a variable that evaluates to the head of the list, -;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to -;;; TNs for the fixed operands. TN-Refs will be made for these operands -;;; according using the specified value of Write-P. More is an expression that -;;; evaluates to a list of TN-Refs that will be made the tail of the list. If -;;; it is constant NIL, then we don't bother to set the tail. +;;; TN-Ref-Across. The first value is code, the second value is LET* +;;; forms, and the third value is a variable that evaluates to the +;;; head of the list, or NIL if there are no operands. Fixed is a list +;;; of forms that evaluate to TNs for the fixed operands. TN-Refs will +;;; be made for these operands according using the specified value of +;;; Write-P. More is an expression that evaluates to a list of TN-Refs +;;; that will be made the tail of the list. If it is constant NIL, +;;; then we don't bother to set the tail. (defun make-operand-list (fixed more write-p) (collect ((forms) (binds)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 0c4b05c..b6e34c8 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -122,7 +122,7 @@ ;; called for, but it believes it has proven that the check won't ;; be done for policy reasons or because a safe implementation ;; will be used. In the latter case, LTN must ensure that a safe - ;; implementation *is* be used. + ;; implementation *is* used. ;; ;; :ERROR ;; There is a compile-time type error in some use of this @@ -960,14 +960,14 @@ (:constructor make-combination (fun)))) (defprinter (combination) (fun :prin1 (continuation-use fun)) - (args :prin1 (mapcar #'(lambda (x) - (if x - (continuation-use x) - "")) + (args :prin1 (mapcar (lambda (x) + (if x + (continuation-use x) + "")) args))) -;;; An MV-Combination is to Multiple-Value-Call as a Combination is to -;;; Funcall. This is used to implement all the multiple-value +;;; An MV-COMBINATION is to MULTIPLE-VALUE-CALL as a COMBINATION is to +;;; FUNCALL. This is used to implement all the multiple-value ;;; receiving forms. (defstruct (mv-combination (:include basic-combination) (:constructor make-mv-combination (fun)))) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 3cdcfa9..aa2bb64 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -71,9 +71,11 @@ ;; behavior, and should probably become the exact behavior. ;; Perhaps INHIBIT-NOTES? inhibit-warnings)) + #| (setf *policy-defaulting-qualities* '((interface-speed . speed) (interface-safety . safety))) + |# (setf *default-policy* (mapcar (lambda (name) ;; CMU CL didn't use 1 as the default for everything, @@ -134,10 +136,8 @@ (binds (mapcar (lambda (name) `(,name (policy-quality ,n-policy ',name))) used-qualities))) - (/show "in compile-time POLICY" expr binds) `(let* ((,n-policy (lexenv-policy ,(if node `(node-lexenv ,node) '*lexenv*))) ,@binds) - ;;(/show "in run-time POLICY" ,@used-qualities) ,expr))) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index b8246a0..859bb93 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -143,21 +143,21 @@ (values)) -;;; Called when we discover that the stack-top unknown-values continuation -;;; at the end of Block1 is different from that at the start of Block2 (its -;;; successor.) +;;; This is called when we discover that the stack-top unknown-values +;;; continuation at the end of BLOCK1 is different from that at the +;;; start of BLOCK2 (its successor). ;;; -;;; We insert a call to a funny function in a new cleanup block introduced -;;; between Block1 and Block2. Since control analysis and LTN have already -;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and -;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1 -;;; in the emit order. +;;; We insert a call to a funny function in a new cleanup block +;;; introduced between BLOCK1 and BLOCK2. Since control analysis and +;;; LTN have already run, we must do make an IR2 block, then do +;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new block. +;;; The new block is inserted after BLOCK1 in the emit order. ;;; -;;; If the control transfer between Block1 and Block2 represents a -;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then -;;; the cleanup code will never actually be executed. It doesn't seem to be -;;; worth the risk of trying to optimize this, since this rarely happens and -;;; wastes only space. +;;; If the control transfer between BLOCK1 and BLOCK2 represents a +;;; tail-recursive return (:DELETED IR2-continuation) or a non-local +;;; exit, then the cleanup code will never actually be executed. It +;;; doesn't seem to be worth the risk of trying to optimize this, +;;; since this rarely happens and wastes only space. (defun discard-unused-values (block1 block2) (declare (type cblock block1 block2)) (let* ((block1-stack (ir2-block-end-stack (block-info block1))) @@ -174,7 +174,7 @@ (2block (make-ir2-block block))) (setf (block-info block) 2block) (add-to-emit-order 2block (block-info block1)) - (ltn-analyze-block block))) + (ltn-analyze-belated-block block))) (values)) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 7fc2f6c..6e8f6fd 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -21,15 +21,15 @@ (deftype local-tn-vector () `(simple-vector ,local-tn-limit)) (deftype local-tn-bit-vector () `(simple-bit-vector ,local-tn-limit)) -;;; Type of an SC number. +;;; type of an SC number (deftype sc-number () `(integer 0 (,sc-number-limit))) -;;; Types for vectors indexed by SC numbers. +;;; types for vectors indexed by SC numbers (deftype sc-vector () `(simple-vector ,sc-number-limit)) (deftype sc-bit-vector () `(simple-bit-vector ,sc-number-limit)) -;;; The different policies we can use to determine the coding strategy. -(deftype policies () +;;; the different policies we can use to determine the coding strategy +(deftype ltn-policy () '(member :safe :small :fast :fast-safe)) ;;;; PRIMITIVE-TYPEs @@ -527,16 +527,15 @@ ;;; a known function. (def!struct (template (:constructor nil) #-sb-xc-host (:pure t)) - ;; The symbol name of this VOP. This is used when printing the VOP + ;; the symbol name of this VOP. This is used when printing the VOP ;; and is also used to provide a handle for definition and ;; translation. (name nil :type symbol) - ;; A Function-Type describing the arg/result type restrictions. We - ;; compute this from the Primitive-Type restrictions to make life - ;; easier for IR1 phases that need to anticipate LTN's template - ;; selection. + ;; the arg/result type restrictions. We compute this from the + ;; PRIMITIVE-TYPE restrictions to make life easier for IR1 phases + ;; that need to anticipate LTN's template selection. (type (required-argument) :type function-type) - ;; Lists of restrictions on the argument and result types. A + ;; lists of restrictions on the argument and result types. A ;; restriction may take several forms: ;; -- The restriction * is no restriction at all. ;; -- A restriction (:OR *) means that the operand @@ -549,13 +548,13 @@ ;; the type tested by the predicate, used when we want to represent ;; the type constraint as a Lisp function type. ;; - ;; If Result-Types is :Conditional, then this is an IF-xxx style + ;; If RESULT-TYPES is :CONDITIONAL, then this is an IF-FOO style ;; conditional that yeilds its result as a control transfer. The ;; emit function takes two info arguments: the target label and a ;; boolean flag indicating whether to negate the sense of the test. (arg-types nil :type list) (result-types nil :type (or list (member :conditional))) - ;; The primitive type restriction applied to each extra argument or + ;; the primitive type restriction applied to each extra argument or ;; result following the fixed operands. If NIL, no extra ;; args/results are allowed. Otherwise, either * or a (:OR ...) list ;; as described for the {ARG,RESULT}-TYPES. @@ -566,22 +565,22 @@ ;; conditionally compile for different target hardware ;; configuarations (e.g. FP hardware.) (guard nil :type (or function null)) - ;; The policy under which this template is the best translation. + ;; the policy under which this template is the best translation. ;; Note that LTN might use this template under other policies if it - ;; can't figure our anything better to do. - (policy (required-argument) :type policies) - ;; The base cost for this template, given optimistic assumptions + ;; can't figure out anything better to do. + (ltn-policy (required-argument) :type ltn-policy) + ;; the base cost for this template, given optimistic assumptions ;; such as no operand loading, etc. (cost (required-argument) :type index) - ;; If true, then a short noun-like phrase describing what this VOP - ;; "does", i.e. the implementation strategy. This is for use in - ;; efficiency notes. + ;; If true, then this is a short noun-like phrase describing what + ;; this VOP "does", i.e. the implementation strategy. This is for + ;; use in efficiency notes. (note nil :type (or string null)) ;; The number of trailing arguments to VOP or %PRIMITIVE that we ;; bundle into a list and pass into the emit function. This provides ;; a way to pass uninterpreted stuff directly to the code generator. (info-arg-count 0 :type index) - ;; A function that emits the VOPs for this template. Arguments: + ;; a function that emits the VOPs for this template. Arguments: ;; 1] Node for source context. ;; 2] IR2-Block that we place the VOP in. ;; 3] This structure. @@ -600,7 +599,7 @@ result-types (more-args-type :test more-args-type :prin1 more-args-type) (more-results-type :test more-results-type :prin1 more-results-type) - policy + ltn-policy cost (note :test note) (info-arg-count :test (not (zerop info-arg-count)))) @@ -611,8 +610,8 @@ (def!struct (vop-info (:include template) (:make-load-form-fun ignore-it)) - ;; Side-effects of this VOP and side-effects that affect the value - ;; of this VOP. + ;; side-effects of this VOP and side-effects that affect the value + ;; of this VOP (effects (required-argument) :type attributes) (affected (required-argument) :type attributes) ;; If true, causes special casing of TNs live after this VOP that @@ -627,7 +626,7 @@ ;; -- If :Compute-Only, just compute the save set, don't do any saving. ;; This is used to get the live variables for debug info. (save-p nil :type (member t nil :force-to-stack :compute-only)) - ;; Info for automatic emission of move-arg VOPs by representation + ;; info for automatic emission of move-arg VOPs by representation ;; selection. If NIL, then do nothing special. If non-null, then ;; there must be a more arg. Each more arg is moved to its passing ;; location using the appropriate representation-specific @@ -647,15 +646,15 @@ ;; :KNOWN-RETURN ;; If needed, the old NFP is computed using COMPUTE-OLD-NFP. (move-args nil :type (member nil :full-call :local-call :known-return)) - ;; A list of sc-vectors representing the loading costs of each fixed - ;; argument and result. + ;; a list of sc-vectors representing the loading costs of each fixed + ;; argument and result (arg-costs nil :type list) (result-costs nil :type list) - ;; If true, sc-vectors representing the loading costs for any more - ;; args and results. + ;; if true, SC-VECTORs representing the loading costs for any more + ;; args and results (more-arg-costs nil :type (or sc-vector null)) (more-result-costs nil :type (or sc-vector null)) - ;; Lists of sc-vectors mapping each SC to the SCs that we can load + ;; lists of SC-VECTORs mapping each SC to the SCs that we can load ;; into. If a SC is directly acceptable to the VOP, then the entry ;; is T. Otherwise, it is a list of the SC numbers of all the SCs ;; that we can load into. This list will be empty if there is no @@ -663,42 +662,32 @@ ;; operand SC restriction. (arg-load-scs nil :type list) (result-load-scs nil :type list) - ;; If true, a function that is called with the VOP to do operand + ;; if true, a function that is called with the VOP to do operand ;; targeting. This is done by modifiying the TN-Ref-Target slots in ;; the TN-Refs so that they point to other TN-Refs in the same VOP. (target-function nil :type (or null function)) - ;; A function that emits assembly code for a use of this VOP when it + ;; a function that emits assembly code for a use of this VOP when it ;; is called with the VOP structure. Null if this VOP has no ;; specified generator (i.e. it exists only to be inherited by other ;; VOPs.) (generator-function nil :type (or function null)) - ;; A list of things that are used to parameterize an inherited + ;; a list of things that are used to parameterize an inherited ;; generator. This allows the same generator function to be used for ;; a group of VOPs with similar implementations. (variant nil :type list) - ;; The number of arguments and results. Each regular arg/result + ;; the number of arguments and results. Each regular arg/result ;; counts as one, and all the more args/results together count as 1. (num-args 0 :type index) (num-results 0 :type index) - ;; Vector of the temporaries the vop needs. See emit-generic-vop in - ;; vmdef for information on how the temps are encoded. - ;; - ;; (The SB-XC-HOST conditionalization on the type is there because - ;; it's difficult to dump specialized arrays portably, so on the - ;; cross-compilation host we punt by using unspecialized arrays - ;; instead.) + ;; a vector of the temporaries the vop needs. See EMIT-GENERIC-VOP + ;; in vmdef for information on how the temps are encoded. (temps nil :type (or null (specializable-vector (unsigned-byte 16)))) - ;; The order all the refs for this vop should be put in. Each + ;; the order all the refs for this vop should be put in. Each ;; operand is assigned a number in the following ordering: args, ;; more-args, results, more-results, temps This vector represents ;; the order the operands should be put into in the next-ref link. - ;; - ;; (The SB-XC-HOST conditionalization on the type is there because - ;; it's difficult to dump specialized arrays portably, so on the - ;; cross-compilation host we punt by using unspecialized arrays - ;; instead.) (ref-ordering nil :type (or null (specializable-vector (unsigned-byte 8)))) - ;; Array of the various targets that should be done. Each element + ;; a vector of the various targets that should be done. Each element ;; encodes the source ref (shifted 8) and the dest ref index. (targets nil :type (or null (specializable-vector (unsigned-byte 16))))) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 9540892..f6cbab8 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -760,8 +760,6 @@ (inst and result #x0000ffff) (inst and temp #x0000ffff) (inst add result temp))) - - ;;;; binary conditional VOPs diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index a9b7b79..2666d4d 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -298,7 +298,7 @@ (:result-types single-float) (:generator 5 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fst (make-ea :dword :base object :index index :scale 1 :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -335,7 +335,7 @@ (:result-types single-float) (:generator 4 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fst (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -405,7 +405,7 @@ (:result-types double-float) (:generator 20 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fstd (make-ea :dword :base object :index index :scale 2 :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -442,7 +442,7 @@ (:result-types double-float) (:generator 19 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fstd (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -522,7 +522,7 @@ ;; temp = 3 * index (inst lea temp (make-ea :dword :base index :index index :scale 2)) (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (store-long-float (make-ea :dword :base object :index temp :scale 1 :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -559,7 +559,7 @@ (:result-types long-float) (:generator 19 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 + ;; Value is in ST0. (store-long-float (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -700,7 +700,7 @@ (let ((value-real (complex-single-reg-real-tn value)) (result-real (complex-single-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fst (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -802,7 +802,7 @@ (let ((value-real (complex-double-reg-real-tn value)) (result-real (complex-double-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fstd (make-ea :dword :base object :index index :scale 4 :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -852,7 +852,7 @@ (let ((value-real (complex-double-reg-real-tn value)) (result-real (complex-double-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0 + ;; Value is in ST0. (inst fstd (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -963,7 +963,7 @@ (let ((value-real (complex-long-reg-real-tn value)) (result-real (complex-long-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0 + ;; Value is in ST0. (store-long-float (make-ea :dword :base object :index temp :scale 2 :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes) @@ -1013,7 +1013,7 @@ (let ((value-real (complex-long-reg-real-tn value)) (result-real (complex-long-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0 + ;; Value is in ST0. (store-long-float (make-ea :dword :base object :disp (- (+ (* sb!vm:vector-data-offset @@ -1057,10 +1057,7 @@ (unless (location= value-imag result-imag) (inst fstd result-imag)) (inst fxch value-imag)))) - -;;;; dtc expanded and fixed the following: - ;;; unsigned-byte-8 (define-vop (data-vector-ref/simple-array-unsigned-byte-8) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 2168017..544c642 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -562,14 +562,6 @@ symbol))))) (error "~S is not a legal structure class name." symbol))) -(defun method-function-returning-nil (args next-methods) - (declare (ignore args next-methods)) - nil) - -(defun method-function-returning-t (args next-methods) - (declare (ignore args next-methods)) - t) - (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) (mlist (if (eq *boot-state* 'complete) @@ -577,7 +569,7 @@ (early-gf-methods gf)))) (unless mlist (unless (eq class *the-class-t*) - (let* ((default-method-function #'method-function-returning-nil) + (let* ((default-method-function #'constantly-nil) (default-method-initargs (list :function default-method-function)) (default-method (make-a-method 'standard-method @@ -589,7 +581,7 @@ (setf (method-function-get default-method-function :constant-value) nil) (add-method gf default-method))) - (let* ((class-method-function #'method-function-returning-t) + (let* ((class-method-function #'constantly-t) (class-method-initargs (list :function class-method-function)) (class-method (make-a-method 'standard-method diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index c2ee95e..2d1476b 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -40,21 +40,10 @@ ;;; FIXME: It's not clear that this adds value any more. Couldn't ;;; we just use EVAL-WHEN? (defun make-top-level-form (name times form) - (flet ((definition-name () - (if (and (listp name) - (memq (car name) - '(defmethod defclass class - method method-combination))) - (format nil "~A~{ ~S~}" - (capitalize-words (car name) ()) (cdr name)) - (format nil "~S" name)))) - ;; FIXME: It appears that we're just consing up a string and then - ;; throwing it away?! - (definition-name) - (if (or (member 'compile times) - (member ':compile-toplevel times)) - `(eval-when ,times ,form) - form))) + (if (or (member 'compile times) + (member ':compile-toplevel times)) + `(eval-when ,times ,form) + form)) (defun make-progn (&rest forms) (let ((progn-form nil)) @@ -162,13 +151,13 @@ (declare (special *initfunctions*)) (cond ((or (eq initform 't) (equal initform ''t)) - '(function true)) + '(function constantly-t)) ((or (eq initform 'nil) (equal initform ''nil)) - '(function false)) + '(function constantly-nil)) ((or (eql initform '0) (equal initform ''0)) - '(function zero)) + '(function constantly-0)) (t (let ((entry (assoc initform *initfunctions* :test #'equal))) (unless entry diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 6e89003..e1c976b 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -300,7 +300,7 @@ (slots nil)) ;;; Both of these operations "work" on structures, which allows the above -;;; weakening of std-instance-p. +;;; weakening of STD-INSTANCE-P. (defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x)) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 92f8ffc..5de7562 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -43,22 +43,23 @@ ;;; implementations, but I will leave it to the compiler to optimize ;;; into calls to them. ;;; -;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we should -;;; use those. POSQ and NEQ aren't defined in SBCL, and are used too often -;;; in PCL to make it appealing to hand expand all uses and then delete -;;; the macros, so they should be boosted up to SBCL to stand by MEMQ, -;;; ASSQ, and DELQ. +;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we +;;; should use those definitions. POSQ and NEQ aren't defined in SBCL, +;;; and are used too often in PCL to make it appealing to hand expand +;;; all uses and then delete the macros, so they should be boosted up +;;; to SB-INT to stand by MEMQ, ASSQ, and DELQ. (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro delq (item list) `(delete ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro neq (x y) `(not (eq ,x ,y))) - -;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and -;;; CONSTANTLY-0, and boost them up to SB-INT. -(defun true (&rest ignore) (declare (ignore ignore)) t) -(defun false (&rest ignore) (declare (ignore ignore)) nil) -(defun zero (&rest ignore) (declare (ignore ignore)) 0) +;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too. +(macrolet ((def-constantly-fun (name constant-expr) + `(setf (symbol-function ',name) + (constantly ,constant-expr)))) + (def-constantly-fun constantly-t t) + (def-constantly-fun constantly-nil nil) + (def-constantly-fun constantly-0 0)) ;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as ;;; it does in zetalisp. I should have just lifted it from there but I @@ -164,45 +165,15 @@ (setq ,var (pop .dolist-carefully.)) ,@body) (,improper-list-handler))))) - -;;; FIXME: Do we really need this? It seems to be used only -;;; for class names. Why not just the default ALL-CAPS? -(defun capitalize-words (string &optional (dashes-p t)) - (let ((string (copy-seq (string string)))) - (declare (string string)) - (do* ((flag t flag) - (length (length string) length) - (char nil char) - (i 0 (+ i 1))) - ((= i length) string) - (setq char (elt string i)) - (cond ((both-case-p char) - (if flag - (and (setq flag (lower-case-p char)) - (setf (elt string i) (char-upcase char))) - (and (not flag) (setf (elt string i) (char-downcase char)))) - (setq flag nil)) - ((char-equal char #\-) - (setq flag t) - (unless dashes-p (setf (elt string i) #\space))) - (t (setq flag nil)))))) ;;;; FIND-CLASS ;;;; -;;;; This is documented in the CLOS specification. -;;;; KLUDGE: Except that SBCL deviates from the spec by having CL:FIND-CLASS -;;;; distinct from PCL:FIND-CLASS, alas. -- WHN 19991203 +;;;; This is documented in the CLOS specification. FIXME: Except that +;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from +;;;; PCL:FIND-CLASS, alas. (defvar *find-class* (make-hash-table :test 'eq)) -(defun function-returning-nil (x) - (declare (ignore x)) - nil) - -(defun function-returning-t (x) - (declare (ignore x)) - t) - (defmacro find-class-cell-class (cell) `(car ,cell)) @@ -214,7 +185,7 @@ (defmacro make-find-class-cell (class-name) (declare (ignore class-name)) - '(list* nil #'function-returning-nil nil)) + '(list* nil #'constantly-nil nil)) (defun find-class-cell (symbol &optional dont-create-p) (or (gethash symbol *find-class*) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 071261b..67c2c0d 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -346,7 +346,7 @@ class)) (defmethod class-predicate-name ((class t)) - 'function-returning-nil) + 'constantly-nil) (defun ensure-class-values (class args) (let* ((initargs (copy-list args)) diff --git a/version.lisp-expr b/version.lisp-expr index 494ef3e..3ab67ce 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.14" +"0.6.9.16" -- 1.7.10.4