Changeset 13789
- Timestamp:
- Jun 8, 2010, 1:14:53 AM (10 years ago)
- Location:
- branches/arm
- Files:
-
- 4 added
- 29 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-arch.lisp
r13780 r13789 16 16 17 17 (defpackage "ARM" 18 (:use "CL")) 18 (:use "CL") 19 #+arm-target 20 (:nicknames "TARGET")) 21 19 22 20 23 (require "ARCH") … … 392 395 (defarmsubprim .SPstkgvector) 393 396 (defarmsubprim .SPmisc-alloc) 394 (defarmsubprim .SP macro-bind)395 (defarmsubprim .SP destructuring-bind)396 (defarmsubprim .SP destructuring-bind-inner)397 (defarmsubprim .SPunused0) 398 (defarmsubprim .SPunused1) 399 (defarmsubprim .SPunused2) 397 400 (defarmsubprim .SPrecover-values) 398 401 (defarmsubprim .SPinteger-sign) … … 406 409 (defarmsubprim .SPmisc-alloc-init) 407 410 (defarmsubprim .SPstack-misc-alloc-init) 411 (defarmsubprim .SPpopj) 408 412 (defarmsubprim .SPlexpr-entry) 409 413 (defarmsubprim .SPgetu64) … … 431 435 (defarmsubprim .SPsdiv32) 432 436 (defarmsubprim .SPeabi-ff-call) 437 (defarmsubprim .SPdebind) 433 438 ))))) 434 439 … … 894 899 895 900 (arm::define-storage-layout lisp-frame 0 896 backlink 901 marker 902 savevsp 897 903 savefn 898 904 savelr 899 savevsp900 905 ) 901 906 … … 1196 1201 :function-tag subtag-function 1197 1202 :function-tag-is-subtag t 1198 :big-endian t1203 :big-endian nil 1199 1204 :misc-subtag-offset misc-subtag-offset 1200 1205 :car-offset cons.car … … 1365 1370 ;;; A function's entrypoint should initially reference .SPfix-nfn-entrypoint, 1366 1371 ;;; which will set it to a locative to the function's code-vector. 1367 (def parameter*function-initial-entrypoint* (ash *arm-subprims-base* (- arm::fixnumshift)))1372 (defconstant *function-initial-entrypoint* (ash *arm-subprims-base* (- arm::fixnumshift))) 1368 1373 1369 1374 -
branches/arm/compiler/ARM/arm-asm.lisp
r13780 r13789 117 117 :rs 118 118 :fpaddr 119 :@rn 119 120 )) 120 121 … … 372 373 (#x00e00010 . #x0ff00090)) 373 374 ()) 374 (define-arm-instruction tst (:r d:shifter)375 (define-arm-instruction tst (:rn :shifter) 375 376 #x01100000 376 377 ((#x03100000 . #x0ff00000) … … 378 379 (#x01100010 . #x0ff00090)) 379 380 ()) 380 (define-arm-instruction tsts (:r d:shifter)381 (define-arm-instruction tsts (:rn :shifter) 381 382 #x01100000 382 383 ((#x03100000 . #x0ff00000) … … 408 409 (#x01d00010 . #x0ff00090)) 409 410 ()) 410 (define-arm-instruction cmp (:r d:shifter)411 (define-arm-instruction cmp (:rn :shifter) 411 412 #x01500000 412 413 ((#x03500000 . #x0ff00000) … … 414 415 (#x01500010 . #x0ff00090)) 415 416 ()) 416 (define-arm-instruction cmps (:r d:shifter)417 (define-arm-instruction cmps (:rn :shifter) 417 418 #x01500000 418 419 ((#x03500000 . #x0ff00000) … … 686 687 #x0f700f00 687 688 ()) 688 (define-arm-instruction f sts (:sd :fpaddr)689 (define-arm-instruction flds (:sd :fpaddr) 689 690 #x0d100a00 690 691 #x0f300f00 691 692 ()) 692 )) 693 (define-arm-instruction ldrex (:rd :@rn) 694 #x01900f9f 695 #x0ff00fff 696 ()) 697 (define-arm-instruction strex (:rd :rm :@rn) 698 #x01800f90 699 #x0ff00ff0 700 ()) 701 (define-arm-instruction clrex () 702 #xf57ff01f 703 #xffffffff 704 (:non-conditional)) 705 (define-arm-instruction clz (:rd :rm) 706 #x016f0f10 707 #x0fff0ff0 708 ()) 709 )) 693 710 694 711 (dotimes (i (length *arm-instruction-table*)) … … 1147 1164 (set-field-value instruction (byte 1 23) 1)) 1148 1165 (set-field-value instruction (byte 8 0) (ash offset-val -3))))))) 1166 1167 (defun parse-@rn-operand (form instruction) 1168 (when (or (atom form) 1169 (not (eq (keywordize (car form)) :@))) 1170 (error "Invalid register indirect operand: ~s" form)) 1171 (destructuring-bind (rn) (cdr form) 1172 (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))) 1149 1173 1150 1174 (defparameter *arm-operand-parsers* … … 1171 1195 parse-rs-operand 1172 1196 parse-fpaddr-operand 1197 parse-@rn-operand 1173 1198 )) 1174 1199 -
branches/arm/compiler/ARM/arm-disassemble.lisp
r13764 r13789 266 266 extract-arm-rd-operand ;rde 267 267 extract-arm-rs-operand 268 extract-arm-fpaddr-operand 269 extract-arm-@rn-operand 268 270 )) 269 271 -
branches/arm/compiler/ARM/arm-lap.lisp
r13761 r13789 26 26 27 27 (defun arm-lap-macro-function (name) 28 (declare (special *arm-backend*)) 28 29 (gethash (string name) (backend-lap-macros *arm-backend*))) 29 30 30 31 (defun (setf arm-lap-macro-function) (def name) 32 (declare (special *arm-backend*)) 31 33 (let* ((s (string name))) 32 34 (when (gethash s arm::*arm-instruction-ordinals*) -
branches/arm/compiler/ARM/arm-vinsns.lisp
r13780 r13789 572 572 (rlwinm dest byteval bit-shift 29 29)) 573 573 574 #+notyet575 574 (define-arm-vinsn mem-ref-bit (((dest :u8)) 576 575 ((src :address) … … 578 577 ((byte-index :s16) 579 578 (bit-shift :u8))) 580 (srwi byte-index bit-index (+ arm::fixnumshift 3)) 581 (extrwi bit-shift bit-index 3 27) 582 (addi bit-shift bit-shift 29) 583 (lbzx dest src byte-index) 584 (rlwnm dest dest bit-shift 31 31)) 585 586 #+notyet 579 580 (mov byte-index (:lsr bit-index (:$ arm::fixnumshift))) 581 (and bit-shift byte-index (:$ 7)) 582 (ldrb byte-index (:@ src (:lsr byte-index (:$ 5)))) 583 (mov dest (:lsr byte-index bit-shift)) 584 (and dest dest (:$ 1))) 585 586 587 587 (define-arm-vinsn mem-ref-bit-fixnum (((dest :lisp)) 588 588 ((src :address) … … 590 590 ((byte-index :s16) 591 591 (bit-shift :u8))) 592 (srwi byte-index bit-index (+ arm::fixnumshift 3)) 593 (extrwi bit-shift bit-index 3 27) 594 (addi bit-shift bit-shift 27) 595 (lbzx byte-index src byte-index) 596 (rlwnm dest 597 byte-index 598 bit-shift 599 (- arm::least-significant-bit arm::fixnum-shift) 600 (- arm::least-significant-bit arm::fixnum-shift))) 592 (mov byte-index (:lsr bit-index (:$ arm::fixnumshift))) 593 (and bit-shift byte-index (:$ 7)) 594 (ldrb byte-index (:@ src (:lsr byte-index (:$ 3)))) 595 (mov byte-index (:lsr byte-index bit-shift)) 596 (mov dest (:$ arm::fixnumone)) 597 (and dest dest (:lsl byte-index (:$ arm::fixnumshift)))) 601 598 602 599 (define-arm-vinsn mem-ref-c-double-float (((dest :double-float)) … … 713 710 (strb val (:@ src index))) 714 711 715 #+later716 712 (define-arm-vinsn mem-set-c-bit-0 (() 717 713 ((src :address) 718 714 (byte-index :s16const) 719 (mask-begin :u8const) 720 (mask-end :u8const)) 715 (mask :u8const)) 721 716 ((val :u8))) 722 (l bz val byte-index src)723 ( rlwinm val val 0 mask-begin mask-end)724 (st b val byte-index src))725 726 #+later 717 (ldrb val (:@ src (:$ byte-index))) 718 (bic val val (:$ mask)) 719 (strb val (:@ src (:$ byte-index)))) 720 721 727 722 (define-arm-vinsn mem-set-c-bit-1 (() 728 723 ((src :address) … … 730 725 (mask :u8const)) 731 726 ((val :u8))) 732 (l bz val byte-index src)733 (or i val val mask)734 (st b val byte-index src))735 736 #+later 727 (ldrb val (:@ src (:$ byte-index))) 728 (orr val val (:$ mask)) 729 (strb val (:@ src (:$ byte-index)))) 730 731 737 732 (define-arm-vinsn mem-set-c-bit (() 738 733 ((src :address) … … 740 735 (bit-index :u8const) 741 736 (val :imm)) 742 ((byteval :u8))) 743 (lbz byteval byte-index src) 744 (rlwimi byteval val (:apply logand 31 (:apply - 29 bit-index)) bit-index bit-index) 745 (stb byteval byte-index src)) 737 ((byteval :u8) 738 (mask :u8))) 739 (mov mask (:$ 1)) 740 (mov mask (:lsl mask bit-index)) 741 (cmp val (:$ 0)) 742 (ldrb byteval (:@ src (:$ byte-index))) 743 (orrne byteval byteval mask) 744 (biceq byteval byteval mask) 745 (strb byteval (:@ src (:$ byte-index))) 746 ) 746 747 747 748 ;;; Hey, they should be happy that it even works. Who cares how big it is or how 748 749 ;;; long it takes ... 749 #+later750 750 (define-arm-vinsn mem-set-bit (() 751 751 ((src :address) … … 753 753 (val :lisp)) 754 754 ((bit-shift :u32) 755 (mask :u32) 756 (byte-index :u32))) 757 (cmplwi crf val (ash 1 arm::fixnumshift)) 758 (extrwi bit-shift bit-index 3 27) 759 (li mask #x80) 760 (srw mask mask bit-shift) 761 (ble+ crf :got-it) 762 (uuo_interr arch::error-object-not-bit src) 763 :got-it 764 (srwi bit-shift bit-index (+ 3 arm::fixnumshift)) 765 (lbzx bit-shift src bit-shift) 766 (beq crf :set) 767 (andc mask bit-shift mask) 768 (b :done) 769 :set 770 (or mask bit-shift mask) 771 :done 772 (srwi bit-shift bit-index (+ 3 arm::fixnumshift)) 773 (stbx mask src bit-shift)) 755 (mask :u32))) 756 (cmp val (:$ (ash 1 arm::fixnumshift))) 757 (mov bit-shift (:$ 7)) 758 (mov mask (:$ 1)) 759 (and bit-shift bit-shift (:lsr bit-index (:$ arm::fixnumshift))) 760 (mov mask (:lsl mask bit-shift)) 761 (ldrb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift))))) 762 (uuo-error-reg-not-xtype (:? hi) val (:$ arm::xtype-bit)) 763 (orrne bit-shift bit-shift mask) 764 (biceq bit-shift bit-shift mask) 765 (strb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift)))))) 774 766 775 767 ;;; Tag and subtag extraction, comparison, checking, trapping ... … … 1346 1338 (cmp arg (:$ imm))) 1347 1339 1348 (define-arm-vinsn double-float-compare (( )1340 (define-arm-vinsn double-float-compare (((crf :crf)) 1349 1341 ((arg0 :double-float) 1350 1342 (arg1 :double-float)) … … 1482 1474 (str cell (:@ new (:$ arm::cons.cdr)))) 1483 1475 1484 #+later 1476 1485 1477 (define-arm-vinsn load-adl (() 1486 1478 ((n :u32const))) 1487 (lis nargs (:apply ldb (byte 16 16) n)) 1488 (ori nargs nargs (:apply ldb (byte 16 0) n))) 1479 (mov nargs (:$ (:apply logand #x00ff0000 n))) 1480 ((:not (:pred = 0 (:apply logand #xff000000 n))) 1481 (orr nargs nargs (:$ (:apply logand #xff000000 n)))) 1482 ((:not (:pred = 0 (:apply logand #x0000ff00 n))) 1483 (orr nargs nargs (:$ (:apply logand #x0000ff00 n)))) 1484 ((:not (:pred = 0 (:apply logand #x000000ff n))) 1485 (orr nargs nargs (:$ (:apply logand #x000000ff n))))) 1489 1486 1490 1487 (define-arm-vinsn set-nargs (() … … 1783 1780 (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) 1784 1781 1785 (define-arm-vinsn set-eabi-single-c-arg (() 1782 1783 (define-arm-vinsn set-single-eabi-c-arg (() 1786 1784 ((argval :single-float) 1787 1785 (argnum :u16const))) 1788 1786 (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift)))))) 1789 1787 1790 (define-arm-vinsn set- eabi-double-c-arg (()1788 (define-arm-vinsn set-double-eabi-c-arg (() 1791 1789 ((argval :double-float) 1792 1790 (argnum :u16const))) … … 1874 1872 (sub allocptr allocptr (:$ (:apply 1875 1873 logand #xff 1876 (:apply - (:apply logand (lognot 7)1877 (:apply + (+ 7 4) nbytes))))))1878 ((:pred > (:apply -1879 1880 (:apply + (+ 7 4) nbytes))1874 (:apply - (:apply logand (lognot 7) 1875 (:apply + (+ 7 4) nbytes)) 1876 arm::fulltag-misc)))) 1877 ((:pred > (:apply - (:apply logand (lognot 7) 1878 (:apply + (+ 7 4) nbytes)) 1881 1879 arm::fulltag-misc) #xff) 1882 1880 (sub allocptr allocptr (:$ (:apply logand #xff00 1883 (:apply -1884 (:apply logand (lognot 7)1885 (:apply + (+ 7 4) nbytes))1886 arm::fulltag-misc)))))1881 (:apply - 1882 (:apply logand (lognot 7) 1883 (:apply + (+ 7 4) nbytes)) 1884 arm::fulltag-misc))))) 1887 1885 (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase))) 1888 1886 (cmp allocptr dest) … … 2679 2677 (add sp sp (:$ arm::dnode-size))) 2680 2678 2681 #+notyet2682 2679 (define-arm-vinsn (temp-push-double-float :push :doubleword :sp) 2683 2680 (() … … 2689 2686 (fstd d (:@ sp (:$ 8)))) 2690 2687 2691 #+notyet2692 2688 (define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp) 2693 2689 (() … … 2696 2692 (add sp sp (:$ (* 2 arm::dnode-size)))) 2697 2693 2698 #+notyet 2694 2699 2695 (define-arm-vinsn (temp-push-single-float :push :word :tsp) 2700 2696 (() … … 2706 2702 (fsts s (:@ sp (:$ 4)))) 2707 2703 2708 #+notyet 2704 2709 2705 (define-arm-vinsn (temp-pop-single-float :pop :word :sp) 2710 2706 (() 2711 2707 ((s :single-float))) 2712 (flds s (:@ sp 4))2708 (flds s (:@ sp (:$ 4))) 2713 2709 (add sp sp (:$ arm::dnode-size))) 2714 2710 … … 2734 2730 (define-arm-vinsn zero-double-float-register (((dest :double-float)) 2735 2731 () 2736 ((temp t)))2732 ((temp :imm))) 2737 2733 (mov temp (:$ 0)) 2738 2734 (fmsr dest temp)) … … 2740 2736 (define-arm-vinsn zero-single-float-register (((dest :single-float)) 2741 2737 () 2742 ((temp t)))2738 ((temp :imm))) 2743 2739 (mov temp (:$ 0)) 2744 2740 (fmdrr dest temp temp)) … … 2805 2801 2806 2802 2807 #+later2808 (define-arm-vinsn save-lisp-context-lexpr (()2809 ()2810 ((imm :u32)))2811 (stwu arm::sp (- arm::lisp-frame.size) arm::sp)2812 (str arm::rzero (:@ arm::sp (:$ arm::lisp-frame.savefn)))2813 (str arm::loc-pc (:@ arm::sp (:$ arm::lisp-frame.savelr)))2814 (str vsp (:@ arm::sp (:$ arm::lisp-frame.savevsp)))2815 (mr arm::fn arm::nfn)2816 ;; Do a stack-probe ...2817 (ldr imm (:@ rcontext (:$ arm::tcr.cs-limit)))2818 (twllt arm::sp imm))2819 2803 2820 2804 (define-arm-vinsn save-cleanup-context (() … … 2827 2811 ;; Vpush the argument registers. We got at least "min-fixed" args; 2828 2812 ;; that knowledge may help us generate better code. 2829 #+later2830 2813 (define-arm-vinsn (save-lexpr-argregs :call :subprim-call) 2831 2814 (() 2832 2815 ((min-fixed :u16const)) 2833 ((crfx :crf) 2834 (crfy :crf) 2835 (entry-vsp (:u32 #.arm::imm0)) 2836 (arg-temp :u32))) 2816 ((entry-vsp (:u32 #.arm::imm1)) 2817 (arg-temp (:u32 #.arm::imm0)) 2818 (other-temp :imm))) 2837 2819 ((:pred >= min-fixed $numarmargregs) 2838 (stwu arm::arg_x -4 vsp) 2839 (stwu arm::arg_y -4 vsp) 2840 (stwu arm::arg_z -4 vsp)) 2820 (stm (:! vsp) (arg_z arg_y arg_x))) 2841 2821 ((:pred = min-fixed 2) ; at least 2 args 2842 (cmplwi crfx nargs (ash 2 arm::word-shift)) 2843 (beq crfx :yz2) ; skip arg_x if exactly 2 2844 (stwu arm::arg_x -4 vsp) 2845 :yz2 2846 (stwu arm::arg_y -4 vsp) 2847 (stwu arm::arg_z -4 vsp)) 2822 (cmp nargs (:$ (ash 2 arm::word-shift))) 2823 (strne arg_x (:@! vsp (:$ -4))) 2824 (stm (:! vsp) (arg_z arg_y))) 2848 2825 ((:pred = min-fixed 1) ; at least one arg 2849 (cmplwi crfx nargs (ash 2 arm::word-shift)) 2850 (blt crfx :z1) ; branch if exactly one 2851 (beq crfx :yz1) ; branch if exactly two 2852 (stwu arm::arg_x -4 vsp) 2853 :yz1 2854 (stwu arm::arg_y -4 vsp) 2855 :z1 2856 (stwu arm::arg_z -4 vsp)) 2826 (cmp nargs (:$ (ash 2 arm::word-shift))) 2827 (strlo arg_z (:@! vsp (:$ (- arm::node-size)))) 2828 (stmeq (:! vsp) (arg_z arg_y)) 2829 (stmhi (:! vsp) (arg_z arg_y arg_x))) 2857 2830 ((:pred = min-fixed 0) 2858 (cmplwi crfx nargs (ash 2 arm::word-shift)) 2859 (cmplwi crfy nargs 0) 2860 (beq crfx :yz0) ; exactly two 2861 (beq crfy :none) ; exactly zero 2862 (blt crfx :z0) ; one 2863 ; Three or more ... 2864 (stwu arm::arg_x -4 vsp) 2865 :yz0 2866 (stwu arm::arg_y -4 vsp) 2867 :z0 2868 (stwu arm::arg_z -4 vsp) 2869 :none 2831 (cmp nargs (:$ 0)) 2832 (beq :done) 2833 (cmp nargs (:$ (ash 2 arm::word-shift))) 2834 (strlo arg_z (:@! vsp (:$ (- arm::node-size)))) 2835 (stmeq (:! vsp) (arg_z arg_y)) 2836 (stmhi (:! vsp) (arg_z arg_y arg_x)) 2837 :done 2870 2838 ) 2871 2839 ((:pred = min-fixed 0) 2872 (st wu nargs -4 vsp))2840 (str nargs (:@! vsp (:$ -4)))) 2873 2841 ((:not (:pred = min-fixed 0)) 2874 (sub i arg-temp nargs (:apply ash min-fixed arm::word-shift))2875 (st wu arg-temp -4 vsp))2842 (sub arg-temp nargs (:$ (:apply ash min-fixed arm::word-shift))) 2843 (str arg-temp (:@! vsp (:$ -4)))) 2876 2844 (add entry-vsp vsp nargs) 2877 (la entry-vsp 4 entry-vsp) 2878 (bl .SPlexpr-entry)) 2845 (mov other-temp (:$ (- arm::nil-value arm::fulltag-nil))) 2846 (ldr other-temp (:@ other-temp (:$ (arm::%kernel-global 'arm::ret1valaddr)))) 2847 (add entry-vsp entry-vsp (:$ 4)) 2848 (cmp other-temp lr) 2849 (mov arg-temp (:$ arm::lisp-frame-marker)) 2850 (stmdb (:! vsp) (arg-temp entry-vsp fn lr)) 2851 (mov fn (:$ 0)) 2852 (moveq lr (:$ (- arm::nil-value arm::fulltag-nil))) 2853 (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return)))) 2854 (stmdbeq (:! vsp) (arg-temp entry-vsp fn lr)) 2855 (moveq lr other-temp) 2856 (movne lr (:$ (- arm::nil-value arm::fulltag-nil))) 2857 (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v)))) 2858 ) 2859 2879 2860 2880 2861 … … 3288 3269 (define-arm-subprim-call-vinsn (slide-values) .SPmvslide) 3289 3270 3290 (define-arm-subprim-call-vinsn (macro-bind) .SPmacro-bind) 3291 3292 (define-arm-subprim-call-vinsn (destructuring-bind-inner) .SPdestructuring-bind-inner) 3293 3294 (define-arm-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind) 3271 3272 (define-arm-subprim-call-vinsn (debind) .SPdebind) 3295 3273 3296 3274 -
branches/arm/compiler/ARM/arm2.lisp
r13780 r13789 896 896 (dotimes (i num-fixed) 897 897 (! copy-lexpr-argument)) 898 (! save-lisp-context- lexpr)))898 (! save-lisp-context-vsp))) 899 899 900 900 (defun arm2-load-lexpr-address (seg dest) … … 2309 2309 (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p)))) 2310 2310 (callable (or symp lfunp label-p)) 2311 (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm:: temp0)))))2311 (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn))))) 2312 2312 (alternate-tail-call 2313 2313 (and tail-p label-p *arm2-tail-label* (eql nargs *arm2-tail-nargs*) (not spread-p))) … … 3137 3137 (! double-float-compare dest ireg jreg) 3138 3138 (^ cr-bit true-p)) 3139 ( with-imm-temps () ((lowbit-reg :natural))3139 (progn 3140 3140 (with-crf-target () flags 3141 3141 (! double-float-compare flags ireg jreg) 3142 (! crbit->bit31 lowbit-reg flags cr-bit)) 3143 (unless true-p 3144 (! invert-lowbit lowbit-reg)) 3145 (ensuring-node-target (target dest) 3146 (! lowbit->truth target lowbit-reg)) 3142 3143 (! cond->boolean dest (if true-p cr-bit (logxor cr-bit 1)))) 3147 3144 (^))) 3148 3145 (^)))) … … 4528 4525 (arm2-init-regvar seg var reg (arm2-vloc-ea vloc)) 4529 4526 (arm2-bind-var seg var vloc lcell))) 4530 (let* ((v2 (%cdr var)) 4531 (v v2) 4532 (vstack *arm2-vstack*) 4533 (whole (pop v)) 4534 (req (pop v)) 4535 (opt (pop v)) 4536 (rest (pop v)) 4537 (keys (pop v))) 4538 4539 (apply #'arm2-bind-structured-lambda seg 4540 (arm2-spread-lambda-list seg (arm2-vloc-ea vloc) whole req opt rest keys context) 4541 vstack context v2)))) 4527 (compiler-bug "Old destructuring code ..."))) 4542 4528 4543 4529 (defun arm2-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen … … 4673 4659 (compiler-bug "unknown payback token ~s" r))))))) 4674 4660 4675 (defun arm2-spread-lambda-list (seg listform whole req opt rest keys 4676 &optional enclosing-ea cdr-p) 4661 (defun arm2-spread-lambda-list (seg listform whole req opt rest keys) 4677 4662 (with-arm-local-vinsn-macros (seg) 4678 4663 (let* ((numopt (length (%car opt))) … … 4681 4666 (vtotal numreq) 4682 4667 (old-top *arm2-top-vstack-lcell*) 4683 (listreg ($ arm:: temp3))4668 (listreg ($ arm::arg_z)) 4684 4669 (doadlword (dpb nkeys (byte 8 16) (dpb numopt (byte 8 8) (dpb numreq (byte 8 0) 0 ))))) 4685 4670 (declare (fixnum numopt nkeys numreq vtotal doadlword)) … … 4692 4677 (arm2-vpush-register seg listreg :reserved)) 4693 4678 (when keys 4694 (setq doadlword (%ilogior2 (ash #x80000000 -6) doadlword))4679 (setq doadlword (%ilogior2 (ash 1 25) doadlword)) 4695 4680 (incf vtotal (%ilsl 1 nkeys)) 4696 4681 (if (%car keys) ; &allow-other-keys … … 4700 4685 (setq vtotal (%i+ vtotal numopt)) 4701 4686 (when (arm2-hard-opt-p opt) 4702 (setq doadlword ( %ilogior2 doadlword (ash #x80000000 -7)))4687 (setq doadlword (logior doadlword (ash 1 29))) 4703 4688 (setq vtotal (%i+ vtotal numopt)))) 4704 4689 (when rest 4705 (setq doadlword (%ilogior2 (ash #x80000000 -4) doadlword) vtotal (%i+ vtotal 1)))4690 (setq doadlword (%ilogior2 (ash 1 26) doadlword) vtotal (%i+ vtotal 1))) 4706 4691 (arm2-reserve-vstack-lcells vtotal) 4707 4692 (! load-adl doadlword) 4708 (if cdr-p 4709 (! macro-bind) 4710 (if enclosing-ea 4711 (progn 4712 (arm2-store-ea seg enclosing-ea arm::arg_z) 4713 (! destructuring-bind-inner)) 4714 (! destructuring-bind))) 4693 (! debind) 4715 4694 (arm2-set-vstack (%i+ *arm2-vstack* (* *arm2-target-node-size* vtotal))) 4716 4695 (arm2-collect-lcells :reserved old-top)))) … … 4962 4941 (unless (or rest keys) 4963 4942 (! check-max-nargs (+ num-fixed num-opt))) 4964 (! save-lisp-context-variable) 4943 (unless lexprp 4944 (! save-lisp-context-variable)) 4965 4945 ;; If there were &optional args, initialize their values 4966 4946 ;; to NIL. All of the argregs get vpushed as a result of this. … … 6425 6405 (defarm2 arm2-debind debind (seg vreg xfer lambda-list bindform req opt rest keys auxen whole body p2decls cdr-p) 6426 6406 (declare (ignore lambda-list)) 6407 (when cdr-p 6408 (compiler-bug "Unsupported: old destructuring code, cdr-p case.")) 6427 6409 (let* ((old-stack (arm2-encode-stack)) 6428 6410 (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*) … … 6431 6413 (arm2-bind-structured-lambda 6432 6414 seg 6433 (arm2-spread-lambda-list seg bindform whole req opt rest keys nil cdr-p)6415 (arm2-spread-lambda-list seg bindform whole req opt rest keys) 6434 6416 vloc (arm2-vloc-ea vloc) whole req opt rest keys auxen) 6435 6417 (arm2-undo-body seg vreg xfer body old-stack) … … 7218 7200 i ($ arm::arg_y) 7219 7201 j ($ arm::arg_z)) 7220 (arm2-fixed-call-builtin seg vreg xfer ' SParef2)))) )7202 (arm2-fixed-call-builtin seg vreg xfer '.SParef2)))) ) 7221 7203 7222 7204 … … 7276 7258 j ($ arm::arg_y) 7277 7259 k ($ arm::arg_z)) 7278 (arm2-fixed-call-builtin seg vreg xfer ' SParef3)))))7260 (arm2-fixed-call-builtin seg vreg xfer '.SParef3))))) 7279 7261 7280 7262 (defarm2 arm2-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) -
branches/arm/level-0/ARM/arm-clos.lisp
r13699 r13789 25 25 ;;; be used when there are less than 255 slots in the class. 26 26 (defarmlapfunction %small-map-slot-id-lookup ((slot-id arg_z)) 27 (ldr temp1 'map nfn) 28 (svref arg_x slot-id.index slot-id) 29 (getvheader imm0 temp1) 30 (header-length imm3 imm0) 31 (ldr temp0 'table nfn) 32 (cmplr arg_x imm3) 33 (srri imm0 arg_x target::word-shift) 34 (la imm0 target::misc-data-offset imm0) 35 (li imm1 target::misc-data-offset) 36 (bge @have-scaled-table-index) 37 (lbzx imm1 temp1 imm0) 38 (slri imm1 imm1 target::word-shift) 39 (la imm1 target::misc-data-offset imm1) 40 @have-scaled-table-index 41 (ldrx arg_z temp0 imm1) 42 (blr)) 27 (ldr temp1 (:@ nfn 'map)) 28 (svref arg_x slot-id.index slot-id) 29 (getvheader imm0 temp1) 30 (header-length imm1 imm0) 31 (ldr temp0 (:@ nfn 'table)) 32 (cmp arg_x imm1) 33 (mov imm0 (:lsr arg_x (:$ arm::word-shift))) 34 (add imm0 imm0 (:$ arm::misc-data-offset)) 35 (mov imm1 (:$ arm::misc-data-offset)) 36 (ldrblo imm1 (:@ temp1 imm0)) 37 (movlo imm1 (:lsr imm1 (:$ arm::word-shift))) 38 (addlo imm1 imm1 (:$ arm::misc-data-offset)) 39 (ldr arg_z (:@ temp0 imm1)) 40 (bx lr)) 43 41 44 42 ;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). 45 43 (defarmlapfunction %large-map-slot-id-lookup ((slot-id arg_z)) 46 (ldr temp1 'map nfn) 47 (svref arg_x slot-id.index slot-id) 48 (getvheader imm0 temp1) 49 (header-length imm3 imm0) 50 (ldr temp0 'table nfn) 51 (cmplr arg_x imm3) 52 #+ppc64-target 53 (progn 54 (srdi imm0 imm0 1) 55 (la imm0 target::misc-data-offset imm0)) 56 #+pp32-target 57 (progn 58 (la imm0 target::misc-data-offset arg_x)) 59 (li imm1 target::misc-data-offset) 60 (bge @have-scaled-table-index) 61 (lwzx imm1 temp1 imm0) 62 (slri imm1 imm1 target::word-shift) 63 (la imm1 target::misc-data-offset imm1) 44 (ldr temp1 (:@ nfn 'map)) 45 (svref arg_x slot-id.index slot-id) 46 (getvheader imm0 temp1) 47 (header-length imm1 imm0) 48 (ldr temp0 (:@ nfn 'table)) 49 (cmp arg_x imm1) 50 (add imm0 arg_x (:$ arm::misc-data-offset)) 51 (mov imm1 (:$ arm::misc-data-offset)) 52 (ldrlo imm1 (:@ temp1 imm0)) 53 (movhi imm1 (:lsr imm1 (:$ arm::word-shift))) 54 (addlo imm1 imm1 (:$ arm::misc-data-offset)) 55 (ldr arg_z (:@ temp0 imm1)) 56 (bx lr)) 57 58 (defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) 59 (ldr temp1 (:@ nfn 'map)) 60 (svref arg_x slot-id.index slot-id) 61 (getvheader imm0 temp1) 62 (ldr temp0 (:@ nfn 'table)) 63 (header-length imm1 imm0) 64 (cmp arg_x imm1) 65 (mov imm0 (:lsr arg_x (:$ arm::word-shift))) 66 (add imm0 imm0 (:$ arm::misc-data-offset)) 67 (bhs @missing) 68 (ldrb imm1 (:@ temp1 imm0)) 69 (cmp imm1 (:$ 0)) 70 (mov imm1 (:lsr imm1 (:$ arm::word-shift))) 71 (add imm1 imm1 (:$ arm::misc-data-offset)) 72 (beq @missing) 73 (ldr arg_z (:@ temp0 imm1)) 74 (ldr arg_x (:@ nfn 'class)) 75 (ldr nfn (:@ nfn '%maybe-std-slot-value)) 76 (set-nargs 3) 77 (ldr pc (:@ nfn (:$ arm::function.entrypoint))) 78 @missing ; (%slot-id-ref-missing instance id) 79 (ldr nfn (:@ nfn '%slot-id-ref-missing)) 80 (set-nargs 2) 81 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 82 83 (defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) 84 (ldr temp1 (:@ nfn 'map)) 85 (svref arg_x slot-id.index slot-id) 86 (getvheader imm0 temp1) 87 (ldr temp0 (:@ nfn 'table)) 88 (header-length imm1 imm0) 89 (cmp arg_x imm1) 90 (add imm0 arg_x (:$ arm::misc-data-offset)) 91 (bhs @missing) 92 (ldr imm1 (:@ temp1 imm0)) 93 (cmp imm1 (:$ 0)) 94 (mov imm1 (:lsr imm1 (:$ arm::word-shift))) 95 (add imm1 imm1 (:$ arm::misc-data-offset)) 96 (beq @missing) 64 97 @have-scaled-table-index 65 (ldrx arg_z temp0 imm1) 66 (blr)) 67 68 (defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) 69 (ldr temp1 'map nfn) 70 (svref arg_x slot-id.index slot-id) 71 (getvheader imm0 temp1) 72 (ldr temp0 'table nfn) 73 (header-length imm3 imm0) 74 (cmplr arg_x imm3) 75 (srri imm0 arg_x target::word-shift) 76 (la imm0 target::misc-data-offset imm0) 77 (bge @missing) 78 (lbzx imm1 temp1 imm0) 79 (cmpri imm1 0) 80 (slri imm1 imm1 target::word-shift) 81 (la imm1 target::misc-data-offset imm1) 82 (beq @missing) 83 (ldrx arg_z temp0 imm1) 84 (ldr arg_x 'class nfn) 85 (ldr nfn '%maybe-std-slot-value nfn) 86 (ldr temp0 target::misc-data-offset nfn) 87 (set-nargs 3) 88 (mtctr temp0) 89 (bctr) 98 (ldr arg_x (:@ nfn 'class)) 99 (ldr nfn (:@ nfn '%maybe-std-slot-value-using-class)) 100 (ldr arg_z (:@ temp0 imm1)) 101 (set-nargs 3) 102 (ldr pc (:@ nfn (:$ arm::function.entrypoint))) 90 103 @missing ; (%slot-id-ref-missing instance id) 91 (ldr nfn '%slot-id-ref-missing nfn)104 (ldr nfn (:@ nfn '%slot-id-ref-missing)) 92 105 (set-nargs 2) 93 (ldr temp0 target::misc-data-offset nfn) 94 (mtctr temp0) 95 (bctr)) 96 97 (defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) 98 (ldr temp1 'map nfn) 99 (svref arg_x slot-id.index slot-id) 100 (getvheader imm0 temp1) 101 (ldr temp0 'table nfn) 102 (header-length imm3 imm0) 103 (cmplr arg_x imm3) 104 #+ppc64-target 105 (progn 106 (srdi imm0 arg_x 1) 107 (la imm0 target::misc-data-offset imm0)) 108 #+ppc32-target 109 (progn 110 (la imm0 target::misc-data-offset arg_x)) 111 (bge @missing) 112 (lwzx imm1 temp1 imm0) 113 (cmpri imm1 0) 114 (slri imm1 imm1 target::word-shift) 115 (la imm1 target::misc-data-offset imm1) 116 (beq @missing) 117 @have-scaled-table-index 118 (ldr arg_x 'class nfn) 119 (ldr nfn '%maybe-std-slot-value-using-class nfn) 120 (ldrx arg_z temp0 imm1) 121 (ldr temp0 target::misc-data-offset nfn) 122 (set-nargs 3) 123 (mtctr temp0) 124 (bctr) 125 @missing ; (%slot-id-ref-missing instance id) 126 (ldr nfn '%slot-id-ref-missing nfn) 127 (set-nargs 2) 128 (ldr temp0 target::misc-data-offset nfn) 129 (mtctr temp0) 130 (bctr)) 106 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 131 107 132 108 (defarmlapfunction %small-set-slot-id-value ((instance arg_x) 133 109 (slot-id arg_y) 134 110 (new-value arg_z)) 135 (ldr temp1 'map nfn)136 (svref imm3slot-id.index slot-id)137 (getvheader imm0 temp1) 138 (ldr temp0 'table nfn)139 (header-length imm 5imm0)140 (cmp lr imm3 imm5)141 ( srri imm0 imm3 target::word-shift)142 ( la imm0 target::misc-data-offset imm0)143 (b ge@missing)144 (l bzx imm1 temp1 imm0)145 (cmp wi imm1 0)146 ( slri imm1 imm1 target::word-shift)147 ( la imm1 target::misc-data-offset imm1)111 (ldr temp1 (:@ nfn 'map)) 112 (svref temp0 slot-id.index slot-id) 113 (getvheader imm0 temp1) 114 (ldr temp0 (:@ nfn 'table)) 115 (header-length imm1 imm0) 116 (cmp temp0 imm1) 117 (mov imm0 (:lsr temp0 (:$ arm::word-shift))) 118 (add imm0 imm0 (:$ arm::misc-data-offset)) 119 (bhs @missing) 120 (ldrb imm1 (:@ temp1 imm0)) 121 (cmp imm1 (:$ 0)) 122 (mov imm1 (:lsr imm1 (:$ arm::word-shift))) 123 (add imm1 imm1 (:$ arm::misc-data-offset)) 148 124 (beq @missing) 149 125 @have-scaled-table-index 150 (ldr temp1 'class nfn)151 (ldr x arg_y temp0 imm1)152 (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)126 (ldr temp1 (:@ nfn 'class)) 127 (ldr arg_y (:@ temp0 imm1)) 128 (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class)) 153 129 (set-nargs 4) 154 (ldr temp0 target::misc-data-offset nfn) 155 (vpush temp1) 156 (mtctr temp0) 157 (bctr) 130 (vpush1 temp1) 131 (ldr pc (:@ nfn (:$ arm::function.entrypoint))) 158 132 @missing ; (%slot-id-set-missing instance id new-value) 159 (ldr nfn '%slot-id-set-missing nfn) 160 (set-nargs 3) 161 (ldr temp0 target::misc-data-offset nfn) 162 (mtctr temp0) 163 (bctr)) 133 (ldr nfn (:@ nfn '%slot-id-set-missing)) 134 (set-nargs 3) 135 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 164 136 165 137 (defarmlapfunction %large-set-slot-id-value ((instance arg_x) 166 138 (slot-id arg_y) 167 139 (new-value arg_z)) 168 (ldr temp1 'map nfn) 169 (svref imm3 slot-id.index slot-id) 170 (getvheader imm0 temp1) 171 (ldr temp0 'table nfn) 172 (header-length imm5 imm0) 173 (cmplr imm3 imm5) 174 #+ppc64-target (srdi imm3 imm3 1) 175 (la imm0 target::misc-data-offset imm3) 176 (bge @missing) 177 (lwzx imm1 temp1 imm0) 178 (cmpwi imm1 0) 179 (slri imm1 imm1 target::word-shift) 180 (la imm1 target::misc-data-offset imm1) 140 (ldr temp1 (:@ nfn 'map)) 141 (svref temp0 slot-id.index slot-id) 142 (getvheader imm0 temp1) 143 (ldr temp0 (:@ nfn 'table)) 144 (header-length imm1 imm0) 145 (cmp temp0 imm1) 146 (add imm0 temp0 (:$ arm::misc-data-offset)) 147 (bhs @missing) 148 (ldr imm1 (:@ temp1 imm0)) 149 (cmp imm1 (:$ 0)) 150 (mov imm1 (:lsr imm1 (:$ arm::word-shift))) 151 (add imm1 imm1 (:$ arm::misc-data-offset)) 181 152 (beq @missing) 182 153 @have-scaled-table-index 183 (ldr temp1 'class nfn)184 (ldr x arg_y temp0 imm1)185 (ldr nfn '%maybe-std-setf-slot-value-using-class nfn)154 (ldr temp1 (:@ nfn 'class)) 155 (ldr arg_y (:@ temp0 imm1)) 156 (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class)) 186 157 (set-nargs 4) 187 (svref temp0 0 nfn) 188 (vpush temp1) 189 (mtctr temp0) 190 (bctr) 158 (vpush1 temp1) 159 (ldr pc (:@ nfn (:$ arm::function.entrypoint))) 191 160 @missing ; (%slot-id-set-missing instance id new-value) 192 (ldr nfn '%slot-id-ref-missing nfn) 193 (set-nargs 3) 194 (ldr temp0 target::misc-data-offset nfn) 195 (mtctr temp0) 196 (bctr)) 197 198 #-dont-use-lexprs 199 (defparameter *gf-proto* 200 (nfunction 201 gag 202 (lambda (&lap &lexpr args) 203 (ppc-lap-function 204 gag 205 () 206 (mflr loc-pc) 207 (vpush-argregs) 208 (vpush nargs) 209 (add imm0 vsp nargs) 210 (la imm0 (ash 1 target::word-shift) imm0) ; caller's vsp 211 (bla .SPlexpr-entry) 212 (mtlr loc-pc) ; return to kernel 213 (mr arg_z vsp) ; lexpr 214 (svref arg_y gf.dispatch-table nfn) ; dispatch table 215 (set-nargs 2) 216 (svref nfn gf.dcode nfn) ; dcode function 217 (ldr temp0 target::misc-data-offset nfn) 218 (mtctr temp0) 219 (bctr))))) 220 221 #+dont-use-lexprs 222 (defparameter *gf-proto* 223 (nfunction 224 gag 225 (lambda (&lap &rest args) 226 (ppc-lap-function 227 gag 228 () 229 ;;(bkpt) 230 (mflr loc-pc) 231 (bla .SPstack-rest-arg) 232 (vpop arg_z) 233 (stru sp (- target::lisp-frame.size) sp) 234 (str fn target::lisp-frame.savefn sp) 235 (str loc-pc target::lisp-frame.savelr sp) 236 (str vsp target::lisp-frame.savevsp sp) 237 (mr fn nfn) 238 ;; If we were called for multiple values, call the dcode 239 ;; for multiple values. 240 (ref-global imm0 ret1valaddr) 241 (cmpr imm0 loc-pc) 242 (svref arg_y gf.dispatch-table fn) ; dispatch table 243 (set-nargs 2) 244 (svref nfn gf.dcode fn) ; dcode function 245 (beq @multiple) 246 (ldr temp0 target::misc-data-offset nfn) 247 (mtctr temp0) 248 (bctrl) 249 (ldr tsp 0 tsp) 250 (restore-full-lisp-context) 251 (blr) 252 @multiple 253 (bl @getback) 254 (mflr loc-pc) 255 (stru sp (- target::lisp-frame.size) sp) 256 (str fn target::lisp-frame.savefn sp) 257 (str loc-pc target::lisp-frame.savelr sp) 258 (str vsp target::lisp-frame.savevsp sp) 259 (mtlr imm0) 260 (li fn 0) 261 (ldr temp0 target::misc-data-offset nfn) 262 (mtctr temp0) 263 (bctr) 264 @getback 265 (blrl) 266 @back 267 (ldr tsp 0 tsp) 268 (ba .SPnvalret))))) 161 (ldr nfn (:@ nfn '%slot-id-ref-missing)) 162 (set-nargs 3) 163 (ldr pc (:@ nfn (:$ arm::function.entrypoint))) 164 ) 165 166 167 168 269 169 270 170 … … 276 176 ;;; This can't reference any of the function's constants. 277 177 (defarmlapfunction unset-fin-trampoline () 278 (mflr loc-pc) 279 (bla .SPheap-rest-arg) ; cons up an &rest arg, vpush it 280 (vpop arg_z) ; whoops, didn't really want to 281 (bla .SPsavecontextvsp) 282 (li arg_x '#.$XNOFINFUNCTION) 283 (mr arg_y nfn) 284 (set-nargs 3) 285 (bla .SPksignalerr) 286 (li arg_z nil) 287 (ba .SPpopj)) 178 (build-lisp-frame) 179 (bl .SPheap-rest-arg) ; cons up an &rest arg, vpush it 180 (vpop1 arg_z) ; whoops, didn't really want to 181 (mov arg_x '#.$XNOFINFUNCTION) 182 (mov arg_y nfn) 183 (set-nargs 3) 184 (bl .SPksignalerr) 185 (mov arg_z 'nil) 186 (return-lisp-frame)) 288 187 289 188 ;;; is a winner - saves ~15% … … 293 192 (set-nargs 2) 294 193 (svref nfn gf.dcode nfn) 295 (ldr temp0 target::misc-data-offset nfn) 296 (mtctr temp0) 297 (bctr)) 194 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 298 195 299 196 … … 303 200 (set-nargs 3) 304 201 (svref nfn gf.dcode nfn) 305 (ldr temp0 target::misc-data-offset nfn) 306 (mtctr temp0) 307 (bctr)) 202 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 308 203 309 204 (defparameter *cm-proto* … … 311 206 gag 312 207 (lambda (&lap &lexpr args) 313 ( ppc-lap-function208 (arm-lap-function 314 209 gag 315 210 () 316 (mflr loc-pc)317 211 (vpush-argregs) 318 (vpush nargs) 319 (add imm0 vsp nargs) 320 (la imm0 target::node-size imm0) ; caller's vsp 321 (bla .SPlexpr-entry) 322 (mtlr loc-pc) ; return to kernel 323 (mr arg_z vsp) ; lexpr 212 (vpush1 nargs) 213 (ref-global arg_x ret1valaddr) 214 (add imm1 vsp nargs) 215 (add imm1 imm1 (:$ arm::node-size)) ; caller's vsp 216 (cmp lr arg_x) 217 (build-lisp-frame imm0 imm1) 218 (mov fn (:$ 0)) 219 (moveq lr (:$ (- arm::nil-value arm::fulltag-nil))) 220 (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return)))) 221 (stmdbeq (:! vsp) (imm0 imm1 fn lr)) 222 (moveq lr arg_x) 223 (movne lr (:$ (- arm::nil-value arm::fulltag-nil))) 224 (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v)))) 225 (mov arg_z vsp) 324 226 (svref arg_y combined-method.thing nfn) ; thing 325 227 (set-nargs 2) 326 228 (svref nfn combined-method.dcode nfn) ; dcode function 327 (ldr temp0 target::misc-data-offset nfn) 328 (mtctr temp0) 329 (bctr))))) 229 (ldr pc (:@ nfn (:$ arm::function.entrypoint))))))) -
branches/arm/level-0/ARM/arm-def.lisp
r13706 r13789 20 20 ;;; If the GC moves this function while we're trying to flush the cache, 21 21 ;;; it'll flush the cache: no harm done in that case. 22 #+notyet ;though we need to on ARM. 23 (defppclapfunction %make-code-executable ((codev arg_z)) 24 (let ((len imm2) 25 (word-offset imm0)) 26 (save-lisp-context) 27 (getvheader word-offset codev) 28 (header-size len word-offset) 29 ;; The idea is that if we GC here, no harm is done (since the GC 30 ;; will do any necessary cache-flushing.) The idea may be 31 ;; incorrect: if we pass an address that's not mapped anymore, 32 ;; could we fault ? 33 (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize 34 #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp) ; make an FFI frame. 35 (la imm0 target::misc-data-offset codev) 36 (slri len len 2) 37 (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0 sp) 38 (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp) 39 (ref-global imm3 kernel-imports) 40 (ldr arg_z target::kernel-import-MakeDataExecutable imm3) 41 (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall) 42 (li arg_z nil) 43 (restore-full-lisp-context) 44 (blr))) 22 23 (defun %make-code-executable (codev) 24 (with-macptrs (p) 25 (let* ((nbytes (ash (uvsize codev) arm::word-shift))) 26 (%vect-data-to-macptr codev p) 27 (ff-call (%kernel-import arm::kernel-import-MakeDataExecutable) 28 :address p 29 :unsigned-fullword nbytes 30 :void)))) 45 31 46 32 (defarmlapfunction %get-kernel-global-from-offset ((offset arg_z)) … … 75 61 (moveq fixnum offset) 76 62 (moveq offset (:$ 0)) 77 @2-args78 63 (unbox-fixnum imm0 offset) 79 64 (ldr arg_z (:@ imm0 fixnum)) … … 156 141 (defarmlapfunction %%frame-backlink ((p arg_z)) 157 142 (check-nargs 1) 158 ( ldr arg_z target::lisp-frame.backlink arg_z)143 (add arg_z p (:$ arm::lisp-frame.size)) 159 144 (bx lr)) 160 145 … … 165 150 (defarmlapfunction %%frame-savefn ((p arg_z)) 166 151 (check-nargs 1) 167 (ldr arg_z target::lisp-frame.savefn arg_z)152 (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savefn))) 168 153 (bx lr)) 169 154 170 155 (defarmlapfunction %cfp-lfun ((p arg_z)) 171 (ldr arg_y target::lisp-frame.savefn p) 156 (build-lisp-frame) 157 (ldr arg_y (:@ p (:$ arm::lisp-frame.savefn))) 172 158 (extract-typecode imm0 arg_y) 173 (cmp ri imm0 target::subtag-function)174 (ldr l oc-pc target::lisp-frame.savelr p)159 (cmp imm0 (:$ arm::subtag-function)) 160 (ldr lr (:@ p (:$ arm::lisp-frame.savelr))) 175 161 (bne @no) 176 (ldr arg_x target::misc-data-offset arg_y)177 (sub imm1 l oc-pcarg_x)178 ( la imm1 (- target::misc-data-offset) imm1)162 (ldr arg_x (:@ arg_y (:$ (+ arm::node-size arm::misc-data-offset)))) 163 (sub imm1 lr arg_x) 164 (add imm1 imm1 (:$ (- arm::misc-data-offset))) 179 165 (getvheader imm0 arg_x) 180 166 (header-length imm0 imm0) 181 (cmp lrimm1 imm0)167 (cmp imm1 imm0) 182 168 (box-fixnum imm1 imm1) 183 (b ge@no)184 (vpush arg_y)185 (vpush imm1)169 (bhs @no) 170 (vpush1 arg_y) 171 (vpush1 imm1) 186 172 @go 187 173 (set-nargs 2) 188 (la temp0 '2 vsp) 189 (ba .SPvalues) 174 (ba .SPnvalret) 190 175 @no 191 ( li imm0nil)192 (vpush imm0)193 (vpush imm0)176 (mov imm0 'nil) 177 (vpush1 imm0) 178 (vpush1 imm0) 194 179 (b @go)) 195 180 … … 199 184 (defarmlapfunction %%frame-savevsp ((p arg_z)) 200 185 (check-nargs 1) 201 (ldr arg_z target::lisp-frame.savevsp arg_z) 202 (bx lr)) 203 204 205 206 207 208 #+ppc32-target 209 (eval-when (:compile-toplevel :execute) 210 (assert (eql ppc32::t-offset #x11))) 186 (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savevsp))) 187 (bx lr)) 188 189 190 191 192 193 211 194 212 195 (defarmlapfunction %uvector-data-fixnum ((uv arg_z)) 213 196 (check-nargs 1) 214 (trap-unless-fulltag= arg_z target::fulltag-misc)215 ( la arg_z target::misc-data-offset arg_z)197 (trap-unless-fulltag= arg_z arm::fulltag-misc) 198 (add arg_z arg_z (:$ arm::misc-data-offset)) 216 199 (bx lr)) 217 200 218 201 (defarmlapfunction %catch-top ((tcr arg_z)) 219 202 (check-nargs 1) 220 (ldr arg_z target::tcr.catch-top tcr) 221 (cmpri cr0 arg_z 0) 222 (bne @ret) 223 (li arg_z nil) 224 @ret 225 (bx lr)) 226 227 (defarmlapfunction %catch-tsp ((catch arg_z)) 228 (check-nargs 1) 229 (la arg_z (- (+ target::fulltag-misc 230 (ash 1 (1+ target::word-shift)))) arg_z) 231 (bx lr)) 203 (ldr arg_z (:@ tcr (:$ arm::tcr.catch-top))) 204 (cmp arg_z (:$ 0)) 205 (moveq arg_z 'nil) 206 (bx lr)) 207 208 232 209 233 210 … … 243 220 244 221 (defarmlapfunction %save-standard-binding-list ((bindings arg_z)) 245 (ldr imm0 target::tcr.vs-area target::rcontext)246 (ldr imm1 target::area.high imm0)247 (push bindings imm1)222 (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area))) 223 (ldr imm1 (:@ imm0 (:$ arm::area.high))) 224 (push1 bindings imm1) 248 225 (bx lr)) 249 226 250 227 (defarmlapfunction %saved-bindings-address () 251 (ldr imm0 target::tcr.vs-area target::rcontext)252 (ldr imm1 target::area.high imm0)253 ( la arg_z (- target::node-size) imm1)228 (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area))) 229 (ldr imm1 (:@ imm0 (:$ arm::area.high))) 230 (add arg_z imm1 (:$ (- arm::node-size))) 254 231 (bx lr)) 255 232 256 233 (defarmlapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z)) 234 (build-lisp-frame) 257 235 (macptr-ptr imm0 pcptr) 258 (ldr l oc-pc 0 imm0)259 (sub imm0 l oc-pccode-vector)260 (sub i imm0 imm0 target::misc-data-offset)236 (ldr lr (:@ imm0 (:$ 0))) 237 (sub imm0 lr code-vector) 238 (sub imm0 imm0 (:$ arm::misc-data-offset)) 261 239 (getvheader imm1 code-vector) 262 240 (header-size imm1 imm1) 263 (slri imm1 imm1 2) 264 (cmplr imm0 imm1) 265 (li arg_z nil) 266 (bgelr) 267 (box-fixnum arg_z imm0) 268 (bx lr)) 269 241 (mov imm1 (:lsr imm1 (:$ 2))) 242 (cmp imm0 imm1) 243 (movhs arg_z 'nil) 244 (movlo arg_z (:lsl imm0 (:$ arm::fixnumshift))) 245 (return-lisp-frame)) 246 247 #+notyet 248 (progn 270 249 ;;; FF-call, in LAP. 271 250 #+eabi-target … … 1050 1029 ) 1051 1030 ) 1031 ) 1052 1032 1053 1033 … … 1055 1035 (defarmlapfunction %get-object ((macptr arg_y) (offset arg_z)) 1056 1036 (check-nargs 2) 1057 (trap-unless- typecode= arg_y target::subtag-macptr)1037 (trap-unless-xtype= arg_y arm::subtag-macptr) 1058 1038 (macptr-ptr imm0 arg_y) 1059 (trap-unless- lisptag= arg_z target::tag-fixnum imm1)1039 (trap-unless-fixnum arg_z) 1060 1040 (unbox-fixnum imm1 arg_z) 1061 (ldr x arg_z imm0 imm1)1041 (ldr arg_z (:@ imm0 imm1)) 1062 1042 (bx lr)) 1063 1043 … … 1065 1045 (defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) 1066 1046 (check-nargs 3) 1067 (trap-unless- typecode= arg_x target::subtag-macptr)1047 (trap-unless-xtype= arg_x arm::subtag-macptr) 1068 1048 (macptr-ptr imm0 arg_x) 1069 (trap-unless- lisptag= arg_y target::tag-fixnum imm1)1049 (trap-unless-fixnum arg_y) 1070 1050 (unbox-fixnum imm1 arg_y) 1071 (str x arg_z imm0 imm1)1051 (str arg_z (:@ imm0 imm1)) 1072 1052 (bx lr)) 1073 1053 … … 1077 1057 (args arg_z)) 1078 1058 ;; Somebody's called (or tail-called) us. 1079 ;; Put magic arg in ppc::next-method-context (= ppc::temp1).1080 ;; Put function in ppc::nfn (= ppc::temp2).1059 ;; Put magic arg in arm::next-method-context (= arm::temp1). 1060 ;; Put function in arm::nfn (= arm::temp2). 1081 1061 ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, 1082 ;; but preserves ppc::nfn/ppc::next-method-context.1083 ;; Jump to the function in ppc::nfn.1084 (mov ppc::next-method-context magic)1085 (mov ppc::nfn function)1062 ;; but preserves arm::nfn/arm::next-method-context. 1063 ;; Jump to the function in arm::nfn. 1064 (mov arm::next-method-context magic) 1065 (mov arm::nfn function) 1086 1066 (set-nargs 0) 1087 (mflr loc-pc) 1088 (bla .SPspread-lexpr-z) 1089 (mtlr loc-pc) 1090 (ldr temp0 target::misc-data-offset nfn) 1091 (mtctr temp0) 1092 (bctr)) 1067 (build-lisp-frame) 1068 (bl .SPspread-lexprz) 1069 (restore-lisp-frame) 1070 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 1093 1071 1094 1072 … … 1097 1075 (args arg_z)) 1098 1076 ;; Somebody's called (or tail-called) us. 1099 ;; Put magic arg in ppc::next-method-context (= ppc::temp1).1100 ;; Put function in ppc::nfn (= ppc::temp2).1077 ;; Put magic arg in arm::next-method-context (= arm::temp1). 1078 ;; Put function in arm::nfn (= arm::temp2). 1101 1079 ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, 1102 ;; but preserves ppc::nfn/ppc::next-method-context.1103 ;; Jump to the function in ppc::nfn.1104 (mov ppc::next-method-context magic)1105 (mov ppc::nfn function)1080 ;; but preserves arm::nfn/arm::next-method-context. 1081 ;; Jump to the function in arm::nfn. 1082 (mov arm::next-method-context magic) 1083 (mov arm::nfn function) 1106 1084 (set-nargs 0) 1107 (mflr loc-pc) 1108 (bla .SPspreadargZ) 1109 (mtlr loc-pc) 1110 (ldr temp0 target::misc-data-offset nfn) 1111 (mtctr temp0) 1112 (bctr)) 1085 (build-lisp-frame) 1086 (bl .SPspreadargZ) 1087 (restore-lisp-frame) 1088 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 1113 1089 1114 1090 … … 1127 1103 ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+ 1128 1104 ;; args node-size), pop the argregs, and jump to the function. 1129 (mflr loc-pc)1130 1105 (ref-global imm0 ret1valaddr) 1131 (cmpr cr2 loc-pc imm0) 1132 (ldr nargs 0 args) 1133 (mov imm5 nargs) 1134 (cmpri cr0 nargs 0) 1135 (cmpri cr1 nargs '2) 1106 (cmp lr imm0) 1107 (ldr nargs (:@ args (:$ 0))) 1136 1108 (mov nfn method) 1137 (ldr temp0 target::misc-data-offset nfn) 1138 (mtctr temp0) 1139 (if (:cr2 :eq) 1140 (la sp target::lisp-frame.size sp)) 1141 (ldr loc-pc target::lisp-frame.savelr sp) 1142 (ldr fn target::lisp-frame.savefn sp) 1143 (ldr imm0 target::lisp-frame.savevsp sp) 1109 (addeq sp sp (:$ arm::lisp-frame.size)) 1110 (ldr lr (:@ sp (:$ arm::lisp-frame.savelr))) 1111 (ldr fn (:@ sp (:$ arm::lisp-frame.savefn))) 1112 (ldr imm0 (:@ sp (:$ arm::lisp-frame.savevsp))) 1144 1113 (sub vsp imm0 nargs) 1145 (mtlr loc-pc) 1146 (la sp target::lisp-frame.size sp) 1147 (beqctr) 1148 (vpop arg_z) 1149 (bltctr cr1) 1150 (vpop arg_y) 1151 (beqctr cr1) 1152 (vpop arg_x) 1153 (bctr)) 1114 (add sp sp (:$ arm::lisp-frame.size)) 1115 (cmp nargs (:$ 0)) 1116 (ldreq pc (:@ nfn (:$ arm::function.entrypoint))) 1117 (cmp nargs '2) 1118 (vpop1 arg_z) 1119 (ldrlo pc (:@ nfn (:$ arm::function.entrypoint))) 1120 (vpop1 arg_y) 1121 (ldreq pc (:@ nfn (:$ arm::function.entrypoint))) 1122 (vpop1 arg_x) 1123 (ldr pc (:@ nfn (:$ arm::function.entrypoint)))) 1154 1124 1155 1125 … … 1162 1132 (error "Wrong size target ~s" target))) 1163 1133 (%copy-gvector-to-gvector proto 0 new 0 total-size) 1134 (setf (%svref new 0 )arm::*function-initial-entrypoint*) 1164 1135 new)) 1165 1136 … … 1167 1138 (if (typep target-fn 'function) 1168 1139 (if (typep proto-fn 'function) 1169 (setf (uvref target-fn 0) 1170 (uvref proto-fn 0))1140 (setf (uvref target-fn 0) arm::*function-initial-entrypoint* 1141 (uvref target-fn 1) (uvref proto-fn 1)) 1171 1142 (report-bad-arg proto-fn 'function)) 1172 1143 (report-bad-arg target-fn 'function))) … … 1174 1145 (defun closure-function (fun) 1175 1146 (while (and (functionp fun) (not (compiled-function-p fun))) 1176 (setq fun (%svref fun 1))1147 (setq fun (%svref fun 2)) 1177 1148 (when (vectorp fun) 1178 1149 (setq fun (svref fun 0)))) … … 1182 1153 ;;; For use by (setf (apply ...) ...) 1183 1154 ;;; (apply+ f butlast last) = (apply f (append butlast (list last))) 1184 #+ppc-target 1185 (defun apply+ (&lap function arg1 arg2 &rest other-args) 1186 (ppc-lap-function apply+ () 1187 (check-nargs 3 nil) 1188 (vpush arg_x) 1189 (mov temp0 arg_z) ; last 1190 (mov arg_z arg_y) ; butlast 1191 (subi nargs nargs '2) ; remove count for butlast & last 1192 (mflr loc-pc) 1193 (bla .SPspreadargz) 1194 (cmpri cr0 nargs '3) 1195 (mtlr loc-pc) 1196 (addi nargs nargs '1) ; count for last 1197 (blt cr0 @nopush) 1198 (vpush arg_x) 1199 @nopush 1200 (mov arg_x arg_y) 1201 (mov arg_y arg_z) 1202 (mov arg_z temp0) 1203 (ldr temp0 'funcall nfn) 1204 (ba .SPfuncall))) 1205 1206 (lfun-bits #'apply+ (logior $lfbits-rest-bit 1207 (dpb 3 $lfbits-numreq 0))) 1208 1209 ;;; end of ppc-def.lisp 1155 (defarmlapfunction apply+ () 1156 (:arglist (function arg1 arg2 &rest other-args)) 1157 (check-nargs 3 nil) 1158 (vpush1 arg_x) 1159 (mov temp0 arg_z) ; last 1160 (mov arg_z arg_y) ; butlast 1161 (sub nargs nargs '2) ; remove count for butlast & last 1162 (build-lisp-frame) 1163 (bl .SPspreadargz) 1164 (cmp nargs '3) 1165 (restore-lisp-frame) 1166 (add nargs nargs '1) ; count for last 1167 (strhs arg_x (:@! vsp (:$ -4))) 1168 (mov arg_x arg_y) 1169 (mov arg_y arg_z) 1170 (mov arg_z temp0) 1171 (ldr nfn (:@ nfn 'funcall)) 1172 (ba .SPfuncall)) 1173 1174 1175 1176 ;;; end of arm-def.lisp -
branches/arm/level-0/ARM/arm-misc.lisp
r13706 r13789 371 371 (bx lr))) 372 372 373 #+notyet ; needs ARM subprim ?374 373 (defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z)) 375 (li imm0 (+ (target-nil-value) (arm::kernel-global gcable-pointers))) 376 @again 377 (lrarx arg_y rzero imm0) 378 (str arg_y arm::xmacptr.link ptr) 379 (strcx. ptr rzero imm0) 374 (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil))) 375 (add imm1 imm0 (:$ (arm::kernel-global gcable-pointers))) 376 @again 377 (ldrex arg_y (:@ imm1)) 378 (str arg_y (:@ ptr (:$ arm::xmacptr.link))) 379 (strex imm0 ptr (:@ imm1)) 380 (cmp imm0 (:$ 0)) 380 381 (bne @again) 381 (isync)382 382 (bx lr)) 383 383 384 384 ;;; Atomically increment or decrement the gc-inhibit-count kernel-global 385 385 ;;; (It's decremented if it's currently negative, incremented otherwise.) 386 #+notyet ;needs ARM subprim ?387 386 (defarmlapfunction %lock-gc-lock () 388 ( li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count)))389 @again390 (lrarx arg_y rzero imm0)391 ( cmpri cr1 arg_y 0)392 ( addi arg_z arg_y '1)393 ( bge cr1 @store)394 (sub iarg_z arg_y '1)387 (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil))) 388 (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count))) 389 @again 390 (ldrex arg_y (:@ imm1)) 391 (cmp arg_y (:$ 0)) 392 (add arg_z arg_y '1) 393 (sublt arg_z arg_y '1) 395 394 @store 396 (strcx. arg_z rzero imm0) 395 (strex imm0 arg_z (:@ imm1)) 396 (cmp imm0 (:$ 0)) 397 397 (bne @again) 398 ;; (isync)399 398 (bx lr)) 400 399 … … 506 505 ;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value 507 506 ;;; was equal to OLDVAL. Return the old value 508 # notyet ;still507 #+notyet ;still 509 508 (defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) 510 509 (macptr-ptr imm0 ptr) … … 666 665 667 666 668 667 #+notyet 669 668 (defarmlapfunction %%save-application ((flags arg_y) (fd arg_z)) 670 669 (unbox-fixnum imm0 flags) 671 (or iimm0 imm0 arch::gc-trap-function-save-application)670 (orr imm0 imm0 arch::gc-trap-function-save-application) 672 671 (unbox-fixnum imm1 fd) 673 672 (trlgei allocptr 0) -
branches/arm/level-0/l0-cfm-support.lisp
r13067 r13789 46 46 ;; be more likely to be fixnums, for instance), so ensure that they 47 47 ;; aren't. 48 #+ x86-target48 #+(or x86-target arm-target) 49 49 (%setf-macptr addr (%int-to-ptr 50 50 (if (< entry 0) 51 51 (logand entry (1- (ash 1 target::nbits-in-word))) 52 52 entry))) 53 #-(or ppc-target x86-target ) (dbg "Fix entry->addr"))53 #-(or ppc-target x86-target arm-target) (dbg "Fix entry->addr")) 54 54 55 55 … … 653 653 (unless (%null-ptr-p addr) ; No function can have address 0 654 654 (or (macptr->fixnum addr) (%inc-ptr addr 0)))) 655 #+ x8632-target655 #+(or x8632-target arm-target) 656 656 (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) 657 657 :address handle -
branches/arm/level-0/l0-hash.lisp
r13279 r13789 96 96 (declare (fixnum typecode)) 97 97 (or (= typecode target::subtag-macptr) 98 #+(or ppc32-target x8632-target )98 #+(or ppc32-target x8632-target arm-target) 99 99 (and (>= typecode target::min-numeric-subtag) 100 100 (<= typecode target::max-numeric-subtag)) -
branches/arm/level-0/l0-pred.lisp
r13067 r13789 90 90 (let* ((typecode (typecode x))) 91 91 (declare (fixnum typecode)) 92 #+(or ppc32-target x8632-target )92 #+(or ppc32-target x8632-target arm-target) 93 93 (and (>= typecode target::min-numeric-subtag) 94 94 (<= typecode target::max-rational-subtag)) … … 115 115 (let* ((typecode (typecode x))) 116 116 (declare (fixnum typecode)) 117 #+(or ppc32-target x8632-target )117 #+(or ppc32-target x8632-target arm-target) 118 118 (or (= typecode target::tag-fixnum) 119 119 (and (>= typecode target::min-numeric-subtag) … … 144 144 (let* ((typecode (typecode x))) 145 145 (declare (fixnum typecode)) 146 #+(or ppc32-target x8632-target )146 #+(or ppc32-target x8632-target arm-target) 147 147 (or (= typecode target::tag-fixnum) 148 148 (and (>= typecode target::min-numeric-subtag) … … 223 223 ;;; things that it wasn't true of on the 68K. 224 224 (defun gvectorp (x) 225 #+(or ppc32-target x8632-target )225 #+(or ppc32-target x8632-target arm-target) 226 226 (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader) 227 227 #+ppc64-target … … 238 238 239 239 (defun ivectorp (x) 240 #+(or ppc32-target x8632-target )240 #+(or ppc32-target x8632-target arm-target) 241 241 (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) 242 242 target::fulltag-immheader) … … 254 254 255 255 (defun miscobjp (x) 256 #+(or ppc32-target x8632-target x8664-target )256 #+(or ppc32-target x8632-target x8664-target arm-target) 257 257 (= (the fixnum (lisptag x)) target::tag-misc) 258 258 #+ppc64-target … … 1053 1053 (defun symbolp (thing) 1054 1054 "Return true if OBJECT is a SYMBOL, and NIL otherwise." 1055 #+(or ppc32-target x8632-target )1055 #+(or ppc32-target x8632-target arm-target) 1056 1056 (if thing 1057 1057 (= (the fixnum (typecode thing)) target::subtag-symbol) -
branches/arm/level-0/l0-symbol.lisp
r13279 r13789 206 206 (defun symbol-name (sym) 207 207 "Return SYMBOL's name as a string." 208 #+(or ppc32-target x8632-target x8664-target )208 #+(or ppc32-target x8632-target x8664-target arm-target) 209 209 (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell) 210 210 #+ppc64-target -
branches/arm/level-1/l1-sockets.lisp
r13382 r13789 949 949 #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag) 950 950 (<= subtype x8664::max-8-bit-ivector-subtag)) 951 #+arm-target (and (<= arm::min-8-bit-ivector-subtag subtype) 952 (<= subtype arm::max-8-bit-ivector-subtag)) 951 953 (report-bad-arg buf `(or (array character) 952 954 (array (unsigned-byte 8)) -
branches/arm/lib/compile-ccl.lisp
r13779 r13789 102 102 (defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image )) 103 103 (defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image )) 104 (defparameter *arm-xload-modules* '(xarmfasload xfasload heap-image )) 104 105 105 106 … … 107 108 (defparameter *ppc-xdev-modules* '(ppc-lapmacros )) 108 109 (defparameter *x86-xdev-modules* '(x86-lapmacros )) 110 (defparameter *arm-xdev-modules* '(arm-lapmacros )) 109 111 110 112 (defun target-xdev-modules (&optional (target … … 113 115 (case target 114 116 ((:ppc32 :ppc64) *ppc-xdev-modules*) 115 ((:x8632 :x8664) *x86-xdev-modules*))) 117 ((:x8632 :x8664) *x86-xdev-modules*) 118 (:arm *arm-xdev-modules*))) 116 119 117 120 (defun target-xload-modules (&optional (target … … 120 123 ((:ppc32 :ppc64) *ppc-xload-modules*) 121 124 (:x8632 *x8632-xload-modules*) 122 (:x8664 *x8664-xload-modules*))) 125 (:x8664 *x8664-xload-modules*) 126 (:arm *arm-xload-modules*))) 123 127 124 128 … … 386 390 387 391 (defun target-xcompile-ccl (target &optional force) 388 (require-update-modules *sysdef-modules* force) ;in the host 392 (let* ((*target-backend* *host-backend*)) 393 (require-update-modules *sysdef-modules* force)) ;in the host 389 394 (let* ((backend (or (find-backend target) *target-backend*)) 390 395 (arch (backend-target-arch-name backend)) -
branches/arm/lib/foreign-types.lisp
r13067 r13789 102 102 (:win32 "ccl:win32-headers;") 103 103 (:solarisx8632 "ccl:solarisx86-headers;") 104 (:freebsdx8632 "ccl:freebsd-headers;")) 104 (:freebsdx8632 "ccl:freebsd-headers;") 105 (:linuxarm "ccl:arm-headers;")) 105 106 :interface-package-name 106 107 #.(ftd-interface-package-name *target-ftd*) -
branches/arm/lib/nfcomp.lisp
r13757 r13789 144 144 (warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-target*) 145 145 (setq target *fasl-target* backend *target-backend*)) 146 (unless (eq *target-backend* *host-backend*) 147 (setq save-source-locations nil)) 146 148 (multiple-value-bind (output-file truename warnings-p serious-p) 147 149 (loop -
branches/arm/lib/systems.lisp
r13779 r13789 134 134 (xx8632fasload "ccl:xdump;xx8632-fasload" ("ccl:xdump;xx8632-fasload.lisp")) 135 135 (xx8664fasload "ccl:xdump;xx8664-fasload" ("ccl:xdump;xx8664-fasload.lisp")) 136 (xarmfasload "ccl:xdump;xarm-fasload" ("ccl:xdump;xarmfasload.lisp")) 136 137 (heap-image "ccl:xdump;heap-image" ("ccl:xdump;heap-image.lisp")) 137 138 (xsym "ccl:xdump;xsym" ("ccl:xdump;xsym.lisp")) -
branches/arm/lisp-kernel/area.h
r13719 r13789 153 153 #define PURESPACE_SIZE (1LL<<30LL) 154 154 #else 155 #ifdef ARM 156 #define PURESPACE_RESERVE (8<<20) 157 #define PURESPACE_SIZE (4<<20) 158 #else 155 159 #define PURESPACE_RESERVE (128<<20) /* MB */ 156 160 #define PURESPACE_SIZE (64<<20) 161 #endif 157 162 #endif 158 163 -
branches/arm/lisp-kernel/arm-constants.s
r13785 r13789 348 348 _struct(lisp_frame,0) 349 349 _node(marker) 350 _node(savevsp) 350 351 _node(savefn) 351 _node(savevsp)352 352 _node(savelr) 353 353 _ends -
branches/arm/lisp-kernel/arm-exceptions.c
r13737 r13789 129 129 130 130 instr = program_counter[-4]; 131 if (IS_SUB_LO W_FROM_ALLOCPTR(instr)) {131 if (IS_SUB_LO_FROM_ALLOCPTR(instr)) { 132 132 return -((signed_natural)(disp | (instr & 0xff))); 133 133 } -
branches/arm/lisp-kernel/arm-spentry.s
r13786 r13789 296 296 __(beq _SPmakes64) 297 297 __(bgt 9f) 298 __(mov imm1,imm1,asl imm2) 299 __(rsb imm2,imm2,#32) 300 __(orr imm1,imm1,imm0,asr imm2) 301 __(unbox_fixnum(imm2,arg_z)) 302 __(mov imm0,imm0,asl imm2) 298 __(rsb imm1,imm2,#32) 299 __(mov imm1,imm0,asr imm1) 300 __(mov imm0,imm0,lsl imm2) 303 301 __(b _SPmakes64) 304 302 9: … … 803 801 __(cmp arg_z,arg_y) 804 802 __(_rplaca(arg_y,arg_z)) 805 __(bx ls lr)803 __(bxhs lr) 806 804 __(ref_global(temp0,ref_base)) 807 805 __(sub imm0,arg_y,temp0) 808 806 __(mov imm0,imm0,lsr #dnode_shift) 809 __(ref_global( temp0,oldspace_dnode_count))810 __(cmp imm0, temp0)807 __(ref_global(imm1,oldspace_dnode_count)) 808 __(cmp imm0,imm1) 811 809 __(bxhs lr) 812 810 __(and imm2,imm0,#31) … … 814 812 __(mov imm1,imm1,lsr imm2) 815 813 __(mov imm0,imm0,lsr #bitmap_shift) 816 __(ref_global( imm2,refbits))817 __(add imm2,imm2,imm0,lsl #word_shift)818 __(ldr imm0,[imm2])819 __( ands imm0,imm0,imm1)820 __( bxne lr)821 __( build_lisp_frame(imm0))822 __( set_ref_bit(rplaca))814 __(ref_global(temp0,refbits)) 815 __(add temp0,temp0,imm0,lsl #word_shift) 816 0: __(ldrex imm2,[temp0]) 817 __(orr imm2,imm2,imm1) 818 __(strex imm0,imm2,[temp0]) 819 __(cmp imm0,#0) 820 __(bne 0b) 823 821 __(bx lr) 824 822 … … 829 827 __(cmp arg_z,arg_y) 830 828 __(_rplacd(arg_y,arg_z)) 831 __(bx ls lr)829 __(bxhs lr) 832 830 __(ref_global(temp0,ref_base)) 833 831 __(sub imm0,arg_y,temp0) 834 832 __(mov imm0,imm0,lsr #dnode_shift) 835 __(ref_global( temp0,oldspace_dnode_count))836 __(cmp imm0, temp0)833 __(ref_global(imm1,oldspace_dnode_count)) 834 __(cmp imm0,imm1) 837 835 __(bxhs lr) 838 836 __(and imm2,imm0,#31) … … 840 838 __(mov imm1,imm1,lsr imm2) 841 839 __(mov imm0,imm0,lsr #bitmap_shift) 842 __(ref_global( imm2,refbits))843 __(add imm2,imm2,imm0,lsl #word_shift)844 __(ldr imm0,[imm2])845 __( ands imm0,imm0,imm1)846 __( bxne lr)847 __( build_lisp_frame(imm0))848 __( set_ref_bit(rplacd))840 __(ref_global(temp0,refbits)) 841 __(add temp0,temp0,imm0,lsl #word_shift) 842 0: __(ldrex imm2,[temp0]) 843 __(orr imm2,imm2,imm1) 844 __(strex imm0,imm2,[temp0]) 845 __(cmp imm0,#0) 846 __(bne 0b) 849 847 __(bx lr) 850 848 … … 929 927 dnl __(isync) 930 928 dnl __(bx lr) 931 dnl 932 dnl /* 933 dnl Interrupt handling (in pc_luser_xp()) notes: 934 dnl If we are in this function and before the test which follows the 935 dnl conditional (at egc_store_node_conditional), or at that test 936 dnl and cr0`eq' is clear, pc_luser_xp() should just let this continue 937 dnl (we either haven't done the store conditional yet, or got a 938 dnl possibly transient failure.) If we're at that test and the 939 dnl cr0`EQ' bit is set, then the conditional store succeeded and 940 dnl we have to atomically memoize the possible intergenerational 941 dnl reference. Note that the local labels 4 and 5 are in the 942 dnl body of the next subprim (and at or beyond 'egc_write_barrier_end'). 943 dnl 944 dnl N.B: it's not possible to really understand what's going on just 945 dnl by the state of the cr0`eq' bit. A transient failure in the 946 dnl conditional stores that handle memoization might clear cr0`eq' 947 dnl without having completed the memoization. 948 dnl */ 949 dnl 929 930 931 /* 932 Interrupt handling (in pc_luser_xp()) notes: 933 If we are in this function and before the test which follows the 934 conditional (at egc_store_node_conditional), or at that test 935 and cr0`eq' is clear, pc_luser_xp() should just let this continue 936 (we either haven't done the store conditional yet, or got a 937 possibly transient failure.) If we're at that test and the 938 cr0`EQ' bit is set, then the conditional store succeeded and 939 we have to atomically memoize the possible intergenerational 940 reference. Note that the local labels 4 and 5 are in the 941 body of the next subprim (and at or beyond 'egc_write_barrier_end'). 942 943 N.B: it's not possible to really understand what's going on just 944 by the state of the cr0`eq' bit. A transient failure in the 945 conditional stores that handle memoization might clear cr0`eq' 946 without having completed the memoization. 947 */ 948 950 949 .globl C(egc_store_node_conditional) 951 950 .globl C(egc_write_barrier_end) 952 951 _spentry(store_node_conditional) 953 952 C(egc_store_node_conditional): 954 dnl __(cmplr(cr2,arg_z,arg_x)) 955 dnl __(vpop(temp0)) 956 dnl __(unbox_fixnum(imm4,temp0)) 957 dnl 1: __(lrarx(temp1,arg_x,imm4)) 958 dnl __(cmpr(cr1,temp1,arg_y)) 959 dnl __(bne cr1,5f) 960 dnl __(strcx(arg_z,arg_x,imm4)) 961 .globl C(egc_store_node_conditional_test) 953 __(vpop1(temp0)) 954 955 1: __(unbox_fixnum(imm2,temp0)) 956 __(add imm2,imm2,arg_x) 957 __(ldrex temp1,[imm2]) 958 __(cmp temp1,arg_y) 959 __(bne 5f) 960 __(strex imm0,arg_z,[imm2]) 961 .globl C(egc_store_node_conditional_test) 962 962 C(egc_store_node_conditional_test): 963 dnl __(bne 1b) 964 dnl __(isync) 965 dnl __(add imm0,imm4,arg_x) 966 dnl __(ref_global(imm2,ref_base)) 967 dnl __(ref_global(imm1,oldspace_dnode_count)) 968 dnl __(sub imm0,imm0,imm2) 969 dnl __(load_highbit(imm3)) 970 dnl __(srri(imm0,imm0,dnode_shift)) 971 dnl __(cmplr(imm0,imm1)) 972 dnl __(extract_bit_shift_count(imm2,imm0)) 973 dnl __(srri(imm0,imm0,bitmap_shift)) 974 dnl __(srr(imm3,imm3,imm2)) 975 dnl __(ref_global(imm2,refbits)) 976 dnl __(bge 4f) 977 dnl __(slri(imm0,imm0,word_shift)) 978 dnl 2: __(lrarx(imm1,imm2,imm0)) 979 dnl __(or imm1,imm1,imm3) 980 dnl __(strcx( imm1,imm2,imm0)) 981 dnl __(bne- 2b) 982 dnl __(isync) 983 dnl __(b 4f) 984 dnl 985 dnl /* arg_z = new value, arg_y = expected old value, arg_x = hash-vector, 986 dnl vsp`0' = (boxed) byte-offset 987 dnl Interrupt-related issues are as in store_node_conditional, but 988 dnl we have to do more work to actually do the memoization.*/ 963 __(cmp imm0,#0) 964 __(bne 1b) 965 __(cmp arg_z,arg_x) 966 __(blo 4f) 967 968 __(ref_global(imm0,ref_base)) 969 __(ref_global(imm1,oldspace_dnode_count)) 970 __(sub imm0,imm2,imm0) 971 __(mov imm0,imm0,lsr #dnode_shift) 972 __(cmp imm0,imm1) 973 __(bhs 4f) 974 __(and imm1,imm0,#31) 975 __(mov arg_x,#0x80000000) 976 __(mov imm1,arg_x,lsr imm1) 977 __(ref_global(temp0,refbits)) 978 __(mov imm0,imm0,lsr #bitmap_shift) 979 __(add temp0,temp0,imm0,lsl #word_shift) 980 2: __(ldrex imm2,[temp0]) 981 __(orr imm2,imm2,imm1) 982 __(strex imm0,imm2,[temp0]) 983 __(cmp imm0,#0) 984 __(bne 2b) 985 __(b 4f) 986 987 /* arg_z = new value, arg_y = expected old value, arg_x = hash-vector, 988 vsp`0' = (boxed) byte-offset 989 Interrupt-related issues are as in store_node_conditional, but 990 l we have to do more work to actually do the memoization.*/ 989 991 _spentry(set_hash_key_conditional) 990 992 .globl C(egc_set_hash_key_conditional) … … 1037 1039 dnl __(isync) 1038 1040 C(egc_write_barrier_end): 1039 dnl 4: __(mov arg_z,#t_value) 1040 dnl __(bx lr) 1041 dnl 5: __(mov imm0,#RESERVATION_DISCHARGE) 1042 dnl __(strcx(rzero,0,imm0)) 1043 dnl __(mov arg_z,#nil_value) 1044 dnl __(bx lr) 1045 dnl 1046 dnl 1047 dnl 1048 dnl 1049 dnl 1041 4: __(mov arg_z,#nil_value) 1042 __(add arg_z,arg_z,#t_offset) 1043 __(bx lr) 1044 5: __(clrex) 1045 __(mov arg_z,#nil_value) 1046 __(bx lr) 1047 1048 1049 1050 1050 1051 1051 1052 /* We always have to create a stack frame (even if nargs is 0), so the compiler */ … … 1316 1317 /* (vpush (< imm1 nargs)) */ 1317 1318 __(cmp imm1,nargs) 1319 __(add imm1,imm1,#fixnumone) 1318 1320 __(subeq arg_x,arg_x,#t_offset) 1319 1321 __(vpush1(arg_x)) … … 2940 2942 popdef(`r',) 2941 2943 2944 2945 2946 _spentry(eabi_ff_call) 2947 __(ldr arg_y,[rcontext,#tcr.last_lisp_frame]) 2948 __(stmdb vsp!,{arg_y,arg_x,temp0,temp1,temp2}) 2949 /* There's a u32 vector on top of the stack ; its first data word points 2950 to the previous stack object. The 4 words at the bottom of the vector 2951 are reserved for a lisp frame, which we construct carefully ... */ 2952 __(mov imm0,#lisp_frame_marker) 2953 __(mov imm1,#0) 2954 __(ldr temp0,[sp,#4]) 2955 __(sub temp0,temp0,#lisp_frame.size) 2956 __(str imm0,[temp0,#lisp_frame.marker]) 2957 __(ldr imm0,[sp,#0]) 2958 __(str imm1,[temp0,#lisp_frame.savefn]) 2959 __(str imm1,[temp0,#lisp_frame.savelr]) 2960 __(sub imm0,imm0,#(lisp_frame.size/4)<<num_subtag_bits) 2961 __(str vsp,[temp0,#lisp_frame.savevsp]) 2962 __(str imm0,[sp,#0]) 2963 __(str lr,[temp0,#lisp_frame.savelr]) 2964 __(str fn,[temp0,#lisp_frame.savefn]) 2965 __(str allocptr,[rcontext,#tcr.save_allocptr]) 2966 __(str temp0,[rcontext,#tcr.last_lisp_frame]) 2967 __(mov temp0,rcontext) 2968 __(mov imm0,#TCR_STATE_FOREIGN) 2969 __(str imm0,[rcontext,#tcr.valence]) 2970 __(add sp,sp,#dnode_size) 2971 __(ldmia sp!,{r0,r1,r2,r3}) 2972 __(blx arg_z) /* fix this */ 2973 __(mov temp1,#0) 2974 __(mov temp2,#0) 2975 __(mov arg_z,#0) 2976 __(mov arg_y,#0) 2977 __(mov arg_x,#0) 2978 __(mov fn,#0) 2979 __(mov allocptr,#VOID_ALLOCPTR) 2980 __(mov rcontext,temp0) 2981 __(ldr sp,[rcontext,#tcr.last_lisp_frame]) 2982 __(str fn,[rcontext,#tcr.valence]) 2983 __(ldr allocptr,[rcontext,#tcr.save_allocptr]) 2984 __(restore_lisp_frame(temp0)) 2985 __(ldmia vsp!,{arg_y,arg_x,temp0,temp1,temp2}) 2986 __(str arg_y,[rcontext,#tcr.last_lisp_frame]) 2987 __(bx lr) 2942 2988 2943 _spentry(eabi_ff_call)2989 2944 2990 2945 2991 _spentry(debind) -
branches/arm/lisp-kernel/arm-subprims.s
r13746 r13789 76 76 __(mov imm0,imm0,lsl #num_subtag_bits-word_shift) 77 77 __(orr imm0,imm0,#subtag_u32_vector) 78 __(stm sp!,{imm0,imm2})78 __(stmdb sp!,{imm0,imm2}) 79 79 __(mov imm0,#TCR_STATE_LISP) 80 80 __(str imm0,[rcontext,#tcr.valence]) 81 81 __(ldr allocptr,[rcontext,#tcr.save_allocptr]) 82 82 __(bl toplevel_loop) 83 __(ld r imm1,[sp,#4])83 __(ldmia sp!,{imm0,imm1}) 84 84 __(mov imm0,#TCR_STATE_FOREIGN) 85 85 __(str imm1,[rcontext,#tcr.last_lisp_frame]) -
branches/arm/lisp-kernel/image.c
r13511 r13789 353 353 image_nil = (LispObj)(a->low) + (1024*4) + fulltag_cons; 354 354 #endif 355 #endif 356 #ifdef ARM 357 image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil; 355 358 #endif 356 359 set_nil(image_nil); -
branches/arm/lisp-kernel/linuxarm/Makefile
r13753 r13789 25 25 CDEFINES = -DLINUX -DARM -D_REENTRANT -D_GNU_SOURCE 26 26 CDEBUG = -g 27 COPT = -O227 COPT = #-O2 28 28 # Once in a while, -Wformat says something useful. The odds are against that, 29 29 # however. -
branches/arm/lisp-kernel/platform-linuxarm.h
r13737 r13789 26 26 27 27 28 #define MAXIMUM_MAPPABLE_MEMORY ( 1U<<30) /* uh, no */29 #define IMAGE_BASE_ADDRESS 0x 31000000 /* not likely */28 #define MAXIMUM_MAPPABLE_MEMORY (256<<20) /* uh, no */ 29 #define IMAGE_BASE_ADDRESS 0x10001000 30 30 31 31 #include "lisptypes.h" -
branches/arm/lisp-kernel/pmcl-kernel.c
r13737 r13789 1816 1816 #ifdef X86 1817 1817 lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10)); 1818 #else 1818 #endif 1819 #ifdef PPC 1819 1820 lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10); 1820 1821 #endif 1822 #ifdef ARM 1823 lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12); 1824 #endif 1825 1821 1826 lisp_global(RET1VALN) = (LispObj)&ret1valn; 1822 1827 lisp_global(LEXPR_RETURN) = (LispObj)&nvalret; … … 1941 1946 xMakeDataExecutable(void *start, unsigned long nbytes) 1942 1947 { 1943 #if ndef X861948 #ifdef PPC 1944 1949 extern void flush_cache_lines(); 1945 1950 natural ustart = (natural) start, base, end; … … 1948 1953 end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1); 1949 1954 flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size); 1955 #endif 1956 #ifdef ARM 1957 extern void flush_cache_lines(void *, void *); 1958 flush_cache_lines(start,((char *)start)+nbytes); 1950 1959 #endif 1951 1960 } -
branches/arm/lisp-kernel/thread_manager.c
r13737 r13789 1524 1524 tcr->cs_area = a; 1525 1525 a->owner = tcr; 1526 #ifdef ARM 1527 tcr->last_lisp_frame = (lisp_frame *)(a->high); 1528 #endif 1526 1529 if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) { 1527 1530 tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit); -
branches/arm/xdump/xfasload.lisp
r13279 r13789 1054 1054 ;; a function vector). The code-vector in its 0th element should 1055 1055 ;; report the appropriate error. 1056 (let* ((udf-object (xload-make-gvector :simple-vector 1))) 1057 (setf (xload-%svref udf-object 0) (xload-save-code-vector 1058 (backend-xload-info-udf-code 1059 *xload-target-backend*)))) 1056 ;; On the ARM: make a two-element vector: entrypoint, code-vector. 1057 (let* ((udf-object (xload-make-gvector :simple-vector (target-arch-case (:arm 2) (otherwise 1))))) 1058 (target-arch-case 1059 (:arm 1060 (setf (xload-%svref udf-object 0) 1061 (subprim-name->offset '.SPfix-nfn-entrypoint *target-backend*))) 1062 (otherwise )) 1063 (setf (xload-%svref udf-object (target-arch-case 1064 (:arm 1) (otherwise 0))) 1065 (xload-save-code-vector 1066 (backend-xload-info-udf-code 1067 *xload-target-backend*)))) 1060 1068 (let* ((udf-object (xload-make-gvector :simple-vector 1))) 1061 1069 (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code
Note: See TracChangeset
for help on using the changeset viewer.