Changeset 15859
 Timestamp:
 Jul 13, 2013, 8:06:10 PM (7 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/acoderewrite/source/compiler/PPC/ppc2.lisp
r15801 r15859 911 911 912 912 913 (defun ppc2structuredinitopt (seg lcells vloc context vars inits spvars) 914 (withppclocalvinsnmacros (seg) 915 (dolist (var vars vloc) 916 (let* ((initform (pop inits)) 917 (spvar (pop spvars)) 918 (spvloc (%i+ vloc *ppc2targetnodesize*)) 919 (varlcell (pop lcells)) 920 (spreg ($ ppc::arg_z)) 921 (splcell (pop lcells))) 922 (unless (nxnull initform) 923 (ppc2stacktoregister seg (ppc2vlocea spvloc) spreg) 924 (let ((skipinitlabel (backendgetnextlabel))) 925 (withcrftarget () crf 926 (ppc2compareregistertonil seg crf (ppc2makecompoundcd 0 skipinitlabel) spreg ppc::ppceqbit t)) 927 (ppc2registertostack seg (ppc2oneuntargetedregform seg initform ($ ppc::arg_z)) (ppc2vlocea vloc)) 928 (@ skipinitlabel))) 929 (ppc2bindstructuredvar seg var vloc varlcell context) 930 (when spvar 931 (ppc2bindvar seg spvar spvloc splcell))) 932 (setq vloc (%i+ vloc (* 2 *ppc2targetnodesize*)))))) 933 934 935 936 (defun ppc2structuredinitkeys (seg lcells vloc context allowothers keyvars keysupp keyinits keykeys) 937 (declare (ignore keykeys allowothers)) 938 (withppclocalvinsnmacros (seg) 939 (dolist (var keyvars) 940 (let* ((spvar (pop keysupp)) 941 (initform (pop keyinits)) 942 (sploc (%i+ vloc *ppc2targetnodesize*)) 943 (varlcell (pop lcells)) 944 (spreg ($ ppc::arg_z)) 945 (splcell (pop lcells))) 946 (unless (nxnull initform) 947 (ppc2stacktoregister seg (ppc2vlocea sploc) spreg) 948 (let ((skipinitlabel (backendgetnextlabel))) 949 (withcrftarget () crf 950 (ppc2compareregistertonil seg crf (ppc2makecompoundcd 0 skipinitlabel) spreg ppc::ppceqbit t)) 951 (ppc2registertostack seg (ppc2oneuntargetedregform seg initform ($ ppc::arg_z)) (ppc2vlocea vloc)) 952 (@ skipinitlabel))) 953 (ppc2bindstructuredvar seg var vloc varlcell context) 954 (when spvar 955 (ppc2bindvar seg spvar sploc splcell))) 956 (setq vloc (%i+ vloc (* 2 *ppc2targetnodesize*)))))) 913 914 915 916 917 957 918 958 919 (defun ppc2vlocea (n &optional vcellp) … … 4841 4802 (ppc2closevar seg var))) 4842 4803 4843 (defun ppc2closestructuredvar (seg var) 4844 (if (ppc2structuredvarp var) 4845 (apply #'ppc2closestructuredlambda seg (cdr var)) 4846 (ppc2closevar seg var))) 4847 4848 (defun ppc2closestructuredlambda (seg whole req opt rest keys auxen) 4849 (if whole 4850 (ppc2closevar seg whole)) 4851 (dolist (var req) 4852 (ppc2closestructuredvar seg var)) 4853 (dolist (var (%car opt)) 4854 (ppc2closestructuredvar seg var)) 4855 (dolist (var (%caddr opt)) 4856 (when var 4857 (ppc2closevar seg var))) 4858 (if rest 4859 (ppc2closestructuredvar seg rest)) 4860 (dolist (var (%cadr keys)) 4861 (ppc2closestructuredvar seg var)) 4862 (dolist (var (%caddr keys)) 4863 (if var (ppc2closevar seg var))) 4864 (dolist (var (%car auxen)) 4865 (ppc2closevar seg var))) 4804 4866 4805 4867 4806 … … 4871 4810 (ppc2setvarea seg var ($ reg)))) 4872 4811 4873 (defun ppc2bindstructuredvar (seg var vloc lcell &optional context) 4874 (if (not (ppc2structuredvarp var)) 4875 (let* ((reg (nx2assignregistervar var))) 4876 (if reg 4877 (ppc2initregvar seg var reg (ppc2vlocea vloc)) 4878 (ppc2bindvar seg var vloc lcell))) 4879 (let* ((v2 (%cdr var)) 4880 (v v2) 4881 (vstack *ppc2vstack*) 4882 (whole (pop v)) 4883 (req (pop v)) 4884 (opt (pop v)) 4885 (rest (pop v)) 4886 (keys (pop v))) 4887 4888 (apply #'ppc2bindstructuredlambda seg 4889 (ppc2spreadlambdalist seg (ppc2vlocea vloc) whole req opt rest keys context) 4890 vstack context v2)))) 4891 4892 (defun ppc2bindstructuredlambda (seg lcells vloc context whole req opt rest keys auxen 4893 &aux (nkeys (listlength (%cadr keys)))) 4894 (declare (fixnum vloc)) 4895 (when whole 4896 (ppc2bindstructuredvar seg whole vloc (pop lcells)) 4897 (incf vloc *ppc2targetnodesize*)) 4898 (dolist (arg req) 4899 (ppc2bindstructuredvar seg arg vloc (pop lcells) context) 4900 (incf vloc *ppc2targetnodesize*)) 4901 (when opt 4902 (if (ppc2hardoptp opt) 4903 (setq vloc (apply #'ppc2structuredinitopt seg lcells vloc context opt) 4904 lcells (nthcdr (ash (length (car opt)) 1) lcells)) 4905 (dolist (var (%car opt)) 4906 (ppc2bindstructuredvar seg var vloc (pop lcells) context) 4907 (incf vloc *ppc2targetnodesize*)))) 4908 (when rest 4909 (ppc2bindstructuredvar seg rest vloc (pop lcells) context) 4910 (incf vloc *ppc2targetnodesize*)) 4911 (when keys 4912 (apply #'ppc2structuredinitkeys seg lcells vloc context keys) 4913 (setq vloc (%i+ vloc (* *ppc2targetnodesize* (+ nkeys nkeys))))) 4914 (ppc2seqbind seg (%car auxen) (%cadr auxen))) 4915 4916 (defun ppc2structuredvarp (var) 4917 (and (consp var) (or (eq (%car var) *nxlambdalist*) 4918 (eq (%car var) (%nx1operator lambdalist))))) 4812 4919 4813 4920 4814 (defun ppc2simplevar (var &aux (bits (cadr var))) … … 5556 5450 5557 5451 5558 (defppc2 ppc2%primitive %primitive (seg vreg xfer &rest ignore) 5559 (declare (ignore seg vreg xfer ignore)) 5560 (compilerbug "You're probably losing big: using %primitive ...")) 5452 5561 5453 5562 5454 (defppc2 ppc2consp consp (seg vreg xfer cc form) … … 6697 6589 (ppc2ternarybuiltin seg vreg xfer '%aset1 v i n)))) 6698 6590 6699 (defppc2 ppc2%i+ %i+ (seg vreg xfer form1 form2 &optional overflow) 6700 (when overflow 6701 (let* ((type *ppc2targethalffixnumtype*)) 6702 (when (and (ppc2formtypep form1 type) 6703 (ppc2formtypep form2 type)) 6704 (setq overflow nil)))) 6705 (let* ((fix1 (acodefixnumformp form1)) 6706 (fix2 (acodefixnumformp form2)) 6707 (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2))))) 6708 (cond ((null vreg) 6709 (ppc2form seg nil nil form1) 6710 (ppc2form seg nil xfer form2)) 6711 (sum 6712 (if (nx1targetfixnump sum) 6713 (ppc2useoperator (%nx1operator fixnum) seg vreg xfer sum) 6714 (ppc2useoperator (%nx1operator immediate) seg vreg xfer sum))) 6715 (overflow 6716 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg form1 ppc::arg_y form2 ppc::arg_z) 6717 (ensuringnodetarget (target vreg) 6718 (if *ppc2opencodeinline* 6719 (! fixnumaddoverflowinline target r1 r2) 6720 (progn 6721 (! fixnumaddoverflowool r1 r2) 6722 (ppc2copyregister 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 *ppc2targetfixnumshift*) 6729 '(signedbyte 32))) 6730 form2 6731 (if (and fix2 6732 (typep (ash fix2 *ppc2targetfixnumshift*) 6733 '(signedbyte 32))) 6734 form1)))) 6735 (if (and fix1 fix2) 6736 (ppc2lri seg vreg (ash (+ fix1 fix2) *ppc2targetfixnumshift*)) 6737 (if other 6738 (let* ((constant (ash (or fix1 fix2) *ppc2targetfixnumshift*)) 6739 (reg (ppc2oneuntargetedregform 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 (withnodetemps (vreg) (temp) 6749 (! addimmediate temp reg high low) 6750 (< temp)) 6751 (ensuringnodetarget (target vreg) 6752 (! addimmediate target reg high low)))))) 6753 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg form1 ppc::arg_y form2 ppc::arg_z) 6754 (ensuringnodetarget (target vreg) 6755 (! fixnumadd target r1 r2))))) 6756 (^)))))) 6757 6758 (defppc2 ppc2%i %i (seg vreg xfer num1 num2 &optional overflow) 6759 (when overflow 6760 (let* ((type *ppc2targethalffixnumtype*)) 6761 (when (and (ppc2formtypep num1 type) 6762 (ppc2formtypep num2 type)) 6763 (setq overflow nil)))) 6764 (let* ((v1 (acodefixnumformp num1)) 6765 (v2 (acodefixnumformp num2)) 6766 (diff (and v1 v2 (if overflow ( v1 v2) (%i v1 v2))))) 6767 (if diff 6768 (if (nx1targetfixnump diff) 6769 (ppc2useoperator (%nx1operator fixnum) seg vreg xfer diff) 6770 (ppc2useoperator (%nx1operator immediate) seg vreg xfer diff)) 6771 (if (and v2 (neq v2 mostnegativefixnum)) 6772 (ppc2useoperator (%nx1operator %i+) seg vreg xfer num1 (makeacode (%nx1operator fixnum) ( v2)) overflow) 6773 (if (eq v2 0) 6774 (ppc2form seg vreg xfer num1) 6775 (cond 6776 ((null vreg) 6777 (ppc2form seg nil nil num1) 6778 (ppc2form seg nil xfer num2)) 6779 (overflow 6780 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg num1 ppc::arg_y num2 ppc::arg_z) 6591 (defun ppc2fixnumadd (seg vreg xfer form1 form2 overflow) 6592 (withppclocalvinsnmacros (seg vreg xfer) 6593 (when overflow 6594 (let* ((type *ppc2targethalffixnumtype*)) 6595 (when (and (ppc2formtypep form1 type) 6596 (ppc2formtypep form2 type)) 6597 (setq overflow nil)))) 6598 (let* ((fix1 (acodefixnumformp form1)) 6599 (fix2 (acodefixnumformp form2)) 6600 (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2))))) 6601 (cond ((null vreg) 6602 (ppc2form seg nil nil form1) 6603 (ppc2form seg nil xfer form2)) 6604 (sum 6605 (if (nx1targetfixnump sum) 6606 (ppc2useoperator (%nx1operator fixnum) seg vreg xfer sum) 6607 (ppc2useoperator (%nx1operator immediate) seg vreg xfer sum))) 6608 (overflow 6609 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg form1 ppc::arg_y form2 ppc::arg_z) 6781 6610 (ensuringnodetarget (target vreg) 6782 6611 (if *ppc2opencodeinline* 6783 (! fixnum suboverflowinline target r1 r2)6612 (! fixnumaddoverflowinline target r1 r2) 6784 6613 (progn 6785 (! fixnum suboverflowool r1 r2)6614 (! fixnumaddoverflowool r1 r2) 6786 6615 (ppc2copyregister seg target ($ ppc::arg_z))))) 6787 (^))) 6788 ((and v1 (<= (integerlength v1) ( 15 *ppc2targetfixnumshift*))) 6789 (ensuringnodetarget (target vreg) 6790 (! fixnumsubfromconstant target v1 (ppc2oneuntargetedregform seg num2 ppc::arg_z))) 6791 (^)) 6792 (t 6793 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg num1 ppc::arg_y num2 ppc::arg_z) 6794 (ensuringnodetarget (target vreg) 6795 (! fixnumsub 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 *ppc2targetfixnumshift*) 6622 '(signedbyte 32))) 6623 form2 6624 (if (and fix2 6625 (typep (ash fix2 *ppc2targetfixnumshift*) 6626 '(signedbyte 32))) 6627 form1)))) 6628 (if (and fix1 fix2) 6629 (ppc2lri seg vreg (ash (+ fix1 fix2) *ppc2targetfixnumshift*)) 6630 (if other 6631 (let* ((constant (ash (or fix1 fix2) *ppc2targetfixnumshift*)) 6632 (reg (ppc2oneuntargetedregform 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 (withnodetemps (vreg) (temp) 6642 (! addimmediate temp reg high low) 6643 (< temp)) 6644 (ensuringnodetarget (target vreg) 6645 (! addimmediate target reg high low)))))) 6646 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg form1 ppc::arg_y form2 ppc::arg_z) 6647 (ensuringnodetarget (target vreg) 6648 (! fixnumadd target r1 r2))))) 6649 (^))))))) 6650 6651 (defppc2 ppc2%i+ %i+ (seg vreg xfer form1 form2 &optional overflow) 6652 (ppc2fixnumadd seg vreg xfer form1 form2 overflow)) 6653 6654 (defppc2 ppc2fixnumaddoverflow fixnumaddoverflow (seg vreg xfer form1 form2) 6655 (ppc2fixnumadd seg vreg xfer form1 form2 t)) 6656 6657 (defppc2 ppc2fixnumaddnooverflow fixnumaddnooverflow (seg vreg xfer form1 form2) 6658 (ppc2fixnumadd seg vreg xfer form1 form2 nil)) 6659 6660 (defun ppc2fixnumsub (seg vreg xfer num1 num2 overflow) 6661 (withppclocalvinsnmacros (seg vreg xfer) 6662 (when overflow 6663 (let* ((type *ppc2targethalffixnumtype*)) 6664 (when (and (ppc2formtypep num1 type) 6665 (ppc2formtypep num2 type)) 6666 (setq overflow nil)))) 6667 (let* ((v1 (acodefixnumformp num1)) 6668 (v2 (acodefixnumformp num2)) 6669 (diff (and v1 v2 (if overflow ( v1 v2) (%i v1 v2))))) 6670 (if diff 6671 (if (nx1targetfixnump diff) 6672 (ppc2useoperator (%nx1operator fixnum) seg vreg xfer diff) 6673 (ppc2useoperator (%nx1operator immediate) seg vreg xfer diff)) 6674 (if (and v2 (neq v2 mostnegativefixnum)) 6675 (ppc2useoperator (%nx1operator %i+) seg vreg xfer num1 (makeacode (%nx1operator fixnum) ( v2)) overflow) 6676 (if (eq v2 0) 6677 (ppc2form seg vreg xfer num1) 6678 (cond 6679 ((null vreg) 6680 (ppc2form seg nil nil num1) 6681 (ppc2form seg nil xfer num2)) 6682 (overflow 6683 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg num1 ppc::arg_y num2 ppc::arg_z) 6684 (ensuringnodetarget (target vreg) 6685 (if *ppc2opencodeinline* 6686 (! fixnumsuboverflowinline target r1 r2) 6687 (progn 6688 (! fixnumsuboverflowool r1 r2) 6689 (ppc2copyregister seg target ($ ppc::arg_z))))) 6690 (^))) 6691 ((and v1 (<= (integerlength v1) ( 15 *ppc2targetfixnumshift*))) 6692 (ensuringnodetarget (target vreg) 6693 (! fixnumsubfromconstant target v1 (ppc2oneuntargetedregform seg num2 ppc::arg_z))) 6694 (^)) 6695 (t 6696 (multiplevaluebind (r1 r2) (ppc2twountargetedregforms seg num1 ppc::arg_y num2 ppc::arg_z) 6697 (ensuringnodetarget (target vreg) 6698 (! fixnumsub target r1 r2)) 6699 (^)))))))))) 6700 6701 (defppc2 ppc2%i %i (seg vreg xfer num1 num2 &optional overflow) 6702 (ppc2fixnumsub seg vreg xfer num1 num2 overflow)) 6703 6704 (defppc2 ppc2fixnumsubnooverflow fixnumsubnooverflow (seg vreg xfer num1 num2) 6705 (ppc2fixnumsub seg vreg xfer num1 num2 nil)) 6706 6707 (defppc2 ppc2fixnumsuboverflow fixnumsuboverflow (seg vreg xfer num1 num2) 6708 (ppc2fixnumsub seg vreg xfer num1 num2 t)) 6797 6709 6798 6710 (defppc2 ppc2%i* %i* (seg vreg xfer num1 num2) … … 6887 6799 (ppc2closevar seg var))))) 6888 6800 6889 (defppc2 ppc2debind debind (seg vreg xfer lambdalist bindform req opt rest keys auxen whole body p2decls cdrp) 6890 (declare (ignore lambdalist)) 6891 (let* ((oldstack (ppc2encodestack)) 6892 (*ppc2topvstacklcell* *ppc2topvstacklcell*) 6893 (vloc *ppc2vstack*)) 6894 (withppcp2declarations p2decls 6895 (ppc2bindstructuredlambda 6896 seg 6897 (ppc2spreadlambdalist seg bindform whole req opt rest keys nil cdrp) 6898 vloc (ppc2vlocea vloc) whole req opt rest keys auxen) 6899 (ppc2undobody seg vreg xfer body oldstack) 6900 (ppc2closestructuredlambda seg whole req opt rest keys auxen)))) 6801 6901 6802 6902 6803 (defppc2 ppc2multiplevalueprog1 multiplevalueprog1 (seg vreg xfer forms) … … 7508 7409 (ppc2closevar seg var))))))) 7509 7410 7510 ;;; Make a function call (e.g., to mapcar) with some of the toplevel arguments 7511 ;;; stackconsed (downward) closures. Bind temporaries to these closures so 7512 ;;; that tailrecursion/nonlocal exits work right. 7513 ;;; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.) 7514 (defppc2 ppc2withdownwardclosures withdownwardclosures (seg vreg xfer tempvars closures callform) 7515 (let* ((oldstack (ppc2encodestack))) 7516 (ppc2seqbind seg tempvars closures) 7517 (ppc2undobody seg vreg xfer callform oldstack) 7518 (dolist (v tempvars) (ppc2closevar seg v)))) 7411 7519 7412 7520 7413
Note: See TracChangeset
for help on using the changeset viewer.