Changeset 15859


Ignore:
Timestamp:
Jul 13, 2013, 8:06:10 PM (7 years ago)
Author:
gb
Message:

Catch up on PPC.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/acode-rewrite/source/compiler/PPC/ppc2.lisp

    r15801 r15859  
    911911
    912912
    913 (defun ppc2-structured-initopt (seg lcells vloc context vars inits spvars)
    914   (with-ppc-local-vinsn-macros (seg)
    915     (dolist (var vars vloc)
    916       (let* ((initform (pop inits))
    917              (spvar (pop spvars))
    918              (spvloc (%i+ vloc *ppc2-target-node-size*))
    919              (var-lcell (pop lcells))
    920              (sp-reg ($ ppc::arg_z))
    921              (sp-lcell (pop lcells)))
    922         (unless (nx-null initform)
    923           (ppc2-stack-to-register seg (ppc2-vloc-ea spvloc) sp-reg)
    924           (let ((skipinitlabel (backend-get-next-label)))
    925             (with-crf-target () crf
    926               (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
    927             (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))
    928             (@ skipinitlabel)))
    929         (ppc2-bind-structured-var seg var vloc var-lcell context)
    930         (when spvar
    931           (ppc2-bind-var seg spvar spvloc sp-lcell)))
    932       (setq vloc (%i+ vloc (* 2 *ppc2-target-node-size*))))))
    933 
    934 
    935 
    936 (defun ppc2-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys)
    937   (declare (ignore keykeys allow-others))
    938   (with-ppc-local-vinsn-macros (seg)
    939     (dolist (var keyvars)
    940       (let* ((spvar (pop keysupp))
    941              (initform (pop keyinits))
    942              (sploc (%i+ vloc *ppc2-target-node-size*))
    943              (var-lcell (pop lcells))
    944              (sp-reg ($ ppc::arg_z))
    945              (sp-lcell (pop lcells)))
    946         (unless (nx-null initform)
    947           (ppc2-stack-to-register seg (ppc2-vloc-ea sploc) sp-reg)
    948           (let ((skipinitlabel (backend-get-next-label)))
    949             (with-crf-target () crf
    950               (ppc2-compare-register-to-nil seg crf (ppc2-make-compound-cd 0 skipinitlabel) sp-reg ppc::ppc-eq-bit t))
    951             (ppc2-register-to-stack seg (ppc2-one-untargeted-reg-form seg initform ($ ppc::arg_z)) (ppc2-vloc-ea vloc))
    952             (@ skipinitlabel)))
    953         (ppc2-bind-structured-var seg var vloc var-lcell context)
    954         (when spvar
    955           (ppc2-bind-var seg spvar sploc sp-lcell)))
    956       (setq vloc (%i+ vloc (* 2 *ppc2-target-node-size*))))))
     913
     914
     915
     916
     917
    957918
    958919(defun ppc2-vloc-ea (n &optional vcell-p)
     
    48414802    (ppc2-close-var seg var)))
    48424803
    4843 (defun ppc2-close-structured-var (seg var)
    4844   (if (ppc2-structured-var-p var)
    4845     (apply #'ppc2-close-structured-lambda seg (cdr var))
    4846     (ppc2-close-var seg var)))
    4847 
    4848 (defun ppc2-close-structured-lambda (seg whole req opt rest keys auxen)
    4849   (if whole
    4850     (ppc2-close-var seg whole))
    4851   (dolist (var req)
    4852     (ppc2-close-structured-var seg var))
    4853   (dolist (var (%car opt))
    4854     (ppc2-close-structured-var seg var))
    4855   (dolist (var (%caddr opt))
    4856     (when var
    4857       (ppc2-close-var seg var)))
    4858   (if rest
    4859     (ppc2-close-structured-var seg rest))
    4860   (dolist (var (%cadr keys))
    4861     (ppc2-close-structured-var seg var))
    4862   (dolist (var (%caddr keys))
    4863     (if var (ppc2-close-var seg var)))
    4864   (dolist (var (%car auxen))
    4865     (ppc2-close-var seg var)))
     4804
    48664805
    48674806
     
    48714810    (ppc2-set-var-ea seg var ($ reg))))
    48724811
    4873 (defun ppc2-bind-structured-var (seg var vloc lcell &optional context)
    4874   (if (not (ppc2-structured-var-p var))
    4875     (let* ((reg (nx2-assign-register-var var)))
    4876       (if reg
    4877         (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc))
    4878         (ppc2-bind-var seg var vloc lcell)))
    4879     (let* ((v2 (%cdr var))
    4880            (v v2)
    4881            (vstack *ppc2-vstack*)
    4882            (whole (pop v))
    4883            (req (pop v))
    4884            (opt (pop v))
    4885            (rest (pop v))
    4886            (keys (pop v)))
    4887      
    4888       (apply #'ppc2-bind-structured-lambda seg
    4889              (ppc2-spread-lambda-list seg (ppc2-vloc-ea vloc) whole req opt rest keys context)
    4890              vstack context v2))))
    4891 
    4892 (defun ppc2-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen
    4893                         &aux (nkeys (list-length (%cadr keys))))
    4894   (declare (fixnum vloc))
    4895   (when whole
    4896     (ppc2-bind-structured-var seg whole vloc (pop lcells))
    4897     (incf vloc *ppc2-target-node-size*))
    4898   (dolist (arg req)
    4899     (ppc2-bind-structured-var seg arg vloc (pop lcells) context)
    4900     (incf vloc *ppc2-target-node-size*))
    4901   (when opt
    4902    (if (ppc2-hard-opt-p opt)
    4903      (setq vloc (apply #'ppc2-structured-initopt seg lcells vloc context opt)
    4904            lcells (nthcdr (ash (length (car opt)) 1) lcells))
    4905      (dolist (var (%car opt))
    4906        (ppc2-bind-structured-var seg var vloc (pop lcells) context)
    4907        (incf vloc *ppc2-target-node-size*))))
    4908   (when rest
    4909     (ppc2-bind-structured-var seg rest vloc (pop lcells) context)
    4910     (incf vloc *ppc2-target-node-size*))
    4911   (when keys
    4912     (apply #'ppc2-structured-init-keys seg lcells vloc context keys)
    4913     (setq vloc (%i+ vloc (* *ppc2-target-node-size* (+ nkeys nkeys)))))
    4914   (ppc2-seq-bind seg (%car auxen) (%cadr auxen)))
    4915 
    4916 (defun ppc2-structured-var-p (var)
    4917   (and (consp var) (or (eq (%car var) *nx-lambdalist*)
    4918                        (eq (%car var) (%nx1-operator lambda-list)))))
     4812
    49194813
    49204814(defun ppc2-simple-var (var &aux (bits (cadr var)))
     
    55565450
    55575451
    5558 (defppc2 ppc2-%primitive %primitive (seg vreg xfer &rest ignore)
    5559   (declare (ignore seg vreg xfer ignore))
    5560   (compiler-bug "You're probably losing big: using %primitive ..."))
     5452
    55615453
    55625454(defppc2 ppc2-consp consp (seg vreg xfer cc form)
     
    66976589      (ppc2-ternary-builtin seg vreg xfer '%aset1 v i n))))
    66986590
    6699 (defppc2 ppc2-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow)
    6700   (when overflow
    6701     (let* ((type *ppc2-target-half-fixnum-type*))
    6702       (when (and (ppc2-form-typep form1 type)
    6703                  (ppc2-form-typep form2 type))
    6704         (setq overflow nil))))
    6705   (let* ((fix1 (acode-fixnum-form-p form1))
    6706          (fix2 (acode-fixnum-form-p form2))
    6707          (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2)))))
    6708     (cond ((null vreg)
    6709            (ppc2-form seg nil nil form1)
    6710            (ppc2-form seg nil xfer form2))
    6711           (sum
    6712            (if (nx1-target-fixnump sum)
    6713              (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer sum)
    6714              (ppc2-use-operator (%nx1-operator immediate) seg vreg xfer sum)))
    6715           (overflow
    6716            (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z)
    6717              (ensuring-node-target (target vreg)
    6718                (if *ppc2-open-code-inline*
    6719                  (! fixnum-add-overflow-inline target r1 r2)
    6720                  (progn
    6721                    (! fixnum-add-overflow-ool r1 r2)
    6722                    (ppc2-copy-register seg target ($ ppc::arg_z)))))
    6723              (^)))
    6724           (t                             
    6725            ;; There isn't any "addi" that checks for overflow, which is
    6726            ;; why we didn't bother.
    6727            (let* ((other (if (and fix1
    6728                                   (typep (ash fix1 *ppc2-target-fixnum-shift*)
    6729                                          '(signed-byte 32)))
    6730                            form2
    6731                            (if (and fix2
    6732                                     (typep (ash fix2 *ppc2-target-fixnum-shift*)
    6733                                            '(signed-byte 32)))
    6734                              form1))))
    6735              (if (and fix1 fix2)
    6736                (ppc2-lri seg vreg (ash (+ fix1 fix2) *ppc2-target-fixnum-shift*))
    6737                (if other
    6738                  (let* ((constant (ash (or fix1 fix2) *ppc2-target-fixnum-shift*))
    6739                         (reg (ppc2-one-untargeted-reg-form seg other ppc::arg_z))
    6740                         (high (ldb (byte 16 16) constant))
    6741                         (low (ldb (byte 16 0) constant)))
    6742                    (declare (fixnum high low))
    6743                    (if (zerop constant)
    6744                      (<- reg)
    6745                      (progn
    6746                        (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high))))
    6747                        (if (and (eq vreg reg) (not (zerop high)))
    6748                          (with-node-temps (vreg) (temp)
    6749                            (! add-immediate temp reg high low)
    6750                            (<- temp))
    6751                          (ensuring-node-target (target vreg)
    6752                            (! add-immediate target reg high low))))))
    6753                  (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z)
    6754                    (ensuring-node-target (target vreg)
    6755                      (! fixnum-add target r1 r2)))))
    6756              (^))))))
    6757 
    6758 (defppc2 ppc2-%i- %i- (seg vreg xfer num1 num2 &optional overflow)
    6759   (when overflow
    6760     (let* ((type *ppc2-target-half-fixnum-type*))
    6761       (when (and (ppc2-form-typep num1 type)
    6762                  (ppc2-form-typep num2 type))
    6763         (setq overflow nil))))
    6764   (let* ((v1 (acode-fixnum-form-p num1))
    6765          (v2 (acode-fixnum-form-p num2))
    6766          (diff (and v1 v2 (if overflow (- v1 v2) (%i- v1 v2)))))
    6767     (if diff
    6768       (if (nx1-target-fixnump diff)
    6769         (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer diff)
    6770         (ppc2-use-operator (%nx1-operator immediate) seg vreg xfer diff))
    6771       (if (and v2 (neq v2 most-negative-fixnum))
    6772         (ppc2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow)
    6773         (if (eq v2 0)
    6774           (ppc2-form seg vreg xfer num1)
    6775           (cond
    6776            ((null vreg)
    6777             (ppc2-form seg nil nil num1)
    6778             (ppc2-form seg nil xfer num2))
    6779            (overflow
    6780             (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z)
     6591(defun ppc2-fixnum-add (seg vreg xfer form1 form2 overflow)
     6592  (with-ppc-local-vinsn-macros (seg vreg xfer)
     6593    (when overflow
     6594      (let* ((type *ppc2-target-half-fixnum-type*))
     6595        (when (and (ppc2-form-typep form1 type)
     6596                   (ppc2-form-typep form2 type))
     6597          (setq overflow nil))))
     6598    (let* ((fix1 (acode-fixnum-form-p form1))
     6599           (fix2 (acode-fixnum-form-p form2))
     6600           (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2)))))
     6601      (cond ((null vreg)
     6602             (ppc2-form seg nil nil form1)
     6603             (ppc2-form seg nil xfer form2))
     6604            (sum
     6605             (if (nx1-target-fixnump sum)
     6606               (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer sum)
     6607               (ppc2-use-operator (%nx1-operator immediate) seg vreg xfer sum)))
     6608            (overflow
     6609             (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z)
    67816610               (ensuring-node-target (target vreg)
    67826611                 (if *ppc2-open-code-inline*
    6783                    (! fixnum-sub-overflow-inline target r1 r2)
     6612                   (! fixnum-add-overflow-inline target r1 r2)
    67846613                   (progn
    6785                      (! fixnum-sub-overflow-ool r1 r2)
     6614                     (! fixnum-add-overflow-ool r1 r2)
    67866615                     (ppc2-copy-register seg target ($ ppc::arg_z)))))
    6787               (^)))
    6788            ((and v1 (<= (integer-length v1) (- 15 *ppc2-target-fixnum-shift*)))
    6789             (ensuring-node-target (target vreg)
    6790               (! fixnum-sub-from-constant target v1 (ppc2-one-untargeted-reg-form seg num2 ppc::arg_z)))
    6791             (^))
    6792            (t
    6793             (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z)
    6794               (ensuring-node-target (target vreg)
    6795                 (! fixnum-sub target r1 r2))
    6796               (^)))))))))
     6616               (^)))
     6617            (t                             
     6618             ;; There isn't any "addi" that checks for overflow, which is
     6619             ;; why we didn't bother.
     6620             (let* ((other (if (and fix1
     6621                                    (typep (ash fix1 *ppc2-target-fixnum-shift*)
     6622                                           '(signed-byte 32)))
     6623                             form2
     6624                             (if (and fix2
     6625                                      (typep (ash fix2 *ppc2-target-fixnum-shift*)
     6626                                             '(signed-byte 32)))
     6627                               form1))))
     6628               (if (and fix1 fix2)
     6629                 (ppc2-lri seg vreg (ash (+ fix1 fix2) *ppc2-target-fixnum-shift*))
     6630                 (if other
     6631                   (let* ((constant (ash (or fix1 fix2) *ppc2-target-fixnum-shift*))
     6632                          (reg (ppc2-one-untargeted-reg-form seg other ppc::arg_z))
     6633                          (high (ldb (byte 16 16) constant))
     6634                          (low (ldb (byte 16 0) constant)))
     6635                     (declare (fixnum high low))
     6636                     (if (zerop constant)
     6637                       (<- reg)
     6638                       (progn
     6639                         (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high))))
     6640                         (if (and (eq vreg reg) (not (zerop high)))
     6641                           (with-node-temps (vreg) (temp)
     6642                             (! add-immediate temp reg high low)
     6643                             (<- temp))
     6644                           (ensuring-node-target (target vreg)
     6645                             (! add-immediate target reg high low))))))
     6646                   (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg form1 ppc::arg_y form2 ppc::arg_z)
     6647                     (ensuring-node-target (target vreg)
     6648                       (! fixnum-add target r1 r2)))))
     6649               (^)))))))
     6650
     6651(defppc2 ppc2-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow)
     6652  (ppc2-fixnum-add seg vreg xfer form1 form2 overflow))
     6653
     6654(defppc2 ppc2-fixnum-add-overflow fixnum-add-overflow (seg vreg xfer form1 form2)
     6655  (ppc2-fixnum-add seg vreg xfer form1 form2 t))
     6656
     6657(defppc2 ppc2-fixnum-add-no-overflow fixnum-add-no-overflow (seg vreg xfer form1 form2)
     6658  (ppc2-fixnum-add seg vreg xfer form1 form2 nil))
     6659
     6660(defun ppc2-fixnum-sub (seg vreg xfer num1 num2 overflow)
     6661  (with-ppc-local-vinsn-macros (seg vreg xfer)
     6662    (when overflow
     6663      (let* ((type *ppc2-target-half-fixnum-type*))
     6664        (when (and (ppc2-form-typep num1 type)
     6665                   (ppc2-form-typep num2 type))
     6666          (setq overflow nil))))
     6667    (let* ((v1 (acode-fixnum-form-p num1))
     6668           (v2 (acode-fixnum-form-p num2))
     6669           (diff (and v1 v2 (if overflow (- v1 v2) (%i- v1 v2)))))
     6670      (if diff
     6671        (if (nx1-target-fixnump diff)
     6672          (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer diff)
     6673          (ppc2-use-operator (%nx1-operator immediate) seg vreg xfer diff))
     6674        (if (and v2 (neq v2 most-negative-fixnum))
     6675          (ppc2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow)
     6676          (if (eq v2 0)
     6677            (ppc2-form seg vreg xfer num1)
     6678            (cond
     6679              ((null vreg)
     6680               (ppc2-form seg nil nil num1)
     6681               (ppc2-form seg nil xfer num2))
     6682              (overflow
     6683               (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z)
     6684                 (ensuring-node-target (target vreg)
     6685                   (if *ppc2-open-code-inline*
     6686                     (! fixnum-sub-overflow-inline target r1 r2)
     6687                     (progn
     6688                       (! fixnum-sub-overflow-ool r1 r2)
     6689                       (ppc2-copy-register seg target ($ ppc::arg_z)))))
     6690                 (^)))
     6691              ((and v1 (<= (integer-length v1) (- 15 *ppc2-target-fixnum-shift*)))
     6692               (ensuring-node-target (target vreg)
     6693                 (! fixnum-sub-from-constant target v1 (ppc2-one-untargeted-reg-form seg num2 ppc::arg_z)))
     6694               (^))
     6695              (t
     6696               (multiple-value-bind (r1 r2) (ppc2-two-untargeted-reg-forms seg num1 ppc::arg_y num2 ppc::arg_z)
     6697                 (ensuring-node-target (target vreg)
     6698                   (! fixnum-sub target r1 r2))
     6699                 (^))))))))))
     6700
     6701(defppc2 ppc2-%i- %i- (seg vreg xfer num1 num2 &optional overflow)
     6702  (ppc2-fixnum-sub seg vreg xfer num1 num2 overflow))
     6703
     6704(defppc2 ppc2-fixnum-sub-no-overflow fixnum-sub-no-overflow (seg vreg xfer num1 num2)
     6705  (ppc2-fixnum-sub seg vreg xfer num1 num2 nil))
     6706
     6707(defppc2 ppc2-fixnum-sub-overflow fixnum-sub-overflow (seg vreg xfer num1 num2)
     6708  (ppc2-fixnum-sub seg vreg xfer num1 num2 t))
    67976709
    67986710(defppc2 ppc2-%i* %i* (seg vreg xfer num1 num2)
     
    68876799        (ppc2-close-var seg var)))))
    68886800
    6889 (defppc2 ppc2-debind debind (seg vreg xfer lambda-list bindform req opt rest keys auxen whole body p2decls cdr-p)
    6890   (declare (ignore lambda-list))
    6891   (let* ((old-stack (ppc2-encode-stack))
    6892          (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
    6893          (vloc *ppc2-vstack*))
    6894     (with-ppc-p2-declarations p2decls     
    6895       (ppc2-bind-structured-lambda
    6896        seg
    6897        (ppc2-spread-lambda-list seg bindform whole req opt rest keys nil cdr-p)
    6898        vloc (ppc2-vloc-ea vloc) whole req opt rest keys auxen)
    6899       (ppc2-undo-body seg vreg xfer body old-stack)
    6900       (ppc2-close-structured-lambda seg whole req opt rest keys auxen))))
     6801
    69016802
    69026803(defppc2 ppc2-multiple-value-prog1 multiple-value-prog1 (seg vreg xfer forms)
     
    75087409            (ppc2-close-var seg var)))))))
    75097410
    7510 ;;; Make a function call (e.g., to mapcar) with some of the toplevel arguments
    7511 ;;; stack-consed (downward) closures.  Bind temporaries to these closures so
    7512 ;;; that tail-recursion/non-local exits work right.
    7513 ;;; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.)
    7514 (defppc2 ppc2-with-downward-closures with-downward-closures (seg vreg xfer tempvars closures callform)
    7515   (let* ((old-stack (ppc2-encode-stack)))
    7516     (ppc2-seq-bind seg tempvars closures)
    7517     (ppc2-undo-body seg vreg xfer callform old-stack)
    7518     (dolist (v tempvars) (ppc2-close-var seg v))))
     7411
    75197412
    75207413
Note: See TracChangeset for help on using the changeset viewer.