diff --git a/assembly/ppc/arith.lisp b/assembly/ppc/arith.lisp index ad082676e8fee1b349945de9f2b43d8345fb7b25..5632f9d22250003a00c227e8156058368428191c 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 7d890ce7f733adf80a96c751e35471a43a4687da..654149ead6475fca2853887bfa475863f47fef60 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 0f7f1224ee141294920e86bad1a1a9600366b052..bc234b6e5d127a0f6009d0571d42f0ad3cb8de30 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 721e47f8f42d5b675f2fc97eb8b50e248e73d6a1..17ad721b6beb063b1d615dfd66aca50bdaf94fc0 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 cce95f8d46560c53a890b677cefac7678d589907..2fba6103c8ef15eebe88bddc88a15c5ad60327f5 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 26ea125a103ae96a7fca1cd25033dc2504308f92..e773f04b7b6362941e09432a01ba662e19445a30 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 4a7ad4474f2f1b0cdb51d4ac09b59721bd3a06db..3edde59ba744a3c4c744308961d156075ba6da75 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 3c7fc5e74b0f6dc80ac64401104dd19d40804509..99b26f7e1d8a56f2d89c093ff8522c05550b939c 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 49cd23ff5d3c5541277e4da9df9266c755b51f32..81bf490c4483fc9dcd83694070d2bd189931c7d0 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 cdab3cd4580c7e8ce963f2fede276e8af8906c90..e99502e5a10c574ef823b784ae78d5f9450f39b4 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 2595f5a403e6c632afb502d7c4f8f5e64299e05b..6400cc650b2936880ac7995f3a97d1d556e0bcdf 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 2a6ff2276a715da99fa06f9399217fe87c189ca1..9436f3d03eef56662eaf4c0ce156bbac3baccbe6 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 7a393e1694bea5d8eb3807bb3ea87ed3f9ca0a85..ed6d8452c0208a34cf069ca64b1c5384a34b146e 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 35f7a64f4f9046656cc08a1959284cfb2684006b..78db756e0d5a1cda36b193bac146fa33552786f2 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 56920f5856f870355a6de5facac33fa733cf04a8..30df3e00051c4a83d621af8a3916d94e2f520fd4 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 b9015c801c73b14f4978bae882cc0691d37dbc7c..c5ef85a2fa467c22dcd0eee15ee6ca1ff693bd77 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 74550a2591e80210843ef9ac4a53adc07729ca2f..b1e83f5dc54191ad37e118172acad34d463b9d00 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 2222b013d7c214a08b5933241f594e5bcaf8156c..870372a5499a0d17a47823621872081782bd0fae 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 412f26304cf67cbe6c91180acb757a455c8dba6e..f5e5faec95131e6b084efa654fba135a16c0ddc8 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)