("src/compiler/copyprop")
("src/compiler/represent")
+ ("src/compiler/ir2opt")
("src/compiler/pack")
("src/compiler/codegen")
("src/compiler/debug")
"VM-SUPPORT-ROUTINES-LOCATION-NUMBER"
"WITH-SOURCE-LOCATION"
- "*SOURCE-LOCATION-THUNKS*"))
+ "*SOURCE-LOCATION-THUNKS*"
+
+ "BRANCH-IF"))
#s(sb-cold:package-data
:name "SB!DEBUG"
(:info dest)
(:generator 5
(inst br zero-tn dest)))
+
+\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
\f
;;;; conditional VOPs
make-dynamic-state-tns
make-nlx-entry-arg-start-location
+ ;; from pred.lisp
+ convert-conditional-move-p
+
;; from support.lisp
generate-call-sequence
generate-return-sequence
atypes)
(template-more-args-type info) "args")
(check-tn-refs (vop-results vop) vop t
- (if (eq rtypes :conditional) 0 (length rtypes))
+ (if (template-conditional-p info) 0 (length rtypes))
(template-more-results-type info) "results")
(check-tn-refs (vop-temps vop) vop t 0 t "temps")
(unless (= (length (vop-codegen-info vop))
(inst b dest :nullify t)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
+\f
;;;; Conditional VOPs:
(define-vop (if-eq)
nargs
min)))
- (when (eq (template-result-types template) :conditional)
+ (when (template-conditional-p template)
(bug "%PRIMITIVE was used with a conditional template."))
(when (template-more-results-type template)
--- /dev/null
+;;;; This file implements some optimisations at the IR2 level.
+;;;; Currently, the pass converts branches to conditional moves,
+;;;; deletes subsequently dead blocks and then reoptimizes jumps.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+;;; We track pred/succ info at the IR2-block level, extrapolating
+;;; most of the data from IR1 to initialise.
+(declaim (type hash-table *2block-pred* *2block-succ* *label-2block*))
+(defvar *2block-pred*)
+(defvar *2block-succ*)
+(defvar *label-2block*)
+
+(defun initialize-ir2-blocks-flow-info (component)
+ (labels ((block-last-2block (block)
+ (declare (type cblock block))
+ (do ((2block (block-info block)
+ (ir2-block-next 2block)))
+ (nil)
+ (let ((next (ir2-block-next 2block)))
+ (when (or (null next)
+ (neq block (ir2-block-block next)))
+ (return 2block)))))
+ (link-2blocks (pred succ)
+ (declare (type ir2-block pred succ))
+ (pushnew pred (gethash succ *2block-pred*))
+ (pushnew succ (gethash pred *2block-succ*))))
+ (do-blocks (block component :both)
+ (let ((succ (block-succ block))
+ (last (block-last-2block block)))
+ (dolist (succ succ)
+ (link-2blocks last (block-info succ)))
+ (do ((2block (block-info block)
+ (ir2-block-next 2block)))
+ ((eq 2block last))
+ (link-2blocks 2block (ir2-block-next 2block)))))
+ (do-ir2-blocks (2block component)
+ (awhen (ir2-block-%label 2block)
+ (setf (gethash it *label-2block*) 2block)))))
+
+(defun update-block-succ (2block succ)
+ (declare (type ir2-block 2block)
+ (type list succ))
+ (flet ((blockify (x)
+ (etypecase x
+ (label (or (gethash x *label-2block*)
+ (error "Unknown label: ~S" x)))
+ (ir2-block x))))
+ (setf succ (mapcar #'blockify succ)))
+ (dolist (old (gethash 2block *2block-succ*))
+ (setf (gethash old *2block-pred*)
+ (remove 2block (gethash old *2block-pred*))))
+ (setf (gethash 2block *2block-succ*) succ)
+ (dolist (new succ)
+ (pushnew 2block (gethash new *2block-pred*))))
+
+;;;; Conditional move insertion support code
+#!-sb-fluid (declaim (inline vop-name))
+(defun vop-name (vop &optional default)
+ (declare (type vop vop))
+ (let ((vop-info (vop-info vop)))
+ (if vop-info
+ (vop-info-name vop-info)
+ default)))
+
+(defun move-value-target (2block)
+ (declare (type ir2-block 2block))
+ (let* ((first (or (ir2-block-start-vop 2block)
+ (return-from move-value-target)))
+ (second (vop-next first)))
+ (when (and (eq (vop-name first) 'move)
+ (or (not second)
+ (eq (vop-name second) 'branch)))
+ (values (tn-ref-tn (vop-args first))
+ (tn-ref-tn (vop-results first))))))
+
+;; A conditional jump may be converted to a conditional move if
+;; both branches move a value to the same TN and then continue
+;; execution in the same successor block.
+;;
+;; The label argument is used to return possible value TNs in
+;; the right order (first TN if the branch would have been taken,
+;; second otherwise)
+(defun cmovp (label a b)
+ (declare (type label label)
+ (type cblock a b))
+ (cond ((eq label (ir2-block-%label (block-info a))))
+ ((eq label (ir2-block-%label (block-info b)))
+ (rotatef a b))
+ (t (return-from cmovp)))
+ (let ((succ-a (block-succ a))
+ (succ-b (block-succ b)))
+ (unless (and (singleton-p succ-a)
+ (singleton-p succ-b)
+ (eq (car succ-a) (car succ-b)))
+ (return-from cmovp))
+ (multiple-value-bind (value-a target)
+ (move-value-target (block-info a))
+ (multiple-value-bind (value-b targetp)
+ (move-value-target (block-info b))
+ (and value-a value-b (eq target targetp)
+ (values (block-label (car succ-a))
+ target value-a value-b))))))
+
+;; To convert a branch to a conditional move:
+;; 1. Convert both possible values to the chosen common representation
+;; 2. Execute the conditional VOP
+;; 3. Execute the chosen conditional move VOP
+;; 4. Convert the result from the common representation
+;; 5. Jump to the successor
+#!-sb-fluid (declaim (inline convert-one-cmov))
+(defun convert-one-cmov (cmove-vop
+ value-if arg-if
+ value-else arg-else
+ target res
+ flags info
+ label
+ vop node 2block)
+ (delete-vop vop)
+ (flet ((load-and-coerce (dst src)
+ (when (and dst (neq dst src))
+ (let ((end (ir2-block-last-vop 2block))
+ (move (template-or-lose 'move)))
+ (multiple-value-bind (first last)
+ (funcall (template-emit-function move) node 2block
+ move (reference-tn src nil)
+ (reference-tn dst t))
+ (insert-vop-sequence first last 2block end))))))
+ (load-and-coerce arg-if value-if)
+ (load-and-coerce arg-else value-else))
+ (emit-template node 2block (template-or-lose cmove-vop)
+ (reference-tn-list (remove nil (list arg-if arg-else))
+ nil)
+ (reference-tn res t)
+ (list* flags info))
+ (emit-move node 2block res target)
+ (vop branch node 2block label)
+ (update-block-succ 2block (list label)))
+
+;; Since conditional branches are always at the end of blocks,
+;; it suffices to look at the last VOP in each block.
+(defun maybe-convert-one-cmov (2block)
+ (let* ((block (ir2-block-block 2block))
+ (succ (block-succ block))
+ (a (first succ))
+ (b (second succ))
+ (vop (or (ir2-block-last-vop 2block)
+ (return-from maybe-convert-one-cmov)))
+ (node (vop-node vop)))
+ (unless (eq (vop-name vop) 'branch-if)
+ (return-from maybe-convert-one-cmov))
+ (destructuring-bind (jump-target flags not-p) (vop-codegen-info vop)
+ (multiple-value-bind (label target value-a value-b)
+ (cmovp jump-target a b)
+ (unless label
+ (return-from maybe-convert-one-cmov))
+ (multiple-value-bind (cmove-vop arg-a arg-b res info)
+ (convert-conditional-move-p node target value-a value-b)
+ (unless cmove-vop
+ (return-from maybe-convert-one-cmov))
+ (when not-p
+ (rotatef value-a value-b)
+ (rotatef arg-a arg-b))
+ (convert-one-cmov cmove-vop value-a arg-a
+ value-b arg-b
+ target res
+ flags info
+ label vop node 2block))))))
+
+(defun convert-cmovs (component)
+ (do-ir2-blocks (2block component (values))
+ (maybe-convert-one-cmov 2block)))
+
+(defun delete-unused-ir2-blocks (component)
+ (declare (component component))
+ (let ((live-2blocks (make-hash-table)))
+ (labels ((mark-2block (2block)
+ (declare (type ir2-block 2block))
+ (when (gethash 2block live-2blocks)
+ (return-from mark-2block))
+ (setf (gethash 2block live-2blocks) t)
+ (map nil #'mark-2block (gethash 2block *2block-succ*))))
+ (mark-2block (block-info (component-head component))))
+
+ (flet ((delete-2block (2block)
+ (declare (type ir2-block 2block))
+ (do ((vop (ir2-block-start-vop 2block)
+ (vop-next vop)))
+ ((null vop))
+ (delete-vop vop))))
+ (do-ir2-blocks (2block component (values))
+ (unless (gethash 2block live-2blocks)
+ (delete-2block 2block))))))
+
+(defun delete-fall-through-jumps (component)
+ (flet ((jump-falls-through-p (2block)
+ (let* ((last (or (ir2-block-last-vop 2block)
+ (return-from jump-falls-through-p nil)))
+ (target (first (vop-codegen-info last))))
+ (unless (eq (vop-name last) 'branch)
+ (return-from jump-falls-through-p nil))
+ (do ((2block (ir2-block-next 2block)
+ (ir2-block-next 2block)))
+ ((null 2block) nil)
+ (cond ((eq target (ir2-block-%label 2block))
+ (return t))
+ ((ir2-block-start-vop 2block)
+ (return nil)))))))
+ ;; Walk the blocks in reverse emission order to catch jumps
+ ;; that fall-through only once another jump is deleted
+ (let ((last-2block
+ (do-ir2-blocks (2block component (aver nil))
+ (when (null (ir2-block-next 2block))
+ (return 2block)))))
+ (do ((2block last-2block
+ (ir2-block-prev 2block)))
+ ((null 2block)
+ (values))
+ (when (jump-falls-through-p 2block)
+ (delete-vop (ir2-block-last-vop 2block)))))))
+
+(defun ir2-optimize (component)
+ (let ((*2block-pred* (make-hash-table))
+ (*2block-succ* (make-hash-table))
+ (*label-2block* (make-hash-table)))
+ (initialize-ir2-blocks-flow-info component)
+
+ (convert-cmovs component)
+ (delete-unused-ir2-blocks component)
+ (delete-fall-through-jumps component))
+ (values))
(declare (type node node) (type ir2-block block)
(type template template) (type (or tn-ref null) args)
(list info-args) (type cif if) (type boolean not-p))
- (aver (= (template-info-arg-count template) (+ (length info-args) 2)))
(let ((consequent (if-consequent if))
- (alternative (if-alternative if)))
- (cond ((drop-thru-p if consequent)
+ (alternative (if-alternative if))
+ (flags (and (consp (template-result-types template))
+ (rest (template-result-types template)))))
+ (aver (= (template-info-arg-count template)
+ (+ (length info-args)
+ (if flags 0 2))))
+ (when not-p
+ (rotatef consequent alternative)
+ (setf not-p nil))
+ (when (drop-thru-p if consequent)
+ (rotatef consequent alternative)
+ (setf not-p t))
+ (cond ((not flags)
(emit-template node block template args nil
- (list* (block-label alternative) (not not-p)
- info-args)))
+ (list* (block-label consequent) not-p
+ info-args))
+ (unless (drop-thru-p if alternative)
+ (vop branch node block (block-label alternative))))
(t
- (emit-template node block template args nil
- (list* (block-label consequent) not-p info-args))
+ (emit-template node block template args nil info-args)
+ (vop branch-if node block (block-label consequent) flags not-p)
(unless (drop-thru-p if alternative)
(vop branch node block (block-label alternative)))))))
(multiple-value-bind (args info-args)
(reference-args call block (combination-args call) template)
(aver (not (template-more-results-type template)))
- (if (eq rtypes :conditional)
+ (if (template-conditional-p template)
(ir2-convert-conditional call block template args info-args
(lvar-dest lvar) nil)
(let* ((results (make-template-result-tns call lvar rtypes))
(multiple-value-bind (args info-args)
(reference-args call block (cddr (combination-args call)) template)
(aver (not (template-more-results-type template)))
- (aver (not (eq rtypes :conditional)))
+ (aver (not (template-conditional-p template)))
(aver (null info-args))
(if info
(unless (and (combination-p use)
(let ((info (basic-combination-info use)))
(and (template-p info)
- (eq (template-result-types info) :conditional))))
+ (template-conditional-p info))))
(annotate-ordinary-lvar test)))
(values))
(if (and safe-p (template-args-ok template call nil))
:arg-check
:arg-types)))
- ((eq (template-result-types template) :conditional)
+ ((template-conditional-p template)
(let ((dest (lvar-dest lvar)))
(if (and (if-p dest)
(immediately-used-p (if-test dest) call))
(maybe-mumble "copy ")
(copy-propagate component))
+ (ir2-optimize component)
+
(select-representations component)
(when *check-consistency*
(operands nil :type list)
;; names of variables that should be declared IGNORE
(ignores () :type list)
- ;; true if this is a :CONDITIONAL VOP
+ ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP,
+ ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp
+ ;; for more information.
(conditional-p nil)
;; argument and result primitive types. These are pulled out of the
;; operands, since we often want to change them without respecifying
(setf (vop-parse-result-types parse) ())
(setf (vop-parse-results parse) ())
(setf (vop-parse-more-results parse) nil)
- (setf (vop-parse-conditional-p parse) t))
+ (setf (vop-parse-conditional-p parse) (or (rest spec) t)))
(:temporary
(parse-temporary spec parse))
(:generator
`(:type (specifier-type '(function () nil))
:arg-types (list ,@(mapcar #'make-operand-type args))
:more-args-type ,(when more-args (make-operand-type more-arg))
- :result-types ,(if conditional
- :conditional
- `(list ,@(mapcar #'make-operand-type results)))
+ :result-types ,(cond ((eq conditional t)
+ :conditional)
+ (conditional
+ `'(:conditional . ,conditional))
+ (t
+ `(list ,@(mapcar #'make-operand-type results))))
:more-results-type ,(when more-results
(make-operand-type more-result)))))
\f
;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
;;; primarily when operands are read or written out of order.
;;;
-;;; :CONDITIONAL
+;;; :CONDITIONAL [Condition-descriptor+]
;;; This is used in place of :RESULTS with conditional branch VOPs.
;;; There are no result values: the result is a transfer of control.
;;; The target label is passed as the first :INFO arg. The second
;;; A side effect is to set the PREDICATE attribute for functions
;;; in the :TRANSLATE option.
;;;
+;;; If some condition descriptors are provided, this is a flag-setting
+;;; VOP. Descriptors are interpreted in an architecture-dependent
+;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp.
+;;;
;;; :TEMPORARY ({Key Value}*) Name*
;;; Allocate a temporary TN for each Name, binding that variable to
;;; the TN within the body of the generators. In addition to :TARGET
(inst nop)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
+\f
;;;; Conditional VOPs:
(define-vop (if-eq)
(inst b dest)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
+\f
;;;; Conditional VOPs:
(define-vop (if-eq)
(:generator 5
(inst b dest)
(inst nop)))
+
+\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
\f
;;;; conditional VOPs:
(let* ((args (convert (template-arg-types template)
(template-more-args-type template)))
(result-restr (template-result-types template))
- (results (if (eq result-restr :conditional)
+ (results (if (template-conditional-p template)
'(boolean)
(convert result-restr
(cond ((template-more-results-type template))
,(if (= (length results) 1)
(first results)
`(values ,@results))))))
+
+#!-sb-fluid (declaim (inline template-conditional-p))
+(defun template-conditional-p (template)
+ (declare (type template template))
+ (let ((rtypes (template-result-types template)))
+ (or (eq rtypes :conditional)
+ (eq (car rtypes) :conditional))))
;; conditional that yields its result as a control transfer. The
;; emit function takes two info arguments: the target label and a
;; boolean flag indicating whether to negate the sense of the test.
+ ;;
+ ;; If RESULT-TYPES is a cons whose car is :CONDITIONAL, then this is
+ ;; a flag-setting VOP. The rest is a list of condition descriptors to
+ ;; be interpreted by the BRANCH-IF VOP (see $ARCH/pred.lisp).
(arg-types nil :type list)
- (result-types nil :type (or list (member :conditional)))
+ (result-types nil :type (or list (member :conditional) (cons (eql :conditional))))
;; the primitive type restriction applied to each extra argument or
;; result following the fixed operands. If NIL, no extra
;; args/results are allowed. Otherwise, either * or a (:OR ...) list
(inst jmp dest)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
+\f
;;;; conditional VOPs
;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
(inst jmp dest)))
\f
+;;;; Generic conditional VOPs
+
+;;; The generic conditional branch, emitted immediately after test
+;;; VOPs that only set flags.
+
+(define-vop (branch-if)
+ (:info dest flags not-p)
+ (:ignore dest flags not-p)
+ (:generator 0
+ (error "BRANCH-IF not yet implemented")))
+
+(!def-vm-support-routine
+ convert-conditional-move-p (node dst-tn x-tn y-tn)
+ (declare (ignore node dst-tn x-tn y-tn))
+ nil)
+
+\f
;;;; conditional VOPs
;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
projects / sbcl.git / commitdiff