X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fassem.lisp;h=3033cb44f07972efe84ec73b8ae862b921b0dec9;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=83c957c4f88430dd7119cb2aaf658948162f3873;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 83c957c..3033cb4 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -25,9 +25,9 @@ ;;;; the SEGMENT structure ;;; This structure holds the state of the assembler. -(defstruct segment +(defstruct (segment (:copier nil)) ;; the name of this segment (for debugging output and stuff) - (name "Unnamed" :type simple-base-string) + (name "unnamed" :type simple-base-string) ;; Ordinarily this is a vector where instructions are written. If ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the ;; vector can be replaced by NIL. @@ -91,7 +91,7 @@ ;; have to be emitted at a specific place (e.g. one slot before the ;; end of the block). (queued-branches nil :type list) - ;; *** state used by the scheduler during instruction scheduling. + ;; *** state used by the scheduler during instruction scheduling ;; ;; the instructions who would have had a read dependent removed if ;; it were not for a delay slot. This is a list of lists. Each @@ -139,17 +139,18 @@ ;; how many instructions follow the branch. branch ;; This attribute indicates that this ``instruction'' can be - ;; variable length, and therefore better never be used in a branch - ;; delay slot. - variable-length) + ;; variable length, and therefore had better never be used in a + ;; branch delay slot. + var-length) (defstruct (instruction (:include sset-element) (:conc-name inst-) - (:constructor make-instruction (number emitter attributes delay))) + (:constructor make-instruction (number emitter attributes delay)) + (:copier nil)) ;; The function to envoke to actually emit this instruction. Gets called ;; with the segment as its one argument. - (emitter (required-argument) :type (or null function)) + (emitter (missing-arg) :type (or null function)) ;; The attributes of this instruction. (attributes (instruction-attributes) :type sb!c:attributes) ;; Number of instructions or cycles of delay before additional @@ -191,7 +192,7 @@ name) '))) (when (inst-depth inst) - (format stream ", depth=~D" (inst-depth inst))))) + (format stream ", depth=~W" (inst-depth inst))))) #!+sb-show-assem (defun reset-inst-ids () @@ -229,7 +230,7 @@ (multiple-value-bind (loc-num size) (sb!c:location-number read) #!+sb-show-assem (format *trace-output* - "~&~S reads ~S[~D for ~D]~%" + "~&~S reads ~S[~W for ~W]~%" inst read loc-num size) (when loc-num ;; Iterate over all the locations for this TN. @@ -266,7 +267,7 @@ (multiple-value-bind (loc-num size) (sb!c:location-number write) #!+sb-show-assem (format *trace-output* - "~&~S writes ~S[~D for ~D]~%" + "~&~S writes ~S[~W for ~W]~%" inst write loc-num size) (when loc-num ;; Iterate over all the locations for this TN. @@ -310,12 +311,12 @@ (inst-write-dependencies inst)) (writes write)) (writes))) - (assert (segment-run-scheduler segment)) + (aver (segment-run-scheduler segment)) (let ((countdown (segment-branch-countdown segment))) (when countdown (decf countdown) - (assert (not (instruction-attributep (inst-attributes inst) - variable-length)))) + (aver (not (instruction-attributep (inst-attributes inst) + var-length)))) (cond ((instruction-attributep (inst-attributes inst) branch) (unless countdown (setf countdown (inst-delay inst))) @@ -335,7 +336,7 @@ ;;; instructions would sit there until the scheduler was turned back ;;; on, and emitted in the wrong place). (defun schedule-pending-instructions (segment) - (assert (segment-run-scheduler segment)) + (aver (segment-run-scheduler segment)) ;; Quick blow-out if nothing to do. (when (and (sset-empty (segment-emittable-insts-sset segment)) @@ -528,7 +529,7 @@ p ;; the branch has two dependents and one of them dpends on (let ((inst (car remaining))) (unless (and delay-slot-p (instruction-attributep (inst-attributes inst) - variable-length)) + var-length)) ;; We've got us a live one here. Go for it. #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst) ;; Delete it from the list of insts. @@ -564,8 +565,8 @@ p ;; the branch has two dependents and one of them dpends on ;;; remove this instruction from their dependents list. If we were the ;;; last dependent, then that dependency can be emitted now. (defun note-resolved-dependencies (segment inst) - (assert (sset-empty (inst-read-dependents inst))) - (assert (sset-empty (inst-write-dependents inst))) + (aver (sset-empty (inst-read-dependents inst))) + (aver (sset-empty (inst-write-dependents inst))) (do-sset-elements (dep (inst-write-dependencies inst)) ;; These are the instructions who have to be completed before our ;; write fires. Doesn't matter how far before, just before. @@ -627,14 +628,16 @@ p ;; the branch has two dependents and one of them dpends on ;;;; structure used during output emission ;;; common supertype for all the different kinds of annotations -(defstruct (annotation (:constructor nil)) +(defstruct (annotation (:constructor nil) + (:copier nil)) ;; Where in the raw output stream was this annotation emitted. (index 0 :type index) ;; What position does that correspond to. (posn nil :type (or index null))) (defstruct (label (:include annotation) - (:constructor gen-label ())) + (:constructor gen-label ()) + (:copier nil)) ;; (doesn't need any additional information beyond what is in the ;; annotation structure) ) @@ -649,22 +652,24 @@ p ;; the branch has two dependents and one of them dpends on (:include annotation) (:conc-name alignment-) (:predicate alignment-p) - (:constructor make-alignment (bits size fill-byte))) - ;; The minimum number of low-order bits that must be zero. + (:constructor make-alignment (bits size fill-byte)) + (:copier nil)) + ;; the minimum number of low-order bits that must be zero (bits 0 :type alignment) - ;; The amount of filler we are assuming this alignment op will take. + ;; the amount of filler we are assuming this alignment op will take (size 0 :type (integer 0 #.(1- (ash 1 max-alignment)))) - ;; The byte used as filling. + ;; the byte used as filling (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits)))) ;;; a reference to someplace that needs to be back-patched when ;;; we actually know what label positions, etc. are (defstruct (back-patch (:include annotation) - (:constructor make-back-patch (size function))) - ;; The area effected by this back-patch. + (:constructor make-back-patch (size function)) + (:copier nil)) + ;; the area effected by this back-patch (size 0 :type index) - ;; The function to use to generate the real data + ;; the function to use to generate the real data (function nil :type function)) ;;; This is similar to a BACK-PATCH, but also an indication that the @@ -674,41 +679,37 @@ p ;; the branch has two dependents and one of them dpends on (defstruct (chooser (:include annotation) (:constructor make-chooser - (size alignment maybe-shrink worst-case-fun))) - ;; the worst case size for this chooser. There is this much space allocated - ;; in the output buffer. + (size alignment maybe-shrink worst-case-fun)) + (:copier nil)) + ;; the worst case size for this chooser. There is this much space + ;; allocated in the output buffer. (size 0 :type index) ;; the worst case alignment this chooser is guaranteed to preserve (alignment 0 :type alignment) - ;; the function to call to determine of we can use a shorter sequence. It - ;; returns NIL if nothing shorter can be used, or emits that sequence and - ;; returns T. + ;; the function to call to determine of we can use a shorter + ;; sequence. It returns NIL if nothing shorter can be used, or emits + ;; that sequence and returns T. (maybe-shrink nil :type function) - ;; the function to call to generate the worst case sequence. This is used - ;; when nothing else can be condensed. + ;; the function to call to generate the worst case sequence. This is + ;; used when nothing else can be condensed. (worst-case-fun nil :type function)) -;;; This is used internally when we figure out a chooser or alignment doesn't -;;; really need as much space as we initially gave it. +;;; This is used internally when we figure out a chooser or alignment +;;; doesn't really need as much space as we initially gave it. (defstruct (filler (:include annotation) - (:constructor make-filler (bytes))) + (:constructor make-filler (bytes)) + (:copier nil)) ;; the number of bytes of filler here (bytes 0 :type index)) ;;;; output functions -;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if necessary. +;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if +;;; necessary. (defun emit-byte (segment byte) (declare (type segment segment)) - ;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's - ;; inspired decision to treat DECLARE as ASSERT by default has not - ;; been copied by other compilers, and this code runs in the - ;; cross-compilation host Common Lisp, not just CMU CL, and (2) - ;; classic CMU CL allowed more things here than this, and I haven't - ;; tried to proof-read all the calls to EMIT-BYTE to ensure that - ;; they're passing appropriate. -- WHN 19990323 - (check-type byte possibly-signed-assembly-unit) + (declare (type possibly-signed-assembly-unit byte)) (vector-push-extend (logand byte assembly-unit-mask) (segment-buffer segment)) (incf (segment-current-posn segment)) @@ -845,7 +846,7 @@ p ;; the branch has two dependents and one of them dpends on (emit-skip segment (- (ash 1 alignment) slop) fill-byte))) (let ((size (logand (1- (ash 1 bits)) (lognot (1- (ash 1 alignment)))))) - (assert (> size 0)) + (aver (> size 0)) (emit-annotation segment (make-alignment bits size fill-byte)) (emit-skip segment size fill-byte)) (setf (segment-alignment segment) bits) @@ -907,13 +908,13 @@ p ;; the branch has two dependents and one of them dpends on (chooser-index note))) (old-size (chooser-size note))) (when (> new-size old-size) - (error "~S emitted ~D bytes, but claimed its max was ~D." + (error "~S emitted ~W bytes, but claimed its max was ~W." note new-size old-size)) (let ((additional-delta (- old-size new-size))) (when (< (find-alignment additional-delta) (chooser-alignment note)) - (error "~S shrunk by ~D bytes, but claimed that it ~ - preserve ~D bits of alignment." + (error "~S shrunk by ~W bytes, but claimed that it ~ + preserves ~W bits of alignment." note additional-delta (chooser-alignment note))) (incf delta additional-delta) (emit-filler segment additional-delta)) @@ -926,7 +927,7 @@ p ;; the branch has two dependents and one of them dpends on ;; The chooser passed on shrinking. Make sure it didn't emit ;; anything. (unless (= (segment-current-index segment) (chooser-index note)) - (error "Chooser ~S passed, but not before emitting ~D bytes." + (error "Chooser ~S passed, but not before emitting ~W bytes." note (- (segment-current-index segment) (chooser-index note)))) @@ -954,8 +955,8 @@ p ;; the branch has two dependents and one of them dpends on (old-size (alignment-size note)) (additional-delta (- old-size size))) (when (minusp additional-delta) - (error "Alignment ~S needs more space now? It was ~D, ~ - and is ~D now." + (error "Alignment ~S needs more space now? It was ~W, ~ + and is ~W now." note old-size size)) (when (plusp additional-delta) (emit-filler segment additional-delta) @@ -990,7 +991,7 @@ p ;; the branch has two dependents and one of them dpends on (size (- new-posn posn)) (old-size (alignment-size note)) (additional-delta (- old-size size))) - (assert (<= 0 size old-size)) + (aver (<= 0 size old-size)) (unless (zerop additional-delta) (setf (segment-last-annotation segment) prev) (incf delta additional-delta) @@ -1026,7 +1027,7 @@ p ;; the branch has two dependents and one of them dpends on (funcall function segment posn) (let ((new-size (- (segment-current-index segment) index))) (unless (= new-size old-size) - (error "~S emitted ~D bytes, but claimed it was ~D." + (error "~S emitted ~W bytes, but claimed it was ~W." note new-size old-size))) (let ((tail (segment-last-annotation segment))) (if tail @@ -1109,17 +1110,17 @@ p ;; the branch has two dependents and one of them dpends on `((**current-segment** ,seg-var))) ,@(when vop `((**current-vop** ,vop-var))) - ,@(mapcar #'(lambda (name) - `(,name (gen-label))) + ,@(mapcar (lambda (name) + `(,name (gen-label))) new-labels)) (symbol-macrolet ((**current-segment** ,seg-var) (**current-vop** ,vop-var) ,@(when (or inherited-labels nested-labels) `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar #'(lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) body)))))) #+sb-xc-host (sb!xc:defmacro assemble ((&optional segment vop &key labels) @@ -1151,17 +1152,17 @@ p ;; the branch has two dependents and one of them dpends on `((**current-segment** ,seg-var))) ,@(when vop `((**current-vop** ,vop-var))) - ,@(mapcar #'(lambda (name) - `(,name (gen-label))) + ,@(mapcar (lambda (name) + `(,name (gen-label))) new-labels)) (symbol-macrolet ((**current-segment** ,seg-var) (**current-vop** ,vop-var) ,@(when (or inherited-labels nested-labels) `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar #'(lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) body)))))) (defmacro inst (&whole whole instruction &rest args &environment env) @@ -1315,7 +1316,7 @@ p ;; the branch has two dependents and one of them dpends on (num-bytes (multiple-value-bind (quo rem) (truncate total-bits assembly-unit-bits) (unless (zerop rem) - (error "~D isn't an even multiple of ~D." + (error "~W isn't an even multiple of ~W." total-bits assembly-unit-bits)) quo)) (bytes (make-array num-bytes :initial-element nil)) @@ -1379,7 +1380,7 @@ p ;; the branch has two dependents and one of them dpends on (let ((forms nil)) (dotimes (i num-bytes) (let ((pieces (svref bytes i))) - (assert pieces) + (aver pieces) (push `(emit-byte ,segment-arg ,(if (cdr pieces) `(logior ,@pieces) @@ -1403,7 +1404,7 @@ p ;; the branch has two dependents and one of them dpends on (when lambda-list (let ((param (car lambda-list))) (cond - ((member param lambda-list-keywords) + ((member param sb!xc:lambda-list-keywords) (new-lambda-list param) (grovel param (cdr lambda-list))) (t @@ -1437,8 +1438,7 @@ p ;; the branch has two dependents and one of them dpends on (multiple-value-bind (key var) (if (consp name) (values (first name) (second name)) - (values (intern (symbol-name name) :keyword) - name)) + (values (keywordicate name) name)) `(append (and ,supplied-p (list ',key ,var)) ,(grovel state (cdr lambda-list)))))) (&rest @@ -1452,11 +1452,11 @@ p ;; the branch has two dependents and one of them dpends on reconstructor)))))) (defun extract-nths (index glue list-of-lists-of-lists) - (mapcar #'(lambda (list-of-lists) - (cons glue - (mapcar #'(lambda (list) - (nth index list)) - list-of-lists))) + (mapcar (lambda (list-of-lists) + (cons glue + (mapcar (lambda (list) + (nth index list)) + list-of-lists))) list-of-lists-of-lists)) (defmacro define-instruction (name lambda-list &rest options) @@ -1504,9 +1504,11 @@ p ;; the branch has two dependents and one of them dpends on (error "You can only specify :VOP-VAR once per instruction.") (setf vop-var (car args)))) (:printer + (sb!int:/noshow "uniquifying :PRINTER with" args) (push (eval `(list (multiple-value-list ,(sb!disassem:gen-printer-def-forms-def-form name + (format nil "~A[~A]" name args) (cdr option-spec))))) pdefs)) (:printer-list @@ -1515,10 +1517,13 @@ p ;; the branch has two dependents and one of them dpends on (push (eval `(eval - `(list ,@(mapcar #'(lambda (printer) - `(multiple-value-list - ,(sb!disassem:gen-printer-def-forms-def-form - ',name printer nil))) + `(list ,@(mapcar (lambda (printer) + `(multiple-value-list + ,(sb!disassem:gen-printer-def-forms-def-form + ',name + (format nil "~A[~A]" ',name printer) + printer + nil))) ,(cadr option-spec))))) pdefs)) (t @@ -1619,10 +1624,10 @@ p ;; the branch has two dependents and one of them dpends on :environment env) `(eval-when (:compile-toplevel :load-toplevel :execute) (%define-instruction ,(symbol-name name) - #'(lambda (,whole ,env) - ,@local-defs - (block ,name - ,body))))))) + (lambda (,whole ,env) + ,@local-defs + (block ,name + ,body))))))) (defun %define-instruction (name defun) (setf (gethash name *assem-instructions*) defun)