X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fassem.lisp;h=3dd4a959b57771f6155fc61079cf6c33f418bdfa;hb=04bc82d1f1c692029c9821acea9dbf295e7628fd;hp=5634b9b1ab474bfb4b7289122be1d020fbd2297a;hpb=0f726536ee7ec85f3a9483a26d08bd7d1cd96750;p=sbcl.git diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 5634b9b..3dd4a95 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -27,7 +27,7 @@ ;;; This structure holds the state of the assembler. (defstruct (segment (:copier nil)) ;; the name of this segment (for debugging output and stuff) - (name "unnamed" :type simple-base-string) + (name "unnamed" :type simple-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. @@ -156,9 +156,7 @@ ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether. (defmacro with-modified-segment-index-and-posn ((segment index posn) &body body) - (let ((n-segment (gensym "SEGMENT")) - (old-index (gensym "OLD-INDEX-")) - (old-posn (gensym "OLD-POSN-"))) + (with-unique-names (n-segment old-index old-posn) `(let* ((,n-segment ,segment) (,old-index (segment-current-index ,n-segment)) (,old-posn (segment-current-posn ,n-segment))) @@ -172,7 +170,7 @@ ;;;; structures/types used by the scheduler -(sb!c:def-boolean-attribute instruction +(!def-boolean-attribute instruction ;; This attribute is set if the scheduler can freely flush this ;; instruction if it thinks it is not needed. Examples are NOP and ;; instructions that have no side effect not described by the @@ -185,9 +183,9 @@ ;; This attribute indicates that this ``instruction'' can be ;; variable length, and therefore had better never be used in a ;; branch delay slot. - var-length) + variable-length) -(defstruct (instruction +(def!struct (instruction (:include sset-element) (:conc-name inst-) (:constructor make-instruction (number emitter attributes delay)) @@ -360,7 +358,7 @@ (when countdown (decf countdown) (aver (not (instruction-attributep (inst-attributes inst) - var-length)))) + variable-length)))) (cond ((instruction-attributep (inst-attributes inst) branch) (unless countdown (setf countdown (inst-delay inst))) @@ -475,7 +473,7 @@ ;; nothing to do, then emit a nop. ### Note: despite the ;; fact that this is a loop, it really won't work for ;; repetitions other then zero and one. For example, if -p ;; the branch has two dependents and one of them dpends on + ;; the branch has two dependents and one of them dpends on ;; the other, then the stuff that grabs a dependent could ;; easily grab the wrong one. But I don't feel like fixing ;; this because it doesn't matter for any of the @@ -573,7 +571,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) - var-length)) + variable-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. @@ -672,16 +670,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) - (:copier nil)) +(def!struct (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 ()) - (:copier nil)) +(def!struct (label (:include annotation) + (:constructor gen-label ()) + (:copier nil)) ;; (doesn't need any additional information beyond what is in the ;; annotation structure) ) @@ -692,11 +690,11 @@ p ;; the branch has two dependents and one of them dpends on (format stream "L~D" (sb!c:label-id label)))) ;;; a constraint on how the output stream must be aligned -(defstruct (alignment-note (:include annotation) - (:conc-name alignment-) - (:predicate alignment-p) - (:constructor make-alignment (bits size fill-byte)) - (:copier nil)) +(def!struct (alignment-note (:include annotation) + (:conc-name alignment-) + (:predicate alignment-p) + (: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 @@ -706,9 +704,9 @@ p ;; the branch has two dependents and one of them dpends on ;;; 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 fun)) - (:copier nil)) +(def!struct (back-patch (:include annotation) + (:constructor make-back-patch (size fun)) + (:copier nil)) ;; the area affected by this back-patch (size 0 :type index :read-only t) ;; the function to use to generate the real data @@ -718,10 +716,10 @@ p ;; the branch has two dependents and one of them dpends on ;;; amount of stuff output depends on label positions, etc. ;;; BACK-PATCHes can't change their mind about how much stuff to emit, ;;; but CHOOSERs can. -(defstruct (chooser (:include annotation) - (:constructor make-chooser - (size alignment maybe-shrink worst-case-fun)) - (:copier nil)) +(def!struct (chooser (:include annotation) + (:constructor make-chooser + (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 :read-only t) @@ -737,9 +735,9 @@ p ;; the branch has two dependents and one of them dpends on ;;; 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)) - (:copier nil)) +(def!struct (filler (:include annotation) + (:constructor make-filler (bytes)) + (:copier nil)) ;; the number of bytes of filler here (bytes 0 :type index)) @@ -770,7 +768,7 @@ p ;; the branch has two dependents and one of them dpends on (declare (type segment segment) (type annotation note)) (when (annotation-posn note) - (error "attempt to emit ~S a second time")) + (error "attempt to emit ~S a second time" note)) (setf (annotation-posn note) (segment-current-posn segment)) (setf (annotation-index note) (segment-current-index segment)) (let ((last (segment-last-annotation segment)) @@ -955,7 +953,7 @@ p ;; the branch has two dependents and one of them dpends on (when (< (find-alignment additional-delta) (chooser-alignment note)) (error "~S shrunk by ~W bytes, but claimed that it ~ - preserves ~W bits of alignment." + preserves ~W bits of alignment." note additional-delta (chooser-alignment note))) (incf delta additional-delta) (emit-filler segment additional-delta)) @@ -997,7 +995,7 @@ p ;; the branch has two dependents and one of them dpends on (additional-delta (- old-size size))) (when (minusp additional-delta) (error "Alignment ~S needs more space now? It was ~W, ~ - and is ~W now." + and is ~W now." note old-size size)) (when (plusp additional-delta) (emit-filler segment additional-delta) @@ -1125,7 +1123,7 @@ p ;; the branch has two dependents and one of them dpends on ;;; FIXME: The way this macro uses MACROEXPAND internally breaks my ;;; old assumptions about macros which are needed both in the host and ;;; the target. (This is more or less the same way that PUSH-IN, -;;; DELETEF-IN, and DEF-BOOLEAN-ATTRIBUTE break my old assumptions, +;;; DELETEF-IN, and !DEF-BOOLEAN-ATTRIBUTE break my old assumptions, ;;; except that they used GET-SETF-EXPANSION instead of MACROEXPAND to ;;; do the dirty deed.) The quick and dirty "solution" here is the ;;; same as there: use cut and paste to duplicate the defmacro in a @@ -1165,16 +1163,24 @@ p ;; the branch has two dependents and one of them dpends on ,@(mapcar (lambda (name) `(,name (gen-label))) new-labels)) - (declare (ignorable ,vop-var ,seg-var)) + (declare (ignorable ,vop-var ,seg-var) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (disable-package-locks %%current-segment%% %%current-vop%%)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host. + ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%% %%current-vop%%)) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(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) &body body @@ -1211,13 +1217,13 @@ p ;; the branch has two dependents and one of them dpends on (declare (ignorable ,vop-var ,seg-var)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) + body))))))) (defmacro inst (&whole whole instruction &rest args &environment env) #!+sb-doc @@ -1272,8 +1278,7 @@ p ;; the branch has two dependents and one of them dpends on (setf (segment-postits segment) (segment-postits other-segment)) (dolist (postit postits) (emit-back-patch segment 0 postit))) - #!-x86 (emit-alignment segment nil max-alignment) - #!+x86 (emit-alignment segment nil max-alignment #x90) + (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90) (let ((segment-current-index-0 (segment-current-index segment)) (segment-current-posn-0 (segment-current-posn segment))) (incf (segment-current-index segment) @@ -1332,6 +1337,7 @@ p ;; the branch has two dependents and one of them dpends on ;;; calling FUNCTION once on the entire compacted segment buffer. -- ;;; WHN 19990322 (defun on-segment-contents-vectorly (segment function) + (declare (type function function)) (let ((buffer (segment-buffer segment)) (i0 0)) (flet ((frob (i0 i1) @@ -1381,7 +1387,7 @@ p ;; the branch has two dependents and one of them dpends on (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr)))) (when (ldb-test (byte byte-size byte-posn) overall-mask) (error "The byte spec ~S either overlaps another byte spec, or ~ - extends past the end." + extends past the end." byte-spec-expr)) (setf (ldb byte-spec overall-mask) -1) (arg-names arg) @@ -1561,7 +1567,7 @@ p ;; the branch has two dependents and one of them dpends on (push (eval `(list (multiple-value-list ,(sb!disassem:gen-printer-def-forms-def-form name - (format nil "~A[~A]" name args) + (format nil "~@:(~A[~A]~)" name args) (cdr option-spec))))) pdefs)) (:printer-list @@ -1574,7 +1580,7 @@ p ;; the branch has two dependents and one of them dpends on `(multiple-value-list ,(sb!disassem:gen-printer-def-forms-def-form ',name - (format nil "~A[~A]" ',name printer) + (format nil "~@:(~A[~A]~)" ',name printer) printer nil))) ,(cadr option-spec))))) @@ -1638,10 +1644,19 @@ p ;; the branch has two dependents and one of them dpends on ,@(when decls `((declare ,@decls))) (let ((,postits (segment-postits ,segment-name))) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (declare (disable-package-locks %%current-segment%%)) (setf (segment-postits ,segment-name) nil) (macrolet ((%%current-segment%% () (error "You can't use INST without an ~ - ASSEMBLE inside emitters."))) + ASSEMBLE inside emitters."))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host + ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%% + ;; declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%%)) ,@emitter)) (values)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -1653,8 +1668,7 @@ p ;; the branch has two dependents and one of them dpends on (append ,@(extract-nths 0 'list pdefs))))))))) (defmacro define-instruction-macro (name lambda-list &body body) - (let ((whole (gensym "WHOLE-")) - (env (gensym "ENV-"))) + (with-unique-names (whole env) (multiple-value-bind (body local-defs) (sb!kernel:parse-defmacro lambda-list whole