From 9923d19d8dcbfb5d7d3b57462a73c21e7dd85696 Mon Sep 17 00:00:00 2001 From: hallgren <hallgren> Date: Wed, 6 Apr 1994 17:00:02 +0000 Subject: [PATCH] Initial revision --- assembly/alpha/alloc.lisp | 24 + assembly/alpha/arith.lisp | 423 +++++++++++ assembly/alpha/array.lisp | 184 +++++ assembly/alpha/assem-rtns.lisp | 236 ++++++ assembly/alpha/support.lisp | 77 ++ code/alpha-vm.lisp | 223 ++++++ compiler/alpha/alloc.lisp | 187 +++++ compiler/alpha/arith.lisp | 808 ++++++++++++++++++++ compiler/alpha/array.lisp | 443 +++++++++++ compiler/alpha/c-call.lisp | 180 +++++ compiler/alpha/call.lisp | 1301 ++++++++++++++++++++++++++++++++ compiler/alpha/cell.lisp | 391 ++++++++++ compiler/alpha/char.lisp | 149 ++++ compiler/alpha/debug.lisp | 165 ++++ compiler/alpha/float.lisp | 531 +++++++++++++ compiler/alpha/insts.lisp | 598 +++++++++++++++ compiler/alpha/macros.lisp | 540 +++++++++++++ compiler/alpha/memory.lisp | 62 ++ compiler/alpha/move.lisp | 347 +++++++++ compiler/alpha/nlx.lisp | 290 +++++++ compiler/alpha/parms.lisp | 214 ++++++ compiler/alpha/pred.lisp | 49 ++ compiler/alpha/print.lisp | 42 ++ compiler/alpha/sap.lisp | 389 ++++++++++ compiler/alpha/static-fn.lisp | 148 ++++ compiler/alpha/subprim.lisp | 64 ++ compiler/alpha/system.lisp | 254 +++++++ compiler/alpha/type-vops.lisp | 545 +++++++++++++ compiler/alpha/values.lisp | 133 ++++ compiler/alpha/vm.lisp | 363 +++++++++ 30 files changed, 9360 insertions(+) create mode 100644 assembly/alpha/alloc.lisp create mode 100644 assembly/alpha/arith.lisp create mode 100644 assembly/alpha/array.lisp create mode 100644 assembly/alpha/assem-rtns.lisp create mode 100644 assembly/alpha/support.lisp create mode 100644 code/alpha-vm.lisp create mode 100644 compiler/alpha/alloc.lisp create mode 100644 compiler/alpha/arith.lisp create mode 100644 compiler/alpha/array.lisp create mode 100644 compiler/alpha/c-call.lisp create mode 100644 compiler/alpha/call.lisp create mode 100644 compiler/alpha/cell.lisp create mode 100644 compiler/alpha/char.lisp create mode 100644 compiler/alpha/debug.lisp create mode 100644 compiler/alpha/float.lisp create mode 100644 compiler/alpha/insts.lisp create mode 100644 compiler/alpha/macros.lisp create mode 100644 compiler/alpha/memory.lisp create mode 100644 compiler/alpha/move.lisp create mode 100644 compiler/alpha/nlx.lisp create mode 100644 compiler/alpha/parms.lisp create mode 100644 compiler/alpha/pred.lisp create mode 100644 compiler/alpha/print.lisp create mode 100644 compiler/alpha/sap.lisp create mode 100644 compiler/alpha/static-fn.lisp create mode 100644 compiler/alpha/subprim.lisp create mode 100644 compiler/alpha/system.lisp create mode 100644 compiler/alpha/type-vops.lisp create mode 100644 compiler/alpha/values.lisp create mode 100644 compiler/alpha/vm.lisp diff --git a/assembly/alpha/alloc.lisp b/assembly/alpha/alloc.lisp new file mode 100644 index 000000000..90b0fd30d --- /dev/null +++ b/assembly/alpha/alloc.lisp @@ -0,0 +1,24 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/alloc.lisp,v 1.1 1994/04/06 16:58:31 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle allocation of stuff we don't want to do inline. +;;; +;;; Written by William Lott. +;;; + +(in-package "ALPHA") + +;;; Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later. + diff --git a/assembly/alpha/arith.lisp b/assembly/alpha/arith.lisp new file mode 100644 index 000000000..c4280e214 --- /dev/null +++ b/assembly/alpha/arith.lisp @@ -0,0 +1,423 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/arith.lisp,v 1.1 1994/04/06 16:58:32 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle simple cases for generic arithmetic. +;;; +;;; Written by William Lott. +;;; Conversion by Sean Hallgren +;;; + +(in-package "ALPHA") + + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst addq x y res) + + ; Check to see if we need a bignum + (inst sra res 31 temp) + (inst beq temp DONE) + (inst not temp temp) + (inst beq temp DONE) + (inst sra res 2 temp3) + + ; From move-from-signed + (inst li 2 temp2) + (inst sra temp3 31 temp) + (inst cmoveq temp 1 temp2) + (inst not temp temp) + (inst cmoveq temp 1 temp2) + (inst sll temp2 type-bits temp2) + (inst bis temp2 bignum-type temp2) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-type res) + (storew temp2 res 0 other-pointer-type) + (storew temp3 res bignum-digits-offset other-pointer-type) + (inst srl temp3 32 temp) + (storew temp res (1+ bignum-digits-offset) other-pointer-type)) + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-function-offset 'two-arg-+) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst subq x y res) + + ; Check to see if we need a bignum + (inst sra res 31 temp) + (inst beq temp DONE) + (inst not temp temp) + (inst beq temp DONE) + (inst sra res 2 temp3) + + ; From move-from-signed + (inst li 2 temp2) + (inst sra temp3 31 temp) + (inst cmoveq temp 1 temp2) + (inst not temp temp) + (inst cmoveq temp 1 temp2) + (inst sll temp2 type-bits temp2) + (inst bis temp2 bignum-type temp2) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-type res) + (storew temp2 res 0 other-pointer-type) + (storew temp3 res bignum-digits-offset other-pointer-type) + (inst srl temp3 32 temp) + (storew temp res (1+ bignum-digits-offset) other-pointer-type)) + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-function-offset 'two-arg--) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip)) + + +(define-assembly-routine (generic-* + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp temp2 non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + ;; If either arg is not a fixnum, call the static function. + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + + ;; Remove the tag from one arg so that the result will have the correct + ;; fixnum tag. + (inst sra x 2 temp) + (inst mulq temp y lo) + (inst sra lo 32 hi) + (inst sll lo 32 res) + (inst sra res 32 res) + ;; Check to see if the result will fit in a fixnum. (I.e. the high word + ;; is just 32 copies of the sign bit of the low word). + (inst sra res 31 temp) + (inst xor hi temp temp) + (inst beq temp DONE) + ;; Shift the double word hi:res down two bits into hi:low to get rid of the + ;; fixnum tag. + (inst srl lo 2 lo) + (inst sra lo 32 hi) + (inst sll lo 32 lo) + (inst sra lo 32 lo) + + ;; Do we need one word or two? Assume two. + (inst sra lo 31 temp) + (inst xor temp hi temp) + (inst li (logior (ash 2 type-bits) bignum-type) temp2) + (inst bne temp two-words) + + ;; Only need one word, fix the header and zero the high-word. + (inst li (logior (ash 1 type-bits) bignum-type) temp2) + (inst li 0 hi) + + TWO-WORDS + (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset))) + (inst bis alloc-tn other-pointer-type res) + (storew temp2 res 0 other-pointer-type)) + + (storew lo res bignum-digits-offset other-pointer-type) + (storew hi res (1+ bignum-digits-offset) other-pointer-type) + + ;; Out of here + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-function-offset 'two-arg-*) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DONE) + + +;;;; Division. + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst beq divisor error)) + + (inst xor dividend divisor quo-sign) + (inst move dividend rem-sign) + (let ((label (gen-label))) + (inst bge dividend label) + (inst subq zero-tn dividend dividend) + (emit-label label)) + (let ((label (gen-label))) + (inst bge divisor label) + (inst subq zero-tn divisor divisor) + (emit-label label)) + (inst move zero-tn rem) + (inst move zero-tn quo) + (inst sll dividend 32 dividend) + + (dotimes (i 32) + (inst srl dividend 63 temp1) + (inst sll rem 1 rem) + (inst bis temp1 rem rem) + (inst cmple divisor rem temp1) + (inst sll quo 1 quo) + (inst bis temp1 quo quo) + (inst sll dividend 1 dividend) + (inst subq temp1 1 temp1) + (inst zap divisor temp1 temp1) + (inst subq rem temp1 rem)) + + (let ((label (gen-label))) + ;; If the quo-sign is negative, we need to negate quo. + (inst bge quo-sign label) + (inst subq zero-tn quo quo) + (emit-label label)) + (let ((label (gen-label))) + ;; If the rem-sign is negative, we need to negate rem. + (inst bge rem-sign label) + (inst subq zero-tn rem rem) + (emit-label label))) + + +;;;; Comparison routines. + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp not-p) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst beq temp DO-COMPARE) + + DO-STATIC-FN + (inst ldl lip (static-function-offset ',static-fn) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DO-COMPARE + ,cmp + (inst move null-tn res) + (inst ,(if not-p 'bne 'beq) temp done) + (load-symbol res t) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) + (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmpeq x y temp) + (inst bne temp RETURN-T) + (inst and x 3 temp) + (inst beq temp RETURN-NIL) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + + RETURN-NIL + (inst move null-tn res) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-function-offset 'eql) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + (inst cmpeq x y temp) + (inst bne temp RETURN-T) + + (inst move null-tn res) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-function-offset 'two-arg-=) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + (inst cmpeq x y temp) + (inst bne temp RETURN-NIL) + + (load-symbol res t) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-function-offset 'two-arg-=) null-tn) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-NIL + (inst move null-tn res)) diff --git a/assembly/alpha/array.lisp b/assembly/alpha/array.lisp new file mode 100644 index 000000000..e890d0b65 --- /dev/null +++ b/assembly/alpha/array.lisp @@ -0,0 +1,184 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/array.lisp,v 1.1 1994/04/06 16:58:33 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the support routines for arrays and vectors. +;;; +;;; Written by William Lott. +;;; Conversion by Sean Hallgren +;;; +(in-package "ALPHA") + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset)) + ;; This is kinda sleezy, changing words like this. But we can because + ;; the vop thinks it is temporary. + (inst addq words (+ (1- (ash 1 lowtag-bits)) + (* vector-data-offset word-bytes)) + words) + (inst li (lognot lowtag-mask) ndescr) + (inst and words ndescr words) + (inst srl type word-shift ndescr) + + (pseudo-atomic () + (inst bis alloc-tn other-pointer-type result) + (inst addq alloc-tn words alloc-tn) + (storew ndescr result 0 other-pointer-type) + (storew length result vector-length-slot other-pointer-type))) + + +;;;; Hash primitives + +(define-assembly-routine (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp length any-reg a1-offset) + + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + + ;; These are needed after we jump into sxhash-simple-substring. + (progn result lip accum data byte retaddr) + + (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1) + (loadw length string vector-length-slot other-pointer-type) + (inst jmp zero-tn temp1 + (make-fixup 'sxhash-simple-substring :assembly-routine))) + +(define-assembly-routine (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset)) + + ;; Save the return address + (inst subq lip code-tn retaddr) + + ;; Get a pointer to the data. + (inst addq string + (- (* vector-data-offset word-bytes) other-pointer-type) + lip) + (move zero-tn accum) + (inst br zero-tn test) + + loop + + (inst and data #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 8 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 16 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 24 byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst addq lip 4 lip) + + test + + (inst subq length (fixnum 4) length) + (inst ldl data 0 lip) + (inst bge length loop) + + (inst addq length (fixnum 3) length) + (inst beq length one-more) + (inst subq length (fixnum 1) length) + (inst beq length two-more) + (inst bne length done) + + (inst srl data 16 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + (inst addq length (fixnum 1) length) + + two-more + + (inst subq length (fixnum 1) length) + (inst srl data 8 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + (inst addq length (fixnum 1) length) + + one-more + + (inst subq length (fixnum 1) length) + (inst and data #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + done + + (inst sll accum 5 result) + (inst mskll result 4 result) + (inst srl result 3 result) + + ;; Restore the return address. + (inst addq code-tn retaddr lip)) diff --git a/assembly/alpha/assem-rtns.lisp b/assembly/alpha/assem-rtns.lisp new file mode 100644 index 000000000..7235089d8 --- /dev/null +++ b/assembly/alpha/assem-rtns.lisp @@ -0,0 +1,236 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/assem-rtns.lisp,v 1.1 1994/04/06 16:58:34 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +(in-package "ALPHA") + + +;;;; Return-multiple with other than one value + +#+assembler ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst ble nvals default-a0-and-on) + (inst ldl a1 (* 1 vm:word-bytes) vals) + (inst subq nvals (fixnum 2) count) + (inst ble count default-a2-and-on) + (inst ldl a2 (* 2 vm:word-bytes) vals) + (inst subq nvals (fixnum 3) count) + (inst ble count default-a3-and-on) + (inst ldl a3 (* 3 vm:word-bytes) vals) + (inst subq nvals (fixnum 4) count) + (inst ble count default-a4-and-on) + (inst ldl a4 (* 4 vm:word-bytes) vals) + (inst subq nvals (fixnum 5) count) + (inst ble count default-a5-and-on) + (inst ldl a5 (* 5 vm:word-bytes) vals) + (inst subq nvals (fixnum 6) count) + (inst ble count done) + + ;; Copy the remaining args to the top of the stack. + (inst addq vals (* 6 vm:word-bytes) vals) + (inst addq cfp-tn (* 6 vm:word-bytes) dst) + + LOOP + (inst ldl temp 0 vals) + (inst addq vals vm:word-bytes vals) + (inst stl temp 0 dst) + (inst subq count (fixnum 1) count) + (inst bne count loop) + (inst addq dst vm:word-bytes dst) + + (inst br zero-tn done) + + DEFAULT-A0-AND-ON + (inst move null-tn a0) + (inst move null-tn a1) + DEFAULT-A2-AND-ON + (inst move null-tn a2) + DEFAULT-A3-AND-ON + (inst move null-tn a3) + DEFAULT-A4-AND-ON + (inst move null-tn a4) + DEFAULT-A5-AND-ON + (inst move null-tn a5) + DONE + + ;; Clear the stack. + (move cfp-tn ocfp-tn) + (move ocfp cfp-tn) + (inst addq ocfp-tn nvals csp-tn) + + ;; Return. + (lisp-return lra lip)) + + +;;;; tail-call-variable. + +#+assembler ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg cfunc-offset) + (:temp temp descriptor-reg l0-offset) + + ;; Needed for the jump + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst subq csp-tn args nargs) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst ldl a0 (* 0 vm:word-bytes) args) + (inst ldl a1 (* 1 vm:word-bytes) args) + (inst ldl a2 (* 2 vm:word-bytes) args) + (inst ldl a3 (* 3 vm:word-bytes) args) + (inst ldl a4 (* 4 vm:word-bytes) args) + (inst ldl a5 (* 5 vm:word-bytes) args) + + ;; Calc SRC, DST, and COUNT + (inst subq nargs (fixnum register-arg-count) count) + (inst addq args (* vm:word-bytes register-arg-count) src) + (inst ble count done) + (inst addq cfp-tn (* vm:word-bytes register-arg-count) dst) + + LOOP + ;; Copy one arg. + (inst ldl temp 0 src) + (inst addq src vm:word-bytes src) + (inst stl temp 0 dst) + (inst subq count (fixnum 1) count) + (inst addq dst vm:word-bytes dst) + (inst bgt count loop) + + DONE + ;; We are done. Do the jump. + (progn + (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) + (lisp-jump temp lip))) + + +;;;; Non-local exit noise. + +(define-assembly-routine + (unwind + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset) + (:temp temp1 non-descriptor-reg nl3-offset)) + (declare (ignore start count)) + + (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst beq block error)) + + (loadw target-uwp block vm:unwind-block-current-uwp-slot) + (inst cmpeq cur-uwp target-uwp temp1) + (inst beq temp1 do-uwp) + + (move block cur-uwp) + + do-exit + + (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) + (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) + (progn + (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil)) + + do-uwp + + (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) + (store-symbol-value next-uwp lisp::*current-unwind-protect-block*) + (inst br zero-tn do-exit)) + + +(define-assembly-routine + throw + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset) + (:temp temp1 non-descriptor-reg nl0-offset)) + + (progn start count) ; We just need them in the registers. + + (load-symbol-value catch lisp::*current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst beq catch error)) + + (loadw tag catch vm:catch-block-tag-slot) + (inst cmpeq tag target temp1) + (inst bne temp1 exit) + (loadw catch catch vm:catch-block-previous-catch-slot) + (inst br zero-tn loop) + + exit + + (move catch target) + (inst li (make-fixup 'unwind :assembly-routine) temp1) + (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine))) diff --git a/assembly/alpha/support.lisp b/assembly/alpha/support.lisp new file mode 100644 index 000000000..175a8a9a7 --- /dev/null +++ b/assembly/alpha/support.lisp @@ -0,0 +1,77 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/alpha/support.lisp,v 1.1 1994/04/06 16:58:36 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the machine specific support routines needed by +;;; the file assembler. +;;; +(in-package "ALPHA") + +(def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (values + `((inst li (make-fixup ',name :assembly-routine) temp) + (inst jsr lip-tn temp)) + '((:temporary (:sc non-descriptor-reg) temp)) + nil)) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + ; here + (inst li (make-fixup ',name :assembly-routine) temp1) + (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move ocfp-tn csp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:save-p t))))) + (:none + (values + `((inst li (make-fixup ',name :assembly-routine) temp) + (inst jsr lip-tn temp (make-fixup ',name :assembly-routine))) + '((:temporary (:scs (non-descriptor-reg)) temp)) + nil)))) + + +(def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst ret zero-tn lip-tn))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) + (:none))) diff --git a/code/alpha-vm.lisp b/code/alpha-vm.lisp new file mode 100644 index 000000000..bf09fbb06 --- /dev/null +++ b/code/alpha-vm.lisp @@ -0,0 +1,223 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.1 1994/04/06 17:00:02 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.1 1994/04/06 17:00:02 hallgren Exp $ +;;; +;;; This file contains the Alpha specific runtime stuff. +;;; +(in-package "ALPHA") +(use-package "SYSTEM") +(use-package "ALIEN") +(use-package "C-CALL") +(use-package "UNIX") + +(export '(fixup-code-object internal-error-arguments + sigcontext-program-counter sigcontext-register + sigcontext-float-register sigcontext-floating-point-modes + extern-alien-name sanctify-for-execution)) + + +;;;; The sigcontext structure. + +(def-alien-type sigcontext + (struct nil + (sc-onstack unsigned-long) + (sc-mask unsigned-long) + (sc-pc system-area-pointer) + (sc-ps unsigned-long) + (sc-regs (array unsigned-long 32)) + (sc-ownedfp unsigned-long) + (sc-fpregs (array unsigned-long 32)) + (sc-fpcr unsigned-long) + (sc-fp-control unsigned-long) + (sc-reserved1 unsigned-long) + (sc-reserved2 unsigned-long) + (sc-reserved3 unsigned-long) + (sc-reserved4 unsigned-long) + (sc-traparg-a0 unsigned-long) + (sc-traparg-a1 unsigned-long) + (sc-traparg-a2 unsigned-long) + (sc-fp-trap-pc unsigned-long) ; imprecise pc + (sc-fp-trigger-sum unsigned-long) + (sc-fp-trigger-inst unsigned-long))) + + + +;;;; Add machine specific features to *features* + +(pushnew :alpha *features*) + + + +;;;; MACHINE-TYPE and MACHINE-VERSION + +(defun machine-type () + "Returns a string describing the type of the local machine." + "DECstation") + +(defun machine-version () + "Returns a string describing the version of the local machine." + "DECstation") + + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; +(defun fixup-code-object (code offset value kind) + (unless (zerop (rem offset word-bytes)) + (error "Unaligned instruction? offset=#x~X." offset)) + (system:without-gcing + (let ((sap (truly-the system-area-pointer + (%primitive c::code-instructions code)))) + (ecase kind + (:jmp-hint + (assert (zerop (ldb (byte 2 0) value))) + #+nil + (setf (sap-ref-16 sap offset) + (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2))))) + (:bits-63-48 + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) + (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) + (:bits-47-32 + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) + (:ldah + (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) + (:lda + (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) + + + +;;;; Internal-error-arguments. + +;;; INTERNAL-ERROR-ARGUMENTS -- interface. +;;; +;;; Given the sigcontext, extract the internal error arguments from the +;;; instruction stream. +;;; +(defun internal-error-arguments (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (let ((pc (slot scp 'sc-pc))) + (declare (type system-area-pointer pc)) + (let* ((length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-from-system-area pc (* vm:byte-bits 5) + vector (* vm:word-bits + vm:vector-data-offset) + (* length vm:byte-bits)) + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (c::read-var-integer vector index))) + (values error-number (sc-offsets)))))))) + + +;;;; Sigcontext access functions. + +;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. +;;; +(defun sigcontext-program-counter (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (slot scp 'sc-pc))) + +;;; SIGCONTEXT-REGISTER -- Interface. +;;; +;;; An escape register saves the value of a register for a frame that someone +;;; interrupts. +;;; +(defun sigcontext-register (scp index) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (deref (slot scp 'sc-regs) index))) + +(defun %set-sigcontext-register (scp index new) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (setf (deref (slot scp 'sc-regs) index) new) + new)) + +(defsetf sigcontext-register %set-sigcontext-register) + + +;;; SIGCONTEXT-FLOAT-REGISTER -- Interface. +;;; +;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Format is the type of float to return. +;;; +(defun sigcontext-float-register (scp index format) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (let ((sap (alien-sap (slot scp 'sc-fpregs)))) + (ecase format + (single-float (system:sap-ref-single sap (* index vm:word-bytes))) + (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) +;;; +(defun %set-sigcontext-float-register (scp index format new-value) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (let ((sap (alien-sap (slot scp 'sc-fpregs)))) + (ecase format + (single-float + (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) + (double-float + (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) +;;; +(defsetf sigcontext-float-register %set-sigcontext-float-register) + + +;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; +;;; Given a sigcontext pointer, return the floating point modes word in the +;;; same format as returned by FLOATING-POINT-MODES. +;;; +(defun sigcontext-floating-point-modes (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (slot scp 'sc-fpcr))) + + + +;;; EXTERN-ALIEN-NAME -- interface. +;;; +;;; The loader uses this to convert alien names to the form they occure in +;;; the symbol table (for example, prepending an underscore). On the MIPS, +;;; we don't do anything. +;;; +(defun extern-alien-name (name) + (declare (type simple-base-string name)) + name) + + + +;;; SANCTIFY-FOR-EXECUTION -- Interface. +;;; +;;; Do whatever is necessary to make the given code component executable. +;;; +(defun sanctify-for-execution (component) + (declare (ignore component)) + nil) diff --git a/compiler/alpha/alloc.lisp b/compiler/alpha/alloc.lisp new file mode 100644 index 000000000..37f43d4d1 --- /dev/null +++ b/compiler/alpha/alloc.lisp @@ -0,0 +1,187 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/alloc.lisp,v 1.1 1994/04/06 16:53:01 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Allocation VOPs for the Alpha port. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. +;;; + +(in-package "ALPHA") + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:scs (descriptor-reg) :type list) ptr) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) + res) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + (move null-tn result)) + ((and star (= num 1)) + (move (tn-ref-tn things) result)) + (t + (macrolet + ((store-car (tn list &optional (slot cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + (zero zero-tn) + (null null-tn) + (control-stack + (load-stack-tn temp ,tn) + temp)))) + (storew reg ,list ,slot list-pointer-type)))) + (let ((cons-cells (if star (1- num) num))) + (pseudo-atomic (:extra (* (pad-data-block cons-size) + cons-cells)) + (inst bis alloc-tn list-pointer-type res) + (move res ptr) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst lda ptr (pad-data-block cons-size) ptr) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-type)) + (store-car (tn-ref-tn things) ptr) + (cond (star + (setf things (tn-ref-across things)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) + (t + (storew null-tn ptr + cons-cdr-slot list-pointer-type))) + (assert (null (tn-ref-across things))) + (move res result)))))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg)) + (unboxed-arg :scs (any-reg))) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (any-reg) :from (:argument 0)) boxed) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:generator 100 + (inst li (lognot lowtag-mask) ndescr) + (inst lda boxed (fixnum (1+ code-trace-table-offset-slot)) + boxed-arg) + (inst and boxed ndescr boxed) + (inst srl unboxed-arg word-shift unboxed) + (inst lda unboxed lowtag-mask unboxed) + (inst and unboxed ndescr unboxed) + (inst sll boxed (- type-bits word-shift) ndescr) + (inst bis ndescr code-header-type ndescr) + + (pseudo-atomic () + (inst bis alloc-tn other-pointer-type result) + (storew ndescr result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + (storew null-tn result code-entry-points-slot other-pointer-type) + (inst addq alloc-tn boxed alloc-tn) + (inst addq alloc-tn unboxed alloc-tn)) + + (storew null-tn result code-debug-info-slot other-pointer-type))) + +(define-vop (make-fdefn) + (:policy :fast-safe) + (:translate make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg) :from :argument)) + (:generator 37 + (with-fixed-allocation (result temp fdefn-type fdefn-size) + (storew name result fdefn-name-slot other-pointer-type) + (storew null-tn result fdefn-function-slot other-pointer-type) + (inst li (make-fixup "undefined_tramp" :foreign) temp) + (storew temp result fdefn-raw-addr-slot other-pointer-type)))) + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + (inst li (logior (ash (1- size) type-bits) closure-header-type) temp) + (pseudo-atomic (:extra (pad-data-block size)) + (inst bis alloc-tn function-pointer-type result) + (storew temp result 0 function-pointer-type)) + (storew function result closure-function-slot function-pointer-type)))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg any-reg null zero))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result temp value-cell-header-type value-cell-size)) + (storew value result value-cell-value-slot other-pointer-type))) + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst li unbound-marker-type result))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (pseudo-atomic (:extra (pad-data-block words)) + (inst bis alloc-tn lowtag result) + (when type + (inst li (logior (ash (1- words) type-bits) type) temp) + (storew temp result 0 lowtag))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) header) + (:temporary (:scs (non-descriptor-reg)) bytes) + (:generator 6 + (inst lda bytes (* (1+ words) word-bytes) extra) + (inst sll bytes (- type-bits 2) header) + (inst lda header (+ (ash -2 type-bits) type) header) + (inst srl bytes lowtag-bits bytes) + (inst sll bytes lowtag-bits bytes) + (pseudo-atomic () + (inst bis alloc-tn lowtag result) + (storew header result 0 lowtag) + (inst addq alloc-tn bytes alloc-tn)))) diff --git a/compiler/alpha/arith.lisp b/compiler/alpha/arith.lisp new file mode 100644 index 000000000..a89d5475c --- /dev/null +++ b/compiler/alpha/arith.lisp @@ -0,0 +1,808 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/arith.lisp,v 1.1 1994/04/06 16:54:36 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/arith.lisp,v 1.1 1994/04/06 16:54:36 hallgren Exp $ +;;; +;;; This file contains the VM definition arithmetic VOPs for the MIPS. +;;; +;;; Written by Rob MacLachlan +;;; Converted by Sean Hallgren +;;; + +(in-package "ALPHA") + + + +;;;; Unary operations. + +(define-vop (fixnum-unop) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num) + (:policy :fast-safe)) + +(define-vop (signed-unop) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num) + (:policy :fast-safe)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst subq zero-tn x res))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst subq zero-tn x res))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (inst eqv x zero-tn res))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst not x res))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg)) + (y :target r :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-signed-binop) + (:args (x :target r :scs (signed-reg)) + (y :target r :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-fixnum-c-binop fast-fixnum-binop) + (:args (x :target r :scs (any-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-signed-c-binop fast-signed-binop) + (:args (x :target r :scs (signed-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(define-vop (fast-unsigned-c-binop fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg))) + (:info y) + (:arg-types tagged-num (:constant integer))) + +(defmacro define-binop (translate cost untagged-cost op + tagged-type untagged-type) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:args (x :target r :scs (any-reg)) + (y :target r :scs (any-reg))) + (:translate ,translate) + (:generator ,(1+ cost) + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:args (x :target r :scs (signed-reg)) + (y :target r :scs (signed-reg))) + (:translate ,translate) + (:generator ,(1+ untagged-cost) + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:args (x :target r :scs (unsigned-reg)) + (y :target r :scs (unsigned-reg))) + (:translate ,translate) + (:generator ,(1+ untagged-cost) + (inst ,op x y r))) + ,@(when tagged-type + `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") + fast-fixnum-c-binop) + (:arg-types tagged-num (:constant ,tagged-type)) + (:translate ,translate) + (:generator ,cost + (inst ,op x (fixnum y) r))))) + ,@(when untagged-type + `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") + fast-signed-c-binop) + (:arg-types signed-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate + "-C/UNSIGNED=>UNSIGNED") + fast-unsigned-c-binop) + (:arg-types unsigned-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))))))) + +(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8)) +(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8)) +(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8)) +(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8)) + + +;;; Shifting + + +(define-vop (fast-ash) + (:note "inline ASH") + (:args (number :scs (signed-reg unsigned-reg) :to :save) + (amount :scs (signed-reg))) + (:arg-types (:or signed-num unsigned-num) signed-num) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:temporary (:sc non-descriptor-reg :to :eval) temp) + (:generator 3 + (inst bge amount positive) + (inst subq zero-tn amount ndesc) + (inst cmplt ndesc 31 temp) + (sc-case number + (signed-reg (inst sra number ndesc result)) + (unsigned-reg (inst srl number ndesc result))) + (inst bne temp done) + (sc-case number + (signed-reg (inst sra number 31 result)) + (unsigned-reg (inst srl number 31 result))) + (inst br zero-tn done) + + POSITIVE + ;; The result-type assures us that this shift will not overflow. + (inst sll number amount result) + + DONE)) + +(define-vop (fast-ash-c) + (:policy :fast-safe) + (:translate ash) + (:note nil) + (:args (number :scs (signed-reg unsigned-reg))) + (:info count) + (:arg-types (:or signed-num unsigned-num) (:constant integer)) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:generator 1 + (cond ((< count 0) + ;; It is a right shift. + (sc-case number + (signed-reg (inst sra number (- count) result)) + (unsigned-reg (inst srl number (- count) result)))) + ((> count 0) + ;; It is a left shift. + (inst sll number count result)) + (t + ;; Count=0? Shouldn't happen, but it's easy: + (move number result))))) + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :to (:argument 1))) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) + (:generator 30 + (inst not arg shift) + (inst cmovge arg arg shift) + (inst subq zero-tn 4 res) + (inst sll shift 1 shift) + LOOP + (inst addq res (fixnum 1) res) + (inst srl shift 1 shift) + (inst bne shift loop))) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target num)) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) + :target res) num) + (:temporary (:scs (non-descriptor-reg)) mask temp) + (:generator 30 + (inst li #x55555555 mask) + (inst srl arg 1 temp) + (inst and arg mask num) + (inst and temp mask temp) + (inst addq num temp num) + (inst li #x33333333 mask) + (inst srl num 2 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst addq num temp num) + (inst li #x0f0f0f0f mask) + (inst srl num 4 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst addq num temp num) + (inst li #x00ff00ff mask) + (inst srl num 8 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst addq num temp num) + (inst li #x0000ffff mask) + (inst srl num 16 temp) + (inst and num mask num) + (inst and temp mask temp) + (inst addq num temp res))) + + +;;; Multiply + +(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:translate *) + (:generator 4 + (inst sra y 2 temp) + (inst mulq x temp r))) + +(define-vop (fast-*/signed=>signed fast-signed-binop) + (:translate *) + (:generator 3 + (inst mulq x y r))) + +(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) + (:translate *) + (:generator 3 + (inst mulq x y r))) + + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:temporary (:scs (non-descriptor-reg)) temp) + (:policy :fast-safe)) + +(deftype integer-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 s))) + `(integer 0 ,(- bound bite 1)))) + (t + (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg))) + (:arg-types tagged-num (:constant (integer-with-a-bite-out 6 4))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg))) + (:arg-types signed-num (:constant (integer-with-a-bite-out 8 1))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num (:constant (integer-with-a-bite-out 8 1))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (translate &rest generator) + `(progn + ,@(mapcar #'(lambda (suffix cost signed) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq translate 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + translate suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,translate) + (:generator ,cost + (let* ((signed ,signed) + (-c/fixnum ,(eq suffix '-c/fixnum)) + (y (if -c/fixnum (fixnum y) y))) + (declare (optimize (inhibit-warnings 3))) + ,@generator))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(3 2 5 4 5 4) + '(t t t t nil nil)))) + +(define-conditional-vop < + (cond ((and signed (eql y 0)) + (if not-p + (inst bge x target) + (inst blt x target))) + (t + (if signed + (inst cmplt x y temp) + (inst cmpult x y temp)) + (if not-p + (inst beq temp target) + (inst bne temp target))))) + +(define-conditional-vop > + (cond ((and signed (eql y 0)) + (if not-p + (inst ble x target) + (inst bgt x target))) + ((integerp y) + (let ((y (+ y (if -c/fixnum (fixnum 1) 1)))) + (if signed + (inst cmplt x y temp) + (inst cmpult x y temp)) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + (t + (if signed + (inst cmplt y x temp) + (inst cmpult y x temp)) + (if not-p + (inst beq temp target) + (inst bne temp target))))) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +(define-conditional-vop eql + (declare (ignore signed)) + (when (integerp y) + (inst li y temp) + (setf y temp)) + (inst cmpeq x y temp) + (if not-p + (inst beq temp target) + (inst bne temp target))) + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. +;;; +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 3 + (cond ((equal y zero-tn) + (if not-p + (inst bne x target) + (inst beq x target))) + (t + (inst cmpeq x y temp) + (if not-p + (inst beq temp target) + (inst bne temp target)))))) + +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg))) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg))) + (:arg-types tagged-num (:constant (signed-byte 6))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:info target not-p y) + (:translate eql) + (:generator 2 + (let ((y (cond ((eql y 0) zero-tn) + (t + (inst li (fixnum y) temp) + temp)))) + (inst cmpeq x y temp) + (if not-p + (inst beq temp target) + (inst bne temp target))))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:arg-types * (:constant (signed-byte 6))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg)) + (prev :scs (unsigned-reg)) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (let ((done (gen-label))) + (inst srl next shift res) + (inst beq shift done) + (inst subq zero-tn shift temp) + (inst sll prev temp temp) + (inst bis res temp res) + (emit-label done) + (move res result)))) + + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not 32bit-logical) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:generator 1 + (inst not x r))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (inst and x y r))) + +(deftransform 32bit-logical-nand ((x y) (* *)) + '(32bit-logical-not (32bit-logical-and x y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (inst bis x y r))) + +(define-vop (32bit-logical-nor 32bit-logical) + (:translate 32bit-logical-nor) + (:generator 1 + (inst ornot x y r))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (inst xor x y r))) + +(deftransform 32bit-logical-eqv ((x y) (* *)) + '(32bit-logical-not (32bit-logical-xor x y))) + +(deftransform 32bit-logical-andc1 ((x y) (* *)) + '(32bit-logical-and (32bit-logical-not x) y)) + +(deftransform 32bit-logical-andc2 ((x y) (* *)) + '(32bit-logical-and x (32bit-logical-not y))) + +(deftransform 32bit-logical-orc1 ((x y) (* *)) + '(32bit-logical-or (32bit-logical-not x) y)) + +(deftransform 32bit-logical-orc2 ((x y) (* *)) + '(32bit-logical-or x (32bit-logical-not y))) + + +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg)) + (amount :scs (signed-reg))) + (:arg-types unsigned-num tagged-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:note "SHIFT-TOWARDS-START") + (:temporary (:sc non-descriptor-reg) temp) + (:generator 1 + (inst and amount #x1f temp) + (inst srl num temp r))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note "SHIFT-TOWARDS-END") + (:temporary (:sc non-descriptor-reg) temp) + (:generator 1 + (inst and amount #x1f temp) + (inst sll num temp r))) + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-ref) + +(define-full-setter bignum-set * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-set #+gengc nil) + +(define-vop (digit-0-or-plus) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:temporary (:sc non-descriptor-reg) temp) + (:conditional) + (:info target not-p) + (:generator 2 + (inst sll digit 32 temp) + (if not-p + (inst blt temp target) + (inst bge temp target)))) + +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from :load) + (carry :scs (unsigned-reg) :from :eval)) + (:result-types unsigned-num positive-fixnum) + (:generator 5 + (inst addq a b result) + (inst addq result c result) + (inst sra result 32 carry) + (inst mskll result 4 result))) + +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from :load) + (borrow :scs (unsigned-reg) :from :eval)) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (inst xor c 1 result) + (inst subq a result result) + (inst subq result b result) + (inst srl result 63 borrow) + (inst xor borrow 1 borrow) + (inst mskll result 4 result))) + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) :to :save)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 6 + (inst mulq x y lo) + (inst addq lo carry-in lo) + (inst sra lo 32 hi) + (inst mskll lo 4 lo))) + + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg)) + (prev :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) :to :save)) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 9 + (inst mulq x y lo) + (inst addq lo prev lo) + (inst addq lo carry-in lo) + (inst sra lo 32 hi) + (inst mskll lo 4 lo))) + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 3 + (inst mulq x y lo) + (inst srl lo 32 hi) + (inst mskll lo 4 lo))) + +(define-vop (bignum-lognot) + (:translate bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst not x r) + (inst mskll r 4 r))) + +(define-vop (fixnum-to-digit) + (:translate bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg))) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (inst sra fixnum 2 digit))) + +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (num-high :scs (unsigned-reg)) + (num-low :scs (unsigned-reg)) + (denom-arg :scs (unsigned-reg) :target denom)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom) + (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) + (:results (quo :scs (unsigned-reg) :from (:eval 0)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:generator 325 ; number of inst assuming targeting works. + (inst sll num-high 32 rem) + (inst bis rem num-low rem) + (inst sll denom-arg 32 denom) + (inst cmpule denom rem quo) + (inst beq quo shift1) + (inst subq rem denom rem) + SHIFT1 + (dotimes (i 32) + (let ((shift2 (gen-label))) + (inst srl denom 1 denom) + (inst cmpule denom rem temp) + (inst sll quo 1 quo) + (inst beq temp shift2) + (inst subq rem denom rem) + (inst bis quo 1 quo) + (emit-label shift2))))) + +(define-vop (signify-digit) + (:translate bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg))) + (:result-types signed-num) + (:generator 2 + (sc-case res + (any-reg + (inst sll digit 34 res) + (inst sra res 32 res)) + (signed-reg + (inst sll digit 32 res) + (inst sra res 32 res))))) + + +(define-vop (digit-ashr) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg)) + (count :scs (unsigned-reg))) + (:arg-types unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:generator 1 + (inst sll digit 32 result) + (inst sra result count result) + (inst srl result 32 result))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (inst srl digit count result))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 1 + (inst sll digit count result))) + + +;;;; Static functions. + +(define-static-function two-arg-gcd (x y) :translate gcd) +(define-static-function two-arg-lcm (x y) :translate lcm) + +(define-static-function two-arg-+ (x y) :translate +) +(define-static-function two-arg-- (x y) :translate -) +(define-static-function two-arg-* (x y) :translate *) +(define-static-function two-arg-/ (x y) :translate /) + +(define-static-function two-arg-< (x y) :translate <) +(define-static-function two-arg-<= (x y) :translate <=) +(define-static-function two-arg-> (x y) :translate >) +(define-static-function two-arg->= (x y) :translate >=) +(define-static-function two-arg-= (x y) :translate =) +(define-static-function two-arg-/= (x y) :translate /=) + +(define-static-function %negate (x) :translate %negate) + +(define-static-function two-arg-and (x y) :translate logand) +(define-static-function two-arg-ior (x y) :translate logior) +(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/alpha/array.lisp b/compiler/alpha/array.lisp new file mode 100644 index 000000000..a015df740 --- /dev/null +++ b/compiler/alpha/array.lisp @@ -0,0 +1,443 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/array.lisp,v 1.1 1994/04/06 16:54:37 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the Alpha definitions for array operations. +;;; +;;; Written by William Lott +;;; Conversion by Sean Hallgren +;;; +(in-package "ALPHA") + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:policy :fast-safe) + (:translate make-array-header) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types positive-fixnum positive-fixnum) + (:temporary (:scs (any-reg)) bytes) + (:temporary (:scs (non-descriptor-reg)) header) + (:results (result :scs (descriptor-reg))) + (:generator 13 + (inst addq rank (+ (* array-dimensions-offset word-bytes) + lowtag-mask) + bytes) + (inst li (lognot lowtag-mask) header) + (inst and bytes header bytes) + (inst addq rank (fixnum (1- array-dimensions-offset)) header) + (inst sll header type-bits header) + (inst bis header type header) + (inst srl header 2 header) + (pseudo-atomic () + (inst bis alloc-tn other-pointer-type result) + (storew header result 0 other-pointer-type) + (inst addq alloc-tn bytes alloc-tn)))) + + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t index) index + (flushable)) +(defknown lisp::%set-array-dimension (t index index) index + ()) + +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%array-dimension) + +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%set-array-dimension #+gengc nil) + + +(defknown lisp::%array-rank (t) index (flushable)) + +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw temp x 0 other-pointer-type) + (inst sra temp type-bits temp) + (inst subq temp (1- array-dimensions-offset) temp) + (inst sll temp 2 res))) + + + +;;;; Bounds checking routine. + + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst cmpult index bound temp) + (inst beq temp error) + (move index result)))) + + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(eval-when (compile eval) + +(defmacro def-full-data-vector-frobs (type element-type &rest scs) + `(progn + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-type + ,(remove-if #'(lambda (x) (member x '(null zero))) scs) + ,element-type + data-vector-ref) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil)))) + +(defmacro def-partial-data-vector-frobs + (type element-type size signed &rest scs) + `(progn + (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + ,size ,signed vector-data-offset other-pointer-type ,scs + ,element-type data-vector-ref) + (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + ,size vector-data-offset other-pointer-type ,scs + ,element-type data-vector-set))) + +); eval-when (compile eval) + +(def-full-data-vector-frobs simple-vector * + descriptor-reg any-reg null zero) + +(def-partial-data-vector-frobs simple-string base-char :byte nil + base-char-reg) + +(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum + :byte nil unsigned-reg signed-reg) + +(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum + :short nil unsigned-reg signed-reg) + +(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) + + + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:generator 20 + (inst srl index ,bit-shift temp) + (inst sll temp 2 temp) + (inst addq object temp lip) + (inst ldl result + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip) + (inst and index ,(1- elements-per-word) temp) + ,@(when (eq (backend-byte-order *backend*) :big-endian) + `((inst xor temp ,(1- elements-per-word) temp))) + ,@(unless (= bits 1) + `((inst sll temp ,(1- (integer-length bits)) temp))) + (inst srl result temp result) + (inst and result ,(1- (ash 1 bits)) result) + (inst sll result 2 value))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type + (:constant + (integer 0 + ,(1- (* (1+ (- (floor (+ #x7fff + other-pointer-type) + word-bytes) + vector-data-offset)) + elements-per-word))))) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + ,@(when (eq (backend-byte-order *backend*) :big-endian) + `((setf extra (logxor extra (1- ,elements-per-word))))) + (loadw result object (+ word vector-data-offset) + other-pointer-type) + (unless (zerop extra) + (inst srl result (* extra ,bits) result)) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits)) result))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg) :target shift) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) temp old) + (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) + (:generator 25 + (inst srl index ,bit-shift temp) + (inst sll temp 2 temp) + (inst addq object temp lip) + (inst ldl old + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip) + (inst and index ,(1- elements-per-word) shift) + ,@(when (eq (backend-byte-order *backend*) :big-endian) + `((inst xor shift ,(1- elements-per-word) shift))) + ,@(unless (= bits 1) + `((inst sll shift ,(1- (integer-length bits)) shift))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst li ,(1- (ash 1 bits)) temp) + (inst sll temp shift temp) + (inst not temp temp) + (inst and old temp old)) + (unless (sc-is value zero) + (sc-case value + (immediate + (inst li (logand (tn-value value) ,(1- (ash 1 bits))) temp)) + (unsigned-reg + (inst and value ,(1- (ash 1 bits)) temp))) + (inst sll temp shift temp) + (inst bis old temp old)) + (inst stl old + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (zero + (move zero-tn result)) + (unsigned-reg + (move value result))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg zero immediate) :target result)) + (:arg-types ,type + (:constant + (integer 0 + ,(1- (* (1+ (- (floor (+ #x7fff + other-pointer-type) + word-bytes) + vector-data-offset)) + elements-per-word)))) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + ,@(when (eq (backend-byte-order *backend*) :big-endian) + `((setf extra (logxor extra (1- ,elements-per-word))))) + (inst ldl object + (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type) + old) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (cond ((= extra ,(1- elements-per-word)) + (inst sll old ,bits old) + (inst srl old ,bits old)) + (t + (inst li + (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))) + temp) + (inst and old temp old)))) + (sc-case value + (zero) + (immediate + (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits))) + (* extra ,bits)))) + (cond ((< value #x10000) + (inst bis old value old)) + (t + (inst li value temp) + (inst bis old temp old))))) + (unsigned-reg + (inst sll value (* extra ,bits) temp) + (inst bis old temp old))) + (inst stl old + (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type) + object) + (sc-case value + (immediate + (inst li (tn-value value) result)) + (zero + (move zero-tn result)) + (unsigned-reg + (move value result))))))))) + +(def-small-data-vector-frobs simple-bit-vector 1) +(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) +(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) + + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-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-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst addq object index lip) + (inst lds value + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip))) + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst addq object index lip) + (inst sts value + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip) + (unless (location= result value) + (inst fmove value result)))) + +(define-vop (data-vector-ref/simple-array-double-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-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst addq object index lip) + (inst addq lip index lip) + (inst ldt value + (- (* vector-data-offset word-bytes) + other-pointer-type) + lip))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (interior-reg)) lip) + (:generator 20 + (inst addq object index lip) + (inst addq lip index lip) + (inst stt value + (- (* vector-data-offset word-bytes) + other-pointer-type) lip) + (unless (location= result value) + (inst fmove value result)))) + + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) + + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num + %raw-bits) +(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) + unsigned-num %set-raw-bits #+gengc nil) + + + +;;;; Misc. Array VOPs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + diff --git a/compiler/alpha/c-call.lisp b/compiler/alpha/c-call.lisp new file mode 100644 index 000000000..2a7af2979 --- /dev/null +++ b/compiler/alpha/c-call.lisp @@ -0,0 +1,180 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/c-call.lisp,v 1.1 1994/04/06 16:54:38 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. +;;; +(in-package "ALPHA") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") + +(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*) + offset)) + +(defstruct arg-state + (stack-frame-size 0)) + +(def-alien-type-method (integer :arg-tn) (type state) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (multiple-value-bind + (ptype reg-sc stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-64 'signed-reg 'signed-stack) + (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)) + (if (< stack-frame-size 4) + (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset)) + (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4))))))) + +(def-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (if (< stack-frame-size 4) + (my-make-wired-tn 'system-area-pointer + 'sap-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + (* 2 (- stack-frame-size 4)))))) + +(def-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (if (< stack-frame-size 6) + (my-make-wired-tn 'double-float + 'double-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'double-float + 'double-stack + (* 2 (- stack-frame-size 6)))))) + +(def-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (if (< stack-frame-size 6) + (my-make-wired-tn 'single-float + 'single-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'single-float + 'single-stack + (* 2 (- stack-frame-size 6)))))) + + + +(def-alien-type-method (integer :result-tn) (type state) + (declare (ignore state)) + (multiple-value-bind + (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-64 'signed-reg) + (values 'unsigned-byte-64 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc lip-offset))) + +(def-alien-type-method (system-area-pointer :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset)) + +(def-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'double-float 'double-reg lip-offset)) + +(def-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'single-float 'single-reg lip-offset)) + +(def-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (cdr values) + (error "Too many result values from c-call.")) + (when values + (invoke-alien-type-method :result-tn (car values) state)))) + +(def-vm-support-routine make-call-out-tns (type) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-function-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) + (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-function-type-result-type type) + nil))))) + + +(define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst li (make-fixup foreign-symbol :foreign) res))) + +(define-vop (call-out) + (:args (function :scs (sap-reg) :target cfunc) + (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:temporary (:sc any-reg :offset cfunc-offset + :from (:argument 0) :to (:result 0)) cfunc) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move function cfunc) + (inst li (make-fixup "call_into_c" :foreign) temp) + (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 7) 7))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn (- delta) nsp-tn)) + (t + (inst li delta temp) + (inst subq nsp-tn temp nsp-tn))))) + (move nsp-tn result))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 7) 7))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn delta nsp-tn)) + (t + (inst li delta temp) + (inst addq nsp-tn temp nsp-tn))))))) diff --git a/compiler/alpha/call.lisp b/compiler/alpha/call.lisp new file mode 100644 index 000000000..531253ad7 --- /dev/null +++ b/compiler/alpha/call.lisp @@ -0,0 +1,1301 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/call.lisp,v 1.1 1994/04/06 16:54:39 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of function call for the Alpha. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted for the Alpha by Sean Hallgren +;;; +(in-package :alpha) + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(def-vm-support-routine standard-argument-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *any-primitive-type* + register-arg-scn + (elt register-arg-offsets n)) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn n))) + + +;;; Make-Return-PC-Passing-Location -- Interface +;;; +;;; Make a passing location TN for a local call return PC. If standard is +;;; true, then use the standard (full call) location, otherwise use any legal +;;; location. Even in the non-standard case, this may be restricted by a +;;; desire to use a subroutine call instruction. +;;; +(def-vm-support-routine make-return-pc-passing-location (standard) + #+gengc (declare (ignore standard)) + #-gengc + (if standard + (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *any-primitive-type* register-arg-scn)) + #+gengc + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ra-offset)) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. This is (obviously) wired in the standard convention, but is +;;; totally unrestricted in non-standard conventions, since we can always fetch +;;; it off of the stack using the arg pointer. +;;; +(def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +(def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) +;;; +(def-vm-support-routine make-return-pc-save-location (env) + (let ((ptype #-gengc *any-primitive-type* + #+gengc *fixnum-primitive-type*)) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn ptype) env) + (make-wired-tn ptype control-stack-arg-scn + #-gengc lra-save-offset #+gengc ra-save-offset)))) + +;;; Make-Argument-Count-Location -- Interface +;;; +;;; Make a TN for the standard argument count passing location. We only +;;; need to make the standard location, since a count is never passed when we +;;; are using non-standard conventions. +;;; +(def-vm-support-routine make-argument-count-location () + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset)) + + +;;; MAKE-NFP-TN -- Interface +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated +;;; once per component, and is component-live. +;;; +(def-vm-support-routine make-nfp-tn () + (component-live-tn + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset))) + +;;; MAKE-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-number-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +(def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (undefined-value)) + + +;;;; Frame hackery: + +;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal +;;; +;;; Return the number of bytes needed for the current non-descriptor stack +;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on +;;; the PMAX. +;;; +(defun bytes-needed-for-non-descriptor-stack-frame () + (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1) + word-bytes)) + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg))) + (:generator 1 + (move cfp-tn val))) + +;;; Used for computing the caller's NFP for use in known-values return. Only +;;; works assuming there is no variable size stuff on the nstack. +;;; +(define-vop (compute-old-nfp) + (:results (val :scs (any-reg))) + (:vop-var vop) + (:generator 1 + (let ((nfp (current-nfp-tn vop))) + (when nfp + (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val))))) + + +(define-vop (xep-allocate-frame) + (:info start-lab) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align lowtag-bits) + (trace-table-entry trace-table-function-prologue) + (emit-label start-lab) + ;; Allocate function header. + (inst function-header-word) + (dotimes (i (1- function-code-offset)) + (inst lword 0)) + ;; The start of the actual code. + ;; Compute CODE from the address of this entry point. + (let ((entry-point (gen-label))) + (emit-label entry-point) + (inst compute-code-from-fn code-tn lip-tn entry-point temp) + ;; ### We should also save it on the stack so that the garbage collector + ;; won't forget about us if we call anyone else. + ) + ;; Build our stack frames. + (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) cfp-tn) + (let ((nfp (current-nfp-tn vop))) + (when nfp + (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn) + (move nsp-tn nfp))) + (trace-table-entry trace-table-normal))) + +(define-vop (allocate-frame) + (:results (res :scs (any-reg)) + (nfp :scs (any-reg))) + (:info callee) + (:generator 2 + (trace-table-entry trace-table-function-prologue) + (move csp-tn res) + (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) csp-tn) + (when (ir2-environment-number-stack-p callee) + (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn) + (move nsp-tn nfp)) + (trace-table-entry trace-table-normal))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. If no stack arguments are passed, then +;;; we don't have to do anything. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg))) + (:generator 2 + (when (> nargs register-arg-count) + (move csp-tn res) + (inst lda csp-tn (* nargs word-bytes) csp-tn)))) + + + +;;; Default-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return-point from an unknown-values call for a +;;; fixed number of values. Values is the head of the TN-Ref list for the +;;; locations that the values are to be received into. Nvals is the number of +;;; values that are to be received (should equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a +;;; single value return returns at the return PC + 8, whereas a return of other +;;; than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case, we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; The general-case code looks like this: +#| + b regs-defaulted ; Skip if MVs + nop + + move a1 null-tn ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + move ocfp csp ; Set up args for SP resetting + +regs-defaulted + subu temp nargs register-arg-count + + bltz temp default-value-7 ; jump to default code + addu temp temp -1 + loadw move-temp ocfp-tn 6 ; Move value to correct location. + store-stack-tn val4-tn move-temp + + bltz temp default-value-8 + addu temp temp -1 + loadw move-temp ocfp-tn 7 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + move sp ocfp ; Reset SP. +<end of code> + +<elsewhere> +default-value-7 + store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) + +default-value-8 + store-stack-tn val5-tn null-tn ; Nil out 8'th value. + + ... + + br defaulting-done + nop +|# +;;; +(defun default-unknown-values (vop values nvals move-temp temp lra-label) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals) (type tn move-temp temp)) + (if (<= nvals 1) + (progn + ;; Note that this is a single-value return point. This is actually + ;; the multiple-value entry point for a single desired value, but + ;; the code location has to be here, or the debugger backtrace + ;; gets confused. + (without-scheduling () + (note-this-location vop :single-value-return) + (move ocfp-tn csp-tn) + (inst nop)) + (when lra-label + #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) + #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))) + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-vals (gen-label))) + (without-scheduling () + ;; Note that this is an unknown-values return point. + (note-this-location vop :unknown-return) + ;; If there are no stack results, clear the stack now. + (if (> nvals register-arg-count) + (inst subq nargs-tn (fixnum register-arg-count) temp) + (move ocfp-tn csp-tn)) + ;; Branch off to the MV case. + (inst br zero-tn regs-defaulted)) + + ;; Do the single value calse. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (move null-tn (tn-ref-tn val))) + (when (> nvals register-arg-count) + (move csp-tn ocfp-tn) + (inst br zero-tn default-stack-vals)) + + (emit-label regs-defaulted) + + (when (> nvals register-arg-count) + ;; If there are stack results, we have to default them + ;; and clear the stack. + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst blt temp default-lab) + (inst ldl move-temp (* i word-bytes) ocfp-tn) + (inst subq temp (fixnum 1) temp) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move ocfp-tn csp-tn) + + (let ((defaults (defaults))) + (assert defaults) + (assemble (*elsewhere*) + (emit-label default-stack-vals) + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (when (null (cdr remaining)) + (inst br zero-tn defaulting-done)) + (store-stack-tn (cdr def) null-tn))))))) + + (when lra-label + #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) + #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)))) + (undefined-value)) + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count lra-label temp) + (declare (type tn args nargs start count temp)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (without-scheduling () + (inst br zero-tn variable-values) + (inst nop)) + + (when lra-label + #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) + #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)) + (inst addq csp-tn 4 csp-tn) + (storew (first register-arg-tns) csp-tn -1) + (inst subq csp-tn 4 start) + (inst li (fixnum 1) count) + + (emit-label done) + + (assemble (*elsewhere*) + (emit-label variable-values) + (when lra-label + #-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp) + #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)) + (do ((arg register-arg-tns (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move args start) + (move nargs count) + (inst br zero-tn done))) + (undefined-value)) + + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:results + (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :offset ocfp-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset nargs-offset + :from :eval :to (:result 1)) + nvals) + (:temporary (:scs (non-descriptor-reg)) temp)) + + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; Return-PC is the TN that the return PC should be passed in. +;;; Target is a continuation pointing to the start of the called function. +;;; Nvals is the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:temporary (:scs (descriptor-reg) :from :eval) move-temp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp) + (:ignore arg-locs args ocfp) + (:generator 5 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-tn cfp-tn fp) + (trace-table-entry trace-table-call-site) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst br zero-tn target) + (trace-table-entry trace-table-normal) + (emit-return-pc label) + (default-unknown-values vop values nvals move-temp temp label) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) + + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 20 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-tn cfp-tn fp) + (trace-table-entry trace-table-call-site) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst bsr zero-tn target) + (trace-table-entry trace-table-normal) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label temp) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save) + (:vop-var vop) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (let (#-gengc (label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (let ((callee-nfp (callee-nfp-tn callee))) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-tn cfp-tn fp) + (trace-table-entry trace-table-call-site) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (note-this-location vop :call-site) + (inst bsr zero-tn target) + (trace-table-entry trace-table-normal) + (emit-return-pc label) + (note-this-location vop :known-return) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-return) + (:args (ocfp :target ocfp-temp) + (return-pc :target return-pc-temp) + (vals :more t)) + (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) + (:temporary (:sc #-gengc descriptor-reg #+gengc any-reg :from (:argument 1)) + return-pc-temp) + #-gengc (:temporary (:scs (interior-reg)) lip) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + (maybe-load-stack-tn ocfp-temp ocfp) + (maybe-load-stack-tn return-pc-temp return-pc) + (move cfp-tn csp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + (inst subq return-pc-temp (- other-pointer-type word-bytes) lip) + (move ocfp-temp cfp-tn) + (inst ret zero-tn lip 1) + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. If there are no stack +;;; arguments, we don't bother allocating a partial frame, and instead set FP +;;; to SP just before the call. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is a symbol whose global function +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Ocfp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to :eval))) + + ,(if named + '(name :target name-pass) + '(arg-fun :target lexenv)) + + ,@(when (eq return :tail) + '((ocfp :target ocfp-pass) + (return-pc :target return-pc-pass))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore #+gengc ,@(unless (eq return :tail) '(return-pc-pass)) + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + (:temporary (:sc descriptor-reg + :offset ocfp-offset + :from (:argument 1) + ,@(unless (eq return :fixed) + '(:to :eval))) + ocfp-pass) + + (:temporary (:sc descriptor-reg + :offset #-gengc lra-offset #+gengc ra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) + + ,@(if named + `((:temporary (:sc descriptor-reg :offset fdefn-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass)) + + `((:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv) + #-gengc + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function))) + + (:temporary (:sc any-reg :offset nargs-offset :to :eval) + nargs-pass) + + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names register-arg-offsets)) + ,@(when (eq return :fixed) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + + ,@(unless (eq return :tail) + '((: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) + 15 + (if (eq return :unknown) 25 0)) + (let* ((cur-nfp (current-nfp-tn vop)) + ,@(unless (eq return :tail) + '((lra-label (gen-label)))) + (filler + (remove nil + (list :load-nargs + ,@(if (eq return :tail) + '((unless (location= ocfp ocfp-pass) + :load-ocfp) + (unless (location= return-pc + return-pc-pass) + :load-return-pc) + (when cur-nfp + :frob-nfp)) + '(#-gengc + :comp-lra + (when cur-nfp + :frob-nfp) + :save-fp + :load-fp)))))) + (flet ((do-next-filler () + (let* ((next (pop filler)) + (what (if (consp next) (car next) next))) + (ecase what + (:load-nargs + ,@(if variable + `((inst subq csp-tn new-fp nargs-pass) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(inst ldl ,name + ,(ash (incf index) + word-shift) + new-fp)) + register-arg-names))) + '((inst li (fixnum nargs) nargs-pass)))) + ,@(if (eq return :tail) + '((:load-ocfp + (sc-case ocfp + (any-reg + (inst move ocfp ocfp-pass)) + (control-stack + (inst ldl ocfp-pass + (ash (tn-offset ocfp) + word-shift) + cfp-tn)))) + (:load-return-pc + (sc-case return-pc + (#-gengc descriptor-reg #+gengc any-reg + (inst move return-pc return-pc-pass)) + (control-stack + (inst ldl return-pc-pass + (ash (tn-offset return-pc) + word-shift) + cfp-tn)))) + (:frob-nfp + (inst addq cur-nfp + (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + `(#-gengc + (:comp-lra + (inst compute-lra-from-code + return-pc-pass code-tn lra-label temp)) + (:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:save-fp + (inst move cfp-tn ocfp-pass)) + (:load-fp + ,(if variable + '(move new-fp cfp-tn) + '(if (> nargs register-arg-count) + (move new-fp cfp-tn) + (move csp-tn cfp-tn))) + (trace-table-entry trace-table-call-site)))) + ((nil)))))) + + ,@(if named + `((sc-case name + (descriptor-reg (move name name-pass)) + (control-stack + (inst ldl name-pass + (ash (tn-offset name) word-shift) cfp-tn) + (do-next-filler)) + (constant + (inst ldl name-pass + (- (ash (tn-offset name) word-shift) + other-pointer-type) code-tn) + (do-next-filler))) + (inst ldl entry-point + (- (ash fdefn-raw-addr-slot word-shift) + other-pointer-type) name-pass) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move arg-fun lexenv)) + (control-stack + (inst ldl lexenv + (ash (tn-offset arg-fun) word-shift) cfp-tn) + (do-next-filler)) + (constant + (inst ldl lexenv + (- (ash (tn-offset arg-fun) word-shift) + other-pointer-type) code-tn) + (do-next-filler))) + #-gengc + (inst ldl function + (- (ash closure-function-slot word-shift) + function-pointer-type) lexenv) + #-gengc + (do-next-filler) + #-gengc + (inst addq function + (- (ash function-code-offset word-shift) + function-pointer-type) entry-point) + #+gengc + (inst ldl entry-point + (- (ash closure-entry-point-slot word-shift) + function-pointer-type) lexenv) + #+gengc + (do-next-filler))) + (loop + (if (cdr filler) + (do-next-filler) + (return))) + + (note-this-location vop :call-site) + (do-next-filler) + (inst jsr zero-tn entry-point)) + + ,@(ecase return + (:fixed + '((trace-table-entry trace-table-normal) + (emit-return-pc lra-label) + (default-unknown-values vop values nvals + move-temp temp lra-label) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) + (:unknown + '((trace-table-entry trace-table-normal) + (emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) + (:tail)))))) + + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. +;;; +(define-vop (tail-call-variable) + (:args + (args-arg :scs (any-reg) :target args) + (function-arg :scs (descriptor-reg) :target lexenv) + (ocfp-arg :scs (any-reg) :target ocfp) + (lra-arg :scs (#-gengc descriptor-reg #+gengc any-reg) :target lra)) + + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args) + (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) + (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp) + (:temporary (:sc any-reg :offset #-gengc lra-offset #+gengc ra-offset + :from (:argument 3)) lra) + (:temporary (:scs (non-descriptor-reg)) temp) + + (:vop-var vop) + + (:generator 75 + + ;; Move these into the passing locations if they are not already there. + (move args-arg args) + (move function-arg lexenv) + (move ocfp-arg ocfp) + (move lra-arg lra) + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + + ;; And jump to the assembly-routine that does the bliting. + (inst li (make-fixup 'tail-call-variable :assembly-routine) temp) + (inst jmp zero-tn temp))) + + +;;;; Unknown values return: + +;;; Return a single value using the unknown-values convention. +;;; +(define-vop (return-single) + (:args (ocfp :scs (any-reg)) + #-gengc (return-pc :scs (descriptor-reg)) + #+gengc (return-pc :scs (any-reg) :target ra) + (value)) + (:ignore value) + #-gengc (:temporary (:scs (interior-reg)) lip) + #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra) + #+gengc (:temporary (:scs (any-reg) :from (:argument 1)) temp) + (:vop-var vop) + (:generator 6 + ;; Clear the number stack. + (trace-table-entry trace-table-function-epilogue) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + ;; Clear the control stack, and restore the frame pointer. + (move cfp-tn csp-tn) + (move ocfp cfp-tn) + ;; Out of here. + #-gengc (lisp-return return-pc lip :offset 2) + #+gengc + (progn + (inst addq return-pc (* 2 word-bytes) temp) + (unless (location= ra return-pc) + (inst move ra return-pc)) + (inst ret zero-tn temp 1)) + (trace-table-entry trace-table-normal))) + + +;;; Do unknown-values return of a fixed number of values. The Values are +;;; required to be set up in the standard passing locations. Nvals is the +;;; number of values returned. +;;; +;;; If returning a single value, then deallocate the current frame, restore +;;; FP and jump to the single-value entry at Return-PC + 8. +;;; +;;; If returning other than one value, then load the number of values returned, +;;; NIL out unsupplied values registers, restore FP and return at Return-PC. +;;; When there are stack values, we must initialize the argument pointer to +;;; point to the beginning of the values block (which is the beginning of the +;;; current frame.) +;;; +(define-vop (return) + (:args (ocfp :scs (any-reg)) + (return-pc :scs (#-gengc descriptor-reg #+gengc any-reg) :to (:eval 1) + #+gengc :target #+gengc ra) + (values :more t)) + (:ignore values) + (:info nvals) + (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) + (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1) + (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2) + (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3) + (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4) + (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) + #-gengc (:temporary (:scs (interior-reg)) lip) + #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 1)) ra) + (:vop-var vop) + (:generator 6 + ;; Clear the number stack. + (trace-table-entry trace-table-function-epilogue) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + ;; Establish the values pointer and values count. + (move cfp-tn val-ptr) + (inst li (fixnum nvals) nargs) + ;; restore the frame pointer and clear as much of the control + ;; stack as possible. + (move ocfp cfp-tn) + (inst addq val-ptr (* nvals word-bytes) csp-tn) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) + (move null-tn reg))) + ;; And away we go. + (lisp-return return-pc lip) + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +(define-vop (return-multiple) + (:args (ocfp-arg :scs (any-reg) :target ocfp) + #-gengc (lra-arg :scs (descriptor-reg) :target lra) + #+gengc (return-pc :scs (any-reg) :target ra) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp) + #-gengc + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + #+gengc + (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra) + (: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) + (:temporary (:scs (non-descriptor-reg)) temp) + #-gengc (:temporary (:scs (interior-reg)) lip) + #+gengc (:temporary (:scs (any-reg) :from (:argument 0)) temp) + + (:vop-var vop) + + (:generator 13 + (trace-table-entry trace-table-function-epilogue) + (let ((not-single (gen-label))) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + + ;; Check for the single case. + (inst li (fixnum 1) a0) + (inst cmpeq nvals-arg a0 temp) + (inst ldl a0 0 vals-arg) + (inst beq temp not-single) + + ;; Return with one value. + (move cfp-tn csp-tn) + (move ocfp-arg cfp-tn) + (lisp-return lra-arg lip :offset 2) + + ;; Nope, not the single case. + (emit-label not-single) + (move ocfp-arg ocfp) + (move lra-arg lra) + (move vals-arg vals) + (move nvals-arg nvals) + (inst li (make-fixup 'return-multiple :assembly-routine) temp) + (inst jmp zero-tn temp)) + (trace-table-entry trace-table-normal))) + + + +;;;; XEP hackery: + + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + )) + +;;; Get the lexical environment from it's passing location. +;;; +(define-vop (setup-closure-environment) + (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure + :to (:result 0)) + lexenv) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move lexenv closure))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +(define-vop (copy-more-arg) + (:temporary (:sc any-reg :offset nl0-offset) result) + (:temporary (:sc any-reg :offset nl1-offset) count) + (:temporary (:sc any-reg :offset nl2-offset) src) + (:temporary (:sc any-reg :offset nl4-offset) dst) + (:temporary (:sc descriptor-reg :offset l0-offset) temp) + (:info fixed) + (:generator 20 + (let ((loop (gen-label)) + (do-regs (gen-label)) + (done (gen-label))) + (when (< fixed register-arg-count) + ;; Save a pointer to the results so we can fill in register args. + ;; We don't need this if there are more fixed args than reg args. + (move csp-tn result)) + ;; Allocate the space on the stack. + (cond ((zerop fixed) + (inst addq csp-tn nargs-tn csp-tn) + (inst beq nargs-tn done)) + (t + (inst subq nargs-tn (fixnum fixed) count) + (inst ble count done) + (inst addq csp-tn count csp-tn))) + (when (< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we run out of + ;; more args. + (inst subq nargs-tn (fixnum register-arg-count) count)) + ;; Initialize dst to be end of stack. + (move csp-tn dst) + ;; Everything of interest in registers. + (inst ble count do-regs) + ;; Initialize src to be end of args. + (inst addq cfp-tn nargs-tn src) + + (emit-label loop) + ;; *--dst = *--src, --count + (inst subq src word-bytes src) + (inst subq count (fixnum 1) count) + (loadw temp src) + (inst subq dst word-bytes dst) + (storew temp dst) + (inst bgt count loop) + + (emit-label do-regs) + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in registers. + ;; We know there is at least one more arg, otherwise we would have + ;; branched to done up at the top. + (inst subq nargs-tn (fixnum (1+ fixed)) count) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Store it relative to the pointer saved at the start. + (storew (nth i register-arg-tns) result (- i fixed)) + ;; Is this the last one? + (inst beq count done) + ;; Decrement count. + (inst subq count (fixnum 1) count))) + (emit-label done)))) + + +;;; More args are stored consequtively on the stack, starting immediately at +;;; the context pointer. The context pointer is not typed, so the lowtag is 0. +;;; +(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:args (context-arg :target context :scs (descriptor-reg)) + (count-arg :target count :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:scs (any-reg) :from (:argument 0)) context) + (:temporary (:scs (any-reg) :from (:argument 1)) count) + (:temporary (:scs (descriptor-reg) :from :eval) temp dst) + (:results (result :scs (descriptor-reg))) + (:translate %listify-rest-args) + (:policy :safe) + (:generator 20 + (let ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label))) + (move context-arg context) + (move count-arg count) + ;; Check to see if there are any arguments. + (move null-tn result) + (inst beq count done) + + ;; We need to do this atomically. + (pseudo-atomic () + ;; Allocate a cons (2 words) for each item. + (inst bis alloc-tn list-pointer-type result) + (move result dst) + (inst sll count 1 temp) + (inst addq alloc-tn temp alloc-tn) + (inst br zero-tn enter) + + ;; Store the current cons in the cdr of the previous cons. + (emit-label loop) + (inst addq dst (* 2 word-bytes) dst) + (storew dst dst -1 list-pointer-type) + + (emit-label enter) + ;; Grab one value. + (loadw temp context) + (inst addq context word-bytes context) + + ;; Store the value in the car (in delay slot) + (storew temp dst 0 list-pointer-type) + + ;; Dec count, and if != zero, go back for more. + (inst subq count (fixnum 1) count) + (inst bne count loop) + + ;; NIL out the last cons. + (storew null-tn dst 1 list-pointer-type)) + (emit-label done)))) + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; NARGS.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate c::%more-arg-context) + (:args (supplied :scs (any-reg))) + (:arg-types tagged-num (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note "more-arg-context") + (:generator 5 + (inst subq supplied (fixnum fixed) count) + (inst subq csp-tn count context))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate c::%verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:temporary (:scs (any-reg) :type fixnum) temp) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (cond ((zerop count) + (inst bne nargs err-lab)) + (t + (inst subq nargs (fixnum count) temp) + (inst bne temp err-lab)))))) + +;;; Various other error signalers. +;;; +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error + c::%argument-count-error nargs) + (frob type-check-error object-not-type-error c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error + object layout) + (frob odd-keyword-arguments-error odd-keyword-arguments-error + c::%odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error + c::%unknown-keyword-argument-error key) + (frob nil-function-returned-error nil-function-returned-error nil fun)) diff --git a/compiler/alpha/cell.lisp b/compiler/alpha/cell.lisp new file mode 100644 index 000000000..8a656abcc --- /dev/null +++ b/compiler/alpha/cell.lisp @@ -0,0 +1,391 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/cell.lisp,v 1.1 1994/04/06 16:54:39 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the Alpha. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Sean Hallgren +;;; + +(in-package "ALPHA") + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg null zero))) + (:info name offset lowtag #+gengc remember) + (:ignore name) + (:results) + (:generator 1 + #+gengc + (if remember + (storew-and-remember-slot value object offset lowtag) + (storew value object offset lowtag)) + #-gengc + (storew value object offset lowtag))) + + +;;;; Symbol hacking VOPs: + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-type)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)) + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value checked-cell-ref) + (:translate symbol-value) + (:generator 9 + (move object obj-temp) + (loadw value obj-temp symbol-value-slot other-pointer-type) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst xor value unbound-marker-type temp) + (inst beq temp err-lab)))) + +;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. +(define-vop (boundp-frob) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value) + (:temporary (:scs (non-descriptor-reg)) temp)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object symbol-value-slot other-pointer-type) + (inst xor value unbound-marker-type temp) + (if not-p + (inst beq temp target) + (inst bne temp target)))) + +(define-vop (fast-symbol-value cell-ref) + (:variant symbol-value-slot other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-function cell-ref) + (:variant fdefn-function-slot other-pointer-type)) + +(define-vop (safe-fdefn-function) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 10 + (move object obj-temp) + (loadw value obj-temp fdefn-function-slot other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (inst cmpeq value null-tn temp) + (inst bne temp err-lab)))) + +(define-vop (set-fdefn-function) + (:policy :fast-safe) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (let ((normal-fn (gen-label))) + (load-type type function (- function-pointer-type)) + (inst xor type function-header-type type) + (inst addq function + (- (ash function-code-offset word-shift) function-pointer-type) + lip) + (inst beq type normal-fn) + (inst li (make-fixup "closure_tramp" :foreign) lip) + (emit-label normal-fn) + (storew lip fdefn fdefn-raw-addr-slot other-pointer-type) + (storew function fdefn fdefn-function-slot other-pointer-type) + (move function result)))) + + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew null-tn fdefn fdefn-function-slot other-pointer-type) + (inst li (make-fixup "undefined_tramp" :foreign) temp) + (move fdefn result) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 5 + (loadw temp symbol symbol-value-slot other-pointer-type) + (inst addq bsp-tn (* 2 word-bytes) bsp-tn) + (storew temp bsp-tn (- binding-value-slot binding-size)) + (storew symbol bsp-tn (- binding-symbol-slot binding-size)) + (#+gengc storew-and-remember-slot #-gengc storew + val symbol symbol-value-slot other-pointer-type))) + + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (#+gengc storew-and-remember-slot #-gengc storew + value symbol symbol-value-slot other-pointer-type) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + (inst subq bsp-tn (* 2 word-bytes) bsp-tn))) + + +(define-vop (unbind-to-here) + (:args (arg :scs (descriptor-reg any-reg) :target where)) + (:temporary (:scs (any-reg) :from (:argument 0)) where) + (:temporary (:scs (descriptor-reg)) symbol value) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 0 + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move arg where) + (inst cmpeq where bsp-tn temp) + (inst bne temp done) + + (emit-label loop) + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (inst beq symbol skip) + (#+gengc storew-and-remember-slot #-gengc storew + value symbol symbol-value-slot other-pointer-type) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + + (emit-label skip) + (inst subq bsp-tn (* 2 word-bytes) bsp-tn) + (inst cmpeq where bsp-tn temp) + (inst beq temp loop) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-full-reffer closure-index-ref * + closure-info-offset function-pointer-type + (descriptor-reg any-reg) * %closure-index-ref) + +(define-full-setter set-funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (descriptor-reg any-reg null zero) * %set-funcallable-instance-info) + +(define-full-reffer funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (descriptor-reg any-reg) * %funcallable-instance-info) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot function-pointer-type)) + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset function-pointer-type)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset function-pointer-type)) + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-type)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-type)) + + + +;;;; Instance hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw res struct 0 instance-pointer-type) + (inst srl res type-bits res))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-type) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +(define-vop (instance-set slot-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) *)) + +(define-full-reffer instance-index-ref * instance-slots-offset + instance-pointer-type (descriptor-reg any-reg) * %instance-ref) + +(define-full-setter instance-index-set * instance-slots-offset + instance-pointer-type (descriptor-reg any-reg null zero) * %instance-set) + + + +;;;; Code object frobbing. + +(define-full-reffer code-header-ref * 0 other-pointer-type + (descriptor-reg any-reg) * code-header-ref) + +(define-full-setter code-header-set * 0 other-pointer-type + (descriptor-reg any-reg null zero) * code-header-set) + + + +;;;; Mutator accessing. + +#+gengc (progn + +(define-vop (mutator-ub32-ref) + (:policy :fast-safe) + (:args) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant-vars slot) + (:generator 2 + (loadw res mutator-tn slot))) + +(define-vop (mutator-descriptor-ref mutator-ub32-ref) + (:results (res :scs (any-reg descriptor-reg))) + (:result-types *)) + +(define-vop (mutator-sap-ref mutator-ub32-ref) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer)) + + +(define-vop (mutator-ub32-set) + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant-vars slot) + (:generator 2 + (storew arg mutator-tn slot) + (move res arg))) + +(define-vop (mutator-descriptor-set mutator-ub32-set) + (:args (arg :scs (any-reg descriptor-reg null zero) :target res)) + (:arg-types *) + (:results (res :scs (any-reg descriptor-reg))) + (:result-types *)) + +(define-vop (mutator-sap-set mutator-ub32-set) + (:args (arg :scs (sap-reg) :target res)) + (:arg-types system-area-pointer) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer)) + + +(eval-when (compile eval) + (defmacro define-mutator-accessors (slot type writable) + (let ((ref (symbolicate "MUTATOR-" slot "-REF")) + (set (and writable (symbolicate "MUTATOR-" slot "-SET"))) + (offset (symbolicate "MUTATOR-" slot "-SLOT")) + (fn + (let ((*package* (find-package :kernel))) + (symbolicate "MUTATOR-" slot)))) + (multiple-value-bind + (lisp-type ref-vop set-vop) + (ecase type + (:des + (values t 'mutator-descriptor-ref 'mutator-descriptor-set)) + (:ub32 + (values '(unsigned-byte 32) 'mutator-ub32-ref 'mutator-ub32-set)) + (:sap + (values 'system-area-pointer 'mutator-sap-ref 'mutator-sap-set))) + `(progn + (export ',fn :kernel) + (defknown ,fn () ,lisp-type (flushable)) + (define-vop (,ref ,ref-vop) + (:translate ,fn) + (:variant ,offset)) + ,@(when writable + `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type (unsafe)) + (define-vop (,set ,set-vop) + (:translate (setf ,fn)) + (:variant ,offset))))))))) + +(define-mutator-accessors thread :des t) +(define-mutator-accessors suspends-disabled-count :ub32 t) +(define-mutator-accessors suspend-pending :ub32 t) +(define-mutator-accessors control-stack-base :sap nil) +(define-mutator-accessors control-stack-end :sap nil) +(define-mutator-accessors current-unwind-protect :sap nil) +(define-mutator-accessors current-catch-block :sap nil) +(define-mutator-accessors binding-stack-base :sap nil) +(define-mutator-accessors binding-stack-end :sap nil) +(define-mutator-accessors number-stack-base :sap nil) +(define-mutator-accessors number-stack-end :sap nil) +(define-mutator-accessors eval-stack :des t) +(define-mutator-accessors eval-stack-top :ub32 t) +(define-mutator-accessors nursery-start :sap nil) +(define-mutator-accessors nursery-end :sap nil) +(define-mutator-accessors storebuf-start :sap nil) +(define-mutator-accessors storebuf-end :sap nil) +(define-mutator-accessors words-consed :ub32 nil) + +); #+gengc progn diff --git a/compiler/alpha/char.lisp b/compiler/alpha/char.lisp new file mode 100644 index 000000000..3d0635e7e --- /dev/null +++ b/compiler/alpha/char.lisp @@ -0,0 +1,149 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/char.lisp,v 1.1 1994/04/06 16:54:40 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/char.lisp,v 1.1 1994/04/06 16:54:40 hallgren Exp $ +;;; +;;; This file contains the RT VM definition of character operations. +;;; +;;; Written by Rob MacLachlan +;;; Converted for the Alpha by Sean Hallgren. +;;; +(in-package "ALPHA") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (base-char-reg))) + (:generator 1 + (inst srl x vm:type-bits y))) +;;; +(define-move-vop move-to-base-char :move + (any-reg descriptor-reg) (base-char-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:generator 1 + (inst sll x vm:type-bits y) + (inst bis y vm:base-char-type y))) +;;; +(define-move-vop move-from-base-char :move + (base-char-reg) (any-reg descriptor-reg)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move x y))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (base-char-reg + (move x y)) + (base-char-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-base-char-argument :move-argument + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg) :target res)) + (:arg-types base-char) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst sll ch 2 res))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (any-reg) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (inst srl code 2 res))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg)) + (y :scs (base-char-reg))) + (:arg-types base-char base-char) + (:temporary (:scs (non-descriptor-reg)) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars cond) + (:generator 3 + (ecase cond + (:eq (inst cmpeq x y temp)) + (:lt (inst cmplt x y temp)) + (:gt (inst cmplt y x temp))) + (if not-p + (inst beq temp target) + (inst bne temp target)))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :eq)) + +(define-vop (fast-char</base-char base-char-compare) + (:translate char<) + (:variant :lt)) + +(define-vop (fast-char>/base-char base-char-compare) + (:translate char>) + (:variant :gt)) diff --git a/compiler/alpha/debug.lisp b/compiler/alpha/debug.lisp new file mode 100644 index 000000000..a3de7eee2 --- /dev/null +++ b/compiler/alpha/debug.lisp @@ -0,0 +1,165 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/debug.lisp,v 1.1 1994/04/06 16:54:41 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. +;;; +(in-package "ALPHA") + + +(define-vop (debug-cur-sp) + (:translate current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move csp-tn res))) + +(define-vop (debug-cur-fp) + (:translate current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move cfp-tn res))) + +(define-vop (read-control-stack) + (:translate stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (any-reg))) + (:arg-types system-area-pointer positive-fixnum) + (:temporary (:scs (sap-reg) :from :eval) sap) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst addq object offset sap) + (inst ldl result 0 sap))) + +(define-vop (read-control-stack-c) + (:translate stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 14))) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 4 + (inst ldl result (* offset word-bytes) object))) + +(define-vop (write-control-stack) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (any-reg)) + (value :scs (descriptor-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:temporary (:scs (sap-reg) :from (:argument 1)) sap) + (:generator 2 + (inst addq object offset sap) + (inst stl value 0 sap) + (move value result))) + +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 14)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 1 + (inst stl value (* offset word-bytes) sap) + (move value result))) + + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst srl temp vm:type-bits temp) + (inst beq temp bogus) + (inst sll temp (1- (integer-length vm:word-bytes)) temp) + (unless (= lowtag vm:other-pointer-type) + (inst subq temp (- vm:other-pointer-type lowtag) temp)) + (inst subq thing temp code) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (move null-tn code) + (inst br zero-tn done))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate lra-code-header) + (:variant vm:other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate function-code-header) + (:variant vm:function-pointer-type)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move value result))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move thing result))) + +(define-vop (function-word-offset) + (:policy :fast-safe) + (:translate function-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 function-pointer-type) + (inst srl res vm:type-bits res))) + + + + + +(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer + (movable foldable flushable)) + +(define-vop (make-number-stack-pointer) + (:policy :fast-safe) + (:translate make-number-stack-pointer) + (:args (arg :scs (unsigned-reg) :to (:argument 1))) + (:arg-types unsigned-num) + (:results (res :scs (sap-reg) :from (:argument 0))) + (:result-types system-area-pointer) + (:generator 5 + (inst mskll nsp-tn 0 res) + (inst bis res arg res))) diff --git a/compiler/alpha/float.lisp b/compiler/alpha/float.lisp new file mode 100644 index 000000000..8fc4fd5ce --- /dev/null +++ b/compiler/alpha/float.lisp @@ -0,0 +1,531 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/float.lisp,v 1.1 1994/04/06 16:54:42 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains floating point support for the Alpha. +;;; +;;; Written by Rob MacLachlan +;;; Conversion by Sean Hallgren +;;; +(in-package "ALPHA") + + +;;;; Move functions: + +(define-move-function (load-fp-zero 1) (vop x y) + ((fp-single-zero) (single-reg) + (fp-double-zero) (double-reg)) + (inst fmove x y)) + +(define-move-function (load-single 1) (vop x y) + ((single-stack) (single-reg)) + (inst lds y (* (tn-offset x) word-bytes) (current-nfp-tn vop))) + +(define-move-function (store-single 1) (vop x y) + ((single-reg) (single-stack)) + (inst sts x (* (tn-offset y) word-bytes) (current-nfp-tn vop))) + + +(define-move-function (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) word-bytes))) + (inst ldt y offset nfp))) + +(define-move-function (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) word-bytes))) + (inst stt x offset nfp))) + + + +;;;; Move VOPs: + +(macrolet ((frob (vop sc) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note "float move") + (:generator 0 + (unless (location= y x) + (inst fmove x y)))) + (define-move-vop ,vop :move (,sc) (,sc))))) + (frob single-move single-reg) + (frob double-move double-reg)) + + +(define-vop (move-from-float) + (:args (x :to :save)) + (:results (y)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:variant-vars double-p size type data) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y ndescr type size) + (if double-p + (inst stt x (- (* data word-bytes) other-pointer-type) y) + (inst sts x (- (* data word-bytes) other-pointer-type) y))))) + +(macrolet ((frob (name sc &rest args) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:results (y :scs (descriptor-reg))) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) + (frob move-from-single single-reg + nil single-float-size single-float-type single-float-value-slot) + (frob move-from-double double-reg + t double-float-size double-float-type double-float-value-slot)) + +(macrolet ((frob (name sc double-p value) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to float coercion") + (:generator 2 + ,@(if double-p + `((inst ldt y (- (* ,value word-bytes) + other-pointer-type) + x)) + `((inst lds y (- (* ,value word-bytes) + other-pointer-type) + x))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg nil single-float-value-slot) + (frob move-to-double double-reg t double-float-value-slot)) + + +(macrolet ((frob (name sc stack-sc double-p) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(if double-p 2 1) + (sc-case y + (,sc + (unless (location= x y) + (inst fmove x y))) + (,stack-sc + (let ((offset (* (tn-offset y) word-bytes))) + ,@(if double-p + '((inst stt x offset nfp)) + '((inst sts x offset nfp)))))))) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-argument single-reg single-stack nil) + (frob move-double-float-argument double-reg double-stack t)) + + +(define-move-vop move-argument :move-argument + (single-reg double-reg) (descriptor-reg)) + + +;;;; Arithmetic VOPs: + +(define-vop (float-op) + (:args (x) (y)) + (:results (r)) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only)) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-op) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) + (frob single-float-op single-reg single-float) + (frob double-float-op double-reg double-float)) + +(macrolet ((frob (op sinst sname scost dinst dname dcost) + `(progn + (define-vop (,sname single-float-op) + (:translate ,op) + (:variant-cost ,scost) + (:generator ,scost + (inst ,sinst x y r))) + (define-vop (,dname double-float-op) + (:translate ,op) + (:variant-cost ,dcost) + (:generator ,dcost + (inst ,dinst x y r)))))) + (frob + adds +/single-float 2 addt +/double-float 2) + (frob - subs -/single-float 2 subt -/double-float 2) + (frob * muls */single-float 4 mult */double-float 5) + (frob / divs //single-float 12 divt //double-float 19)) + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc) :target y)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst ,inst x y))))) + (frob abs/single-float fabs abs single-reg single-float) + (frob abs/double-float fabs abs double-reg double-float) + (frob %negate/single-float fneg %negate single-reg single-float) + (frob %negate/double-float fneg %negate double-reg double-float)) + + +;;;; Comparison: + +(define-vop (float-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:variant-vars eq complement) + (:temporary (:scs (single-reg)) temp) + (:policy :fast-safe) + (:note "inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (note-this-location vop :internal-error) + (if eq + (inst cmpteq x y temp) + (if complement + (inst cmptle x y temp) + (inst cmptlt x y temp))) + (if (if complement (not not-p) not-p) + (inst fbeq temp target) + (inst fbne temp target)))) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg single-float) + (frob double-float-compare double-reg double-float)) + +(macrolet ((frob (translate complement sname dname eq) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant ,eq ,complement)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant ,eq ,complement))))) + (frob < nil </single-float </double-float nil) + (frob > t >/single-float >/double-float nil) + (frob = nil =/single-float =/double-float t)) + + +;;;; Conversion: + +(macrolet ((frob (name translate inst ld-inst to-sc to-type &optional single) + `(define-vop (,name) + (:args (x :scs (signed-reg) :target temp + :load-if (not (sc-is x signed-stack)))) + (:temporary (:scs (single-stack)) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((stack-tn + (sc-case x + (signed-reg + (inst stl x + (* (tn-offset temp) vm:word-bytes) + (current-nfp-tn vop)) + temp) + (signed-stack + x)))) + (inst ,ld-inst y + (* (tn-offset stack-tn) vm:word-bytes) + (current-nfp-tn vop)) + (note-this-location vop :internal-error) + ,@(when single + `((inst cvtlq y y))) + (inst ,inst y y)))))) + (frob %single-float/signed %single-float cvtqs lds single-reg single-float t) + (frob %double-float/signed %double-float cvtqt lds double-reg double-float t)) + +(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (inst ,inst x y))))) + (frob %single-float/double-float %single-float cvtts + double-reg double-float single-reg single-float) + (frob %double-float/single-float %double-float fmove + single-reg single-float double-reg double-float)) + +(macrolet ((frob (trans from-sc from-type inst &optional single) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc) :target temp)) + (:temporary (:from (:argument 0) :sc single-reg) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:results (y :scs (signed-reg) + :load-if (not (sc-is y signed-stack)))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst ,inst x temp) + (sc-case y + (signed-stack + (inst stt temp + (* (tn-offset y) vm:word-bytes) + (current-nfp-tn vop))) + (signed-reg + (inst stt temp + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)) + (inst ldq y + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)))))))) + (frob %unary-truncate single-reg single-float cvttq/c t) + (frob %unary-truncate double-reg double-float cvttq/c) + (frob %unary-round single-reg single-float cvttq t) + (frob %unary-round double-reg double-float cvttq)) + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (sc-is bits signed-stack)))) + (:results (res :scs (single-reg) + :load-if (not (sc-is res single-stack)))) + (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case res + (single-reg + (inst stl bits + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)) + (inst lds res + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop))) + (single-stack + (inst stl bits + (* (tn-offset res) vm:word-bytes) + (current-nfp-tn vop))))) + (signed-stack + (sc-case res + (single-reg + (inst lds res + (* (tn-offset bits) vm:word-bytes) + (current-nfp-tn vop))) + (single-stack + (unless (location= bits res) + (inst ldl temp + (* (tn-offset bits) vm:word-bytes) + (current-nfp-tn vop)) + (inst stl temp + (* (tn-offset res) vm:word-bytes) + (current-nfp-tn vop))))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg) + :load-if (not (sc-is res double-stack)))) + (:temporary (:scs (double-stack)) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((stack-tn (sc-case res + (double-stack res) + (double-reg temp)))) + (inst stl hi-bits + (* (1+ (tn-offset stack-tn)) vm:word-bytes) + (current-nfp-tn vop)) + (inst stl lo-bits + (* (tn-offset stack-tn) vm:word-bytes) + (current-nfp-tn vop))) + (when (sc-is res double-reg) + (inst ldt res + (* (tn-offset temp) vm:word-bytes) + (current-nfp-tn vop))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg) + :load-if (or (sc-is float descriptor-reg single-stack) + (not (sc-is bits signed-stack))))) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (inst sts float + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)) + (inst ldl bits + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop))) + (single-stack + (inst ldl bits + (* (tn-offset float) vm:word-bytes) + (current-nfp-tn vop))) + (descriptor-reg + (loadw bits float vm:single-float-value-slot vm:other-pointer-type)))) + (signed-stack + (sc-case float + (single-reg + (inst sts float + (* (tn-offset bits) vm:word-bytes) + (current-nfp-tn vop)))))))) + +(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 (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 float + (double-reg + (inst stt float + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)) + (inst ldl hi-bits + (* (1+ (tn-offset stack-temp)) vm:word-bytes) + (current-nfp-tn vop))) + (double-stack + (inst ldl hi-bits + (* (1+ (tn-offset float)) vm:word-bytes) + (current-nfp-tn vop))) + (descriptor-reg + (loadw hi-bits float (1+ 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 (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 float + (double-reg + (inst stt float + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop)) + (inst ldl lo-bits + (* (tn-offset stack-temp) vm:word-bytes) + (current-nfp-tn vop))) + (double-stack + (inst ldl lo-bits + (* (tn-offset float) vm:word-bytes) + (current-nfp-tn vop))) + (descriptor-reg + (loadw lo-bits float vm:double-float-value-slot + vm:other-pointer-type))) + (inst mskll lo-bits 4 lo-bits))) + + +;;;; Float mode hackery: + +(deftype float-modes () '(unsigned-byte 24)) +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc unsigned-stack) temp) + (:temporary (:sc single-reg) temp1) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (inst mf_fpcr temp1 temp1 temp1) + (inst sts temp1 (* word-bytes (tn-offset temp)) nfp) + (loadw res nfp (tn-offset temp))))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc unsigned-stack) temp) + (:temporary (:sc single-reg) temp1) + (:vop-var vop) + (:generator 3 + (let ((nfp (current-nfp-tn vop))) + (storew new nfp (tn-offset temp)) + (inst lds temp1 (* word-bytes (tn-offset temp)) nfp) + (inst mt_fpcr temp1 temp1 temp1) + (move res new)))) diff --git a/compiler/alpha/insts.lisp b/compiler/alpha/insts.lisp new file mode 100644 index 000000000..61a0e0394 --- /dev/null +++ b/compiler/alpha/insts.lisp @@ -0,0 +1,598 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/insts.lisp,v 1.1 1994/04/06 16:54:42 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the instruction set definition for the Alpha. +;;; +;;; Written by Sean Hallgren. +;;; + +(in-package :alpha) + +(use-package :new-assem) + +(def-assembler-params + :scheduler-p nil) + + +;;;; Utility functions. + +(defun reg-tn-encoding (tn) + (declare (type tn tn) + (values (unsigned-byte 5))) + (sc-case tn + (zero zero-offset) + (null null-offset) + (t + (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (tn-offset tn)))) + +(defun fp-reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (fp-single-zero (tn-offset fp-single-zero-tn)) + (fp-double-zero (tn-offset fp-double-zero-tn)) + (t + (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) + (error "~S isn't a floating-point register." tn)) + (tn-offset tn)))) + + +;;;; Initial disassembler setup. + +(disassem:set-disassem-params :instruction-alignment 32) + +(defvar *disassem-use-lisp-reg-names* t) + +(defparameter reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) + *register-names*)) + +(disassem:define-argument-type reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'registers + regname + dstate)))) + +(defparameter float-reg-symbols + (coerce + (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n))) + 'vector)) + +(disassem:define-argument-type fp-reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +(disassem:define-argument-type relative-label + :sign-extend t + :use-label #'(lambda (value dstate) + (declare (type (signed-byte 21) value) + (type disassem:disassem-state dstate)) + (+ (ash value 2) (disassem:dstate-cur-addr dstate)))) + + + +;;;; Define-instruction-formats for disassembler. +(disassem:define-instruction-format + (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")")) + (op :field (byte 6 26)) + (ra :field (byte 5 21) :type 'reg) + (rb :field (byte 5 16) :type 'reg) + (disp :field (byte 16 0) :sign-extend t)) + +(disassem:define-instruction-format + (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint)) + (op :field (byte 6 26)) + (ra :field (byte 5 21) :type 'reg) + (rb :field (byte 5 16) :type 'reg) + (subop :field (byte 2 14)) + (hint :field (byte 14 0))) + +(disassem:define-instruction-format + (branch 32 :default-printer '(:name :tab ra "," disp)) + (op :field (byte 6 26)) + (ra :field (byte 5 21) :type 'reg) + (disp :field (byte 21 0) :type 'relative-label)) + +(disassem:define-instruction-format + (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc)) + (op :field (byte 6 26)) + (ra :field (byte 5 21) :type 'reg) + (rb :field (byte 5 16) :type 'reg) + (sbz :field (byte 3 13)) + (f :field (byte 1 12) :value 0) + (fn :field (byte 7 5)) + (rc :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc)) + (op :field (byte 6 26)) + (ra :field (byte 5 21) :type 'reg) + (lit :field (byte 8 13)) + (f :field (byte 1 12) :value 1) + (fn :field (byte 7 5)) + (rc :field (byte 5 0) :type 'reg)) + +(disassem:define-instruction-format + (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc)) + (op :field (byte 6 26)) + (fa :field (byte 5 21) :type 'fp-reg) + (fb :field (byte 5 16) :type 'fp-reg) + (fn :field (byte 11 5)) + (fc :field (byte 5 0) :type 'fp-reg)) + +(disassem:define-instruction-format + (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name)) + (op :field (byte 6 26) :value 0) + (palcode :field (byte 26 0))) + + +;;;; Emitters. +(define-emitter emit-word 16 + (byte 16 0)) + +(define-emitter emit-lword 32 + (byte 32 0)) + +(define-emitter emit-qword 64 + (byte 64 0)) + +(define-emitter emit-memory 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0)) + +(define-emitter emit-branch 32 + (byte 6 26) (byte 5 21) (byte 21 0)) + +(define-emitter emit-reg-operate 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5) + (byte 5 0)) + +(define-emitter emit-lit-operate 32 + (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0)) + +(define-emitter emit-fp-operate 32 + (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0)) + +(define-emitter emit-pal 32 + (byte 6 26) (byte 26 0)) + + +;;;; Macros for instructions. +(defmacro define-memory (name op &optional fixup float) + `(define-instruction ,name (segment ra disp rb ,@(if fixup + '(&optional type))) + (:declare (type tn ra rb) + ,@(if fixup ; ### unsigned-byte 16 bad idea? + '((type (or (unsigned-byte 16) (signed-byte 16) fixup) + disp)) + '((type (or (unsigned-byte 16) (signed-byte 16)) disp)))) + (:printer memory ((op ,op))) + (:emitter + ,@(when fixup + `((when (fixup-p disp) + (note-fixup segment (or type ,fixup) disp) + (setf disp 0)))) + (emit-memory segment ,op ,@(if float + '((fp-reg-tn-encoding ra)) + '((reg-tn-encoding ra))) + (reg-tn-encoding rb) + disp)))) + +(defmacro define-jump (name subop) + `(define-instruction ,name (segment ra rb &optional (hint 0)) + (:declare (type tn ra rb) + (type (or (unsigned-byte 14) fixup) hint)) + (:printer jump ((op #x1a) (subop ,subop))) + (:emitter + (when (fixup-p hint) + (note-fixup segment :jmp-hint hint) + (setf hint 0)) + (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb) + (logior (ash ,subop 14) hint))))) + +(defmacro define-branch (name op &optional (float nil)) + `(define-instruction ,name (segment ra target) + (:declare (type tn ra) + (type label target)) + (:printer branch ((op ,op) + ,@(when float + '((ra nil :type 'fp-reg))))) + (:emitter + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-branch segment ,op + ,@(if float + '((fp-reg-tn-encoding ra)) + '((reg-tn-encoding ra))) + (ash (- (label-position target) + (+ posn 4)) + -2))))))) + +(defmacro define-operate (name op fn) + `(define-instruction ,name (segment ra rb rc) + (:declare (type tn ra rc) + (type (or tn (unsigned-byte 8)) rb)) + (:printer reg-operate ((op ,op) (fn ,fn))) + (:printer lit-operate ((op ,op) (fn ,fn))) + ,@(when (and (= op #x11) (= fn #x20)) + `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31)) + '('move :tab rb "," rc)) + (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31)) + '('nop)))) + (:emitter + (etypecase rb + (tn + (emit-reg-operate segment ,op (reg-tn-encoding ra) + (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc))) + (number + (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn + (reg-tn-encoding rc))))))) + +(defmacro define-fp-operate (name op fn &optional (args 3)) + `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc) + (:declare (type tn ,@(when (= args 3) '(fa)) fb fc)) + (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31)))) + ,@(when (= args 2) + '('(:name :tab fb "," fc)))) + ,@(when (and (= op #x17) (= fn #x20)) + `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31)) + '('fabs :tab fb "," fc)))) + (:emitter + (emit-fp-operate segment ,op ,@(if (= args 3) + '((fp-reg-tn-encoding fa)) + '(31)) + (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))) + + +;;;; Instructions. +(define-memory lda #x08 :lda) +(define-memory ldah #x09 :ldah) +(define-memory ldl #x28) +(define-memory ldq #x29) +(define-memory ldl_l #x2a) +(define-memory ldq_q #x2b) +(define-memory ldq_u #x0b) +(define-memory stl #x2c) +(define-memory stq #x2d) +(define-memory stl_c #x2e) +(define-memory stq_c #x2f) +(define-memory stq_u #x0f) +(define-memory ldf #x20 nil t) +(define-memory ldg #x21 nil t) +(define-memory lds #x22 nil t) +(define-memory ldt #x23 nil t) +(define-memory stf #x24 nil t) +(define-memory stg #x25 nil t) +(define-memory sts #x26 nil t) +(define-memory stt #x27 nil t) + +(define-jump jmp 0) +(define-jump jsr 1) +(define-jump ret 2) +(define-jump jsr-coroutine 3) + +(define-branch br #x30) +(define-branch bsr #x34) +(define-branch blbc #x38) +(define-branch blbs #x3c) +(define-branch fbeq #x31 t) +(define-branch fbne #x35 t) +(define-branch beq #x39) +(define-branch bne #x3d) +(define-branch fblt #x32 t) +(define-branch fbge #x36 t) +(define-branch blt #x3a) +(define-branch bge #x3e) +(define-branch fble #x33 t) +(define-branch fbgt #x37 t) +(define-branch ble #x3b) +(define-branch bgt #x3f) + +(define-operate addl #x10 #x00) +(define-operate addl/v #x10 #x40) +(define-operate addq #x10 #x20) +(define-operate addq/v #x10 #x60) +(define-operate cmpule #x10 #x3d) +(define-operate cmpbge #x10 #x0f) +(define-operate subl #x10 #x09) +(define-operate subl/v #x10 #x49) +(define-operate subq #x10 #x29) +(define-operate subq/v #x10 #x69) +(define-operate cmpeq #x10 #x2d) +(define-operate cmplt #x10 #x4d) +(define-operate cmple #x10 #x6d) +(define-operate cmpult #x10 #x1d) +(define-operate s4addl #x10 #x02) +(define-operate s4addq #x10 #x22) +(define-operate s4subl #x10 #x0b) +(define-operate s4subq #x10 #x2b) +(define-operate s8addl #x10 #x12) +(define-operate s8addq #x10 #x32) +(define-operate s8subl #x10 #x1b) +(define-operate s8subq #x10 #x3b) + +(define-operate and #x11 #x00) +(define-operate bic #x11 #x08) +(define-operate cmoveq #x11 #x24) +(define-operate cmovne #x11 #x26) +(define-operate cmovlbs #x11 #x14) +(define-operate bis #x11 #x20) +(define-operate ornot #x11 #x28) +(define-operate cmovlt #x11 #x44) +(define-operate cmovge #x11 #x46) +(define-operate cmovlbc #x11 #x16) +(define-operate xor #x11 #x40) +(define-operate eqv #x11 #x48) +(define-operate cmovle #x11 #x64) +(define-operate cmovgt #x11 #x66) + +(define-operate sll #x12 #x39) +(define-operate extbl #x12 #x06) +(define-operate extwl #x12 #x16) +(define-operate extll #x12 #x26) +(define-operate extql #x12 #x36) +(define-operate extwh #x12 #x5a) +(define-operate extlh #x12 #x6a) +(define-operate extqh #x12 #x7a) +(define-operate sra #x12 #x3c) +(define-operate insbl #x12 #x0b) +(define-operate inswl #x12 #x1b) +(define-operate insll #x12 #x2b) +(define-operate insql #x12 #x3b) +(define-operate inswh #x12 #x57) +(define-operate inslh #x12 #x67) +(define-operate insqh #x12 #x77) +(define-operate srl #x12 #x34) +(define-operate mskbl #x12 #x02) +(define-operate mskwl #x12 #x12) +(define-operate mskll #x12 #x22) +(define-operate mskql #x12 #x32) +(define-operate mskwh #x12 #x52) +(define-operate msklh #x12 #x62) +(define-operate mskqh #x12 #x72) +(define-operate zap #x12 #x30) +(define-operate zapnot #x12 #x31) + +(define-operate mull #x13 #x00) +(define-operate mulq/v #x13 #x60) +(define-operate mull/v #x13 #x40) +(define-operate umulh #x13 #x30) +(define-operate mulq #x13 #x20) + +(define-fp-operate cpys #x17 #x020) +(define-fp-operate mf_fpcr #x17 #x025) +(define-fp-operate cpysn #x17 #x021) +(define-fp-operate mt_fpcr #x17 #x024) +(define-fp-operate cpyse #x17 #x022) +(define-fp-operate cvtql/sv #x17 #x530 2) +(define-fp-operate cvtlq #x17 #x010 2) +(define-fp-operate cvtql #x17 #x030 2) +(define-fp-operate cvtql/v #x17 #x130 2) +(define-fp-operate fcmoveq #x17 #x02a) +(define-fp-operate fcmovne #x17 #x02b) +(define-fp-operate fcmovlt #x17 #x02c) +(define-fp-operate fcmovge #x17 #x02d) +(define-fp-operate fcmovle #x17 #x02e) +(define-fp-operate fcmovgt #x17 #x02f) + +(define-fp-operate cvtqs #x16 #x0bc 2) +(define-fp-operate cvtqt #x16 #x0be 2) +(define-fp-operate cvtts #x16 #x0ac 2) +(define-fp-operate cvttq #x16 #x0af 2) +(define-fp-operate cvttq/c #x16 #x02f 2) +(define-fp-operate cmpteq #x16 #x5a5) +(define-fp-operate cmptlt #x16 #x5a6) +(define-fp-operate cmptle #x16 #x5a7) +(define-fp-operate cmptun #x16 #x5a4) +(define-fp-operate adds #x16 #x080) +(define-fp-operate addt #x16 #x0a0) +(define-fp-operate divs #x16 #x083) +(define-fp-operate divt #x16 #x0a3) +(define-fp-operate muls #x16 #x082) +(define-fp-operate mult #x16 #x0a2) +(define-fp-operate subs #x16 #x081) +(define-fp-operate subt #x16 #x0a1) + +(define-instruction gentrap (segment code) + (:printer call-pal ((palcode #xaa0000))) + (:emitter + (emit-pal segment 0 #x0000aa) + (emit-lword segment code))) + +(define-instruction-macro move (src dst) + `(inst bis zero-tn ,src ,dst)) + +(define-instruction-macro not (src dst) + `(inst ornot zero-tn ,src ,dst)) + +(define-instruction-macro fmove (src dst) + `(inst cpys ,src ,src ,dst)) + +(define-instruction-macro fabs (src dst) + `(inst cpys fp-single-zero-tn ,src ,dst)) + +(define-instruction-macro fneg (src dst) + `(inst cpysn ,src ,src ,dst)) + +(define-instruction-macro nop () + `(inst bis zero-tn zero-tn zero-tn)) + +(defun %li (value reg) + (etypecase value + ((signed-byte 16) + (inst lda reg value zero-tn)) + ((signed-byte 32) + (flet ((se (x n) + (let ((x (logand x (lognot (ash -1 n))))) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)))) + (let* ((value (se value 32)) + (low (ldb (byte 16 0) value)) + (tmp1 (- value (se low 16))) + (high (ldb (byte 16 16) tmp1)) + (tmp2 (- tmp1 (se (ash high 16) 32))) + (extra 0)) + (unless (= tmp2 0) + (setf extra #x4000) + (setf tmp1 (- tmp1 #x40000000)) + (setf high (ldb (byte 16 16) tmp1))) + (inst lda reg low zero-tn) + (unless (= extra 0) + (inst ldah reg extra reg)) + (unless (= high 0) + (inst ldah reg high reg))))) + ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64)) + (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1)) + (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2))) + (inst lda reg (ldb (byte 16 32) value2) zero-tn) + (unless (= value3 0) + (inst ldah reg (ldb (byte 16 48) value3) reg)) + (unless (and (= value2 0) (= value3 0)) + (inst sll reg 32 reg)) + (unless (= value 0) + (inst lda reg (ldb (byte 16 0) value) reg)) + (unless (= value1 0) + (inst ldah reg (ldb (byte 16 16) value1) reg)))) + (fixup + (inst lda reg value zero-tn :bits-47-32) + (inst ldah reg value reg :bits-63-48) + (inst sll reg 32 reg) + (inst lda reg value reg) + (inst ldah reg value reg)))) + +(define-instruction-macro li (value reg) + `(%li ,value ,reg)) + + +;;;; + +(define-instruction lword (segment lword) + (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword)) + (:cost 0) + (:emitter + (emit-lword segment lword))) + +(define-instruction short (segment word) + (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word)) + (:cost 0) + (:emitter + (emit-word segment word))) + +(define-instruction byte (segment byte) + (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) + (:cost 0) + (:emitter + (emit-byte segment byte))) + +(defun emit-header-data (segment type) + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-lword segment + (logior type + (ash (+ posn (component-header-length)) + (- type-bits word-shift))))))) + +(define-instruction function-header-word (segment) + (:cost 0) + (:emitter + (emit-header-data segment function-header-type))) + +(define-instruction lra-header-word (segment) + (:cost 0) + (:emitter + (emit-header-data segment return-pc-header-type))) + +(defun emit-compute-inst (segment vop dst src label temp calc) + (declare (ignore temp)) + (emit-chooser + ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. + segment 12 3 + #'(lambda (segment posn delta-if-after) + (let ((delta (funcall calc label posn delta-if-after))) + (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (assemble (segment vop) + (inst lda dst + (funcall calc label posn 0) + src)))) + t))) + #'(lambda (segment posn) + (assemble (segment vop) + (flet ((se (x n) + (let ((x (logand x (lognot (ash -1 n))))) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)))) + (let* ((value (se (funcall calc label posn 0) 2)) + (low (ldb (byte 16 0) value)) + (tmp1 (- value (se low 16))) + (high (ldb (byte 16 16) tmp1)) + (tmp2 (- tmp1 (se (ash high 16) 32))) + (extra 0)) + (unless (= tmp2 0) + (setf extra #x4000) + (setf tmp1 (- tmp1 #x40000000)) + (setf high (ldb (byte 16 16) tmp1))) + (inst lda dst low src) + (inst ldah dst extra dst) + (inst ldah dst high dst))))))) + +;; code = fn - header - label-offset + other-pointer-tag +(define-instruction compute-code-from-fn (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (- other-pointer-type + (label-position label posn delta-if-after) + (component-header-length)))))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +;; = lra - (header + label-offset) +(define-instruction compute-code-from-lra (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-instruction compute-lra-from-code (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (:vop-var vop) + (:emitter + (emit-compute-inst segment vop dst src label temp + #'(lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length)))))) diff --git a/compiler/alpha/macros.lisp b/compiler/alpha/macros.lisp new file mode 100644 index 000000000..fe30491f3 --- /dev/null +++ b/compiler/alpha/macros.lisp @@ -0,0 +1,540 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/macros.lisp,v 1.1 1994/04/06 16:54:43 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains various useful macros for generating Alpha code. +;;; +;;; Written by William Lott and Christopher Hoover. +;;; Alpha conversion by Sean Hallgren. +;;; + +(in-package :alpha) + +;;; Handy macro for defining top-level forms that depend on the compile +;;; environment. + +(defmacro expand (expr) + (let ((gensym (gensym))) + `(macrolet + ((,gensym () + ,expr)) + (,gensym)))) + + +;;; Instruction-like macros. + +(defmacro move (src dst) + "Move SRC into DST unless they are location=." + (once-only ((src src) (dst dst)) + `(unless (location= ,src ,dst) + (inst move ,src ,dst)))) + +(defmacro loadw (result base &optional (offset 0) (lowtag 0)) + (once-only ((result result) (base base)) + `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base))) + +(defmacro loadq (result base &optional (offset 0) (lowtag 0)) + (once-only ((result result) (base base)) + `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base))) + +(defmacro storew (value base &optional (offset 0) (lowtag 0)) + (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) + `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base))) + +(defmacro storeq (value base &optional (offset 0) (lowtag 0)) + (once-only ((value value) (base base) (offset offset) (lowtag lowtag)) + `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base))) + +(defmacro load-symbol (reg symbol) + (once-only ((reg reg) (symbol symbol)) + `(inst lda ,reg (static-symbol-offset ,symbol) null-tn))) + +(defmacro load-symbol-value (reg symbol) + `(inst ldl ,reg + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type)) + null-tn)) + +(defmacro store-symbol-value (reg symbol) + `(inst stl ,reg + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type)) + null-tn)) + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + `(progn + (inst ldl ,n-target ,n-offset ,n-source) + (inst and ,n-target #xff ,n-target)))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. + +(defmacro lisp-jump (function lip) + "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." + `(progn + (inst lda ,lip (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type) + ,function) + (move ,function code-tn) + (inst jsr zero-tn ,lip 1))) + +(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) + "Return to RETURN-PC. LIP is an interior-reg temporary." + `(progn + (inst lda ,lip + (- (* (1+ ,offset) word-bytes) other-pointer-type) + ,return-pc) + ,@(when frob-code + `((move ,return-pc code-tn))) + (inst ret zero-tn ,lip 1))) + + +(defmacro emit-return-pc (label) + "Emit a return-pc header word. LABEL is the label to use for this + return-pc." + `(progn + (align lowtag-bits) + (emit-label ,label) + (inst lra-header-word))) + + + +;;;; Stack TN's + +;;; Load-Stack-TN, Store-Stack-TN -- Interface +;;; +;;; Move a stack TN to a register and vice-versa. +;;; +(defmacro load-stack-tn (reg stack) + `(let ((reg ,reg) + (stack ,stack)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (loadw reg cfp-tn offset)))))) + +(defmacro store-stack-tn (stack reg) + `(let ((stack ,stack) + (reg ,reg)) + (let ((offset (tn-offset stack))) + (sc-case stack + ((control-stack) + (storew reg cfp-tn offset)))))) + + +;;; MAYBE-LOAD-STACK-TN -- Interface +;;; +(defmacro maybe-load-stack-tn (reg reg-or-stack) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + +;;; MAYBE-LOAD-STACK-NFP-TN -- Interface +;;; +(defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp) + "Move the TN Reg-Or-Stack into Reg if it isn't already there." + (once-only ((n-reg reg) + (n-stack reg-or-stack)) + `(when ,reg + (sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) + (inst mskll nsp-tn 0 ,temp) + (inst bis ,temp ,n-reg ,n-reg)))))))) + + + +;;;; Storage allocation: + +(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) + &body body) + "Do stuff to allocate an other-pointer object of fixed Size with a single + word header having the specified Type-Code. The result is placed in + Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non- + descriptor temp (which may be randomly used by the body.) The body is + placed inside the PSEUDO-ATOMIC, and presumably initializes the object." + `(pseudo-atomic (:extra (pad-data-block ,size)) + (inst bis alloc-tn other-pointer-type ,result-tn) + (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn) + (storew ,temp-tn ,result-tn 0 other-pointer-type) + ,@body)) + + + +;;;; Error Code + + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst gentrap ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + (inst br zero-tn ,label) + ,@(emit-error-break vop cerror-trap error-code values))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) + + +;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;; +(defmacro pseudo-atomic ((&key (extra 0)) &rest forms) + `(progn + (inst addq alloc-tn 1 alloc-tn) + ,@forms + (inst lda alloc-tn (1- ,extra) alloc-tn) + (inst stl zero-tn 0 alloc-tn))) + + + +;;;; Memory accessor vop generators + +(deftype load/store-index (scale lowtag min-offset + &optional (max-offset min-offset)) + `(integer ,(- (truncate (+ (ash 1 16) + (* min-offset word-bytes) + (- lowtag)) + scale)) + ,(truncate (- (+ (1- (ash 1 16)) lowtag) + (* max-offset word-bytes)) + scale))) + +(defmacro define-full-reffer (name type offset lowtag scs el-type + &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,type tagged-num) + (:temporary (:scs (interior-reg)) lip) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addq object index lip) + (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip) + ,@(when (equal scs '(unsigned-reg)) + '((inst mskll value 4 value))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,word-bytes ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 4 + (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag) + object) + ,@(when (equal scs '(unsigned-reg)) + '((inst mskll value 4 value))))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type + &optional translate #+gengc (remember t)) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 2 + (inst addq index object lip) + (inst stl value (- (* ,offset word-bytes) ,lowtag) lip) + (move value result))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,word-bytes ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 1 + (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag) + object) + (move value result))))) + + +(defmacro define-partial-reffer (name type size signed offset lowtag scs + el-type &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq index lip lip))) + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + lip) + (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag)) + lip) + (inst extqh temp temp1 temp) + (inst sra temp 56 value)) + `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip) + (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + lip) + (inst extbl temp temp1 value)))) + (:short + (if signed + `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + lip) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 value)) + `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip) + (inst extwl temp temp1 value))))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 5 + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (1+ (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag)) + object) + (inst extqh temp temp1 temp) + (inst sra temp 56 value)) + `((inst ldq_u temp (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extbl temp temp1 value)))) + (:short + (if signed + `((inst ldq_u temp (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag)) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 value)) + `((inst ldq_u temp (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extwl temp temp1 value)))))))))) + +(defmacro define-partial-setter (name type size offset lowtag scs el-type + &optional translate) + (let ((scale (ecase size (:byte 1) (:short 2)))) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type positive-fixnum ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq lip index lip))) + ,@(ecase size + (:byte + `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip))) + (:short + `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip)))) + (move value result))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + ,@(ecase size + (:byte + `((inst lda temp (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) + object) + (inst ldq_u temp1 (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) + object) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) object))) + (:short + `((inst lda temp (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) + object) + (inst ldq_u temp1 (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) + object) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp (- (* ,offset word-bytes) + (* index ,scale) ,lowtag) object)))) + (move value result)))))) diff --git a/compiler/alpha/memory.lisp b/compiler/alpha/memory.lisp new file mode 100644 index 000000000..90854c52c --- /dev/null +++ b/compiler/alpha/memory.lisp @@ -0,0 +1,62 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/memory.lisp,v 1.1 1994/04/06 16:54:44 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the Alpha definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Sean Hallgren. +;;; + +(in-package "ALPHA") + + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg null zero))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. We add +;;; in the stardard g-vector overhead. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg null zero))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) diff --git a/compiler/alpha/move.lisp b/compiler/alpha/move.lisp new file mode 100644 index 000000000..eeacad3c1 --- /dev/null +++ b/compiler/alpha/move.lisp @@ -0,0 +1,347 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/move.lisp,v 1.1 1994/04/06 16:54:45 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the MIPS VM definition of operand loading/saving and +;;; the Move VOP. +;;; +;;; Written by Rob MacLachlan. +;;; Conversion by Sean Hallgren. +;;; +(in-package "ALPHA") + + +(define-move-function (load-immediate 1) (vop x y) + ((null zero immediate) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst li (fixnum val) y)) + (null + (move null-tn y)) + (symbol + (load-symbol y val)) + (character + (inst li (logior (ash (char-code val) type-bits) base-char-type) + y))))) + +(define-move-function (load-number 1) (vop x y) + ((zero immediate) + (signed-reg unsigned-reg)) + (inst li (tn-value x) y)) + +(define-move-function (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst li (char-code (tn-value x)) y)) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst li (sap-int (tn-value x)) y)) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg any-reg)) + (loadw y code-tn (tn-offset x) other-pointer-type)) + +(define-move-function (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg)) + (load-stack-tn y x)) + +(define-move-function (load-number-stack 5) (vop x y) + ((base-char-stack) (base-char-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-function (load-number-stack-64 5) (vop x y) + ((sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadq y nfp (tn-offset x)))) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg descriptor-reg null zero) (control-stack)) + (store-stack-tn y x)) + +(define-move-function (store-number-stack 5) (vop x y) + ((base-char-reg) (base-char-stack)) + (let ((nfp (current-nfp-tn vop))) + (storew x nfp (tn-offset y)))) + +(define-move-function (store-number-stack-64 5) (vop x y) + ((sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (let ((nfp (current-nfp-tn vop))) + (storeq x nfp (tn-offset y)))) + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :target y + :scs (any-reg descriptor-reg zero null) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg control-stack) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (unless (location= x y) + (sc-case y + ((any-reg descriptor-reg) + (inst move x y)) + (control-stack + (store-stack-tn y x)))))) + +(define-move-vop move :move + (any-reg descriptor-reg zero null) + (any-reg descriptor-reg)) + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg descriptor-reg null zero)) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (move x y)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg null zero) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (inst sra x 2 y))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst li (tn-value x) y))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:sc non-descriptor-reg) header) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 3 + (inst and x 3 temp) + (inst sra x 2 y) + (inst beq temp done) + + (loadw header x 0 other-pointer-type) + (inst srl header (1+ type-bits) header) + (loadw y x bignum-digits-offset other-pointer-type) + (inst beq header one) + + (loadw header x (1+ bignum-digits-offset) other-pointer-type) + (inst sll header 32 header) + (inst mskll y 4 y) + (inst bis header y y) + (inst br zero-tn done) + ONE + (when (sc-is y unsigned-reg) + (inst mskll y 4 y)) + DONE)) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (inst sll x 2 y))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +(define-vop (move-from-signed) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg) header) + (:note "signed word to integer coercion") + (:generator 18 + (move arg x) + (inst sra x 29 temp) + (inst sll x 2 y) + (inst beq temp done) + (inst not temp temp) + (inst beq temp done) + + (inst li 2 header) + (inst sra x 31 temp) + (inst cmoveq temp 1 header) + (inst not temp temp) + (inst cmoveq temp 1 header) + (inst sll header type-bits header) + (inst bis header bignum-type header) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-type y) + (storew header y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type) + (inst srl x 32 temp) + (storew temp y (1+ bignum-digits-offset) other-pointer-type)) + DONE)) + +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; +(define-vop (move-from-unsigned) + (:args (arg :scs (signed-reg unsigned-reg) :target x)) + (:results (y :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:note "unsigned word to integer coercion") + (:generator 20 + (move arg x) + (inst srl x 29 temp) + (inst sll x 2 y) + (inst beq temp done) + + (inst li 3 temp) + (inst cmovge x 2 temp) + (inst srl x 31 temp1) + (inst cmoveq temp1 1 temp) + (inst sll temp type-bits temp) + (inst bis temp bignum-type temp) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-type y) + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type) + (inst srl x 32 temp) + (storew temp y (1+ bignum-digits-offset) other-pointer-type)) + DONE)) + +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move x y))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move x y)) + ((signed-stack unsigned-stack) + (storeq x fp (tn-offset y)))))) +;;; +(define-move-vop move-word-argument :move-argument + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/alpha/nlx.lisp b/compiler/alpha/nlx.lisp new file mode 100644 index 000000000..deba971bd --- /dev/null +++ b/compiler/alpha/nlx.lisp @@ -0,0 +1,290 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/nlx.lisp,v 1.1 1994/04/06 16:54:46 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the definitions of VOPs used for non-local exit +;;; (throw, lexical exit, etc.) +;;; +;;; Written by Rob MacLachlan +;;; Conversion by Sean Hallgren +;;; +(in-package "ALPHA") + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(def-vm-support-routine make-nlx-sp-tn (env) + (environment-live-tn + (make-representation-tn *fixnum-primitive-type* immediate-arg-scn) + env)) + + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and binding +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. If there +;;; were any additional stacks, then this would be the place to restore the top +;;; pointers. + + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(def-vm-support-routine make-dynamic-state-tns () + (list (make-normal-tn *any-primitive-type*) + (make-normal-tn *any-primitive-type*) + (make-normal-tn *any-primitive-type*) + (make-normal-tn *any-primitive-type*))) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:generator 13 + (load-symbol-value catch lisp::*current-catch-block*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst mskll cur-nfp 4 nfp))) + (inst mskll nsp-tn 4 nsp) + (load-symbol-value eval lisp::*eval-stack-top*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:vop-var vop) + (:temporary (:sc any-reg) temp) + (:generator 10 + (store-symbol-value catch lisp::*current-catch-block*) + (store-symbol-value eval lisp::*eval-stack-top*) + (inst mskll nsp-tn 0 temp) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst bis nfp temp cur-nfp))) + (inst bis nsp temp nsp-tn))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move csp-tn res))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move bsp-tn res))) + + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +;;; +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 22 + (inst lda block (* (tn-offset tn) vm:word-bytes) cfp-tn) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block vm:unwind-block-current-uwp-slot) + (storew cfp-tn block vm:unwind-block-current-cont-slot) + (storew code-tn block vm:unwind-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp block vm:catch-block-entry-pc-slot))) + + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg))) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 44 + (inst lda result (* (tn-offset tn) vm:word-bytes) cfp-tn) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp result vm:catch-block-current-uwp-slot) + (storew cfp-tn result vm:catch-block-current-cont-slot) + (storew code-tn result vm:catch-block-current-code-slot) + (inst compute-lra-from-code temp code-tn entry-label ndescr) + (storew temp result vm:catch-block-entry-pc-slot) + + (storew tag result vm:catch-block-tag-slot) + (load-symbol-value temp lisp::*current-catch-block*) + (storew temp result vm:catch-block-previous-catch-slot) + (store-symbol-value result lisp::*current-catch-block*) + + (move result block))) + + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:scs (descriptor-reg)) new-uwp) + (:generator 7 + (inst lda new-uwp (* (tn-offset tn) vm:word-bytes) cfp-tn) + (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) + + +(define-vop (unlink-catch-block) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-catch-block*) + (loadw block block vm:catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:scs (any-reg)) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-unwind-protect-block*) + (loadw block block vm:unwind-block-current-uwp-slot) + (store-symbol-value block lisp::*current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: + + +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the LRA. + (start) + (count)) + (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc non-descriptor-reg) temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (move null-tn (tn-ref-tn values)) + (inst beq count no-values) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst move count temp) + (inst lda count (fixnum -1) count) + (inst beq temp default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move null-tn tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst br zero-tn defaulting-done)))))) + (load-stack-tn csp-tn sp))) + + +(define-vop (nlx-entry-multiple) + (:args (top :target dst) (start :target src) (count :target num)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:scs (any-reg) :from (:argument 0)) dst) + (:temporary (:scs (any-reg) :from (:argument 1)) src) + (:temporary (:scs (any-reg) :from (:argument 2)) num) + (:temporary (:scs (descriptor-reg)) temp) + (:results (new-start) (new-count)) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (let ((loop (gen-label)) + (done (gen-label))) + + ;; Copy args. + (load-stack-tn dst top) + (move start src) + (move count num) + + ;; Establish results. + (sc-case new-start + (any-reg (move dst new-start)) + (control-stack (store-stack-tn new-start dst))) + (sc-case new-count + (any-reg (inst move num new-count)) + (control-stack (store-stack-tn new-count num))) + (inst beq num done) + + ;; Copy stuff on stack. + (emit-label loop) + (loadw temp src) + (inst lda src vm:word-bytes src) + (storew temp dst) + (inst lda num (fixnum -1) num) + (inst lda dst vm:word-bytes dst) + (inst bne num loop) + + (emit-label done) + (inst move dst csp-tn)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + (emit-return-pc label) + (note-this-location vop :non-local-entry))) diff --git a/compiler/alpha/parms.lisp b/compiler/alpha/parms.lisp new file mode 100644 index 000000000..3e025139d --- /dev/null +++ b/compiler/alpha/parms.lisp @@ -0,0 +1,214 @@ +;;; -*- Package: alpha -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/parms.lisp,v 1.1 1994/04/06 16:54:47 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains some parameterizations of various VM +;;; attributes for the Apha. This file is separate from other stuff so +;;; that it can be compiled and loaded earlier. +;;; +;;; Written by William Lott. +;;; Alpha conversion by Sean Hallgren. +;;; + +(in-package :alpha) +(use-package :c) + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +(setf (backend-name *target-backend*) "ALPHA") +(setf (backend-version *target-backend*) "Alpha") +(setf (backend-fasl-file-type *target-backend*) "axpf") +(setf (backend-fasl-file-implementation *target-backend*) + alpha-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) 2) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :little-endian) +(setf (backend-page-size *target-backend*) 8192) + +); eval-when + + +;;;; Machine Architecture parameters: + +(export '(word-bits byte-bits word-shift word-bytes float-sign-shift + + single-float-bias single-float-exponent-byte + single-float-significand-byte single-float-normal-exponent-min + single-float-normal-exponent-max single-float-hidden-bit + single-float-trapping-nan-bit single-float-digits + + double-float-bias double-float-exponent-byte + double-float-significand-byte double-float-normal-exponent-min + double-float-normal-exponent-max double-float-hidden-bit + double-float-trapping-nan-bit double-float-digits + + float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit)) + + + +(eval-when (compile load eval) + +(defconstant word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant word-bytes (/ word-bits byte-bits) + "Number of bytes in a word.") + +(defconstant float-sign-shift 31) + +(defconstant single-float-bias 126) +(defconstant single-float-exponent-byte (byte 8 23)) +(defconstant single-float-significand-byte (byte 23 0)) +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) +(defconstant single-float-trapping-nan-bit (ash 1 22)) + +(defconstant double-float-bias 1022) +(defconstant double-float-exponent-byte (byte 11 20)) +(defconstant double-float-significand-byte (byte 20 0)) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) +(defconstant double-float-trapping-nan-bit (ash 1 19)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) word-bits 1)) + +(defconstant float-inexact-trap-bit (ash 1 0)) +(defconstant float-underflow-trap-bit (ash 1 1)) +(defconstant float-overflow-trap-bit (ash 1 2)) +(defconstant float-divide-by-zero-trap-bit (ash 1 3)) +(defconstant float-invalid-trap-bit (ash 1 4)) + +(defconstant float-round-to-nearest 0) +(defconstant float-round-to-zero 1) +(defconstant float-round-to-positive 2) +(defconstant float-round-to-negative 3) + +(defconstant float-rounding-mode (byte 2 7)) +(defconstant float-sticky-bits (byte 5 27)) +(defconstant float-traps-byte (byte 5 0)) +(defconstant float-exceptions-byte (byte 5 27)) +(defconstant float-condition-bit (ash 1 26)) +(defconstant float-fast-bit 0) ; No fast mode on HPPA. + +); eval-when + + + +;;;; Description of the target address space. + +(export '(target-read-only-space-start + target-static-space-start + target-dynamic-space-start)) + +;;; Where to put the different spaces. +;;; +(defparameter target-read-only-space-start #x20000000) +(defparameter target-static-space-start #x28000000) +(defparameter target-dynamic-space-start #x30000000) + +;; The space-register holding the lisp heap. +(defconstant lisp-heap-space 4) + +;; The space-register holding the C text segment. +(defconstant c-text-space 4) + + +;;;; Other random constants. + +(export '(halt-trap pending-interrupt-trap error-trap cerror-trap + breakpoint-trap function-end-breakpoint-trap single-step-breakpoint + trace-table-normal trace-table-call-site + trace-table-function-prologue trace-table-function-epilogue)) + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + function-end-breakpoint + single-step-breakpoint) + +(defenum (:prefix trace-table-) + normal + call-site + function-prologue + function-epilogue) + + + +;;;; Static symbols. + +(export '(static-symbols static-functions)) + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +(defparameter static-symbols + '(t + + ;; The C startup code must fill these in. + lisp::lisp-environment-list + lisp::lisp-command-line-list + lisp::*initial-fdefn-objects* + + ;; Functions that the C code needs to call + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + di::handle-breakpoint + di::handle-function-end-breakpoint + lisp::fdefinition-object + + ;; Free Pointers. + lisp::*read-only-space-free-pointer* + lisp::*static-space-free-pointer* + lisp::*initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + lisp::*current-catch-block* + lisp::*current-unwind-protect-block* + *eval-stack-top* + + ;; Interrupt Handling + lisp::*free-interrupt-context-index* + unix::*interrupts-enabled* + unix::*interrupt-pending* + )) + +(defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql + %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + )) diff --git a/compiler/alpha/pred.lisp b/compiler/alpha/pred.lisp new file mode 100644 index 000000000..e5a47067c --- /dev/null +++ b/compiler/alpha/pred.lisp @@ -0,0 +1,49 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/pred.lisp,v 1.1 1994/04/06 16:54:48 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of predicate VOPs for the Alpha. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by Sean Hallgren. +;;; + +(in-package "ALPHA") + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst br zero-tn dest))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:temporary (:scs (non-descriptor-reg)) temp) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (inst cmpeq x y temp) + (if not-p + (inst beq temp target) + (inst bne temp target)))) diff --git a/compiler/alpha/print.lisp b/compiler/alpha/print.lisp new file mode 100644 index 000000000..998f28edb --- /dev/null +++ b/compiler/alpha/print.lisp @@ -0,0 +1,42 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/print.lisp,v 1.1 1994/04/06 16:54:48 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains temporary printing utilities and similar noise. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. + +(in-package "ALPHA") + + +(define-vop (print) + (:args (object :scs (descriptor-reg) :target a0)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0)) + cfunc) + (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (move object a0) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst li (make-fixup "debug_print" :foreign) cfunc) + (inst li (make-fixup "call_into_c" :foreign) temp) + (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) + (move cfunc result)))) diff --git a/compiler/alpha/sap.lisp b/compiler/alpha/sap.lisp new file mode 100644 index 000000000..b07a4fed5 --- /dev/null +++ b/compiler/alpha/sap.lisp @@ -0,0 +1,389 @@ +;;; -*- Package: VM; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/sap.lisp,v 1.1 1994/04/06 16:54:51 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the Alpha VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; Alpha conversion by Sean Hallgren. +;;; +(in-package "ALPHA") + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; + +(define-vop (move-to-sap) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "system area pointer indirection") + (:generator 1 + (loadq y x sap-pointer-slot other-pointer-type))) + +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + + +;;; Move an untagged SAP to a tagged representation. +;;; +(define-vop (move-from-sap) + (:args (x :scs (sap-reg) :target sap)) + (:temporary (:scs (sap-reg) :from (:argument 0)) sap) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (y :scs (descriptor-reg))) + (:note "system area pointer allocation") + (:generator 20 + (move x sap) + (with-fixed-allocation (y ndescr sap-type sap-size) + (storeq sap y sap-pointer-slot other-pointer-type)))) +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move x y))) +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (sap-reg + (move x y)) + (sap-stack + (storeq x fp (tn-offset y)))))) +;;; +(define-move-vop move-sap-argument :move-argument + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg)) + (offset :scs (signed-reg immediate))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (sc-case offset + (signed-reg + (inst addq offset ptr res)) + (immediate + (inst lda res (tn-value offset) ptr))))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg)) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg))) + (:result-types signed-num) + (:generator 1 + (inst subq ptr1 ptr2 res))) + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(eval-when (compile eval) + +(defmacro def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (unsigned-reg))) + (:arg-types system-area-pointer unsigned-num) + ,@(when (or (eq size :byte) (eq size :short)) + `((:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:temporary (:scs (sap-reg) :from (:argument 0)) sap) + (:generator 5 + (inst addq object offset sap) + ,@(ecase size + (:byte + (if signed + '((inst ldq_u temp 0 sap) + (inst lda temp1 1 sap) + (inst extqh temp temp1 temp) + (inst sra temp 56 result)) + '((inst ldq_u temp 0 sap) + (inst lda temp1 0 sap) + (inst extbl temp temp1 result)))) + (:short + (if signed + '((inst ldq_u temp 0 sap) + (inst lda temp1 0 sap) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 result)) + '((inst ldq_u temp 0 sap) + (inst lda temp1 0 sap) + (inst extwl temp temp1 result)))) + (:long + `((inst ldl result 0 sap) + ,@(unless signed + '((inst mskll result 4 result))))) + (:quad + '((inst ldq result 0 sap))) + (:single + '((inst lds result 0 sap))) + (:double + '((inst ldt result 0 sap)))))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg))) + (:arg-types system-area-pointer + (:constant ,(if (eq size :double) + ;; We need to be able to add 4. + `(integer ,(- (ash 1 16)) + ,(- (ash 1 16) 5)) + '(signed-byte 16)))) + ,@(when (or (eq size :byte) (eq size :short)) + `((:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg) temp1))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + ,@(ecase size + (:byte + (if signed + '((inst ldq_u temp offset object) + (inst lda temp1 (1+ offset) object) + (inst extqh temp temp1 temp) + (inst sra temp 56 result)) + '((inst ldq_u temp offset object) + (inst lda temp1 offset object) + (inst extbl temp temp1 result)))) + (:short + (if signed + '((inst ldq_u temp offset object) + (inst lda temp1 offset object) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 result)) + '((inst ldq_u temp offset object) + (inst lda temp1 offset object) + (inst extwl temp temp1 result)))) + (:long + `((inst ldl result offset object) + ,@(unless signed + '((inst mskll result 4 result))))) + (:quad + '((inst ldq result offset object))) + (:single + '((inst lds result offset object))) + (:double + '((inst ldt result (+ offset word-bytes) object)))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (unsigned-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer unsigned-num ,type) + (:results (result :scs (,sc))) + (:result-types ,type) + (:temporary (:scs (sap-reg) :from (:argument 0)) sap) + ,@(when (or (eq size :byte) (eq size :short)) + `((:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2))) + (:generator 5 + (inst addq object offset sap) + ,@(ecase size + (:byte + '((inst lda temp 0 sap) + (inst ldq_u temp1 0 sap) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 0 sap) + (inst move value result))) + (:short + '((inst lda temp 0 sap) + (inst ldq_u temp1 0 sap) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp 0 sap) + (inst move value result))) + (:long + '((inst stl value 0 sap) + (move value result))) + (:quad + '((inst stq value 0 sap) + (move value result))) + (:single + '((unless (location= result value) + (inst fmove value result)) + (inst sts value 0 sap))) + (:double + '((unless (location= result value) + (inst fmove value result)) + (inst stt value 0 sap)))))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (object :scs (sap-reg)) + (value :scs (,sc) :target result)) + (:arg-types system-area-pointer + (:constant ,(if (eq size :double) + ;; We need to be able to add 4. + `(integer ,(- (ash 1 16)) + ,(- (ash 1 16) 5)) + '(signed-byte 16))) + ,type) + ,@(when (or (eq size :byte) (eq size :short)) + `((:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2))) + (:info offset) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(ecase size + (:byte + '((inst lda temp offset object) + (inst ldq_u temp1 offset object) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 offset object) + (inst move value result))) + (:short + '((inst lda temp offset object) + (inst ldq_u temp1 offset object) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp offset object) + (inst move value result))) + (:long + '((inst stl value offset object) + (move value result))) + (:quad + '((inst stq value offset object) + (move value result))) + (:single + '((unless (location= result value) + (inst fmove value result)) + (inst sts value offset object))) + (:double + '((unless (location= result value) + (inst fmove value result)) + (inst stt value offset object))))))))) + +); eval-when (compile eval) + +(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) +(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) +(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :short nil) +(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :short t) +(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg unsigned-num :long nil) +(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg signed-num :long t) +(def-system-ref-and-set sap-ref-64 %set-sap-ref-64 + unsigned-reg unsigned-num :quad nil) +(def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64 + signed-reg signed-num :quad t) +(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :quad) +(def-system-ref-and-set sap-ref-single %set-sap-ref-single + single-reg single-float :single) +(def-system-ref-and-set sap-ref-double %set-sap-ref-double + double-reg double-float :double) + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg))) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst lda sap + (- (* vector-data-offset word-bytes) other-pointer-type) + vector))) diff --git a/compiler/alpha/static-fn.lisp b/compiler/alpha/static-fn.lisp new file mode 100644 index 000000000..a508806a1 --- /dev/null +++ b/compiler/alpha/static-fn.lisp @@ -0,0 +1,148 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/static-fn.lisp,v 1.1 1994/04/06 16:54:52 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. +;;; +(in-package "ALPHA") + + + +(define-vop (static-function-template) + (:save-p t) + (:policy :safe) + (:variant-vars symbol) + (:vop-var vop) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg)) move-temp) + (:temporary (:sc descriptor-reg :offset lra-offset) lra) + (:temporary (:sc interior-reg :offset lip-offset) entry-point) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) ocfp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) + + +(eval-when (compile load eval) + + +(defun static-function-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-function~)" + num-args num-results))) + + +(defun moves (src dst) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car src) ,(car dst)))) + (moves))) + +(defun static-function-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~D) or too many results (~D). Max = ~D" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc descriptor-reg + :offset ,(nth i register-arg-offsets) + ,@(when (< i num-args) + `(:from (:argument ,i))) + ,@(when (< i num-results) + `(:to (:result ,i) + :target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg null zero) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-function-template-name num-args num-results) + static-function-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + (let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + ,@(moves (arg-names) (temp-names)) + (inst li (fixnum ,num-args) nargs) + (inst ldl entry-point (static-function-offset symbol) null-tn) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst move cfp-tn ocfp) + (inst compute-lra-from-code lra code-tn lra-label temp) + (note-this-location vop :call-site) + (inst move csp-tn cfp-tn) + (inst jsr zero-tn entry-point) + (emit-return-pc lra-label) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values vop + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label))) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) + ,@(moves (temp-names) (result-names)))))))) + + +) ; eval-when (compile load eval) + + +(expand + (collect ((templates (list 'progn))) + (dotimes (i register-arg-count) + (templates (static-function-template-vop i 1))) + (templates))) + + +(defmacro define-static-function (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-function-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/compiler/alpha/subprim.lisp b/compiler/alpha/subprim.lisp new file mode 100644 index 000000000..4ec7ef5b0 --- /dev/null +++ b/compiler/alpha/subprim.lisp @@ -0,0 +1,64 @@ +;;; -*- Package: ALPHA; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/subprim.lisp,v 1.1 1994/04/06 16:54:56 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; Converted by Sean Hallgren. +;;; +(in-package "ALPHA") + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg) :target ptr)) + (:arg-types list) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result) + count) + (:results (result :scs (any-reg descriptor-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 50 + (move object ptr) + (move zero-tn count) + + LOOP + + (inst cmpeq ptr null-tn temp) + (inst bne temp done) + + (inst and ptr lowtag-mask temp) + (inst xor temp list-pointer-type temp) + (inst bne temp not-list) + + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst addq count (fixnum 1) count) + (inst br zero-tn loop) + + NOT-LIST + (cerror-call vop done object-not-list-error ptr) + + DONE + (move count result))) + + +(define-static-function length (object) :translate length) + + + diff --git a/compiler/alpha/system.lisp b/compiler/alpha/system.lisp new file mode 100644 index 000000000..d85af3406 --- /dev/null +++ b/compiler/alpha/system.lisp @@ -0,0 +1,254 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/system.lisp,v 1.1 1994/04/06 16:54:57 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Alpha VM definitions of various system hacking operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Mips conversion by William Lott and Christopher Hoover. +;;; Alpha conversion by Sean Hallgren. +;;; +(in-package "ALPHA") + + +;;;; Type frobbing VOPs + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst and object lowtag-mask result))) + +(define-vop (get-type) + (:translate get-type) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + ;; Pick off objects with headers. + (inst and object lowtag-mask result) + (inst cmpeq result other-pointer-type ndescr) + (inst bne ndescr other-ptr) + (inst cmpeq result function-pointer-type ndescr) + (inst bne ndescr function-ptr) + + ;; Pick off structure and list pointers. + (inst blbs object done) + + ;; Pick off fixnums. + (inst and object 3 result) + (inst beq result done) + + ;; Must be an other immediate. + (inst and object type-mask result) + (inst br zero-tn done) + + FUNCTION-PTR + (load-type result object (- function-pointer-type)) + (inst br zero-tn done) + + OTHER-PTR + (load-type result object (- other-pointer-type)) + + DONE)) + +(define-vop (function-subtype) + (:translate function-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type result function (- function-pointer-type)))) + +(define-vop (set-function-subtype) + (:translate (setf function-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target result) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (inst ldl temp (- function-pointer-type) function) + (inst and temp #xff temp) + (inst bis type temp temp) + (inst stl temp (- function-pointer-type) function) + (move type result))) + + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-type) + (inst srl res type-bits res))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 function-pointer-type) + (inst srl res type-bits res))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res) + (data :scs (any-reg immediate zero))) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) t1 t2) + (:generator 6 + (loadw t1 x 0 other-pointer-type) + (inst and t1 type-mask t1) + (sc-case data + (any-reg + (inst sll data (- type-bits 2) t2) + (inst bis t1 t2 t1)) + (immediate + (let ((c (ash (tn-value data) type-bits))) + (cond ((<= 0 c (1- (ash 1 8))) + (inst bis t1 c t1)) + (t + (inst li c t2) + (inst bis t1 t2 t1))))) + (zero)) + (storew t1 x 0 other-pointer-type) + (move x res))) + +(define-vop (c::make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (inst sll ptr 35 res) + (inst srl res 33 res))) + +(define-vop (c::make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg)) + (type :scs (any-reg descriptor-reg immediate) + :target temp)) + (:results (res :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 2 + (sc-case type + ((immediate) + (inst sll val type-bits temp) + (inst bis temp (tn-value type) res)) + (t + (inst sra type 2 temp) + (inst sll val (- type-bits 2) res) + (inst bis res temp res))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (move alloc-tn int))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move bsp-tn int))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move csp-tn int))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 10 + (loadw ndescr code 0 other-pointer-type) + (inst srl ndescr type-bits ndescr) + (inst sll ndescr word-shift ndescr) + (inst subq ndescr other-pointer-type ndescr) + (inst addq code ndescr sap))) + +(define-vop (compute-function) + (:args (code :scs (descriptor-reg)) + (offset :scs (signed-reg unsigned-reg))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:generator 10 + (loadw ndescr code 0 other-pointer-type) + (inst srl ndescr type-bits ndescr) + (inst sll ndescr word-shift ndescr) + (inst addq ndescr offset ndescr) + (inst subq ndescr (- other-pointer-type function-pointer-type) ndescr) + (inst addq code ndescr func))) + + +;;;; Other random VOPs. + + +(defknown unix::do-pending-interrupt () (values)) +(define-vop (unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate unix::do-pending-interrupt) + (:generator 1 + (inst gentrap pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst gentrap halt-trap))) + + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:temporary (:scs (non-descriptor-reg)) count) + (:generator 1 + (let ((offset + (- (* (+ index vector-data-offset) word-bytes) other-pointer-type))) + (inst ldl count offset count-vector) + (inst addq count 1 count) + (inst stl count offset count-vector)))) diff --git a/compiler/alpha/type-vops.lisp b/compiler/alpha/type-vops.lisp new file mode 100644 index 000000000..5222dbc0c --- /dev/null +++ b/compiler/alpha/type-vops.lisp @@ -0,0 +1,545 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/type-vops.lisp,v 1.1 1994/04/06 16:54:57 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the MIPS. +;;; +;;; Written by William Lott +;;; Earlier versions by Rob MacLachlan and Christopher Hoover. +;;; Alpha conversion by Sean Hallgren +;;; +(in-package "ALPHA") + + + +;;;; Test generation utilities. + +(eval-when (compile eval) + +(defparameter immediate-types + (list unbound-marker-type base-char-type)) + +(defparameter function-header-types + (list funcallable-instance-header-type dylan-function-header-type + byte-code-function-type byte-code-closure-type + function-header-type closure-function-header-type + closure-header-type)) + +(defun canonicalize-headers (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta (- other-immediate-1-type other-immediate-0-type))) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +(defmacro test-type (value temp target not-p &rest type-codes) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (member even-fixnum-type type-codes) + (member odd-fixnum-type type-codes) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p (if (intersection headers function-header-types) + (if (subsetp headers function-header-types) + t + (error "Can't test for mix of function subtypes ~ + and normal header types.")) + nil))) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (cond + (fixnump + (when (remove-if #'(lambda (x) + (or (= x even-fixnum-type) + (= x odd-fixnum-type))) + lowtags) + (error "Can't mix fixnum testing with other lowtags.")) + (when function-p + (error "Can't mix fixnum testing with function subtype testing.")) + (when immediates + (error "Can't mix fixnum testing with other immediates.")) + (if headers + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p + ',(canonicalize-headers headers)) + `(%test-fixnum ,value ,temp ,target ,not-p))) + (immediates + (when headers + (error "Can't mix testing of immediates with testing of headers.")) + (when lowtags + (error "Can't mix testing of immediates with testing of lowtags.")) + (when (cdr immediates) + (error "Can't test multiple immediates at the same time.")) + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates))) + (lowtags + (when (cdr lowtags) + (error "Can't test multiple lowtags at the same time.")) + (if headers + `(%test-lowtag-and-headers + ,value ,temp ,target ,not-p ,(car lowtags) + ,function-p ',(canonicalize-headers headers)) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags)))) + (headers + `(%test-headers ,value ,temp ,target ,not-p ,function-p + ',(canonicalize-headers headers))) + (t + (error "Nothing to test?"))))) + +); eval-when (compile eval) + +(defun %test-fixnum (value temp target not-p) + (assemble () + (inst and value 3 temp) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + +(defun %test-fixnum-and-headers (value temp target not-p headers) + (let ((drop-through (gen-label))) + (assemble () + (inst and value 3 temp) + (inst beq temp (if not-p drop-through target))) + (%test-headers value temp target not-p nil headers drop-through))) + +(defun %test-immediate (value temp target not-p immediate) + (assemble () + (inst and value 255 temp) + (inst xor temp immediate temp) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + +(defun %test-lowtag (value temp target not-p lowtag) + (assemble () + (inst and value lowtag-mask temp) + (inst xor temp lowtag temp) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + +(defun %test-lowtag-and-headers (value temp target not-p lowtag + function-p headers) + (let ((drop-through (gen-label))) + (%test-lowtag value temp (if not-p drop-through target) nil lowtag) + (%test-headers value temp target not-p function-p headers drop-through))) + +(defun %test-headers (value temp target not-p function-p headers + &optional (drop-through (gen-label))) + (let ((lowtag (if function-p function-pointer-type other-pointer-type))) + (multiple-value-bind + (when-true when-false) + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when + ;; we know it's true and when we know it's false respectively. + (if not-p + (values drop-through target) + (values target drop-through)) + (assemble () + (%test-lowtag value temp when-false t lowtag) + (load-type temp value (- lowtag)) + (let ((delta 0)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst subq temp (- header delta) temp) + (setf delta header) + (if last + (if not-p + (inst bne temp target) + (inst beq temp target)) + (inst beq temp when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst subq temp (- start delta) temp) + (setf delta start) + (inst blt temp when-false)) + (inst subq temp (- end delta) temp) + (setf delta end) + (if last + (if not-p + (inst bgt temp target) + (inst ble temp target)) + (inst ble temp when-true)))))))) + (emit-label drop-through))))) + + + +;;;; Type checking and testing: + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value temp target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value temp err-lab t ,@type-codes) + (move value result)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +); eval-when (compile eval) + +(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + even-fixnum-type odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error function-pointer-type) + +(def-type-vops listp check-list list object-not-list-error + list-pointer-type) + +(def-type-vops %instancep check-instance instance object-not-instance-error + instance-pointer-type) + +(def-type-vops bignump check-bignum bignum + object-not-bignum-error bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error ratio-type) + +(def-type-vops complexp check-complex complex + object-not-complex-error complex-type) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error simple-vector-type) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + simple-array-unsigned-byte-2-type) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + simple-array-unsigned-byte-4-type) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + simple-array-unsigned-byte-8-type) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + simple-array-unsigned-byte-16-type) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + simple-array-unsigned-byte-32-type) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + simple-array-single-float-type) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + simple-array-double-float-type) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error base-char-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error weak-pointer-type) + +(def-type-vops scavenger-hook-p nil nil nil + #-gengc 0 #+gengc scavenger-hook-type) + +(def-type-vops code-component-p nil nil nil + code-header-type) + +(def-type-vops lra-p nil nil nil + #-gengc return-pc-header-type #+gengc 0) + +(def-type-vops fdefn-p nil nil nil + fdefn-type) + +(def-type-vops funcallable-instance-p nil nil nil + funcallable-instance-header-type) + +(def-type-vops dylan::dylan-function-p nil nil nil + dylan-function-header-type) + +(def-type-vops array-header-p nil nil nil + simple-array-type complex-string-type complex-bit-vector-type + complex-vector-type complex-array-type) + +(def-type-vops nil check-function-or-symbol nil + object-not-function-or-symbol-error + function-pointer-type symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + simple-string-type complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + simple-bit-vector-type complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil object-not-vector-error + 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-single-float-type + simple-array-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 + 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-single-float-type simple-array-double-float-type) + +(def-type-vops arrayp check-array nil object-not-array-error + 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-single-float-type simple-array-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 + even-fixnum-type odd-fixnum-type bignum-type ratio-type + single-float-type double-float-type complex-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + even-fixnum-type odd-fixnum-type bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + single-float-type double-float-type) + +(def-type-vops realp check-real nil object-not-real-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type + single-float-type double-float-type) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(defun signed-byte-32-test (value temp temp1 not-p target not-target) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (assemble () + (inst and value 3 temp) + (inst beq temp yep) + (inst and value lowtag-mask temp) + (inst xor temp other-pointer-type temp) + (inst bne temp nope) + (loadw temp value 0 other-pointer-type) + (inst li (+ (ash 1 type-bits) bignum-type) temp1) + (inst xor temp temp1 temp) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + (undefined-value)) + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:generator 45 + (signed-byte-32-test value temp temp1 not-p target not-target) + NOT-TARGET)) + +(define-vop (check-signed-byte-32 check-type) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:generator 45 + (let ((loose (generate-error-code vop object-not-signed-byte-32-error + value))) + (signed-byte-32-test value temp temp1 t loose okay)) + OKAY + (move value result))) + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +(defun unsigned-byte-32-test (value temp temp1 not-p target not-target) + (multiple-value-bind (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (assemble () + ;; Is it a fixnum? + (inst and value 3 temp1) + (inst move value temp) + (inst beq temp1 fixnum) + + ;; If not, is it an other pointer? + (inst and value lowtag-mask temp) + (inst xor temp other-pointer-type temp) + (inst bne temp nope) + ;; Get the header. + (loadw temp value 0 other-pointer-type) + ;; Is it one? + (inst li (+ (ash 1 type-bits) bignum-type) temp1) + (inst xor temp temp1 temp) + (inst beq temp single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst li (logxor (+ (ash 1 type-bits) bignum-type) + (+ (ash 2 type-bits) bignum-type)) + temp1) + (inst xor temp temp1 temp) + (inst bne temp nope) + ;; Get the second digit. + (loadw temp value (1+ bignum-digits-offset) other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst beq temp yep) + (inst br zero-tn nope) + + SINGLE-WORD + ;; Get the single digit. + (loadw temp value bignum-digits-offset other-pointer-type) + + ;; positive implies (unsigned-byte 32). + FIXNUM + (if not-p + (inst blt temp target) + (inst bge temp target)))) + (undefined-value)) + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:generator 45 + (unsigned-byte-32-test value temp temp1 not-p target not-target) + NOT-TARGET)) + +(define-vop (check-unsigned-byte-32 check-type) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:generator 45 + (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error + value))) + (unsigned-byte-32-test value temp temp1 t loose okay)) + OKAY + (move value result))) + + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 12 + (inst cmpeq value null-tn temp) + (inst bne temp (if not-p drop-thru target)) + (test-type value temp target not-p symbol-header-type) + DROP-THRU)) + +(define-vop (check-symbol check-type) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 12 + (inst cmpeq value null-tn temp) + (inst bne temp drop-thru) + (let ((error (generate-error-code vop object-not-symbol-error value))) + (test-type value temp error t symbol-header-type)) + DROP-THRU + (move value result))) + +(define-vop (consp type-predicate) + (:translate consp) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 8 + (inst cmpeq value null-tn temp) + (inst bne temp (if not-p target drop-thru)) + (test-type value temp target not-p list-pointer-type) + DROP-THRU)) + +(define-vop (check-cons check-type) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmpeq value null-tn temp) + (inst bne temp error) + (test-type value temp error t list-pointer-type)) + (move value result))) diff --git a/compiler/alpha/values.lisp b/compiler/alpha/values.lisp new file mode 100644 index 000000000..6ecfd7880 --- /dev/null +++ b/compiler/alpha/values.lisp @@ -0,0 +1,133 @@ +;;; -*- Package: ALPHA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/values.lisp,v 1.1 1994/04/06 16:54:58 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted to the Alpha by Sean Hallgren. +;;; + +(in-package "ALPHA") + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move ptr csp-tn))) + + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args + (vals :more t)) + (:results + (start :scs (any-reg)) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (descriptor-reg) + :to (:result 0) + :target start) + start-temp) + (:generator 20 + (move csp-tn start-temp) + (inst lda csp-tn (* nvals word-bytes) csp-tn) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (let ((tn (tn-ref-tn val))) + (sc-case tn + (descriptor-reg + (storew tn start-temp i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start-temp i))))) + (move start-temp start) + (inst li (fixnum nvals) count))) + + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (move arg list) + (move csp-tn start) + + LOOP + (inst cmpeq list null-tn temp) + (inst bne temp done) + (loadw temp list cons-car-slot list-pointer-type) + (loadw list list cons-cdr-slot list-pointer-type) + (inst lda csp-tn word-bytes csp-tn) + (storew temp csp-tn -1) + (inst and list lowtag-mask ndescr) + (inst xor ndescr list-pointer-type ndescr) + (inst beq ndescr loop) + (error-call vop bogus-argument-to-values-list-error list) + + DONE + (inst subq csp-tn start count))) + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg zero immediate)) + (num :scs (any-reg) :target count)) + (:arg-types * positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :from (:argument 0)) src) + (:temporary (:sc any-reg :from (:argument 2)) dst) + (:temporary (:sc descriptor-reg :from (:argument 1)) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (zero + (move context src)) + (immediate + (inst lda src (* (tn-value skip) word-bytes) context)) + (any-reg + (inst addq context skip src))) + (move num count) + (inst move csp-tn start) + (inst beq num done) + (inst move csp-tn dst) + (inst addq csp-tn count csp-tn) + LOOP + (inst ldl temp 0 src) + (inst addq src 4 src) + (inst addq dst 4 dst) + (inst stl temp -4 dst) + (inst cmpeq dst csp-tn temp1) + (inst beq temp1 loop) + DONE)) diff --git a/compiler/alpha/vm.lisp b/compiler/alpha/vm.lisp new file mode 100644 index 000000000..e31b3405e --- /dev/null +++ b/compiler/alpha/vm.lisp @@ -0,0 +1,363 @@ +;;; -*- Package: alpha -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/vm.lisp,v 1.1 1994/04/06 16:54:59 hallgren Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition for the Alpha. +;;; +;;; Written by William Lott. +;;; Alpha conversion by Sean Hallgren. +;;; + +(in-package "ALPHA") + + +;;;; Define the registers + +(eval-when (compile eval) + +(defmacro defreg (name offset) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(eval-when (compile eval load) + (defconstant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) + +(defmacro defregset (name &rest regs) + `(eval-when (compile eval load) + (defconstant ,name + (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) + +); eval-when (compile eval) + + +(eval-when (compile load eval) + +(defvar *register-names* (make-array 32 :initial-element nil)) + +); eval-when (compile load eval) + + +;; Ra +(defreg lip 0) +;; Caller saved 0-7 +(defreg a0 1) +(defreg a1 2) +(defreg a2 3) +(defreg a3 4) +(defreg a4 5) +(defreg a5 6) +(defreg l0 7) +(defreg nargs 8) +;; Callee saved 0-6 +(defreg csp 9) +(defreg cfp 10) +(defreg ocfp 11) +(defreg bsp 12) +(defreg lexenv 13) +(defreg code 14) +(defreg null 15) +;; Arg 0-5 +(defreg nl0 16) +(defreg nl1 17) +(defreg nl2 18) +(defreg nl3 19) +(defreg nl4 20) +(defreg nl5 21) +;; Caller saved 8-11 +(defreg alloc 22) +(defreg fdefn 23) +(defreg cfunc 24) +(defreg nfp 25) +;; Ra +(defreg lra 26) +;; Caller saved 12 +(defreg l1 27) +;; Assembler temp (at) +(defreg l2 28) +;; Global pointer (gp) +(defreg gp 29) +;; Stack pointer +(defreg nsp 30) +;; Wired zero +(defreg zero 31) + +(defregset non-descriptor-regs + nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) + +(defregset descriptor-regs + fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) + +(defregset register-arg-offsets + a0 a1 a2 a3 a4 a5) + + +(define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 64) +(define-storage-base control-stack :unbounded :size 8) +(define-storage-base non-descriptor-stack :unbounded :size 0) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (do ((forms (list 'progn) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(defconstant ,constant-name ,index) + `(export ',constant-name) + forms))) + (index 0 (1+ index)) + (classes classes (cdr classes))) + ((null classes) + (nreverse forms)))) + +(define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + ;; ZERO and NULL are in registers. + (zero immediate-constant) + (null immediate-constant) + (fp-single-zero immediate-constant) + (fp-double-zero immediate-constant) + + ;; Anything else that can be an immediate. + (immediate immediate-constant) + + + ;; **** The stacks. + + ;; The control stack. (Scanned by GC) + (control-stack control-stack) + + ;; The non-descriptor stacks. + (signed-stack non-descriptor-stack + :element-size 2 :alignment 2) ; (signed-byte 64) + (unsigned-stack non-descriptor-stack + :element-size 2 :alignment 2) ; (unsigned-byte 64) + (base-char-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack + :element-size 2 :alignment 2) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack + :element-size 2 :alignment 2) ; double floats. + + + ;; **** Things that can go in the integer registers. + + ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing + ;; bad will happen if they are. (fixnums, characters, header values, etc). + (any-reg + registers + :locations #.(append non-descriptor-regs descriptor-regs) + :constant-scs (zero immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.descriptor-regs + :constant-scs (constant null immediate) + :save-p t + :alternate-scs (control-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.non-descriptor-regs + :constant-scs (zero immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (non-descriptor-reg registers + :locations #.non-descriptor-regs) + + ;; Pointers to the interior of objects. Used only as an temporary. + (interior-reg registers + :locations (#.lip-offset)) + + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations #.(loop for i from 4 to 31 collect i) + :constant-scs (fp-single-zero) + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations #.(loop for i from 4 to 31 collect i) + :constant-scs (fp-double-zero) + :save-p t + :alternate-scs (double-stack)) + + ;; A catch or unwind block. + (catch-block control-stack :element-size vm:catch-block-size)) + + +;;;; Make some random tns for important registers. + +(eval-when (compile eval) + +(defmacro defregtn (name sc) + (let ((offset-sym (symbolicate name "-OFFSET")) + (tn-sym (symbolicate name "-TN"))) + `(defparameter ,tn-sym + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc) + :offset ,offset-sym)))) + +); eval-when (compile eval) + +;; These, we access by foo-TN only + +(defregtn zero any-reg) +(defregtn null descriptor-reg) +(defregtn code descriptor-reg) +(defregtn alloc any-reg) +(defregtn bsp any-reg) +(defregtn csp any-reg) +(defregtn cfp any-reg) +(defregtn nsp any-reg) + +;; These alias regular locations, so we have to make sure we don't bypass +;; the register allocator when using them. +(defregtn nargs any-reg) +(defregtn ocfp any-reg) +(defregtn lip interior-reg) + +;; And some floating point values. +(defparameter fp-single-zero-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'single-reg) + :offset 31)) +(defparameter fp-double-zero-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset 31)) + + +;;; Immediate-Constant-SC -- Interface +;;; +;;; If value can be represented as an immediate constant, then return the +;;; appropriate SC number, otherwise return NIL. +;;; +(def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((integer 0 0) + (sc-number-or-lose 'zero *backend*)) + (null + (sc-number-or-lose 'null *backend*)) + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate *backend*)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate *backend*) + nil)) + (single-float + (if (zerop value) + (sc-number-or-lose 'fp-single-zero *backend*) + nil)) + (double-float + (if (zerop value) + (sc-number-or-lose 'fp-double-zero *backend*) + nil)))) + +;;;; Function Call Parameters + +;;; The SC numbers for register and stack arguments/return values. +;;; +(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) + +(eval-when (compile load eval) + +;;; Offsets of special stack frame locations +(defconstant ocfp-save-offset 0) +(defconstant lra-save-offset 1) +(defconstant nfp-save-offset 2) + +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 6) + +;;; Names to use for the argument registers. +;;; +(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5)) + +); Eval-When (Compile Load Eval) + + +;;; A list of TN's describing the register arguments. +;;; +(defparameter register-arg-tns + (mapcar #'(lambda (n) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + register-arg-offsets)) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(export 'single-value-return-byte-offset) +(defconstant single-value-return-byte-offset 4) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let ((sb (sb-name (sc-sb (tn-sc tn)))) + (offset (tn-offset tn))) + (ecase sb + (registers (or (svref *register-names* offset) + (format nil "R~D" offset))) + (float-registers (format nil "F~D" offset)) + (control-stack (format nil "CS~D" offset)) + (non-descriptor-stack (format nil "NS~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed")))) -- GitLab