From cd45202a3716df70ec202fe96503dfb15cc608f5 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Sun, 25 Jul 2004 18:15:52 +0000 Subject: [PATCH] Commit of the compiler backend portion of the PPC/Darwin port. This includes various fixes from SBCL and other sources to the PPC backend. It also does away with Gary Byers' renumbering of the type tags for function and instance pointers, which allowed for a slightly clever and presumably faster function calling convention. These changes have been conditionalized out with the PPC-FUN-HACK conditional, so that we might revisit the changes in the future. The current port has only been tested without PPC-FUN-HACK, but this might change. --- assembly/ppc/arith.lisp | 76 +++++++++++- assembly/ppc/assem-rtns.lisp | 21 +++- assembly/ppc/support.lisp | 6 +- compiler/generic/new-genesis.lisp | 18 ++- compiler/generic/objdef.lisp | 12 +- compiler/ppc/alloc.lisp | 6 +- compiler/ppc/arith.lisp | 27 ++-- compiler/ppc/array.lisp | 5 +- compiler/ppc/c-call.lisp | 197 ++++++++++++++++++++++++++---- compiler/ppc/call.lisp | 70 ++++++++--- compiler/ppc/cell.lisp | 13 +- compiler/ppc/float.lisp | 94 ++++++-------- compiler/ppc/insts.lisp | 45 +++++-- compiler/ppc/macros.lisp | 24 +++- compiler/ppc/move.lisp | 4 +- compiler/ppc/parms.lisp | 34 ++++-- compiler/ppc/print.lisp | 6 +- compiler/ppc/static-fn.lisp | 11 +- compiler/ppc/vm.lisp | 18 ++- 19 files changed, 518 insertions(+), 169 deletions(-) diff --git a/assembly/ppc/arith.lisp b/assembly/ppc/arith.lisp index ad082676e..5632f9d22 100644 --- a/assembly/ppc/arith.lisp +++ b/assembly/ppc/arith.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/arith.lisp,v 1.2 2003/08/03 11:27:51 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/arith.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -39,6 +39,8 @@ (:temp flag non-descriptor-reg nl3-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp ocfp any-reg ocfp-offset)) ; Clear the damned "sticky overflow" bit in :cr0 and :xer @@ -54,15 +56,24 @@ (inst add temp2 temp2 temp) (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FUN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'two-arg-+)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'two-arg-+)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) DONE (move res temp)) @@ -85,6 +96,8 @@ (:temp flag non-descriptor-reg nl3-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp ocfp any-reg ocfp-offset)) ; Clear the damned "sticky overflow" bit in :cr0 @@ -102,15 +115,24 @@ (inst sub temp2 temp temp2) (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FUN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'two-arg--)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'two-arg--)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) DONE (move res temp)) @@ -136,6 +158,8 @@ (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) (:temp pa-flag non-descriptor-reg nl3-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) @@ -182,15 +206,24 @@ (storew lo res bignum-digits-offset other-pointer-type))) ;; Out of here GO-HOME + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FUN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'two-arg-*)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'two-arg-*)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) LOW-FITS-IN-FIXNUM (move res lo)) @@ -308,6 +341,8 @@ (:res res descriptor-reg a0-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) @@ -317,12 +352,18 @@ (inst beq DO-COMPARE) DO-STATIC-FN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset ',static-fn)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset ',static-fn)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) DO-COMPARE (load-symbol res t) @@ -348,6 +389,8 @@ (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst cmpw :cr1 x y) @@ -359,15 +402,24 @@ RETURN-NIL (inst mr res null-tn) + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'eql)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'eql)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) RETURN-T (load-symbol res t)) @@ -385,6 +437,8 @@ (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) @@ -395,15 +449,24 @@ (inst beq :cr1 RETURN-T) (inst mr res null-tn) + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'two-arg-=)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) RETURN-T (load-symbol res t)) @@ -420,6 +483,8 @@ (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst or nargs x y) @@ -429,14 +494,23 @@ (inst beq :cr1 RETURN-NIL) (load-symbol res t) + #+PPC-FUN-HACK (lisp-return lra :offset 2) + #-PPC-FUN-HACK + (lisp-return lra lip :offset 2) DO-STATIC-FN + #+PPC-FUN-HACK (inst lwz code-tn null-tn (static-function-offset 'two-arg-=)) + #-PPC-FUN-HACK + (inst lwz lip null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) + #+PPC-FUN-HACK (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) + #-PPC-FUN-HACK + (inst j lip 0) (inst mr cfp-tn csp-tn) RETURN-NIL diff --git a/assembly/ppc/assem-rtns.lisp b/assembly/ppc/assem-rtns.lisp index 7d890ce7f..654149ead 100644 --- a/assembly/ppc/assem-rtns.lisp +++ b/assembly/ppc/assem-rtns.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/assem-rtns.lisp,v 1.2 2003/08/03 11:27:51 gerd Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/assem-rtns.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $ ;;; ;;; (in-package "PPC") @@ -27,6 +27,8 @@ (:temp lra descriptor-reg lra-offset) ;; These are just needed to facilitate the transfer + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp count any-reg nl2-offset) (:temp src any-reg nl3-offset) (:temp dst any-reg cfunc-offset) @@ -83,7 +85,10 @@ (inst add csp-tn ocfp-tn nvals) ;; Return. - (lisp-return lra)) + #+PPC-FUN-HACK + (lisp-return lra) + #-PPC-FUN-HACK + (lisp-return lra lip)) @@ -106,6 +111,8 @@ (:temp dst any-reg nl2-offset) (:temp count any-reg nl3-offset) (:temp temp descriptor-reg l0-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) @@ -142,7 +149,10 @@ DONE ;; We are done. Do the jump. (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) - (lisp-jump temp)) + #+PPC-FUN-HACK + (lisp-jump temp) + #-PPC-FUN-HACK + (lisp-jump temp lip)) @@ -156,6 +166,8 @@ (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lra descriptor-reg lra-offset) + #-PPC-FUN-HACK + (:temp lip interior-reg lip-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset)) @@ -177,7 +189,10 @@ (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) + #+PPC-FUN-HACK (lisp-return lra :frob-code nil) + #-PPC-FUN-HACK + (lisp-return lra lip :frob-code nil) DO-UWP diff --git a/assembly/ppc/support.lisp b/assembly/ppc/support.lisp index 0f7f1224e..bc234b6e5 100644 --- a/assembly/ppc/support.lisp +++ b/assembly/ppc/support.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/support.lisp,v 1.1 2001/02/11 14:21:52 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/support.lisp,v 1.2 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -61,5 +61,9 @@ `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg *backend*) :offset lra-offset) + #-PPC-FUN-HACK + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg *backend*) + :offset lip-offset) :offset 2))) (:none))) diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 721e47f8f..17ad721b6 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.69 2004/07/08 04:44:15 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.70 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -917,7 +917,8 @@ (ecase type (#.vm:function-header-type (if (or (c:backend-featurep :sparc) - (c:backend-featurep :ppc)) + (and (c:backend-featurep :ppc) + (c:backend-featurep :ppc-fun-hack))) defn (make-random-descriptor (+ (logandc2 (descriptor-bits defn) vm:lowtag-mask) @@ -1938,6 +1939,9 @@ ((and #+linkage-table nil (or linux-p freebsd4-p) (lookup-sym (concatenate 'string "PVE_stub_" name)))) + ((and #+linkage-table nil + (c:backend-featurep :darwin) + (lookup-sym (concatenate 'string "ldso_stub__" name)))) ;; Non-linux case (#-irix (lookup-sym name) @@ -2200,15 +2204,19 @@ (ecase kind (:ba (setf (sap-ref-32 sap 0) - (dpb (ash value -2) (byte 24 2) (sap-ref-32 sap 0)))) + (maybe-byte-swap + (dpb (ash value -2) (byte 24 2) + (maybe-byte-swap (sap-ref-32 sap 0)))))) (:ha (let* ((h (ldb (byte 16 16) value)) (l (ldb (byte 16 0) value))) (setf (sap-ref-16 sap 2) - (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (maybe-byte-swap-short + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))) (:l (setf (sap-ref-16 sap 2) - (ldb (byte 16 0) value))))))) + (maybe-byte-swap-short + (ldb (byte 16 0) value)))))))) (undefined-value)) (defun linkage-info-to-core () diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp index cce95f8d4..2fba6103c 100644 --- a/compiler/generic/objdef.lisp +++ b/compiler/generic/objdef.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.56 2004/05/24 23:12:30 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.57 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -96,11 +96,11 @@ ;;; (defenum (:suffix -type) even-fixnum - #-ppc function-pointer #+ppc instance-pointer + #-PPC-FUN-HACK function-pointer #+PPC-FUN-HACK instance-pointer other-immediate-0 list-pointer odd-fixnum - #-ppc instance-pointer #+ppc function-pointer + #-PPC-FUN-HACK instance-pointer #+PPC-FUN-HACK function-pointer other-immediate-1 other-pointer) @@ -303,7 +303,7 @@ (define-primitive-object (function :type function :lowtag function-pointer-type :header function-header-type) - #+ppc (jump-insn) + #+PPC-FUN-HACK (jump-insn) #-gengc (self :ref-trans %function-self :set-trans (setf %function-self)) #+gengc (entry-point :c-type "char *") (next :type (or function null) @@ -331,7 +331,7 @@ (define-primitive-object (closure :lowtag function-pointer-type :header closure-header-type) - #+ppc (jump-insn) + #+PPC-FUN-HACK (jump-insn) #-gengc (function :init :arg :ref-trans %closure-function) #+gengc (entry-point :c-type "char *") (info :rest-p t)) @@ -340,7 +340,7 @@ :lowtag function-pointer-type :header funcallable-instance-header-type :alloc-trans %make-funcallable-instance) - #+ppc (jump-insn) + #+PPC-FUN-HACK (jump-insn) #-gengc (function :ref-known (flushable) :ref-trans %funcallable-instance-function diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp index 26ea125a1..e773f04b7 100644 --- a/compiler/ppc/alloc.lisp +++ b/compiler/ppc/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.4 2003/08/25 20:50:58 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.5 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -130,7 +130,7 @@ (:translate make-fdefn) (:generator 37 (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size) - (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign)) (storew name result fdefn-name-slot other-pointer-type) (storew null-tn result fdefn-function-slot other-pointer-type) (storew temp result fdefn-raw-addr-slot other-pointer-type)))) @@ -150,7 +150,9 @@ (inst ori result result function-pointer-type) (inst lr temp (logior (ash (1- size) type-bits) closure-header-type)) (storew temp result 0 function-pointer-type))) + #+PPC-FUN-HACK (inst lis temp (ash 18 10)) + #+PPC-FUN-HACK (storew temp result closure-jump-insn-slot function-pointer-type) (storew function result closure-function-slot function-pointer-type))) diff --git a/compiler/ppc/arith.lisp b/compiler/ppc/arith.lisp index 4a7ad4474..3edde59ba 100644 --- a/compiler/ppc/arith.lisp +++ b/compiler/ppc/arith.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/arith.lisp,v 1.3 2003/08/03 11:27:47 gerd Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/arith.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $ ;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; @@ -92,7 +92,6 @@ (:result-types signed-num) (:note "inline (signed-byte 32) arithmetic")) - (define-vop (fast-fixnum-binop-c fast-safe-arith-op) (:args (x :target r :scs (any-reg zero))) (:info y) @@ -235,7 +234,7 @@ (:note "safe inline fixnum arithmetic") (:generator 4 (let* ((no-overflow (gen-label))) - (inst mcrxr :cr0) + (inst mtxer zero-tn) (inst addo. r x y) (inst bns no-overflow) (inst unimp (logior (ash (reg-tn-encoding r) 5) @@ -250,7 +249,7 @@ (:note "safe inline fixnum arithmetic") (:generator 4 (let* ((no-overflow (gen-label))) - (inst mcrxr :cr0) + (inst mtxer zero-tn) (inst subo. r x y) (inst bns no-overflow) (inst unimp (logior (ash (reg-tn-encoding r) 5) @@ -281,7 +280,7 @@ (inst cmpwi ndesc 31) (inst srw result number ndesc) (inst ble done) - (inst srwi result number 31) + (move result zero-tn) (inst b done) (emit-label positive) @@ -289,14 +288,12 @@ (inst slw result number amount) (emit-label done))) - (immediate (let ((amount (tn-value amount))) - (if (minusp amount) - (let ((amount (min 31 (- amount)))) - (inst srwi result number amount)) - (inst slwi result number amount))))))) - + (cond + ((and (minusp amount) (< amount -31)) (move result zero-tn)) + ((minusp amount) (inst srwi result number (- amount))) + (t (inst slwi result number amount)))))))) (define-vop (fast-ash/signed=>signed) (:note "inline ASH") @@ -792,11 +789,11 @@ (define-vop (bignum-mult) (:translate bignum::%multiply) (:policy :fast-safe) - (:args (x :scs (unsigned-reg) :to (:result 1)) - (y :scs (unsigned-reg) :to (:result 1))) + (:args (x :scs (unsigned-reg) :to (:eval 1)) + (y :scs (unsigned-reg) :to (:eval 1))) (:arg-types unsigned-num unsigned-num) - (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) + (:results (hi :scs (unsigned-reg) :from (:eval 1)) + (lo :scs (unsigned-reg) :from (:eval 0))) (:result-types unsigned-num unsigned-num) (:generator 40 (inst mullw lo x y) diff --git a/compiler/ppc/array.lisp b/compiler/ppc/array.lisp index 3c7fc5e74..99b26f7e1 100644 --- a/compiler/ppc/array.lisp +++ b/compiler/ppc/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.3 2003/08/03 11:27:47 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -207,8 +207,7 @@ (inst lr temp offset) (inst lwzx result object temp)))) (unless (zerop extra) - (inst srwi result result - (logxor (* extra ,bits) ,(1- elements-per-word)))) + (inst srwi result result (* ,bits extra))) (unless (= extra ,(1- elements-per-word)) (inst andi. result result ,(1- (ash 1 bits))))))) (define-vop (,(symbolicate 'data-vector-set/ type)) diff --git a/compiler/ppc/c-call.lisp b/compiler/ppc/c-call.lisp index 49cd23ff5..81bf490c4 100644 --- a/compiler/ppc/c-call.lisp +++ b/compiler/ppc/c-call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/c-call.lisp,v 1.3 2003/07/20 13:53:11 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/c-call.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,6 +18,18 @@ ;;; (in-package "PPC") +;;; Return the number of bytes needed for the current non-descriptor +;;; stack frame. Non-descriptor stack frames must be multiples of 16 +;;; bytes under the PPC SVr4 ABI (though the EABI may be less +;;; restrictive). On linux, two words are reserved for the stack +;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT). + +(defconstant +stack-alignment-bytes+ + ;; Duh. PPC Linux (and VxWorks) adhere to the EABI. + #-darwin 7 + ;; But Darwin doesn't + #+darwin 15) + (defun my-make-wired-tn (prim-type-name sc-name offset) (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) (sc-number-or-lose sc-name *backend*) @@ -26,8 +38,13 @@ (defstruct arg-state (gpr-args 0) (fpr-args 0) - ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer). - (stack-frame-size 2)) + ;; SVR4 [a]abi wants two words on stack (callee saved lr, backpointer). + #-darwin + (stack-frame-size 2) + ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10 + ;; in addition to the 6 words of link area (see number-stack-displacement) + #+darwin + (stack-frame-size (+ 8 6))) (defun int-arg (state prim-type reg-sc stack-sc) (let ((reg-args (arg-state-gpr-args state))) @@ -48,10 +65,11 @@ (declare (ignore type)) (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) -; If a single-float arg has to go on the stack, it's promoted to -; double. That way, C programs can get subtle rounding errors -; when unrelated arguments are introduced. +;;; If a single-float arg has to go on the stack, it's promoted to +;;; double. That way, C programs can get subtle rounding errors +;;; when unrelated arguments are introduced. +#-darwin (def-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) (let* ((fprs (arg-state-fpr-args state))) @@ -66,6 +84,36 @@ (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) +#+darwin +(def-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let* ((fprs (arg-state-fpr-args state)) + (gprs (arg-state-gpr-args state))) + (cond ((< gprs 8) ; and by implication also (< fprs 13) + ;; Corresponding GPR is kept empty for functions with fixed args + (incf (arg-state-gpr-args state)) + (incf (arg-state-fpr-args state)) + ;; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + ((< fprs 13) + ;; According to PowerOpen ABI, we need to pass those both in the + ;; FPRs _and_ the stack. However empiric testing on OS X/gcc + ;; shows they are only passed in FPRs, AFAICT. + ;; + ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still + ;; reverse-engineering comments in 2003 :-) + ;; + ;; Yes, it does -- me :) + (incf (arg-state-fpr-args state)) + (incf (arg-state-stack-frame-size state)) + (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + (t + ;; Pass on stack only + (let ((stack-offset (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state)) + (my-make-wired-tn 'single-float 'single-stack stack-offset)))))) + +#-darwin (def-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let* ((fprs (arg-state-fpr-args state))) @@ -80,27 +128,71 @@ (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) -(def-alien-type-method (integer :result-tn) (type) - (if (alien-integer-type-signed type) - (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) - (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) +#+darwin +(def-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((fprs (arg-state-fpr-args state)) + (gprs (arg-state-gpr-args state))) + (cond ((< gprs 8) ; and by implication also (< fprs 13) + ;; Corresponding GPRs are also kept empty + (incf (arg-state-gpr-args state) 2) + (when (> (arg-state-gpr-args state) 8) + ;; Spill one word to stack + (decf (arg-state-gpr-args state)) + (incf (arg-state-stack-frame-size state))) + (incf (arg-state-fpr-args state)) + ;; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + ((< fprs 13) + ;; According to PowerOpen ABI, we need to pass those both in the + ;; FPRs _and_ the stack. However empiric testing on OS X/gcc + ;; shows they are only passed in FPRs, AFAICT. + (incf (arg-state-stack-frame-size state) 2) + (incf (arg-state-fpr-args state)) + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + (t + ;; Pass on stack only + (let ((stack-offset (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state) 2) + (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) +;;; Result state handling -(def-alien-type-method (system-area-pointer :result-tn) (type) - (declare (ignore type)) - (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) +(defstruct result-state + (num-results 0)) -(def-alien-type-method (single-float :result-tn) (type) +(defun generate-result-reg-offset (state) + (let ((slot (result-state-num-results state))) + (incf (result-state-num-results state)) + (ecase slot + (0 nl0-offset) + (1 nl1-offset)))) + +(def-alien-type-method (integer :result-tn) (type state) + (let ((offset (generate-result-reg-offset state))) + (if (alien-integer-type-signed type) + (my-make-wired-tn 'signed-byte-32 'signed-reg offset) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg offset)))) + + +(def-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (generate-result-reg-offset state))) + +(def-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type state)) (my-make-wired-tn 'single-float 'single-reg 1)) -(def-alien-type-method (double-float :result-tn) (type) - (declare (ignore type)) +(def-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type state)) (my-make-wired-tn 'double-float 'double-reg 1)) -(def-alien-type-method (values :result-tn) (type) +(def-alien-type-method (values :result-tn) (type state) + (when (> (length (alien-values-type-values type)) 2) + (error "Too many result values from c-call.")) (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type)) + (invoke-alien-type-method :result-tn type state)) (alien-values-type-values type))) @@ -115,7 +207,62 @@ (arg-tns) (invoke-alien-type-method :result-tn - (alien-function-type-result-type type)))))) + (alien-function-type-result-type type) + (make-result-state)))))) + +(deftransform %alien-funcall ((function type &rest args)) + (assert (c::constant-continuation-p type)) + (let* ((type (c::continuation-value type)) + (arg-types (alien-function-type-arg-types type)) + (result-type (alien-function-type-result-type type))) + (assert (= (length arg-types) (length args))) + (if (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32)) + (new-args `(ash ,arg -32)) + (new-args `(logand ,arg #xffffffff)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (t + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (signed 32) (unsigned 32)) + '(values (unsigned 32) (unsigned 32))))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (high low) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))) + (c::give-up)))) (define-vop (foreign-symbol-address) @@ -127,7 +274,7 @@ (:results (res :scs (sap-reg))) (:result-types system-area-pointer) (:generator 2 - (inst lr res (make-fixup foreign-symbol :foreign)))) + (inst lr res (make-fixup (extern-alien-name foreign-symbol) :foreign)))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) @@ -144,7 +291,7 @@ (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign)) (inst mtctr temp) (move cfunc function) (inst bctrl) @@ -158,7 +305,9 @@ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:generator 0 (unless (zerop amount) - (let ((delta (- (logandc2 (+ amount 8 7) 7)))) + (let ((delta (- (logandc2 (+ amount number-stack-displacement + +stack-alignment-bytes+) + +stack-alignment-bytes+)))) (cond ((>= delta (ash -1 16)) (inst stwu nsp-tn nsp-tn delta)) (t @@ -175,7 +324,9 @@ (:policy :fast-safe) (:generator 0 (unless (zerop amount) - (let ((delta (logandc2 (+ amount 8 7) 7))) + (let ((delta (logandc2 (+ amount number-stack-displacement + +stack-alignment-bytes+) + +stack-alignment-bytes+))) (cond ((< delta (ash 1 16)) (inst addi nsp-tn nsp-tn delta)) (t diff --git a/compiler/ppc/call.lisp b/compiler/ppc/call.lisp index cdab3cd45..e99502e5a 100644 --- a/compiler/ppc/call.lisp +++ b/compiler/ppc/call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.4 2003/08/05 15:51:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.5 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -141,11 +141,11 @@ ;;; are reserved for the stack backlink and saved LR (see PPC::NUMBER-STACK- ;;; DISPLACEMENT.) ;;; -;;; Duh. PPC Linux (and VxWorks) adhere to the EABI. +;;; Duh. PPC Linux (and VxWorks) adhere to the EABI, but Darwin doesn't. (defun bytes-needed-for-non-descriptor-stack-frame () - (logandc2 (+ 7 number-stack-displacement + (logandc2 (+ +stack-alignment-bytes+ number-stack-displacement (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes)) - 7)) + +stack-alignment-bytes+)) ;;; Used for setting up the Old-FP in local call. @@ -178,16 +178,26 @@ (align vm:lowtag-bits) (trace-table-entry trace-table-function-prologue) (emit-label start-lab) + #+PPC-FUN-HACK (let* ((entry-label (gen-label))) ;; Allocate function header. (inst function-header-word) (inst b entry-label) (dotimes (i (1- (1- vm:function-code-offset))) (inst word 0)) - (emit-label entry-label)) - ;; The start of the actual code. - ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn code-tn code-tn start-lab temp) + (emit-label entry-label) + ;; The start of the actual code. + ;; Fix CODE, cause the function object was passed in. + (inst compute-code-from-fn code-tn code-tn start-lab temp)) + #-PPC-FUN-HACK + (let* ((entry-label (gen-label))) + ;; Allocate function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst word 0)) + (emit-label entry-label) + ;; The start of the actual code. + (inst compute-code-from-fn code-tn lip-tn entry-label temp)) ;; Build our stack frames. (inst addi csp-tn cfp-tn (* vm:word-bytes (sb-allocated-size 'control-stack))) @@ -358,9 +368,8 @@ default-value-8 ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) - (when (null (cdr remaining)) - (inst b defaulting-done)) (store-stack-tn (cdr def) null-tn))) + (inst b defaulting-done) (trace-table-entry trace-table-normal)))))) (inst compute-code-from-lra code-tn code-tn lra-label temp))) @@ -697,7 +706,8 @@ default-value-8 return-pc-pass) ,(if named - `(:temporary (:sc descriptor-reg :offset cname-offset + `(:temporary (:sc descriptor-reg :offset #+PPC-FUN-HACK cname-offset + #-PPC-FUN-HACK fdefn-offset :from (:argument ,(if (eq return :tail) 0 1)) :to :eval) name-pass) @@ -725,6 +735,8 @@ default-value-8 '((:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + (:temporary (:sc interior-reg :offset lip-offset) entry-point) + (:generator ,(+ (if named 5 0) (if variable 19 1) (if (eq return :tail) 0 10) @@ -807,8 +819,12 @@ default-value-8 (loadw name-pass code-tn (tn-offset name) vm:other-pointer-type) (do-next-filler))) + #+PPC-FUN-HACK (loadw function name-pass fdefn-raw-addr-slot other-pointer-type) + #-PPC-FUN-HACK + (loadw entry-point name-pass fdefn-raw-addr-slot + other-pointer-type) (do-next-filler)) `((sc-case arg-fun (descriptor-reg (move lexenv arg-fun)) @@ -821,15 +837,19 @@ default-value-8 (do-next-filler))) (loadw function lexenv vm:closure-function-slot vm:function-pointer-type) - (do-next-filler))) + (do-next-filler) + #-PPC-FUN-HACK + (inst addi entry-point function + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type)))) (loop (if filler (do-next-filler) (return))) (note-this-location vop :call-site) - (inst mtctr function) - (inst mr code-tn function) + (inst mtctr #+PPC-FUN-HACK function #-PPC-FUN-HACK entry-point) + #+PPC-FUN-HACK-MAYBE (inst mr code-tn function) (inst bctr) #| (inst j function @@ -914,6 +934,8 @@ default-value-8 (return-pc :scs (descriptor-reg)) (value)) (:ignore value) + #-PPC-FUN-HACK + (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 6 (trace-table-entry trace-table-function-epilogue) @@ -927,7 +949,10 @@ default-value-8 (move csp-tn cfp-tn) (move cfp-tn old-fp) ;; Out of here. + #+PPC-FUN-HACK (lisp-return return-pc :offset 2) + #-PPC-FUN-HACK + (lisp-return return-pc lip :offset 2) (trace-table-entry trace-table-normal))) ;;; Do unknown-values return of a fixed number of values. The Values are @@ -956,6 +981,8 @@ default-value-8 (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) (:temporary (:sc any-reg :offset nargs-offset) nargs) (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + #-PPC-FUN-HACK + (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 6 (trace-table-entry trace-table-function-epilogue) @@ -970,7 +997,10 @@ default-value-8 (move csp-tn cfp-tn) (move cfp-tn old-fp) ;; Out of here. - (lisp-return return-pc :offset 2)) + #+PPC-FUN-HACK + (lisp-return return-pc :offset 2) + #-PPC-FUN-HACK + (lisp-return return-pc lip :offset 2)) (t ;; Establish the values pointer and values count. (move val-ptr cfp-tn) @@ -984,7 +1014,10 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return return-pc))) + #+PPC-FUN-HACK + (lisp-return return-pc) + #-PPC-FUN-HACK + (lisp-return return-pc lip))) (trace-table-entry trace-table-normal))) ;;; Do unknown-values return of an arbitrary number of values (passed on the @@ -1004,6 +1037,8 @@ default-value-8 (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals) (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) (:temporary (:sc descriptor-reg :offset a0-offset) a0) + #-PPC-FUN-HACK + (:temporary (:scs (interior-reg)) lip) (:vop-var vop) @@ -1026,7 +1061,10 @@ default-value-8 ;; Return with one value. (move csp-tn cfp-tn) (move cfp-tn old-fp-arg) + #+PPC-FUN-HACK (lisp-return lra-arg :offset 2) + #-PPC-FUN-HACK + (lisp-return lra-arg lip :offset 2) ;; Nope, not the single case. (emit-label not-single) diff --git a/compiler/ppc/cell.lisp b/compiler/ppc/cell.lisp index 2595f5a40..6400cc650 100644 --- a/compiler/ppc/cell.lisp +++ b/compiler/ppc/cell.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/cell.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/cell.lisp,v 1.2 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -123,10 +123,16 @@ (let ((normal-fn (gen-label))) (load-type type function (- function-pointer-type)) (inst cmpwi type function-header-type) + #+PPC-FUN-HACK (inst mr lip function) + #-PPC-FUN-HACK + (inst addi lip function + (- (ash vm:function-code-offset vm:word-shift) + function-pointer-type)) (inst beq normal-fn) - (inst lr lip (make-fixup "closure_tramp" :foreign)) + (inst lr lip (make-fixup (extern-alien-name "closure_tramp") :foreign)) (emit-label normal-fn) + ;;PRM:FIXME? Order of following stores is reversed in SBCL (storew function fdefn fdefn-function-slot other-pointer-type) (storew lip fdefn fdefn-raw-addr-slot other-pointer-type) (move result function)))) @@ -139,7 +145,7 @@ (:results (result :scs (descriptor-reg))) (:generator 38 (storew null-tn fdefn fdefn-function-slot other-pointer-type) - (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign)) (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) (move result fdefn))) @@ -256,6 +262,7 @@ (:translate %instance-ref) (:arg-types instance (:constant index))) +;;PRM:FIXME? Commented out in SBCL (define-vop (instance-set slot-set) (:policy :fast-safe) (:translate %instance-set) diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp index 2a6ff2276..9436f3d03 100644 --- a/compiler/ppc/float.lisp +++ b/compiler/ppc/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.2 2001/02/11 16:43:18 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -139,7 +139,7 @@ :offset (tn-offset x))) (defun complex-double-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) - :offset (+ (tn-offset x) 2))) + :offset (1+ (tn-offset x)))) (define-move-function (load-complex-single 2) (vop x y) @@ -510,8 +510,7 @@ (:args (x :scs (,from-sc) :target temp)) (:temporary (:from (:argument 0) :sc single-reg) temp) (:temporary (:scs (double-stack)) stack-temp) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) + (:results (y :scs (signed-reg))) (:arg-types ,from-type) (:result-types signed-num) (:translate ,trans) @@ -522,15 +521,10 @@ (:generator 5 (note-this-location vop :internal-error) (inst ,inst temp x) - (sc-case y - (signed-stack - (inst stfd temp (current-nfp-tn vop) - (* (tn-offset y) vm:word-bytes))) - (signed-reg - (inst stfd temp (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst lwz y (current-nfp-tn vop) - (+ 4 (* (tn-offset stack-temp) vm:word-bytes))))))))) + (inst stfd temp (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst lwz y (current-nfp-tn vop) + (+ 4 (* (tn-offset stack-temp) vm:word-bytes))))))) (frob %unary-truncate single-reg single-float fctiwz) (frob %unary-truncate double-reg double-float fctiwz) (frob %unary-round single-reg single-float fctiw) @@ -632,68 +626,50 @@ (define-vop (double-float-high-bits) (:args (float :scs (double-reg descriptor-reg) :load-if (not (sc-is float double-stack)))) - (:results (hi-bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is hi-bits signed-stack))))) - (:temporary (:scs (signed-stack)) stack-temp) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) (:result-types signed-num) (:translate double-float-high-bits) (:policy :fast-safe) (:vop-var vop) (:generator 5 - (sc-case hi-bits - (signed-reg - (sc-case float - (double-reg - (inst stfd float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst lwz hi-bits (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes))) - (double-stack - (inst lwz hi-bits (current-nfp-tn vop) - (* (tn-offset float) vm:word-bytes))) - (descriptor-reg - (loadw hi-bits float vm:double-float-value-slot - vm:other-pointer-type)))) - (signed-stack - (sc-case float - (double-reg - (inst stfd float (current-nfp-tn vop) - (* (tn-offset hi-bits) vm:word-bytes)))))))) + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (double-stack + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw hi-bits float vm:double-float-value-slot + vm:other-pointer-type))))) (define-vop (double-float-low-bits) (:args (float :scs (double-reg descriptor-reg) :load-if (not (sc-is float double-stack)))) - (:results (lo-bits :scs (unsigned-reg) - :load-if (or (sc-is float descriptor-reg double-stack) - (not (sc-is lo-bits unsigned-stack))))) - (:temporary (:scs (unsigned-stack)) stack-temp) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) (:result-types unsigned-num) (:translate double-float-low-bits) (:policy :fast-safe) (:vop-var vop) (:generator 5 - (sc-case lo-bits - (unsigned-reg - (sc-case float - (double-reg - (inst stfd float (current-nfp-tn vop) - (* (tn-offset stack-temp) vm:word-bytes)) - (inst lwz lo-bits (current-nfp-tn vop) - (* (1+ (tn-offset stack-temp)) vm:word-bytes))) - (double-stack - (inst lwz lo-bits (current-nfp-tn vop) - (* (1+ (tn-offset float)) vm:word-bytes))) - (descriptor-reg - (loadw lo-bits float (1+ vm:double-float-value-slot) - vm:other-pointer-type)))) - (unsigned-stack - (sc-case float - (double-reg - (inst stfd float (current-nfp-tn vop) - (* (tn-offset lo-bits) vm:word-bytes)))))))) + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (double-stack + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset float)) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type))))) ;;;; Float mode hackery: diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp index 7a393e169..ed6d8452c 100644 --- a/compiler/ppc/insts.lisp +++ b/compiler/ppc/insts.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.3 2002/01/11 16:27:12 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -249,16 +249,36 @@ (lk-bit (if lk-p 1 0))) (if aa-p ; Not bloody likely, bwth. (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-b-form-inst - segment - 16 - bo - bi - (ash (- (label-position target) posn) -2) - aa-bit - lk-bit)))))) + ;; the target may be >+-8k away, in which case we have to invert the + ;; test and do an absolute branch + (emit-chooser + ;; We emit either 4 or 8 bytes, so I think we declare this as + ;; preserving 4 byte alignment. If this gives us no joy, we can + ;; stick a nop in the long branch and then we will be + ;; preserving 8 byte alignment + segment 8 2 ; 2^2 is 4 byte alignment. I think + #'(lambda (segment posn magic-value) + (let ((delta (ash (- (label-position target posn magic-value) posn) + -2))) + (when (typep delta '(signed-byte 14)) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-b-form-inst + segment 16 bo bi + (ash (- (label-position target) posn) -2) + aa-bit lk-bit))) + t))) + #'(lambda (segment posn) + (let ((bo (logxor 8 bo))) ;; invert the test + (emit-b-form-inst segment 16 bo bi + 2 ; skip over next instruction + 0 0) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-i-form-branch segment target lk-p))))) + )))) + + ; non-absolute I-form: B, BL. (defun emit-i-form-branch (segment target &optional lk-p) @@ -1689,7 +1709,7 @@ (define-instruction mffs. (segment frd) (:printer x-22 ((op 63) (xo 583) (rc 1))) (:delay 1) - (:dependencies (reads :fpscr) (writes frd)) + (:dependencies (reads :fpscr) (writes frd) (writes :ccr)) (:emitter (emit-x-form-inst segment 63 (fp-reg-tn-encoding frd) @@ -2028,6 +2048,7 @@ (emit-compute-inst segment vop dst src label temp #'(lambda (label posn delta-if-after) (- other-pointer-type + #+PPC-FUN-HACK-MAYBE function-pointer-type (label-position label posn delta-if-after) (component-header-length)))))) diff --git a/compiler/ppc/macros.lisp b/compiler/ppc/macros.lisp index 35f7a64f4..78db756e0 100644 --- a/compiler/ppc/macros.lisp +++ b/compiler/ppc/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.1 2001/02/11 14:22:04 dtc Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.2 2004/07/25 18:15:52 pmai Exp $ ;;; ;;; This file contains various useful macros for generating PC code. ;;; @@ -78,6 +78,7 @@ ;;; Macros to handle the fact that we cannot use the machine native call and ;;; return instructions. +#+PPC-FUN-HACK (defmacro lisp-jump (function) "Jump to the lisp function FUNCTION." `(progn @@ -85,6 +86,17 @@ (move code-tn ,function) (inst bctr))) +#-PPC-FUN-HACK +(defmacro lisp-jump (function lip) + "Jump to the lisp function FUNCTION." + `(progn + (inst addi ,lip ,function (- (* vm:word-bytes vm:function-code-offset) + vm:function-pointer-type)) + (inst mtctr ,lip) + (move code-tn ,function) + (inst bctr))) + +#+PPC-FUN-HACK (defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) "Return to RETURN-PC." `(progn @@ -94,6 +106,16 @@ `((move code-tn ,return-pc))) (inst blr))) +#-PPC-FUN-HACK +(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst addi ,lip ,return-pc (- (* (1+ ,offset) vm:word-bytes) vm:other-pointer-type)) + (inst mtlr ,lip) + ,@(if frob-code + `((move code-tn ,return-pc))) + (inst blr))) + (defmacro emit-return-pc (label) "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn diff --git a/compiler/ppc/move.lisp b/compiler/ppc/move.lisp index 56920f585..30df3e000 100644 --- a/compiler/ppc/move.lisp +++ b/compiler/ppc/move.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/move.lisp,v 1.2 2003/08/03 11:27:47 gerd Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/move.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $ ;;; ;;; This file contains the SPARC VM definition of operand loading/saving and ;;; the Move VOP. @@ -222,7 +222,7 @@ (:generator 20 (move x arg) (let ((done (gen-label))) - (inst mcrxr :cr0) ; clear sticky overflow bits in XER, CR0 + (inst mtxer zero-tn) ; clear sticky overflow bit in XER, CR0 (inst addo temp x x) ; set XER OV if top two bits differ (inst addo. temp temp temp) ; set CR0 SO if any top three bits differ (inst slwi y x 2) ; assume fixnum (tagged ok, maybe lost some high bits) diff --git a/compiler/ppc/parms.lisp b/compiler/ppc/parms.lisp index b9015c801..c5ef85a2f 100644 --- a/compiler/ppc/parms.lisp +++ b/compiler/ppc/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.6 2003/09/26 15:37:11 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.7 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -116,9 +116,9 @@ (defconstant float-round-to-negative 3) (defconstant float-rounding-mode (byte 2 0)) ; RD -(defconstant float-sticky-bits (byte 10 19)) -(defconstant float-traps-byte (byte 6 3)) ; -(defconstant float-exceptions-byte (byte 5 0)) ; cexc +(defconstant float-sticky-bits (byte 5 25)) +(defconstant float-traps-byte (byte 5 3)) ; +(defconstant float-exceptions-byte (byte 5 25)) ; cexc (defconstant float-fast-bit 2) ; Non-IEEE mode @@ -131,7 +131,8 @@ ;;; work. ;;; (defconstant number-stack-displacement - (* 2 vm:word-bytes)) + (* #-darwin 2 + #+darwin 8 vm:word-bytes)) ;;;; Description of the target address space. @@ -145,8 +146,8 @@ ;;; Where to put the different spaces. ;;; (defparameter target-read-only-space-start #x01000000) -(defparameter target-static-space-start #x05000000) -(defparameter target-dynamic-space-start #x07000000) +(defparameter target-static-space-start #x08000000) +(defparameter target-dynamic-space-start #x40000000) (defparameter target-foreign-linkage-space-start #x0fc00000) (defconstant target-foreign-linkage-entry-size 8) ;In bytes. Duh. @@ -226,6 +227,25 @@ unix::*interrupts-enabled* unix::*interrupt-pending* + ;; Make the ..slot-unbound.. symbol static to optimise the + ;; common slot unbound check. + pcl::..slot-unbound.. + + ;; These are filled in the C run-time. + lisp::*cmucl-lib* + lisp::*cmucl-core-path* + + ;; Spare symbols. Rename these when you need to add some static + ;; symbols and don't want to do a cross-compile. + spare-8 + spare-7 + spare-6 + spare-5 + spare-4 + spare-3 + spare-2 + spare-1 + #|kernel::*current-thread*|# )) diff --git a/compiler/ppc/print.lisp b/compiler/ppc/print.lisp index 74550a259..b1e83f5dc 100644 --- a/compiler/ppc/print.lisp +++ b/compiler/ppc/print.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/print.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/print.lisp,v 1.2 2004/07/25 18:15:52 pmai Rel $ ;;; ;;; This file contains VOPs for things like printing during %initial-function ;;; before the world is initialized. @@ -32,10 +32,10 @@ (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (move nl0 object) - (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign)) (inst mr lip temp) (inst mtctr lip) - (inst lr cfunc (make-fixup "debug_print" :foreign)) + (inst lr cfunc (make-fixup (extern-alien-name "debug_print") :foreign)) (inst bctrl) (when cur-nfp (load-stack-tn cur-nfp nfp-save)) diff --git a/compiler/ppc/static-fn.lisp b/compiler/ppc/static-fn.lisp index 2222b013d..870372a54 100644 --- a/compiler/ppc/static-fn.lisp +++ b/compiler/ppc/static-fn.lisp @@ -7,7 +7,7 @@ ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/static-fn.lisp,v 1.2 2003/08/03 11:27:47 gerd Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/static-fn.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $ ;;; ;;; This file contains the VOPs and macro magic necessary to call static ;;; functions. @@ -26,6 +26,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc descriptor-reg :offset lra-offset) lra) + #-PPC-FUN-HACK + (:temporary (:sc interior-reg :offset lip-offset) entry-point) (:temporary (:scs (descriptor-reg)) func) (:temporary (:sc any-reg :offset nargs-offset) nargs) (:temporary (:sc any-reg :offset ocfp-offset) old-fp) @@ -86,7 +88,10 @@ (let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn vop))) ,@(moves (temp-names) (arg-names)) + #+PPC-FUN-HACK (inst lwz func null-tn (static-function-offset symbol)) + #-PPC-FUN-HACK + (inst lwz entry-point null-tn (static-function-offset symbol)) (inst lr nargs (fixnumize ,num-args)) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) @@ -94,8 +99,12 @@ (inst mr cfp-tn csp-tn) (inst compute-lra-from-code lra code-tn lra-label temp) (note-this-location vop :call-site) + #+PPC-FUN-HACK-MAYBE (inst mr code-tn func) + #+PPC-FUN-HACK (inst mtctr func) + #-PPC-FUN-HACK + (inst mtctr entry-point) (inst bctr) (emit-return-pc lra-label) ,(collect ((bindings) (links)) diff --git a/compiler/ppc/vm.lisp b/compiler/ppc/vm.lisp index 412f26304..f5e5faec9 100644 --- a/compiler/ppc/vm.lisp +++ b/compiler/ppc/vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.3 2004/07/25 18:15:52 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -52,10 +52,16 @@ (defreg nl4 7) (defreg nl5 8) (defreg nl6 9) -(defreg nl7 10) +(defreg fdefn 10) (defreg nargs 11) -(defreg nfp 12) -(defreg cfunc 13) +;;; The following two registers were originally reversed in the PPC Linux +;;; port. Putting the address of the called function in GPR12 is however +;;; mandated by the OS X Mach-O ABI, in order to facilitate indirect +;;; addressing of dynamically linked code, as described in the OS X Mach O +;;; Runtime documentation. Since swapping those two registers shouldn't +;;; matter to PPC Linux, we swap them unconditionally. -- PRM, 2003-12-28 +(defreg cfunc 12) +(defreg nfp 13) (defreg bsp 14) (defreg cfp 15) (defreg csp 16) @@ -76,10 +82,10 @@ (defreg lip 31) (defregset non-descriptor-regs - nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 cfunc nargs nfp) + nl0 nl1 nl2 nl3 nl4 nl5 nl6 cfunc nargs nfp) (defregset descriptor-regs - a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 l2 ) + fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 l2 ) (defregset register-arg-offsets a0 a1 a2 a3) -- GitLab