Function: comp--add-cond-cstrs

comp--add-cond-cstrs is a byte-compiled function defined in comp.el.gz.

Signature

(comp--add-cond-cstrs)

Documentation

comp--add-cstrs worker function for each selected function.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/comp.el.gz
(defun comp--add-cond-cstrs ()
  "`comp--add-cstrs' worker function for each selected function."
  (cl-loop
   for b being each hash-value of (comp-func-blocks comp-func)
   do
   (cl-loop
    named in-the-basic-block
    with prev-insns-seq
    for insns-seq on (comp-block-insns b)
    do
    (pcase insns-seq
      (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
              ,(and (pred comp-mvar-p) mvar-tested))
         (set ,(and (pred comp-mvar-p) mvar-1)
              (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
         (set ,(and (pred comp-mvar-p) mvar-2)
              (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
         (set ,(and (pred comp-mvar-p) mvar-3)
              (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
         (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
       (comp--emit-assume 'and mvar-tested
                         (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
                         (comp--add-cond-cstrs-target-block b bb2)
                         nil)
       (comp--emit-assume 'and mvar-tested
                         (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
                         (comp--add-cond-cstrs-target-block b bb1)
                         t))
      (`((set ,(and (pred comp-mvar-p) cmp-res)
              (,(pred comp--call-op-p)
               ,(and (or (pred comp--equality-fun-p)
                         (pred comp--arithm-cmp-fun-p))
                     fun)
               ,op1 ,op2))
	 ;; (comment ,_comment-str)
	 (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
       (cl-loop
        with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq) b)
        with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq) b)
        for branch-target-cell on blocks
        for branch-target = (car branch-target-cell)
        for negated in '(t nil)
        for kind = (cl-case fun
                     (equal 'and-nhc)
                     (eql 'and-nhc)
                     (eq 'and)
                     (t fun))
        when (or (comp--mvar-used-p target-mvar1)
                 (comp--mvar-used-p target-mvar2))
        do
        (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
          (setf (car branch-target-cell) (comp-block-name block-target))
          (when (comp--mvar-used-p target-mvar1)
            (comp--emit-assume kind target-mvar1
                              (comp--maybe-add-vmvar op2 cmp-res prev-insns-seq)
                              block-target negated))
          (when (comp--mvar-used-p target-mvar2)
            (comp--emit-assume (comp--reverse-arithm-fun kind)
                              target-mvar2
                              (comp--maybe-add-vmvar op1 cmp-res prev-insns-seq)
                              block-target negated)))
        finally (cl-return-from in-the-basic-block)))
      (`((set ,(and (pred comp-mvar-p) cmp-res)
              (,(pred comp--call-op-p)
               ,(and (pred comp--known-predicate-p) fun)
               ,op))
         . ,(or
	     ;; (comment ,_comment-str)
	     (and `((cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
                  (let negated-branch nil))
             (and `((set ,neg-cmp-res
                         (call eq ,cmp-res ,(pred comp-cstr-null-p)))
                    (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
                  (let negated-branch t))))
       (cl-loop
        with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
        for branch-target-cell on blocks
        for branch-target = (car branch-target-cell)
        for negated in (if negated-branch '(nil t) '(t nil))
        when (comp--mvar-used-p target-mvar)
        do
        (let ((block-target (comp--add-cond-cstrs-target-block
                             b branch-target)))
          (setf (car branch-target-cell) (comp-block-name block-target))
          (comp--emit-assume 'and target-mvar (if negated
                                                  (comp--pred-to-neg-cstr fun)
                                                (comp--pred-to-pos-cstr fun))
                             block-target nil))
        finally (cl-return-from in-the-basic-block))))
    (setf prev-insns-seq insns-seq))))