Skip to content
Snippets Groups Projects
Commit 065709dd authored by ram's avatar ram
Browse files

Undid last change, and radically changed how load-TN packing recovers when

there isn't a free register.  This should eliminate many problems with the
register not finding a legal packing when there is one.  Now, instead of
spilling a TN for the duration of the VOP, we pick some live TN to unpack and
then repack it on the stack. 
parent 20186dce
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/pack.lisp,v 1.38 1991/07/10 17:52:46 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.39 1991/07/17 23:05:34 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -379,42 +379,43 @@ ...@@ -379,42 +379,43 @@
;;; If load TN packing fails, try to give a helpful error message. We find ;;; If load TN packing fails, try to give a helpful error message. We find
;;; a TN in each location that conflicts, and print it. ;;; a TN in each location that conflicts, and print it.
;;; ;;;
(defun failed-to-pack-load-tn-error (sc op) (defun failed-to-pack-load-tn-error (scs op)
(declare (type sc sc) (type tn-ref op)) (declare (list scs) (type tn-ref op))
(collect ((used) (collect ((used)
(unused)) (unused))
(let* ((sb (sc-sb sc)) (dolist (sc scs)
(confs (finite-sb-live-tns sb))) (let* ((sb (sc-sb sc))
(assert (eq (sb-kind sb) :finite)) (confs (finite-sb-live-tns sb)))
(dolist (el (sc-locations sc)) (assert (eq (sb-kind sb) :finite))
(let ((conf (load-tn-conflicts-in-sc op sc el t))) (dolist (el (sc-locations sc))
(if conf (let ((conf (load-tn-conflicts-in-sc op sc el t)))
(used (describe-tn-use el conf op)) (if conf
(loop for i from el (used (describe-tn-use el conf op))
as victim = (svref confs i) (loop for i from el
repeat (sc-element-size sc) do as victim = (svref confs i)
(when (and victim (eq (tn-kind victim) :component)) repeat (sc-element-size sc) do
(used (describe-tn-use el victim op)) (when (and victim (eq (tn-kind victim) :component))
(return t)) (used (describe-tn-use el victim op))
finally (unused el)))))) (return t))
finally (unused el)))))))
(multiple-value-bind (arg-p n more-p costs load-scs incon) (multiple-value-bind (arg-p n more-p costs load-scs incon)
(get-operand-info op) (get-operand-info op)
(declare (ignore costs load-scs)) (declare (ignore costs load-scs))
(assert (not more-p)) (assert (not more-p))
(error "Unable to pack a Load-TN in SC ~S for the ~:R ~ (error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
~:[result~;argument~] to~@ for the ~:R ~:[result~;argument~] to~@
the ~S VOP,~@ the ~S VOP,~@
~:[since all SC elements are in use:~:{~%~@?~}~%~;~ ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~ ~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~
~:[~;~@ ~:[~;~@
Current cost info inconsistent with that in effect at compile ~ Current cost info inconsistent with that in effect at compile ~
time. Recompile.~%Compilation order may be incorrect.~]" time. Recompile.~%Compilation order may be incorrect.~]"
(sc-name sc) (mapcar #'sc-name scs)
n arg-p n arg-p
(vop-info-name (vop-info (tn-ref-vop op))) (vop-info-name (vop-info (tn-ref-vop op)))
(unused) (used) (unused) (used)
incon))) incon)))
(undefined-value)) (undefined-value))
...@@ -891,7 +892,6 @@ ...@@ -891,7 +892,6 @@
(if (and (eq target-sb (sc-sb sc)) (if (and (eq target-sb (sc-sb sc))
(or (eq (sb-kind target-sb) :unbounded) (or (eq (sb-kind target-sb) :unbounded)
(member loc (sc-locations sc))) (member loc (sc-locations sc)))
(not (member loc (sc-reserve-locations sc)))
(= (sc-element-size target-sc) (sc-element-size sc)) (= (sc-element-size target-sc) (sc-element-size sc))
(not (conflicts-in-sc tn sc loc)) (not (conflicts-in-sc tn sc loc))
(zerop (mod loc (sc-alignment sc)))) (zerop (mod loc (sc-alignment sc))))
...@@ -1001,6 +1001,12 @@ ...@@ -1001,6 +1001,12 @@
(defvar *live-block*) (defvar *live-block*)
(defvar *live-vop*) (defvar *live-vop*)
;;; If we unpack some TNs, then we mark all affected blocks by sticking them in
;;; this hash-table. This is initially null. We create the hashtable if we do
;;; any unpacking.
;;;
(defvar *repack-blocks*)
(declaim (type (or hash-table null) *repack-blocks*))
;;; Init-Live-TNs -- Internal ;;; Init-Live-TNs -- Internal
;;; ;;;
...@@ -1178,97 +1184,93 @@ ...@@ -1178,97 +1184,93 @@
(return loc)))) (return loc))))
(defevent spill-conditional-arg-tn (defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.")
"Spilled a TN that was an arg to a :CONDITIONAL VOP.")
;;; SPILL-CONDITIONAL-ARG-TN -- Internal
;;;
;;; Fix things up when we spill a TN for loading of an argument to a
;;; conditional VOP. We have to insert a block on the branch target path that
;;; restores the spilled value. In addition to inserting a block in the IR1
;;; flow graph, we must also insert an IR2 block into the emit order and frob
;;; the assembly level control flow by emitting or modifying branches.
;;;
;;; We change the conditional's target label to be the new block's label.
;;; We insert the new block in the emit order immediately after the conditional
;;; block. In order to do this, we must insert a branch at the end of the
;;; conditional block if it currently drops through.
;;;
(defun spill-conditional-arg-tn (victim vop)
(declare (type tn victim) (type vop vop))
(let* ((info-args (vop-codegen-info vop))
(lab (first info-args))
(node (vop-node vop))
(2block (vop-block vop))
(block (ir2-block-block 2block))
(succ (find lab (block-succ block) :key #'block-label))
(new (insert-cleanup-code block succ node
"<conditional spill hack>"))
(new-2block (make-ir2-block new)))
(event spill-conditional-arg-tn node)
(setf (block-info new) new-2block)
(setf (first info-args) (block-label new))
(emit-operand-load node new-2block (tn-save-tn victim) victim nil)
(vop branch node new-2block lab)
(let ((next-lab (block-label (ir2-block-block (ir2-block-next 2block)))))
(add-to-emit-order new-2block 2block)
(unless (eq (vop-info-name (vop-info (ir2-block-last-vop 2block)))
'branch)
(vop branch node 2block next-lab)))
(undefined-value)))
;;; UNPACK-TN -- Internal
;;;
;;; Make TN's location the same as for its save TN (allocating a save TN if
;;; necessary.) Delete any save/restore code that has been emitted thus far.
;;; Mark all blocks containing references as needing to be repacked.
;;;
(defun unpack-tn (tn)
(event unpack-tn)
(let ((stn (or (tn-save-tn tn)
(pack-save-tn tn))))
(setf (tn-sc tn) (tn-sc stn))
(setf (tn-offset tn) (tn-offset stn))
(flet ((zot (refs)
(do ((ref refs (tn-ref-next ref)))
((null ref))
(let ((vop (tn-ref-vop ref)))
(if (eq (vop-info-name (vop-info vop)) 'move-operand)
(delete-vop vop)
(setf (gethash (vop-block vop) *repack-blocks*) t))))))
(zot (tn-reads tn))
(zot (tn-writes tn))))
(defevent spill-tn "Spilled a TN to satisfy operand SC restriction.") (undefined-value))
;;; Spill-And-Pack-Load-TN -- Internal (defevent unpack-fallback "Unpacked some random operand TN.")
;;;
;;; Handle the case of Pack-Load-TN where there isn't any location free ;;; UNPACK-FOR-LOAD-TN -- Internal
;;; that we can pack into. What we do is spill some live TN to memory, and
;;; then pack the load TN in the freed location.
;;; ;;;
;;; When we find any location in SC that isn't in use within the VOP, we spill ;;; Called by Pack-Load-TN where there isn't any location free that we can
;;; the TN in that location. There must be some TN live in every location, ;;; pack into. What we do is move some live TN in one of the specified SCs to
;;; since normal load TN packing failed. ;;; memory, then mark this block all blocks that reference the TN as needing
;;; repacking. If we suceed, we throw to UNPACKED-TN. If we fail, we return
;;; NIL.
;;; ;;;
;;; We never spill component TNs, since there are used magically within VOPs. ;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired
;;; Spilling is done using the same mechanism as register saving. We mark the ;;; or restricted.) We prefer to unpack TNs that are not used by the VOP. If
;;; spilled TN for the debugger, so that it doesn't think it is valid when the ;;; we can't find any such TN, then we unpack some random argument or result
;;; value has been moved elsewhere. ;;; TN. The only way we can fail is if all locations in SC are used by
;;; load-TNs or temporaries in VOP.
;;; ;;;
(defun spill-and-pack-load-tn (sc op) (defun unpack-for-load-tn (sc op)
(declare (type sc sc) (type tn-ref op)) (declare (type sc sc) (type tn-ref op))
(let ((vop (tn-ref-vop op)) (let ((sb (sc-sb sc))
(sb (sc-sb sc))) (normal-tns (ir2-component-normal-tns
(component-info *compile-component*)))
(dolist (loc (sc-locations sc) (fallback nil))
(failed-to-pack-load-tn-error sc op)) (flet ((unpack-em (victims)
(declare (type index loc)) (unless *repack-blocks*
(unless (load-tn-conflicts-in-sc op sc loc t) (setq *repack-blocks* (make-hash-table :test #'eq)))
(let ((spills (delete-duplicates (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
(loop for i from loc (dolist (victim victims)
as victim = (svref (finite-sb-live-tns sb) i) (unpack-tn victim))
repeat (sc-element-size sc) (throw 'unpacked-tn nil)))
when victim (dolist (loc (sc-locations sc))
collect victim)))) (declare (type index loc))
(assert spills) (block SKIP
(unless (find :component spills :key #'tn-kind) (collect ((victims nil adjoin))
(dolist (victim spills) (loop for i from loc
(event spill-tn (vop-node vop)) as victim = (svref (finite-sb-live-tns sb) i)
(basic-save-tn victim vop) repeat (sc-element-size sc) do
(note-spilled-tn victim vop) (when victim
(when (eq (template-result-types (vop-info vop)) :conditional) (unless (find-in #'tn-next victim normal-tns)
(spill-conditional-arg-tn victim vop))) (return-from SKIP))
(victims victim)))
(let ((res (make-tn 0 :load nil sc))) (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
(setf (tn-offset res) loc) (cond ((not conf)
(return res)))))))) (unpack-em (victims)))
((eq conf :overflow))
((not fallback)
(if (find conf (victims))
(setq fallback (victims))
(setq fallback (list conf)))))))))
(when fallback
(event unpack-fallback)
(unpack-em fallback))))
nil)
;;; Pack-Load-TN -- Internal ;;; Pack-Load-TN -- Internal
;;; ;;;
;;; Try to pack a load TN in the SCs indicated by Load-SCs. If this fails, ;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run out
;;; then we let Spill-And-Pack-Load-TN do its thing. We return the packed load ;;; of SCs, then we unpack some TN and try again. We return the packed load
;;; TN. ;;; TN.
;;; ;;;
;;; Note: we allow a Load-TN to be packed in the target location even if that ;;; Note: we allow a Load-TN to be packed in the target location even if that
...@@ -1285,31 +1287,38 @@ ...@@ -1285,31 +1287,38 @@
(compute-live-tns (vop-block vop) vop)) (compute-live-tns (vop-block vop) vop))
(let* ((tn (tn-ref-tn op)) (let* ((tn (tn-ref-tn op))
(ptype (tn-primitive-type tn))) (ptype (tn-primitive-type tn))
(let ((scs (svref load-scs (sc-number (tn-sc tn)))) (scs (svref load-scs (sc-number (tn-sc tn)))))
(allowed nil)) (let ((current-scs scs)
(allowed ()))
(loop (loop
(when (null scs) (cond
(unless allowed (no-load-scs-allowed-by-primitive-type-error op)) ((null current-scs)
(return (spill-and-pack-load-tn allowed op))) (unless allowed
(no-load-scs-allowed-by-primitive-type-error op))
(let* ((sc (svref (backend-sc-numbers *backend*) (pop scs))) (dolist (sc allowed (failed-to-pack-load-tn-error allowed op))
(target (find-load-tn-target op sc))) (when (unpack-for-load-tn sc op) (return)))
(when (or target (sc-allowed-by-primitive-type sc ptype)) (setq current-scs scs allowed ()))
(setq allowed sc) (t
(let ((loc (or target (let* ((sc (svref (backend-sc-numbers *backend*) (pop current-scs)))
(select-load-tn-location op sc)))) (target (find-load-tn-target op sc)))
(when loc (when (or target (sc-allowed-by-primitive-type sc ptype))
(let ((res (make-tn 0 :load nil sc))) (let ((loc (or target
(setf (tn-offset res) loc) (select-load-tn-location op sc))))
(return res)))))))))) (when loc
(let ((res (make-tn 0 :load nil sc)))
(setf (tn-offset res) loc)
(return res))))
(push sc allowed)))))))))
;;; Check-Operand-Restrictions -- Internal ;;; Check-Operand-Restrictions -- Internal
;;; ;;;
;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by ;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by
;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the ;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the
;;; restriction, we pack a Load-TN and load the operand into it. ;;; restriction, we pack a Load-TN and load the operand into it. If a load-tn
;;; has already been allocated, we can assume that the restriction is
;;; satisfied.
;;; ;;;
(proclaim '(inline check-operand-restrictions)) (proclaim '(inline check-operand-restrictions))
(defun check-operand-restrictions (scs ops) (defun check-operand-restrictions (scs ops)
...@@ -1317,9 +1326,13 @@ ...@@ -1317,9 +1326,13 @@
(do ((scs scs (cdr scs)) (do ((scs scs (cdr scs))
(op ops (tn-ref-across op))) (op ops (tn-ref-across op)))
((null scs)) ((null scs))
(let ((ref-scn (sc-number (tn-sc (tn-ref-tn op))))) (let* ((load-tn (tn-ref-load-tn op))
(unless (eq (svref (car scs) ref-scn) t) (load-scs (svref (car scs)
(setf (tn-ref-load-tn op) (pack-load-tn (car scs) op))))) (sc-number (tn-sc (or load-tn (tn-ref-tn op)))))))
(if load-tn
(assert (eq load-scs t))
(unless (eq load-scs t)
(setf (tn-ref-load-tn op) (pack-load-tn (car scs) op))))))
(undefined-value)) (undefined-value))
...@@ -1330,13 +1343,14 @@ ...@@ -1330,13 +1343,14 @@
;;; later, and our conflict analysis is a backward scan. ;;; later, and our conflict analysis is a backward scan.
;;; ;;;
(defun pack-load-tns (block) (defun pack-load-tns (block)
(do ((vop (ir2-block-last-vop block) (vop-prev vop))) (catch 'unpacked-tn
((null vop)) (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
(let ((info (vop-info vop))) ((null vop))
(check-operand-restrictions (vop-info-result-load-scs info) (let ((info (vop-info vop)))
(vop-results vop)) (check-operand-restrictions (vop-info-result-load-scs info)
(check-operand-restrictions (vop-info-arg-load-scs info) (vop-results vop))
(vop-args vop)))) (check-operand-restrictions (vop-info-arg-load-scs info)
(vop-args vop)))))
(undefined-value)) (undefined-value))
...@@ -1419,9 +1433,12 @@ ...@@ -1419,9 +1433,12 @@
(add-location-conflicts original sc offset))) (add-location-conflicts original sc offset)))
(defevent repack-block "Repacked a block due to TN unpacking.")
;;; Pack -- Interface ;;; Pack -- Interface
;;; ;;;
(defun pack (component) (defun pack (component)
(assert (not *in-pack*))
(let ((*in-pack* t) (let ((*in-pack* t)
(optimize (policy nil (or (>= speed cspeed) (>= space cspeed)))) (optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
(2comp (component-info component))) (2comp (component-info component)))
...@@ -1480,15 +1497,27 @@ ...@@ -1480,15 +1497,27 @@
(pack-tn tn nil))) (pack-tn tn nil)))
;; ;;
;; Do load TN packing and emit saves. ;; Do load TN packing and emit saves.
(let ((*live-block* nil) (let ((*repack-blocks* nil))
(*live-vop* nil)) (let ((*live-block* nil)
(cond ((and optimize pack-optimize-saves) (*live-vop* nil))
(optimized-emit-saves component) (cond ((and optimize pack-optimize-saves)
(do-ir2-blocks (block component) (optimized-emit-saves component)
(pack-load-tns block))) (do-ir2-blocks (block component)
(t (pack-load-tns block)))
(do-ir2-blocks (block component) (t
(emit-saves block) (do-ir2-blocks (block component)
(pack-load-tns block))))) (emit-saves block)
(pack-load-tns block)))))
(when *repack-blocks*
(loop
(when (zerop (hash-table-count *repack-blocks*)) (return))
(let ((*live-block* nil)
(*live-vop* nil))
(maphash #'(lambda (block v)
(declare (ignore v))
(remhash block *repack-blocks*)
(event repack-block)
(pack-load-tns block))
*repack-blocks*)))))
(undefined-value))) (undefined-value)))
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