diff --git a/compiler/ppc/arith.lisp b/compiler/ppc/arith.lisp index 0f991a931c325275954a29c7f5fcb90e68bfa974..8f41e2e69c0a04f8184a781ca450a9578118f018 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.1 2001/02/11 14:22:04 dtc Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/arith.lisp,v 1.2 2001/02/11 16:43:18 dtc Exp $ ;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; @@ -227,7 +227,7 @@ ;;; Special case fixnum + and - that trap on overflow. Useful when we ;;; don't know that the output type is a fixnum. - +;;; (define-vop (+/fixnum fast-+/fixnum=>fixnum) (:policy :safe) (:results (r :scs (any-reg descriptor-reg))) @@ -238,18 +238,10 @@ (inst mcrxr :cr0) (inst addo. r x y) (inst bns no-overflow) - (inst unimp (logior (ash (reg-tn-encoding r) 5) fixnum-additive-overflow-trap)) + (inst unimp (logior (ash (reg-tn-encoding r) 5) + fixnum-additive-overflow-trap)) (emit-label no-overflow)))) -#| -(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 3 - (inst taddcctv r x (fixnum y)))) -|# (define-vop (-/fixnum fast--/fixnum=>fixnum) (:policy :safe) @@ -261,27 +253,58 @@ (inst mcrxr :cr0) (inst subo. r x y) (inst bns no-overflow) - (inst unimp (logior (ash (reg-tn-encoding r) 5) fixnum-additive-overflow-trap)) + (inst unimp (logior (ash (reg-tn-encoding r) 5) + fixnum-additive-overflow-trap)) (emit-label no-overflow)))) -#| -(define-vop (--c/fixnum fast---c/fixnum=>fixnum) - (:policy :safe) - (:results (r :scs (any-reg descriptor-reg))) - (:result-types tagged-num) - (:note "safe inline fixnum arithmetic") - (:generator 3 - (inst tsubcctv r x (fixnum y)))) -|# + ;;; Shifting -(define-vop (fast-ash) +(define-vop (fast-ash/unsigned=>unsigned) + (:note "inline ASH") + (:args (number :scs (unsigned-reg) :to :save) + (amount :scs (signed-reg immediate))) + (:arg-types (:or unsigned-num) signed-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 3 + (sc-case amount + (signed-reg + (let ((positive (gen-label)) + (done (gen-label))) + (inst cmpwi amount 0) + (inst neg ndesc amount) + (inst bge positive) + (inst cmpwi ndesc 31) + (inst srw result number ndesc) + (inst ble done) + (inst srwi result number 31) + (inst b done) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (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))))))) + + +(define-vop (fast-ash/signed=>signed) (:note "inline ASH") - (:args (number :scs (signed-reg unsigned-reg) :to :save) + (:args (number :scs (signed-reg) :to :save) (amount :scs (signed-reg immediate))) - (:arg-types (:or signed-num unsigned-num) signed-num) - (:results (result :scs (signed-reg unsigned-reg))) - (:result-types (:or signed-num unsigned-num)) + (:arg-types (:or signed-num) signed-num) + (:results (result :scs (signed-reg))) + (:result-types (:or signed-num)) (:translate ash) (:policy :fast-safe) (:temporary (:sc non-descriptor-reg) ndesc) @@ -294,13 +317,9 @@ (inst neg ndesc amount) (inst bge positive) (inst cmpwi ndesc 31) - (sc-case number - (signed-reg (inst sraw result number ndesc)) - (unsigned-reg (inst srw result number ndesc))) + (inst sraw result number ndesc) (inst ble done) - (sc-case number - (signed-reg (inst srawi result number 31)) - (unsigned-reg (inst srwi result number 31))) + (inst srawi result number 31) (inst b done) (emit-label positive) @@ -313,11 +332,7 @@ (let ((amount (tn-value amount))) (if (minusp amount) (let ((amount (min 31 (- amount)))) - (sc-case number - (unsigned-reg - (inst srwi result number amount)) - (signed-reg - (inst srawi result number amount)))) + (inst srawi result number amount)) (inst slwi result number amount))))))) diff --git a/compiler/ppc/array.lisp b/compiler/ppc/array.lisp index 909f54cc7a66cb7f712dd5a32f96ef075f096f6a..493cca663e44f056df07b1b82def38d81b403e38 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.1 2001/02/11 14:22:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.2 2001/02/11 16:43:18 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -148,10 +148,8 @@ (def-data-vector-frobs simple-array-unsigned-byte-32 word-index unsigned-num unsigned-reg) -#+signed-array (def-data-vector-frobs simple-array-signed-byte-30 word-index tagged-num any-reg) -#+signed-array (def-data-vector-frobs simple-array-signed-byte-32 word-index signed-num signed-reg) @@ -372,7 +370,7 @@ (:generator 7 (inst slwi offset index 1) (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) - vm:other-pointer-type)) + vm:other-pointer-type)) (inst lfdx value object offset))) (define-vop (data-vector-set/simple-array-double-float) @@ -394,6 +392,107 @@ (unless (location= result value) (inst fmr result value)))) + +;;; Complex float arrays. + +(define-vop (data-vector-ref/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-complex-single-float positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:result-types complex-single-float) + (:generator 5 + (let ((real-tn (complex-single-reg-real-tn value))) + (inst slwi offset index 1) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lfsx real-tn object offset)) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (inst addi offset offset vm:word-bytes) + (inst lfsx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types simple-array-complex-single-float positive-fixnum + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst slwi offset index 1) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stfsx value-real object offset) + (unless (location= result-real value-real) + (inst frsp result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst addi offset offset vm:word-bytes) + (inst stfsx value-imag object offset) + (unless (location= result-imag value-imag) + (inst frsp result-imag value-imag))))) + + +(define-vop (data-vector-ref/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-float positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 7 + (let ((real-tn (complex-double-reg-real-tn value))) + (inst slwi offset index 2) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lfdx real-tn object offset)) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst lfdx imag-tn object offset)))) + +(define-vop (data-vector-set/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types simple-array-complex-double-float positive-fixnum + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst slwi offset index 2) + (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst addi offset offset (* 2 vm:word-bytes)) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag))))) + + ;;; These VOPs are used for implementing float slots in structures (whose raw ;;; data is an unsigned-32 vector. ;;; @@ -413,6 +512,28 @@ (:translate %raw-set-double) (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) +(define-vop (raw-ref-complex-single + data-vector-ref/simple-array-complex-single-float) + (:translate %raw-ref-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-single + data-vector-set/simple-array-complex-single-float) + (:translate %raw-set-complex-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-single-float)) +;;; +(define-vop (raw-ref-complex-double + data-vector-ref/simple-array-complex-double-float) + (:translate %raw-ref-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-complex-double + data-vector-set/simple-array-complex-double-float) + (:translate %raw-set-complex-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum + complex-double-float)) + ;;; These vops are useful for accessing the bits of a vector irrespective of ;;; what type of vector it is. @@ -454,7 +575,7 @@ ;;; -#+signed-array + (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref) (:note "inline array access") (:variant vm:vector-data-offset vm:other-pointer-type) @@ -462,7 +583,7 @@ (:arg-types simple-array-signed-byte-8 positive-fixnum) (:results (value :scs (signed-reg))) (:result-types tagged-num)) -#+signed-array + (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set) (:note "inline array store") (:variant vm:vector-data-offset vm:other-pointer-type) @@ -474,7 +595,6 @@ (:results (result :scs (signed-reg))) (:result-types tagged-num)) -#+signed-array (define-vop (data-vector-ref/simple-array-signed-byte-16 signed-halfword-index-ref) (:note "inline array access") @@ -483,7 +603,7 @@ (:arg-types simple-array-signed-byte-16 positive-fixnum) (:results (value :scs (signed-reg))) (:result-types tagged-num)) -#+signed-array + (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set) (:note "inline array store") (:variant vm:vector-data-offset vm:other-pointer-type) diff --git a/compiler/ppc/call.lisp b/compiler/ppc/call.lisp index 05259e0749cdcc7fd0f539d9f45b15b369d62f43..dba443d0711adc5f793185b8884b37887ab4fd11 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.1 2001/02/11 14:22:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.2 2001/02/11 16:43:18 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -168,7 +168,8 @@ (define-vop (xep-allocate-frame) - (:info start-lab) + (:info start-lab copy-more-arg-follows) + (:ignore copy-more-arg-follows) (:vop-var vop) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 1 diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp index eacc2d604d674569df94243a411dd19df23bccff..2a6ff2276a715da99fa06f9399217fe87c189ca1 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.1 2001/02/11 14:22:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.2 2001/02/11 16:43:18 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -124,8 +124,238 @@ (frob move-double-float-argument double-reg double-stack t)) + +;;;; Complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :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))) + + +(define-move-function (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-single-reg-real-tn y))) + (inst lfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst lfs imag-tn nfp (+ offset vm:word-bytes))))) + +(define-move-function (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn nfp (+ offset vm:word-bytes))))) + + +(define-move-function (load-complex-double 4) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lfd imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) + +(define-move-function (store-complex-double 4) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn nfp (+ offset (* 2 vm:word-bytes)))))) + + +;;; +;;; Complex float register to register moves. +;;; +(define-vop (complex-single-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) + (:note "complex single float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmr y-imag x-imag))))) +;;; +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) + (:note "complex double float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmr y-imag x-imag))))) +;;; +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + + +;;; +;;; Move from a complex float to a descriptor register allocating a +;;; new complex float object in the process. +;;; +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "complex single float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr vm:complex-single-float-type + vm:complex-single-float-size)) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn y (- (* vm:complex-single-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn y (- (* vm:complex-single-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:note "complex double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y pa-flag ndescr vm:complex-double-float-type + vm:complex-double-float-size)) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn y (- (* vm:complex-double-float-real-slot + vm:word-bytes) + vm:other-pointer-type))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn y (- (* vm:complex-double-float-imag-slot + vm:word-bytes) + vm:other-pointer-type))))) +;;; +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + + +;;; +;;; Move from a descriptor to a complex float register +;;; +(define-vop (move-to-complex-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-single-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-single-reg-real-tn y))) + (inst lfs real-tn x (- (* complex-single-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (inst lfs imag-tn x (- (* complex-single-float-imag-slot word-bytes) + other-pointer-type))))) +(define-move-vop move-to-complex-single :move + (descriptor-reg) (complex-single-reg)) + +(define-vop (move-to-complex-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (complex-double-reg))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (inst lfd real-tn x (- (* complex-double-float-real-slot word-bytes) + other-pointer-type))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (inst lfd imag-tn x (- (* complex-double-float-imag-slot word-bytes) + other-pointer-type))))) +(define-move-vop move-to-complex-double :move + (descriptor-reg) (complex-double-reg)) + + +;;; +;;; Complex float move-argument vop +;;; +(define-vop (move-complex-single-float-argument) + (:args (x :scs (complex-single-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (:results (y)) + (:note "complex single-float argument move") + (:generator 1 + (sc-case y + (complex-single-reg + (unless (location= x y) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmr y-imag x-imag)))) + (complex-single-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst stfs real-tn nfp offset)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst stfs imag-tn nfp (+ offset word-bytes)))))))) +(define-move-vop move-complex-single-float-argument :move-argument + (complex-single-reg descriptor-reg) (complex-single-reg)) + +(define-vop (move-complex-double-float-argument) + (:args (x :scs (complex-double-reg) :target y) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (:results (y)) + (:note "complex double-float argument move") + (:generator 2 + (sc-case y + (complex-double-reg + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmr y-real x-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmr y-imag x-imag)))) + (complex-double-stack + (let ((offset (* (tn-offset y) word-bytes))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stfd real-tn nfp offset)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stfd imag-tn nfp (+ offset (* 2 word-bytes))))))))) +(define-move-vop move-complex-double-float-argument :move-argument + (complex-double-reg descriptor-reg) (complex-double-reg)) + + (define-move-vop move-argument :move-argument - (single-reg double-reg) (descriptor-reg)) + (single-reg double-reg complex-single-reg complex-double-reg) + (descriptor-reg)) ;;;; Arithmetic VOPs: @@ -503,3 +733,129 @@ (inst lfd fp-temp nfp (* word-bytes (tn-offset temp))) (inst mtfsf 255 fp-temp) (move res new)))) + + +;;;; Complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :target r + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-single-reg-real-tn r))) + (unless (location= real r-real) + (inst fmr r-real real))) + (let ((r-imag (complex-single-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst fmr r-imag imag)))) + (complex-single-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (inst stfs real nfp offset)) + (inst stfs imag nfp (+ offset vm:word-bytes))))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note "inline complex double-float creation") + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (inst fmr r-real real))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (inst fmr r-imag imag)))) + (complex-double-stack + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset r) vm:word-bytes))) + (unless (location= real r) + (inst stfd real nfp offset)) + (inst stfd imag nfp (+ offset (* 2 vm:word-bytes)))))))) + + +(define-vop (complex-single-float-value) + (:args (x :scs (complex-single-reg) :target r + :load-if (not (sc-is x complex-single-stack)))) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-single-reg + (let ((value-tn (ecase slot + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmr r value-tn)))) + (complex-single-stack + (inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1)) + (tn-offset x)) + vm:word-bytes)))))) + +(define-vop (realpart/complex-single-float complex-single-float-value) + (:translate realpart) + (:note "complex single float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-single-float complex-single-float-value) + (:translate imagpart) + (:note "complex single float imagpart") + (:variant :imag)) + +(define-vop (complex-double-float-value) + (:args (x :scs (complex-double-reg) :target r + :load-if (not (sc-is x complex-double-stack)))) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:variant-vars slot) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (sc-case x + (complex-double-reg + (let ((value-tn (ecase slot + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmr r value-tn)))) + (complex-double-stack + (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2)) + (tn-offset x)) + vm:word-bytes)))))) + +(define-vop (realpart/complex-double-float complex-double-float-value) + (:translate realpart) + (:note "complex double float realpart") + (:variant :real)) + +(define-vop (imagpart/complex-double-float complex-double-float-value) + (:translate imagpart) + (:note "complex double float imagpart") + (:variant :imag)) + + diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp index a7a97cc617017d658a2bbc934cdbd7e7b630e487..5d554c0e32a9568b27edc28676500e1f0d84e444 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.1 2001/02/11 14:22:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -498,7 +498,7 @@ ;;;; -(def-ppc-iformat (xfx 32) +(def-ppc-iformat (xfx) rt spr (xo xo21-30)) (def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs)) diff --git a/compiler/ppc/nlx.lisp b/compiler/ppc/nlx.lisp index b1789435df71e83aa0a8781af92d842f210c11dc..40e99ac1445c16e173e2f099bb4bccf031cc6e1a 100644 --- a/compiler/ppc/nlx.lisp +++ b/compiler/ppc/nlx.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/nlx.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/nlx.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $ ;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) @@ -25,6 +25,13 @@ (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) env)) +;;; Make-NLX-Entry-Argument-Start-Location -- Interface +;;; +;;; Make a TN for the argument count passing location for a +;;; non-local entry. +;;; +(def-vm-support-routine make-nlx-entry-argument-start-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)) ;;; Save and restore dynamic environment. diff --git a/compiler/ppc/parms.lisp b/compiler/ppc/parms.lisp index 511d8abdb7a2dfd8f34330f5ba73b36bd7c851f3..33fdf26e67147305e76131372563389f2f8a5697 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.1 2001/02/11 14:22:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -36,7 +36,6 @@ (setf (backend-register-save-penalty *target-backend*) 3) (setf (backend-byte-order *target-backend*) :big-endian) (setf (backend-page-size *target-backend*) 4096) -(setf (c::backend-%features *target-backend*) '(:ppc :linux :new-assembler :new-random :signed-array)) ); eval-when @@ -199,6 +198,7 @@ ;; The C startup code must fill these in. lisp::lisp-environment-list lisp::lisp-command-line-list + ext::*batch-mode* lisp::*initial-fdefn-objects* ;; Functions that the C code needs to call diff --git a/compiler/ppc/sap.lisp b/compiler/ppc/sap.lisp index 8b21fcfe8dd28af11d880d08a9a675fb7b37c730..0c686ca323201acb9a05af440b34911f3284f687 100644 --- a/compiler/ppc/sap.lisp +++ b/compiler/ppc/sap.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/sap.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/sap.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -170,8 +170,8 @@ (:translate ,ref-name) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (unsigned-reg))) - (:arg-types system-area-pointer unsigned-num) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 @@ -206,9 +206,9 @@ (:translate ,set-name) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (unsigned-reg)) + (offset :scs (signed-reg)) (value :scs (,sc) :target result)) - (:arg-types system-area-pointer unsigned-num ,type) + (:arg-types system-area-pointer signed-num ,type) (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 diff --git a/compiler/ppc/type-vops.lisp b/compiler/ppc/type-vops.lisp index c2ebe168f2878f2747e359d54a615c9b682cb22c..f20f9edb2f91fcbcc3c0fced79b4a49ba691e58c 100644 --- a/compiler/ppc/type-vops.lisp +++ b/compiler/ppc/type-vops.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/type-vops.lisp,v 1.1 2001/02/11 14:22:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -113,7 +113,23 @@ object-not-ratio-error vm:ratio-type) (def-type-vops complexp check-complex complex - object-not-complex-error vm:complex-type) + object-not-complex-error vm:complex-type + complex-single-float-type complex-double-float-type) + +(def-type-vops complex-rational-p check-complex-rational nil + object-not-complex-rational-error complex-type) + +(def-type-vops complex-float-p check-complex-float nil + object-not-complex-float-error + complex-single-float-type complex-double-float-type) + +(def-type-vops complex-single-float-p check-complex-single-float + complex-single-float object-not-complex-single-float-error + complex-single-float-type) + +(def-type-vops complex-double-float-p check-complex-double-float + complex-double-float object-not-complex-double-float-error + complex-double-float-type) (def-type-vops single-float-p check-single-float single-float object-not-single-float-error vm:single-float-type) @@ -160,28 +176,24 @@ object-not-simple-array-unsigned-byte-32-error vm:simple-array-unsigned-byte-32-type) -#+signed-array (def-type-vops simple-array-signed-byte-8-p check-simple-array-signed-byte-8 simple-array-signed-byte-8 object-not-simple-array-signed-byte-8-error simple-array-signed-byte-8-type) -#+signed-array (def-type-vops simple-array-signed-byte-16-p check-simple-array-signed-byte-16 simple-array-signed-byte-16 object-not-simple-array-signed-byte-16-error simple-array-signed-byte-16-type) -#+signed-array (def-type-vops simple-array-signed-byte-30-p check-simple-array-signed-byte-30 simple-array-signed-byte-30 object-not-simple-array-signed-byte-30-error simple-array-signed-byte-30-type) -#+signed-array (def-type-vops simple-array-signed-byte-32-p check-simple-array-signed-byte-32 simple-array-signed-byte-32 @@ -196,6 +208,18 @@ simple-array-double-float object-not-simple-array-double-float-error vm:simple-array-double-float-type) +(def-type-vops simple-array-complex-single-float-p + check-simple-array-complex-single-float + simple-array-complex-single-float + object-not-simple-array-complex-single-float-error + simple-array-complex-single-float-type) + +(def-type-vops simple-array-complex-double-float-p + check-simple-array-complex-double-float + simple-array-complex-double-float + object-not-simple-array-complex-double-float-error + simple-array-complex-double-float-type) + (def-type-vops base-char-p check-base-char base-char object-not-base-char-error vm:base-char-type) @@ -234,32 +258,45 @@ vm:simple-bit-vector-type vm:complex-bit-vector-type) (def-type-vops vectorp check-vector nil object-not-vector-error - vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type - vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type - vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type - vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type - vm:simple-array-double-float-type vm:complex-string-type - vm:complex-bit-vector-type vm:complex-vector-type) + simple-string-type simple-bit-vector-type simple-vector-type + simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type + simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type + simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type + complex-string-type complex-bit-vector-type complex-vector-type) (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type) + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type) (def-type-vops arrayp check-array nil object-not-array-error - vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type - vm:simple-vector-type vm:simple-array-unsigned-byte-2-type - vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type - vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type - vm:simple-array-single-float-type vm:simple-array-double-float-type - vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type - vm:complex-array-type) + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-signed-byte-8-type simple-array-signed-byte-16-type + simple-array-signed-byte-30-type simple-array-signed-byte-32-type + simple-array-single-float-type simple-array-double-float-type + simple-array-complex-single-float-type + simple-array-complex-double-float-type + complex-string-type complex-bit-vector-type complex-vector-type + complex-array-type) (def-type-vops numberp check-number nil object-not-number-error - vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type - vm:single-float-type vm:double-float-type vm:complex-type) + even-fixnum-type odd-fixnum-type bignum-type ratio-type + single-float-type double-float-type complex-type + complex-single-float-type complex-double-float-type) (def-type-vops rationalp check-rational nil object-not-rational-error vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) diff --git a/compiler/ppc/vm.lisp b/compiler/ppc/vm.lisp index 276050ba1371770e9c294c33e69046e1426d7b11..412f26304cf67cbe6c91180acb757a455c8dba6e 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.1 2001/02/11 14:22:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -142,6 +142,8 @@ (single-stack non-descriptor-stack) ; single-floats (double-stack non-descriptor-stack :element-size 2 :alignment 2) ; double floats. + (complex-single-stack non-descriptor-stack :element-size 2) + (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) ;; **** Things that can go in the integer registers. @@ -201,7 +203,7 @@ ;; Non-Descriptor single-floats. (single-reg float-registers - :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) + :locations #.(loop for i from 0 to 31 collect i) ;; ### Note: We really should have every location listed, but then we ;; would have to make load-tns work with element-sizes other than 1. :constant-scs () @@ -210,13 +212,26 @@ ;; Non-Descriptor double-floats. (double-reg float-registers - :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) + :locations #.(loop for i from 0 to 31 collect i) ;; ### Note: load-tns don't work with an element-size other than 1. ;; :element-size 2 :alignment 2 :constant-scs () :save-p t :alternate-scs (double-stack)) + (complex-single-reg float-registers + :locations #.(loop for i from 0 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) + + (complex-double-reg float-registers + :locations #.(loop for i from 0 to 30 by 2 collect i) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) ;; A catch or unwind block. (catch-block control-stack :element-size vm:catch-block-size))