diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp index 67fe7ac0e19bd85a51d54e30cbc7627d74eb6eeb..6eaf533ae73e241b342e2abd972b6f3b0767684c 100644 --- a/compiler/new-assem.lisp +++ b/compiler/new-assem.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.1 1992/05/18 17:56:10 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.2 1992/05/28 23:40:49 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,7 @@ ;;; (in-package :new-assem) -(export '(emit-byte emit-skip emit-back-patch emit-chooser +(export '(emit-byte emit-skip emit-back-patch emit-chooser emit-postit define-emitter define-instruction define-instruction-macro def-assembler-params @@ -154,6 +154,9 @@ ;; ;; *** State used by the scheduler during instruction queueing. ;; + ;; List of postit's. These are accumulated between instructions. + (postits nil :type list) + ;; ;; A-lists mapping locations to the instruction that reads them and ;; instructions that write them. If maintaining these as a-lists is ;; too expensive (consing, time, or whatever) we could represent this @@ -859,14 +862,18 @@ (setf (segment-block-end segment) (system:int-sap 0)) (ext:undefined-value)) -;;; EMIT-LABEL -- internal. +;;; %EMIT-LABEL -- internal. ;;; ;;; EMIT-LABEL (the interface) basically just expands into this, supplying -;;; the segment. +;;; the segment and vop. ;;; (defun %emit-label (segment vop label) (when (segment-run-scheduler segment) (schedule-pending-instructions segment)) + (let ((postits (segment-postits segment))) + (setf (segment-postits segment) nil) + (dolist (postit postits) + (emit-back-patch segment 0 postit))) (let ((hook (segment-inst-hook segment))) (when hook (funcall hook segment vop :label label))) @@ -925,6 +932,16 @@ (when (logbitp i offset) (return i)))) +;;; EMIT-POSTIT -- Internal. +;;; +;;; Emit a postit. The function will be called as a back-patch with the +;;; position the following instruction is finally emitted. Postits do not +;;; interfere at all with scheduling. +;;; +(defun %emit-postit (segment function) + (push function (segment-postits segment)) + (ext:undefined-value)) + ;;;; Output compression/position assignment stuff @@ -1173,6 +1190,11 @@ "Emit LABEL at this location in the current segment." `(%emit-label *current-segment* *current-vop* ,label)) +;;; EMIT-POSTIT -- interface. +;;; +(defmacro emit-postit (function) + `(%emit-postit *current-segment* ,function)) + ;;; ALIGN -- interface. ;;; (defmacro align (bits) @@ -1194,6 +1216,12 @@ (defun append-segment (segment other-segment) "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT for anything after this." + (when (segment-run-scheduler segment) + (schedule-pending-instructions segment)) + (let ((postits (segment-postits segment))) + (setf (segment-postits segment) (segment-postits other-segment)) + (dolist (postit postits) + (emit-back-patch segment 0 postit))) (emit-alignment segment nil max-alignment) (let ((offset-in-last-block (rem (segment-current-index segment) output-block-size))) @@ -1235,6 +1263,10 @@ covered by this segment." (when (segment-run-scheduler segment) (schedule-pending-instructions segment)) + (let ((postits (segment-postits segment))) + (setf (segment-postits segment) nil) + (dolist (postit postits) + (emit-back-patch segment 0 postit))) (setf (segment-final-index segment) (segment-current-index segment)) (setf (segment-final-posn segment) (segment-current-posn segment)) (setf (segment-inst-hook segment) nil) @@ -1453,6 +1485,7 @@ (defmacro define-instruction (name lambda-list &rest options) (let* ((sym-name (symbol-name name)) (defun-name (ext:symbolicate sym-name "-INST-EMITTER")) + (postits (gensym "POSTITS-")) (emitter nil) (decls nil) (attributes nil) @@ -1501,6 +1534,9 @@ (funcall hook ,segment-name ,vop-name ,sym-name ,arg-reconstructor))) emitter) + (push `(dolist (postit ,postits) + (emit-back-patch ,segment-name 0 postit)) + emitter) (when (assem-params-scheduler-p (c:backend-assembler-params c:*target-backend*)) (if pinned @@ -1526,8 +1562,11 @@ (defun ,defun-name ,new-lambda-list ,@(when decls `((declare ,@decls))) - (symbol-macrolet ((*current-segment* ,segment-name)) - ,@emitter) + (let ((,postits (segment-postits ,segment-name))) + (setf (segment-postits ,segment-name) nil) + (symbol-macrolet ((*current-segment* ,segment-name) + (*current-vop* ,vop-name)) + ,@emitter)) (ext:undefined-value)) (eval-when (compile load eval) (%define-instruction ,sym-name ',defun-name))))))