Skip to content
Snippets Groups Projects
Commit 1f61eea3 authored by wlott's avatar wlott
Browse files

Implemented EMIT-POSTIT, which is needed by NOTE-NEXT-INSTRUCTION.

parent 2e1000e0
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -17,7 +17,7 @@
;;; ;;;
(in-package :new-assem) (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 define-emitter define-instruction define-instruction-macro
def-assembler-params def-assembler-params
...@@ -154,6 +154,9 @@ ...@@ -154,6 +154,9 @@
;; ;;
;; *** State used by the scheduler during instruction queueing. ;; *** 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 ;; A-lists mapping locations to the instruction that reads them and
;; instructions that write them. If maintaining these as a-lists is ;; instructions that write them. If maintaining these as a-lists is
;; too expensive (consing, time, or whatever) we could represent this ;; too expensive (consing, time, or whatever) we could represent this
...@@ -859,14 +862,18 @@ ...@@ -859,14 +862,18 @@
(setf (segment-block-end segment) (system:int-sap 0)) (setf (segment-block-end segment) (system:int-sap 0))
(ext:undefined-value)) (ext:undefined-value))
;;; EMIT-LABEL -- internal. ;;; %EMIT-LABEL -- internal.
;;; ;;;
;;; EMIT-LABEL (the interface) basically just expands into this, supplying ;;; EMIT-LABEL (the interface) basically just expands into this, supplying
;;; the segment. ;;; the segment and vop.
;;; ;;;
(defun %emit-label (segment vop label) (defun %emit-label (segment vop label)
(when (segment-run-scheduler segment) (when (segment-run-scheduler segment)
(schedule-pending-instructions 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))) (let ((hook (segment-inst-hook segment)))
(when hook (when hook
(funcall hook segment vop :label label))) (funcall hook segment vop :label label)))
...@@ -925,6 +932,16 @@ ...@@ -925,6 +932,16 @@
(when (logbitp i offset) (when (logbitp i offset)
(return i)))) (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 ;;;; Output compression/position assignment stuff
...@@ -1173,6 +1190,11 @@ ...@@ -1173,6 +1190,11 @@
"Emit LABEL at this location in the current segment." "Emit LABEL at this location in the current segment."
`(%emit-label *current-segment* *current-vop* ,label)) `(%emit-label *current-segment* *current-vop* ,label))
;;; EMIT-POSTIT -- interface.
;;;
(defmacro emit-postit (function)
`(%emit-postit *current-segment* ,function))
;;; ALIGN -- interface. ;;; ALIGN -- interface.
;;; ;;;
(defmacro align (bits) (defmacro align (bits)
...@@ -1194,6 +1216,12 @@ ...@@ -1194,6 +1216,12 @@
(defun append-segment (segment other-segment) (defun append-segment (segment other-segment)
"Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT
for anything after this." 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) (emit-alignment segment nil max-alignment)
(let ((offset-in-last-block (rem (segment-current-index segment) (let ((offset-in-last-block (rem (segment-current-index segment)
output-block-size))) output-block-size)))
...@@ -1235,6 +1263,10 @@ ...@@ -1235,6 +1263,10 @@
covered by this segment." covered by this segment."
(when (segment-run-scheduler segment) (when (segment-run-scheduler segment)
(schedule-pending-instructions 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-index segment) (segment-current-index segment))
(setf (segment-final-posn segment) (segment-current-posn segment)) (setf (segment-final-posn segment) (segment-current-posn segment))
(setf (segment-inst-hook segment) nil) (setf (segment-inst-hook segment) nil)
...@@ -1453,6 +1485,7 @@ ...@@ -1453,6 +1485,7 @@
(defmacro define-instruction (name lambda-list &rest options) (defmacro define-instruction (name lambda-list &rest options)
(let* ((sym-name (symbol-name name)) (let* ((sym-name (symbol-name name))
(defun-name (ext:symbolicate sym-name "-INST-EMITTER")) (defun-name (ext:symbolicate sym-name "-INST-EMITTER"))
(postits (gensym "POSTITS-"))
(emitter nil) (emitter nil)
(decls nil) (decls nil)
(attributes nil) (attributes nil)
...@@ -1501,6 +1534,9 @@ ...@@ -1501,6 +1534,9 @@
(funcall hook ,segment-name ,vop-name ,sym-name (funcall hook ,segment-name ,vop-name ,sym-name
,arg-reconstructor))) ,arg-reconstructor)))
emitter) emitter)
(push `(dolist (postit ,postits)
(emit-back-patch ,segment-name 0 postit))
emitter)
(when (assem-params-scheduler-p (when (assem-params-scheduler-p
(c:backend-assembler-params c:*target-backend*)) (c:backend-assembler-params c:*target-backend*))
(if pinned (if pinned
...@@ -1526,8 +1562,11 @@ ...@@ -1526,8 +1562,11 @@
(defun ,defun-name ,new-lambda-list (defun ,defun-name ,new-lambda-list
,@(when decls ,@(when decls
`((declare ,@decls))) `((declare ,@decls)))
(symbol-macrolet ((*current-segment* ,segment-name)) (let ((,postits (segment-postits ,segment-name)))
,@emitter) (setf (segment-postits ,segment-name) nil)
(symbol-macrolet ((*current-segment* ,segment-name)
(*current-vop* ,vop-name))
,@emitter))
(ext:undefined-value)) (ext:undefined-value))
(eval-when (compile load eval) (eval-when (compile load eval)
(%define-instruction ,sym-name ',defun-name)))))) (%define-instruction ,sym-name ',defun-name))))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment