From 4df954cb4290c9251eb92ac05a1774abbe928cd9 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 30 Nov 1990 17:05:10 +0000 Subject: [PATCH] Initial revision --- compiler/sparc/alloc.lisp | 124 ++++ compiler/sparc/arith.lisp | 708 ++++++++++++++++++++ compiler/sparc/array.lisp | 419 ++++++++++++ compiler/sparc/c-call.lisp | 150 +++++ compiler/sparc/call.lisp | 1190 +++++++++++++++++++++++++++++++++ compiler/sparc/cell.lisp | 336 ++++++++++ compiler/sparc/char.lisp | 133 ++++ compiler/sparc/debug.lisp | 108 +++ compiler/sparc/float.lisp | 529 +++++++++++++++ compiler/sparc/insts.lisp | 612 +++++++++++++++++ compiler/sparc/macros.lisp | 458 +++++++++++++ compiler/sparc/memory.lisp | 160 +++++ compiler/sparc/move.lisp | 278 ++++++++ compiler/sparc/nlx.lisp | 306 +++++++++ compiler/sparc/parms.lisp | 176 +++++ compiler/sparc/pred.lisp | 46 ++ compiler/sparc/print.lisp | 41 ++ compiler/sparc/sap.lisp | 365 ++++++++++ compiler/sparc/static-fn.lisp | 154 +++++ compiler/sparc/subprim.lisp | 60 ++ compiler/sparc/system.lisp | 272 ++++++++ compiler/sparc/type-vops.lisp | 447 +++++++++++++ compiler/sparc/values.lisp | 89 +++ compiler/sparc/vm.lisp | 334 +++++++++ 24 files changed, 7495 insertions(+) create mode 100644 compiler/sparc/alloc.lisp create mode 100644 compiler/sparc/arith.lisp create mode 100644 compiler/sparc/array.lisp create mode 100644 compiler/sparc/c-call.lisp create mode 100644 compiler/sparc/call.lisp create mode 100644 compiler/sparc/cell.lisp create mode 100644 compiler/sparc/char.lisp create mode 100644 compiler/sparc/debug.lisp create mode 100644 compiler/sparc/float.lisp create mode 100644 compiler/sparc/insts.lisp create mode 100644 compiler/sparc/macros.lisp create mode 100644 compiler/sparc/memory.lisp create mode 100644 compiler/sparc/move.lisp create mode 100644 compiler/sparc/nlx.lisp create mode 100644 compiler/sparc/parms.lisp create mode 100644 compiler/sparc/pred.lisp create mode 100644 compiler/sparc/print.lisp create mode 100644 compiler/sparc/sap.lisp create mode 100644 compiler/sparc/static-fn.lisp create mode 100644 compiler/sparc/subprim.lisp create mode 100644 compiler/sparc/system.lisp create mode 100644 compiler/sparc/type-vops.lisp create mode 100644 compiler/sparc/values.lisp create mode 100644 compiler/sparc/vm.lisp diff --git a/compiler/sparc/alloc.lisp b/compiler/sparc/alloc.lisp new file mode 100644 index 000000000..3b205b981 --- /dev/null +++ b/compiler/sparc/alloc.lisp @@ -0,0 +1,124 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.1 1990/11/30 17:04:22 wlott Exp $ +;;; +;;; Allocation VOPs for the SPARC port. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") + + +;;;; 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) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + (move result null-tn)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((store-car (tn list &optional (slot cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg zero 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 (ndescr) + (inst add res alloc-tn list-pointer-type) + (inst add alloc-tn alloc-tn + (* (pad-data-block cons-size) cons-cells)) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst add ptr ptr (pad-data-block cons-size)) + (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 result res)))))))) + +(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 add boxed boxed-arg (fixnum (1+ code-constants-offset))) + (inst and boxed (lognot lowtag-mask)) + (inst srl unboxed unboxed-arg word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + (pseudo-atomic (ndescr) + (inst add result alloc-tn other-pointer-type) + (inst add alloc-tn boxed) + (inst add alloc-tn unboxed) + (inst sll ndescr boxed (- type-bits word-shift)) + (inst or ndescr code-header-type) + (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) + (storew null-tn result code-debug-info-slot other-pointer-type)))) + +(define-vop (make-symbol) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (result :scs (descriptor-reg) :from :argument)) + (:policy :fast-safe) + (:translate make-symbol) + (:generator 37 + (with-fixed-allocation (result temp symbol-header-type symbol-size) + (inst li temp unbound-marker-type) + (storew temp result symbol-value-slot other-pointer-type) + (storew temp result symbol-function-slot other-pointer-type) + (storew temp result symbol-setf-function-slot other-pointer-type) + (inst li temp (make-fixup "_undefined_tramp" :foreign)) + (storew temp result symbol-raw-function-addr-slot + other-pointer-type) + (storew null-tn result symbol-plist-slot other-pointer-type) + (storew name result symbol-name-slot other-pointer-type) + (storew null-tn result symbol-package-slot other-pointer-type)))) + + diff --git a/compiler/sparc/arith.lisp b/compiler/sparc/arith.lisp new file mode 100644 index 000000000..0e36a3b5f --- /dev/null +++ b/compiler/sparc/arith.lisp @@ -0,0 +1,708 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/arith.lisp,v 1.1 1990/11/30 17:04:24 wlott Exp $ +;;; +;;; This file contains the VM definition arithmetic VOPs for the MIPS. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + + + +;;;; Unary operations. + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg))) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg))) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (inst neg res x))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (inst neg res x))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (inst xor res x (fixnum -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (inst not res x))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero)) + (y :target r :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero)) + (y :target r :scs (unsigned-reg zero))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero)) + (y :target r :scs (signed-reg zero))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg zero))) + (:info y) + (:arg-types tagged-num + (:constant (and (signed-byte 11) (not (integer 0 0))))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg zero))) + (:info y) + (:arg-types unsigned-num + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg zero))) + (:info y) + (:arg-types signed-num + (:constant (and (signed-byte 13) (not (integer 0 0))))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(eval-when (compile load eval) + +(defmacro define-binop (translate cost op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + (:generator ,(1+ cost) + (inst ,op r x y))) + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + (:translate ,translate) + (:generator ,cost + (inst ,op r x (fixnum y)))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(+ cost 3) + (inst ,op r x y))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,(+ cost 2) + (inst ,op r x y))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(+ cost 3) + (inst ,op r x y))) + (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,(+ cost 2) + (inst ,op r x y))))) + +); eval-when + +(define-binop + 2 add) +(define-binop - 2 sub) +(define-binop logand 1 and) +(define-binop logandc2 1 andn) +(define-binop logior 1 or) +(define-binop logorc2 1 orn) +(define-binop logxor 1 xor) +(define-binop logeqv 1 xnor) + +;;; Special case fixnum + and - that trap on overflow. Useful when we +;;; don't know that the output type is a fixnum. + +(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 1 + (inst taddcctv r x y))) + +(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 1 + (inst taddcctv r x y))) + +(define-vop (fast--/fixnum fast--/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 1 + (inst tsubcctv r x y))) + +(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum) + (:results (r :scs (any-reg descriptor-reg))) + (:result-types (:or signed-num unsigned-num)) + (:note nil) + (:generator 1 + (inst tsubcctv r x y))) + +;;; Shifting + +(define-vop (fast-ash) + (:note "inline ASH") + (:args (number :scs (signed-reg unsigned-reg) :to :save) + (amount :scs (signed-reg immediate))) + (:arg-types (:or signed-num unsigned-num) signed-num) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:translate ash) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) ndesc) + (:generator 3 + (sc-case amount + (signed-reg + (let ((positive (gen-label)) + (done (gen-label))) + (inst cmp amount) + (inst b :ge positive) + (inst neg ndesc amount) + (inst cmp ndesc 31) + (inst b :le done) + (sc-case number + (signed-reg (inst sra result number ndesc)) + (unsigned-reg (inst srl result number ndesc))) + (inst b done) + (sc-case number + (signed-reg (inst sra result number 31)) + (unsigned-reg (inst srl result number 31))) + + (emit-label positive) + ;; The result-type assures us that this shift will not overflow. + (inst sll result number amount) + + (emit-label done))) + + (immediate + (let ((amount (tn-value amount))) + (if (minusp amount) + (let ((amount (min 31 (- amount)))) + (sc-case number + (unsigned-reg + (inst srl result number amount)) + (signed-reg + (inst sra result number amount)))) + (inst sll result number amount))))))) + + + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :target shift)) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) + (:generator 30 + (let ((loop (gen-label)) + (test (gen-label))) + (inst addcc shift zero-tn arg) + (inst b :ge test) + (move res zero-tn) + (inst b test) + (inst not shift) + + (emit-label loop) + (inst add res (fixnum 1)) + + (emit-label test) + (inst cmp shift) + (inst b :ne loop) + (inst srl shift 1)))) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target shift)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp) + (:generator 30 + (let ((loop (gen-label)) + (done (gen-label))) + (inst addcc shift zero-tn arg) + (inst b :eq done) + (move res zero-tn) + + (emit-label loop) + (inst sub temp shift 1) + (inst andcc shift temp) + (inst b :ne loop) + (inst add res 1) + + (emit-label done)))) + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(deftype integer-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- 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 zero)) + (y :scs (any-reg zero))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg zero))) + (:arg-types tagged-num (:constant (signed-byte 11))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg zero)) + (y :scs (signed-reg zero))) + (: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 zero))) + (:arg-types signed-num (:constant (signed-byte 13))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (: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 zero))) + (:arg-types unsigned-num (:constant (unsigned-byte 12))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) + `(progn + ,@(mapcar #'(lambda (suffix signed) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq tran 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator 3 + (inst cmp x + ,(if (eq suffix '-c/fixnum) '(fixnum y) 'y)) + (inst b (if not-p + ,(if signed not-cond not-unsigned) + ,(if signed cond unsigned)) + target) + (inst nop))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(t t t t nil nil)))) + +(define-conditional-vop < :lt :ltu :ge :geu) + +(define-conditional-vop > :gt :gtu :le :leu) + +(define-conditional-vop eql :eq :eq :ne :ne) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg descriptor-reg zero)) + (y :scs (any-reg zero))) + (:arg-types * tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 3 + (inst cmp x y) + (inst b (if not-p :ne :eq) target) + (inst nop))) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg descriptor-reg zero))) + (:arg-types * (:constant (signed-byte 11))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (inst cmp x (fixnum y)) + (inst b (if not-p :ne :eq) target) + (inst nop))) + + + +;;;; 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 cmp shift) + (inst b :eq done) + (inst srl res next shift) + (inst sub temp zero-tn shift) + (inst sll temp prev temp) + (inst or res temp) + (emit-label done) + (move result res)))) + + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg zero)) + (y :scs (unsigned-reg zero))) + (: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 zero))) + (:arg-types unsigned-num) + (:generator 1 + (inst not r x))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (inst and r x y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (inst or r x y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (inst xor r x y))) + + + + +;;;; 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-vop (bignum-ref word-index-ref) + (:variant vm:bignum-digits-offset vm:other-pointer-type) + (:translate bignum::%bignum-ref) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (bignum-set word-index-set) + (:variant vm:bignum-digits-offset vm:other-pointer-type) + (:translate bignum::%bignum-set) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate zero)) + (value :scs (unsigned-reg))) + (:arg-types t positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (digit-0-or-plus) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (let ((done (gen-label))) + (inst cmp digit) + (inst b :lt done) + (move result null-tn) + (load-symbol result t) + (emit-label done)))) + +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 3 + (inst addcc zero-tn c -1) + (inst addxcc result a b) + (inst addx carry zero-tn zero-tn))) + +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg)) + (b :scs (unsigned-reg)) + (c :scs (any-reg))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg)) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:temporary (temp :scs (non-descriptor-reg))) + (:generator 4 + (inst subcc zero-tn c 1) + (inst subxcc result a b) + (inst addx borrow zero-tn zero-tn) + (inst xor borrow 1))) + +;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly +;;; routines. +;;; +(defun emit-multiply (multiplier multiplicand result-high result-low) + "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result + in RESULT-HIGH and RESULT-LOW. KIND is either :signed or :unsigned. + Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap." + (declare (type tn multiplier result-high result-low) + (type (or tn (signed-byte 13)) multiplicand)) + (let ((label (gen-label))) + (inst wry multiplier) + (inst andcc result-high zero-tn) + ;; Note: we can't use the Y register until three insts after it's written. + (inst nop) + (inst nop) + (dotimes (i 32) + (inst mulscc result-high multiplicand)) + (inst mulscc result-high zero-tn) + (inst cmp multiplicand) + (inst b :ge label) + (inst nop) + (inst add result-high multiplier) + (emit-label label) + (inst rdy result-low))) + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:eval 1)) + (y :scs (unsigned-reg) :to (:eval 1)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg) :from (:eval 0)) + (lo :scs (unsigned-reg) :from (:eval 1))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi lo) + (inst addcc lo carry-in) + (inst addx hi zero-tn))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:eval 1)) + (y :scs (unsigned-reg) :to (:eval 1)) + (prev :scs (unsigned-reg) :to (:eval 2)) + (carry-in :scs (unsigned-reg) :to (:eval 2))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg) :from (:eval 0)) + (lo :scs (unsigned-reg) :from (:eval 1))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi lo) + (inst addcc lo carry-in) + (inst addx hi zero-tn) + (inst addcc lo prev) + (inst addx hi zero-tn))) + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :to (:result 1)) + (y :scs (unsigned-reg) :to (:result 1))) + (:arg-types unsigned-num unsigned-num) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 40 + (emit-multiply x y hi 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 r x))) + +(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 digit fixnum 2))) + +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target rem) + (div-low :scs (unsigned-reg) :target quo) + (divisor :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (quo :scs (unsigned-reg) :from (:argument 1)) + (rem :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num unsigned-num) + (:generator 300 + (move rem div-high) + (move quo div-low) + (dotimes (i 33) + (let ((label (gen-label))) + (inst cmp rem divisor) + (inst b :ltu label) + (inst addxcc quo quo) + (inst sub rem divisor) + (emit-label label) + (unless (= i 32) + (inst addx rem rem)))) + (inst not quo))) + +(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 1 + (sc-case res + (any-reg + (inst sll res digit 2)) + (signed-reg + (move res digit))))) + + +(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))) + (:result-types unsigned-num) + (:generator 1 + (inst sra result digit count))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (inst srl result digit count))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 1 + (inst sll result digit count))) + + +;;;; 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/sparc/array.lisp b/compiler/sparc/array.lisp new file mode 100644 index 000000000..9783baabc --- /dev/null +++ b/compiler/sparc/array.lisp @@ -0,0 +1,419 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.1 1990/11/30 17:04:28 wlott Exp $ +;;; +;;; This file contains the SPARC definitions for array operations. +;;; +;;; Written by William Lott +;;; +(in-package "SPARC") + + +;;;; Allocator for the array header. + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types tagged-num tagged-num) + (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:results (result :scs (descriptor-reg))) + (:generator 0 + (pseudo-atomic (ndescr) + (inst add header alloc-tn vm:other-pointer-type) + (inst add alloc-tn + (+ (* vm:array-dimensions-offset vm:word-bytes) + vm:lowtag-mask)) + (inst add alloc-tn rank) + (inst and alloc-tn (lognot vm:lowtag-mask)) + (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset))) + (inst sll ndescr ndescr vm:type-bits) + (inst or ndescr ndescr type) + (inst srl ndescr ndescr 2) + (storew ndescr header 0 vm:other-pointer-type)) + (move result header))) + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t fixnum) fixnum + (flushable)) +(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum + ()) + +(define-vop (%array-dimension word-index-ref) + (:translate lisp::%array-dimension) + (:policy :fast-safe) + (:variant vm:array-dimensions-offset vm:other-pointer-type)) + +(define-vop (%set-array-dimension word-index-set) + (:translate lisp::%set-array-dimension) + (:policy :fast-safe) + (:variant vm:array-dimensions-offset vm:other-pointer-type)) + + + +(defknown lisp::%array-rank (t) fixnum (flushable)) + +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg) :type random) temp) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw temp x 0 vm:other-pointer-type) + (inst sra temp vm:type-bits) + (inst sub temp (1- vm:array-dimensions-offset)) + (inst sll res temp 2))) + + + +;;;; 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))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index))) + (inst cmp index bound) + (inst b :gtu error) + (inst nop) + (move result index)))) + + + +;;;; 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. + +(defmacro def-data-vector-frobs (type variant element-type &rest scs) + `(progn + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-REF/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-REF"))) + (:note "inline array access") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-ref) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,element-type)) + (define-vop (,(intern (concatenate 'simple-string + "DATA-VECTOR-SET/" + (string type))) + ,(intern (concatenate 'simple-string + (string variant) + "-SET"))) + (:note "inline array store") + (:variant vm:vector-data-offset vm:other-pointer-type) + (:translate data-vector-set) + (:arg-types ,type positive-fixnum ,element-type) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs ,scs)) + (:results (result :scs ,scs)) + (:result-types ,element-type)))) + +(def-data-vector-frobs simple-string byte-index + base-character base-character-reg) +(def-data-vector-frobs simple-vector word-index + * descriptor-reg any-reg) + +(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index + positive-fixnum unsigned-reg) +(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index + positive-fixnum unsigned-reg) +(def-data-vector-frobs simple-array-unsigned-byte-32 word-index + unsigned-num unsigned-reg) + + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(eval-when (compile eval) + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor vm: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 (non-descriptor-reg) :to (:result 0)) temp result) + (:generator 20 + (inst srl temp index ,bit-shift) + (inst sll temp 2) + (inst add temp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ld result object temp) + (inst and temp index ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst sll temp ,(1- (integer-length bits))))) + (inst srl result temp) + (inst and result ,(1- (ash 1 bits))) + (inst sll value result 2))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 13)) + (inst ld result object offset)) + (t + (inst li temp offset) + (inst ld result object temp)))) + (unless (zerop extra) + (inst srl result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (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 (non-descriptor-reg)) temp old offset) + (:temporary (:scs (non-descriptor-reg) :from :eval) shift) + (:generator 25 + (inst srl offset index ,bit-shift) + (inst sll offset 2) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ld old object offset) + (inst and shift index ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst sll shift ,(1- (integer-length bits))))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst li temp ,(1- (ash 1 bits))) + (inst sll temp shift) + (inst not temp) + (inst and old temp)) + (unless (sc-is value zero) + (sc-case value + (immediate + (inst li temp (logand (tn-value value) ,(1- (ash 1 bits))))) + (unsigned-reg + (inst and temp value ,(1- (ash 1 bits))))) + (inst sll temp shift) + (inst or old temp)) + (inst st old object offset) + (sc-case value + (immediate + (inst li result (tn-value value))) + (t + (move result value))))) + (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 index) + positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) offset-reg temp old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes) + vm:other-pointer-type))) + (cond ((typep offset '(signed-byte 13)) + (inst ld old object offset)) + (t + (inst li offset-reg offset) + (inst ld old object offset-reg))) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (cond ((= extra ,(1- elements-per-word)) + (inst sll old ,bits) + (inst srl old ,bits)) + (t + (inst li temp + (lognot (ash ,(1- (ash 1 bits)) + (* extra ,bits)))) + (inst and old temp)))) + (sc-case value + (zero) + (immediate + (let ((value (ash (logand (tn-value value) + ,(1- (ash 1 bits))) + (* extra ,bits)))) + (cond ((typep value '(signed-byte 13)) + (inst or old value)) + (t + (inst li temp value) + (inst or old temp))))) + (unsigned-reg + (inst sll temp value (* extra ,bits)) + (inst or old temp))) + (if (typep offset '(signed-byte 13)) + (inst st old object offset) + (inst st old object offset-reg))) + (sc-case value + (immediate + (inst li result (tn-value value))) + (t + (move result value))))))))) + +); eval-when (compile eval) + +(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))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (inst add offset index (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst ldf value object offset))) + + +(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 (non-descriptor-reg)) offset) + (:generator 5 + (inst add offset index + (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stf value object offset) + (unless (location= result value) + (inst fmovs result value)))) + +(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 (non-descriptor-reg)) offset) + (:generator 7 + (inst sll offset index 1) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst lddf value object offset))) + +(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 (non-descriptor-reg)) offset) + (:generator 20 + (inst sll offset index 1) + (inst add offset (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + (inst stdf value object offset) + (unless (location= result value) + (inst fmovs result value) + (inst fmovs-odd result value)))) + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-vop (raw-bits word-index-ref) + (:note "raw-bits VOP") + (:translate %raw-bits) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 vm:other-pointer-type)) + +(define-vop (set-raw-bits word-index-set) + (:note "setf raw-bits VOP") + (:translate %set-raw-bits) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + (value :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant 0 vm:other-pointer-type)) + + + +;;;; Misc. Array VOPs. + + +#+nil +(define-vop (vector-word-length) + (:args (vec :scs (descriptor-reg))) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 6 + (loadw res vec clc::g-vector-header-words) + (inst niuo res res clc::g-vector-words-mask-16))) + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp new file mode 100644 index 000000000..3d793ef9a --- /dev/null +++ b/compiler/sparc/c-call.lisp @@ -0,0 +1,150 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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 (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.1 1990/11/30 17:04:30 wlott Exp $ +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + +(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)) + +(def-vm-support-routine make-call-out-nsp-tn () + (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)) + +(def-vm-support-routine make-call-out-argument-tns (arg-types) + (let ((register-args 0) + (stack-frame-size 0)) + (collect ((tns)) + (dolist (type arg-types) + (let ((name (if (consp type) (car type) type))) + (flet ((int-arg (prim-type sc) + (cond ((< register-args 6) + (tns (my-make-wired-tn prim-type sc + (+ register-args nl0-offset))) + (incf register-args)) + (t + (tns (my-make-wired-tn prim-type sc + (+ stack-frame-size 16 1 6))) + (incf stack-frame-size))))) + (ecase name + ((unsigned-byte port) + (int-arg 'unsigned-byte-32 'unsigned-reg)) + (signed-byte + (int-arg 'signed-byte-32 'signed-reg)) + (system-area-pointer + (int-arg 'system-area-pointer 'sap-reg)) + (double-float + (error "A double-float made it through the deftransform?")) + (single-float + (error "Can't deal with floats yet.")))))) + (values (tns) + (logandc2 (1+ stack-frame-size) 1))))) + +(def-vm-support-routine make-call-out-result-tn (type) + (let ((name (if (consp type) (car type) type))) + (ecase name + ((unsigned-byte port) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)) + (signed-byte + (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)) + (system-area-pointer + (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) + (double-float + (my-make-wired-tn 'double-float 'double-reg 0)) + (single-float + (error "Can't return single-floats yet."))))) + + +(deftransform ext::call-foreign-function + ((name return-type arg-types &rest args) + (string t list &rest t)) + (assert (c::constant-continuation-p name)) + (assert (c::constant-continuation-p return-type)) + (assert (c::constant-continuation-p arg-types)) + (let ((name (c::continuation-value name)) + (return-type (c::continuation-value return-type)) + (arg-types (c::continuation-value arg-types))) + (assert (= (length arg-types) (length args))) + (if (member 'double-float arg-types) + (let ((new-args nil) + (lambda-vars nil) + (new-types nil)) + (dolist (type arg-types) + (let ((arg (gensym))) + (push arg lambda-vars) + (case type + (double-float + (push `(double-float-high-bits ,arg) new-args) + (push '(signed-byte 32) new-types) + (push `(double-float-low-bits ,arg) new-args) + (push '(unsigned-byte 32) new-types)) + (t + (push arg new-args) + (push type new-types))))) + `(lambda (name return-type arg-types ,@(nreverse lambda-vars)) + (declare (ignore name return-type arg-types)) + (ext::call-foreign-function ,name ',return-type + ',(nreverse new-types) + ,@(nreverse new-args)))) + (c::give-up)))) + + +(define-vop (foreign-symbol-address) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:generator 2 + (inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol) + :foreign)))) + +(define-vop (call-out) + (:args (args :more t)) + (:results (results :more t)) + (:ignore args results) + (:save-p t) + (:info function) + (:temporary (:sc any-reg :offset cfunc-offset :to (:result 0)) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (any-reg) :to (:result 0)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 0 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst li cfunc + (make-fixup (concatenate 'simple-string "_" function) :foreign)) + (inst li temp (make-fixup "_call_into_c" :foreign)) + (inst jal lip temp) + (inst nop) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (unless (zerop amount) + (inst add nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7)))) + (unless (location= nsp-tn result) + (inst add result nsp-tn number-stack-displacement)))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:policy :fast-safe) + (:generator 0 + (unless (zerop amount) + (inst add nsp-tn nsp-tn (logandc2 (+ amount 7) 7))))) diff --git a/compiler/sparc/call.lisp b/compiler/sparc/call.lisp new file mode 100644 index 000000000..9c1867907 --- /dev/null +++ b/compiler/sparc/call.lisp @@ -0,0 +1,1190 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.1 1990/11/30 17:04:32 wlott Exp $ +;;; +;;; This file contains the VM definition of function call for the SPARC. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +;;;; 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) + (if standard + (make-wired-tn *any-primitive-type* register-arg-scn lra-offset) + (make-restricted-tn *any-primitive-type* register-arg-scn))) + +;;; 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) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env) + (make-wired-tn *any-primitive-type* + control-stack-arg-scn + lra-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) + vm:word-bytes)) + +;;; NUMBER-STACK-DISPLACEMENT +;;; +;;; The number of bytes reserved above the number stack pointer. +;;; +(defconstant number-stack-displacement + (* (+ 16 ; 16 words to save ins and locals in. + 1 ; extra word required by C call convention. + 6 ; space where anyone we call can save his args. + 1) ; and one more to round it out. + vm:word-bytes)) + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg))) + (:generator 1 + (move val cfp-tn))) + +;;; 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 add val nfp (bytes-needed-for-non-descriptor-stack-frame)))))) + + +(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 vm:lowtag-bits) + (emit-label start-lab) + ;; Allocate function header. + (inst function-header-word) + (dotimes (i (1- vm:function-header-code-offset)) + (inst word 0)) + ;; The start of the actual code. + ;; Fix CODE, cause the function object was passed in. + (inst compute-code-from-fn code-tn code-tn start-lab temp) + ;; Build our stack frames. + (inst add csp-tn cfp-tn + (* vm:word-bytes (sb-allocated-size 'control-stack))) + (let ((nfp-tn (current-nfp-tn vop))) + (when nfp-tn + (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) + (inst add nfp-tn nsp-tn number-stack-displacement))))) + +(define-vop (allocate-frame) + (:results (res :scs (any-reg)) + (nfp :scs (any-reg))) + (:info callee) + (:generator 2 + (move res csp-tn) + (inst add csp-tn csp-tn + (* vm:word-bytes (sb-allocated-size 'control-stack))) + (when (ir2-environment-number-stack-p callee) + (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) + (inst add nfp nsp-tn number-stack-displacement)))) + +;;; 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 res csp-tn) + (inst add csp-tn csp-tn (* nargs vm:word-bytes))))) + + + + +;;; 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 old-fp csp ; Set up args for SP resetting + +regs-defaulted + subcc temp nargs register-arg-count + + b :lt default-value-7 ; jump to default code + loadw move-temp ocfp-tn 6 ; Move value to correct location. + subcc temp 1 + store-stack-tn val4-tn move-temp + + b :lt default-value-8 + loadw move-temp ocfp-tn 7 + subcc temp 1 + store-stack-tn val5-tn move-temp + + ... + +defaulting-done + move csp 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 (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 + (move csp-tn ocfp-tn) + (inst nop) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label))) + ;; Branch off to the MV case. + (inst b regs-defaulted) + (inst nop) + + ;; 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 (tn-ref-tn val) null-tn)) + (when (> nvals register-arg-count) + (inst li nargs-tn (fixnum 1)) + (move ocfp-tn csp-tn)) + + (emit-label regs-defaulted) + (inst compute-code-from-lra code-tn code-tn lra-label temp) + + (when (> nvals register-arg-count) + (inst subcc temp nargs-tn (fixnum register-arg-count)) + (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 b :lt default-lab) + (inst ld move-temp ocfp-tn (* i vm:word-bytes)) + (inst subcc temp (fixnum 1)) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move csp-tn ocfp-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (when (null (cdr remaining)) + (inst b defaulting-done)) + (store-stack-tn (cdr def) null-tn)))))))))) + (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))) + (inst b variable-values) + (inst nop) + + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (inst add csp-tn 4) + (storew (first register-arg-tns) csp-tn -1) + (inst sub start csp-tn 4) + (inst li count (fixnum 1)) + + (emit-label done) + + (assemble (*elsewhere*) + (emit-label variable-values) + (inst compute-code-from-lra code-tn code-tn lra-label temp) + (do ((arg register-arg-tns (rest arg)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) + (move start args) + (move count nargs) + (inst b done) + (inst nop))) + (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 0)) 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 0)) 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)) + (maybe-load-stack-tn cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (inst b target) + (inst nop) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (default-unknown-values values nvals move-temp temp label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +;;; 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) + (:generator 20 + (let ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (maybe-load-stack-tn cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (inst b target) + (inst nop) + (emit-return-pc label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + + +;;;; 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 ((label (gen-label)) + (cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (maybe-load-stack-tn cfp-tn fp) + (let ((callee-nfp (callee-nfp-tn callee))) + (when callee-nfp + (move callee-nfp nfp))) + (inst compute-lra-from-code + (callee-return-pc-tn callee) code-tn label temp) + (inst b target) + (inst nop) + (emit-return-pc label) + (note-this-location vop :known-return) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + +;;; 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 (old-fp :target old-fp-temp) + (return-pc :target return-pc-temp) + (vals :more t)) + (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) + (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (maybe-load-stack-tn old-fp-temp old-fp) + (maybe-load-stack-tn return-pc-temp return-pc) + (move csp-tn cfp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type)) + (move cfp-tn old-fp-temp))) + + +;;;; 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 Old-Fp 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) + '((old-fp :target old-fp-pass) + (return-pc :target return-pc-pass))) + + ,@(unless variable '((args :more t)))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + ,@(unless (eq return :tail) + `((:save-p t) + ,@(unless 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 + ,@(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))) + old-fp-pass) + + (:temporary (:sc descriptor-reg + :offset lra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) + + ,(if named + `(:temporary (:sc descriptor-reg :offset cname-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)) + + (: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) :from :eval) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + + (: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= old-fp old-fp-pass) + :load-old-fp) + (unless (location= return-pc + return-pc-pass) + :load-return-pc) + (when cur-nfp + :frob-nfp)) + '(: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 sub nargs-pass csp-tn new-fp) + ,@(let ((index -1)) + (mapcar #'(lambda (name) + `(loadw ,name new-fp + ,(incf index))) + register-arg-names))) + '((inst li nargs-pass (fixnum nargs))))) + ,@(if (eq return :tail) + '((:load-old-fp + (sc-case old-fp + (any-reg + (inst move old-fp-pass old-fp)) + (control-stack + (loadw old-fp-pass cfp-tn + (tn-offset old-fp))))) + (:load-return-pc + (sc-case return-pc + (descriptor-reg + (inst move return-pc-pass return-pc)) + (control-stack + (loadw return-pc-pass cfp-tn + (tn-offset return-pc))))) + (:frob-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + `((: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 old-fp-pass cfp-tn)) + (:load-fp + ,(if variable + '(move cfp-tn new-fp) + '(if (> nargs register-arg-count) + (move cfp-tn new-fp) + (move cfp-tn csp-tn)))))) + ((nil)))))) + + ,@(if named + `((sc-case name + (descriptor-reg (move name-pass name)) + (control-stack + (loadw name-pass cfp-tn (tn-offset name)) + (do-next-filler)) + (immediate + (load-symbol name-pass (tn-value name))) + (constant + (loadw name-pass code-tn (tn-offset name) + vm:other-pointer-type) + (do-next-filler))) + (loadw function name-pass vm:symbol-raw-function-addr-slot + vm:other-pointer-type) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move lexenv arg-fun)) + (control-stack + (loadw lexenv cfp-tn (tn-offset arg-fun)) + (do-next-filler)) + (constant + (loadw lexenv code-tn (tn-offset arg-fun) + vm:other-pointer-type) + (do-next-filler))) + (loadw function lexenv vm:closure-function-slot + vm:function-pointer-type) + (do-next-filler))) + (loop + (if filler + (do-next-filler) + (return))) + + (inst j function + (- (ash vm:function-header-code-offset vm:word-shift) + vm:function-pointer-type)) + (inst move code-tn function)) + + ,@(ecase return + (:fixed + '((emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (default-unknown-values values nvals move-temp temp lra-label) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (: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) + (old-fp-arg :scs (any-reg) :target old-fp) + (lra-arg :scs (descriptor-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)) old-fp) + (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra) + + (:temporary (:scs (any-reg) :from :eval) temp) + + (:vop-var vop) + + (:generator 75 + + ;; Move these into the passing locations if they are not already there. + (move args args-arg) + (move lexenv function-arg) + (move old-fp old-fp-arg) + (move lra lra-arg) + + ;; Clear the number stack if anything is there. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + ;; And jump to the assembly-routine that does the bliting. + (inst li temp (make-fixup 'tail-call-variable :assembly-routine)) + (inst j temp) + (inst nop))) + + +;;;; Unknown values return: + + +;;; 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 + (old-fp :scs (any-reg)) + (return-pc :scs (descriptor-reg) :to (:eval 1)) + (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) + (:vop-var vop) + (:generator 6 + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + (cond ((= nvals 1) + ;; Clear the control stack, and restore the frame pointer. + (move csp-tn cfp-tn) + (move cfp-tn old-fp) + ;; Out of here. + (lisp-return return-pc :offset 2)) + (t + ;; Establish the values pointer and values count. + (move val-ptr cfp-tn) + (inst li nargs (fixnum nvals)) + ;; restore the frame pointer and clear as much of the control + ;; stack as possible. + (move cfp-tn old-fp) + (inst add csp-tn val-ptr (* nvals word-bytes)) + ;; 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 reg null-tn))) + ;; And away we go. + (lisp-return return-pc))))) + +;;; 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 + (old-fp-arg :scs (any-reg) :to (:eval 1)) + (lra-arg :scs (descriptor-reg) :to (:eval 1)) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) + + (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp) + (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra) + (: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 (any-reg) :from (:eval 1)) temp) + + (:vop-var vop) + + (:generator 13 + (let ((not-single (gen-label))) + ;; Clear the number stack. + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (inst add nsp-tn cur-nfp + (- (bytes-needed-for-non-descriptor-stack-frame) + number-stack-displacement)))) + + ;; Check for the single case. + (inst cmp nvals-arg (fixnum 1)) + (inst b :ne not-single) + (inst ld a0 vals-arg) + + ;; Return with one value. + (move csp-tn cfp-tn) + (move cfp-tn old-fp-arg) + (lisp-return lra-arg :offset 2) + + ;; Nope, not the single case. + (emit-label not-single) + (move old-fp old-fp-arg) + (move lra lra-arg) + (move vals vals-arg) + (move nvals nvals-arg) + (inst li temp (make-fixup 'return-multiple :assembly-routine)) + (inst j temp) + (inst nop)))) + + + +;;;; 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 closure lexenv))) + +;;; 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 nl3-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 result csp-tn)) + ;; Allocate the space on the stack. + (cond ((zerop fixed) + (inst cmp nargs-tn) + (inst b :eq done) + (inst add csp-tn csp-tn nargs-tn)) + (t + (inst subcc count nargs-tn (fixnum fixed)) + (inst b :le done) + (inst nop) + (inst add csp-tn csp-tn count))) + (when (< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we run out of + ;; more args. + (inst subcc count nargs-tn (fixnum register-arg-count)) + ;; Everything of interest in registers. + (inst b :le do-regs)) + ;; Initialize dst to be end of stack. + (move dst csp-tn) + ;; Initialize src to be end of args. + (inst add src cfp-tn nargs-tn) + + (emit-label loop) + ;; *--dst = *--src, --count + (inst add src src (- vm:word-bytes)) + (inst subcc count count (fixnum 1)) + (loadw temp src) + (inst add dst dst (- vm:word-bytes)) + (inst b :gt loop) + (storew temp dst) + + (emit-label do-regs) + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in registers. + (inst subcc count nargs-tn (fixnum fixed)) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Don't deposit any more than there are. + (inst b :eq done) + (inst subcc count (fixnum 1)) + ;; Store it relative to the pointer saved at the start. + (storew (nth i register-arg-tns) result (- i fixed)))) + (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-vop (more-arg word-index-ref) + (:variant 0 0) + (:translate %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) + (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr 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 context-arg) + (move count count-arg) + ;; Check to see if there are any arguments. + (inst cmp count) + (inst b :eq done) + (move result null-tn) + + ;; We need to do this atomically. + (pseudo-atomic (ndescr) + ;; Allocate a cons (2 words) for each item. + (inst add result alloc-tn vm:list-pointer-type) + (move dst result) + (inst add alloc-tn alloc-tn count) + (inst b enter) + (inst add alloc-tn alloc-tn count) + + ;; Store the current cons in the cdr of the previous cons. + (emit-label loop) + (storew dst dst -1 vm:list-pointer-type) + + ;; Grab one value and stash it in the car of this cons. + (emit-label enter) + (loadw temp context) + (inst add context context vm:word-bytes) + (storew temp dst 0 vm:list-pointer-type) + + ;; Dec count, and if != zero, go back for more. + (inst subcc count (fixnum 1)) + (inst b :gt loop) + (inst add dst dst (* 2 vm:word-bytes)) + + ;; NIL out the last cons. + (storew null-tn dst -1 vm: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) + (:args (supplied :scs (any-reg))) + (:arg-types positive-fixnum) + (:info fixed) + (:results + (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:generator 5 + (inst sub count supplied (fixnum fixed)) + (inst sub context csp-tn count))) + + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +(define-vop (verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (inst cmp nargs (fixnum count)) + (inst b :ne err-lab) + (inst nop)))) + +;;; Signal various errors. +;;; +(macrolet ((frob (name error &rest args) + `(define-vop (,name) + (: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 nargs) + (frob type-check-error object-not-type-error object type) + (frob odd-keyword-arguments-error odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error key)) diff --git a/compiler/sparc/cell.lisp b/compiler/sparc/cell.lisp new file mode 100644 index 000000000..bb62a1db6 --- /dev/null +++ b/compiler/sparc/cell.lisp @@ -0,0 +1,336 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/cell.lisp,v 1.1 1990/11/30 17:04:38 wlott Exp $ +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the SPARC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + + +;;;; Data object definition macros. + +(vm:define-for-each-primitive-object (obj) + (collect ((forms)) + (let ((lowtag (vm:primitive-object-lowtag obj))) + (dolist (slot (vm:primitive-object-slots obj)) + (let* ((name (vm:slot-name slot)) + (offset (vm:slot-offset slot)) + (rest-p (vm:slot-rest-p slot)) + (slot-opts (vm:slot-options slot)) + (ref-trans (getf slot-opts :ref-trans)) + (ref-vop (getf slot-opts :ref-vop ref-trans)) + (set-trans (getf slot-opts :set-trans)) + (setf-function-p (and (listp set-trans) + (= (length set-trans) 2) + (eq (car set-trans) 'setf))) + (setf-vop (getf slot-opts :setf-vop + (when setf-function-p + (intern (concatenate + 'simple-string + "SET-" + (string (cadr set-trans))))))) + (set-vop (getf slot-opts :set-vop + (if setf-vop nil set-trans)))) + (when ref-vop + (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + (when (or set-vop setf-vop) + (forms `(define-vop ,(cond ((and rest-p setf-vop) + (error "Can't automatically generate ~ + a setf VOP for :rest-p ~ + slots: ~S in ~S" + name + (vm:primitive-object-name obj))) + (rest-p `(,set-vop slot-set)) + ((and set-vop setf-function-p) + (error "Setf functions (list ~S) must ~ + use :setf-vops." + set-trans)) + (set-vop `(,set-vop cell-set)) + (setf-function-p + `(,setf-vop cell-setf-function)) + (t + `(,setf-vop cell-setf))) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans))))))))) + (when (forms) + `(progn + ,@(forms))))) + + + +;;;; Symbol hacking VOPs: + +;;; 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 (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 obj-temp object) + (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (inst cmp value vm:unbound-marker-type) + (inst b :eq err-lab) + (inst nop)))) + +;;; With Symbol-Function, we check that the result is a function, so NIL is +;;; always un-fbound. +;;; +(define-vop (symbol-function checked-cell-ref) + (:translate symbol-function) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (test-type value temp err-lab t vm:function-pointer-type)))) + +#+nil +(define-vop (symbol-setf-function checked-cell-ref) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:translate symbol-setf-function) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp vm:symbol-setf-function-slot vm:other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (test-type value temp err-lab t vm:function-pointer-type)))) + + +;;; 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)) + +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object vm:symbol-value-slot vm:other-pointer-type) + (inst cmp value vm:unbound-marker-type) + (inst b (if not-p :eq :ne) target) + (inst nop))) + + +;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction +;;; on the symbol case of fboundp. Instead, we transform to a funny function. + +(defknown fboundp/symbol (t) boolean (flushable)) +;;; +(deftransform fboundp ((x) (symbol)) + '(fboundp/symbol x)) +;;; +(define-vop (fboundp/symbol boundp-frob) + (:translate fboundp/symbol) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:generator 10 + (loadw value object vm:symbol-function-slot vm:other-pointer-type) + (test-type value temp target not-p vm:function-pointer-type))) + +#+nil(progn +(defknown fboundp/setf (t) boolean (flushable)) +;;; +(deftransform fboundp ((x) (cons)) + '(fboundp/setf (cadr x))) +;;; +(define-vop (fboundp/setf boundp-frob) + (:translate fboundp/setf) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:generator 10 + (loadw value object vm:symbol-setf-function-slot vm:other-pointer-type) + (test-type value temp target not-p vm:function-pointer-type))) +) + +(define-vop (fast-symbol-value cell-ref) + (:variant vm:symbol-value-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + +(define-vop (fast-symbol-function cell-ref) + (:variant vm:symbol-function-slot vm:other-pointer-type) + (:policy :fast) + (:translate symbol-function)) + + +(define-vop (set-symbol-function) + (:translate %sp-set-definition) + (:policy :fast-safe) + (:args (symbol :scs (descriptor-reg)) + (function :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) type) + (:temporary (:scs (any-reg)) temp) + (:save-p :compute-only) + (:vop-var vop) + (:generator 30 + (let ((closure (gen-label)) + (normal-fn (gen-label))) + (load-type type function (- vm:function-pointer-type)) + (inst nop) + (inst cmp type vm:closure-header-type) + (inst b :eq closure) + (inst cmp type vm:function-header-type) + (inst b :eq normal-fn) + (inst move temp function) + (error-call vop kernel:object-not-function-error function) + (emit-label closure) + (inst li temp (make-fixup "_closure_tramp" :foreign)) + (emit-label normal-fn) + (storew function symbol vm:symbol-function-slot vm:other-pointer-type) + (storew temp symbol vm:symbol-raw-function-addr-slot + vm:other-pointer-type) + (move result function)))) + + +(defknown fmakunbound/symbol (symbol) symbol (unsafe)) +;;; +(deftransform fmakunbound ((symbol) (symbol)) + '(progn + (fmakunbound/symbol symbol) + t)) +;;; +(define-vop (fmakunbound/symbol) + (:translate fmakunbound/symbol) + (:policy :fast-safe) + (:args (symbol :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (inst li temp vm:unbound-marker-type) + (storew temp symbol vm:symbol-function-slot vm:other-pointer-type) + (inst li temp (make-fixup "_undefined_tramp" :foreign)) + (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type) + (move result symbol))) + + +;;; 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 vm:symbol-value-slot vm:other-pointer-type) + (inst add bsp-tn bsp-tn (* 2 vm:word-bytes)) + (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (storew val symbol vm:symbol-value-slot vm:other-pointer-type))) + + +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) symbol value) + (:generator 0 + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)))) + + +(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) + (:generator 0 + (let ((loop (gen-label)) + (skip (gen-label)) + (done (gen-label))) + (move where arg) + (inst cmp where bsp-tn) + (inst b :eq done) + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label loop) + (inst cmp symbol) + (inst b :eq skip) + (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label skip) + (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes)) + (inst cmp where bsp-tn) + (inst b :ne loop) + (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) + + (emit-label done)))) + + + +;;;; Closure indexing. + +(define-vop (closure-index-ref word-index-ref) + (:variant vm:closure-info-offset vm:function-pointer-type) + (:translate %closure-index-ref)) + + +;;;; Structure hackery: + +(define-vop (structure-length cell-ref) + (:variant vm:vector-length-slot vm:other-pointer-type) + (:policy :fast-safe) + (:translate structure-length)) + +(define-vop (structure-ref slot-ref) + (:variant vm:vector-data-offset vm:other-pointer-type) + (:policy :fast-safe) + (:translate structure-ref) + (:arg-types structure (:constant (integer 0 #.(1- (ash 1 29)))))) + +(define-vop (structure-set slot-set) + (:policy :fast-safe) + (:translate structure-set) + (:variant vm:vector-data-offset vm:other-pointer-type) + (:arg-types structure (:constant (integer 0 #.(1- (ash 1 29)))) *)) + +(define-vop (structure-index-ref word-index-ref) + (:policy :fast-safe) + (:translate structure-ref) + (:variant vm:vector-data-offset vm:other-pointer-type) + (:arg-types structure positive-fixnum)) + +(define-vop (structure-index-set word-index-set) + (:policy :fast-safe) + (:translate structure-set) + (:variant vm:vector-data-offset vm:other-pointer-type) + (:arg-types structure positive-fixnum *)) + + + +;;;; Extra random indexers. + +(define-vop (code-constant-set word-index-set) + (:variant vm:code-constants-offset vm:other-pointer-type)) + diff --git a/compiler/sparc/char.lisp b/compiler/sparc/char.lisp new file mode 100644 index 000000000..eb8a6e629 --- /dev/null +++ b/compiler/sparc/char.lisp @@ -0,0 +1,133 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/char.lisp,v 1.1 1990/11/30 17:04:40 wlott Exp $ +;;; +;;; This file contains the SPARC VM definition of character operations. +;;; +;;; Written by Rob MacLachlan +;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; And then to the SPARC by William Lott. +;;; +(in-package "SPARC") + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-character) + (:args (x :scs (any-reg))) + (:results (y :scs (base-character-reg))) + (:generator 1 + (inst srl y x vm:type-bits))) +;;; +(define-move-vop move-to-base-character :move + (any-reg) (base-character-reg)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-character) + (:args (x :scs (base-character-reg))) + (:results (y :scs (any-reg))) + (:generator 1 + (inst sll y x vm:type-bits) + (inst or y vm:base-character-type))) +;;; +(define-move-vop move-from-base-character :move + (base-character-reg) (any-reg)) + +;;; Move untagged base-character values. +;;; +(define-vop (base-character-move) + (:args (x :target y + :scs (base-character-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-character-reg) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-character-move :move + (base-character-reg) (base-character-reg)) + + +;;; Move untagged base-character arguments/return-values. +;;; +(define-vop (move-base-character-argument) + (:args (x :target y + :scs (base-character-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-character-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (base-character-reg + (move y x)) + (base-character-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-base-character-argument :move-argument + (any-reg base-character-reg) (base-character-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-character +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-character-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-character-reg) :target res)) + (:arg-types base-character) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst sll res ch 2))) + +(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-character-reg))) + (:result-types base-character) + (:generator 1 + (inst srl res code 2))) + + +;;; Comparison of base-characters. +;;; +(define-vop (base-character-compare pointer-compare) + (:args (x :scs (base-character-reg)) + (y :scs (base-character-reg))) + (:arg-types base-character base-character)) + +(define-vop (fast-char=/base-character base-character-compare) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char</base-character base-character-compare) + (:translate char<) + (:variant :ltu :geu)) + +(define-vop (fast-char>/base-character base-character-compare) + (:translate char>) + (:variant :gtu :leu)) + diff --git a/compiler/sparc/debug.lisp b/compiler/sparc/debug.lisp new file mode 100644 index 000000000..fe306eaf6 --- /dev/null +++ b/compiler/sparc/debug.lisp @@ -0,0 +1,108 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/debug.lisp,v 1.1 1990/11/30 17:04:41 wlott Exp $ +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + +(defknown di::current-sp () system-area-pointer (movable flushable)) +(defknown di::current-fp () system-area-pointer (movable flushable)) +(defknown di::stack-ref (system-area-pointer index) t (flushable)) +(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe)) +(defknown di::lra-code-header (t) t (movable flushable)) +(defknown di::function-code-header (t) t (movable flushable)) +(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable)) +(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable)) + +(define-vop (debug-cur-sp) + (:translate di::current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res csp-tn))) + +(define-vop (debug-cur-fp) + (:translate di::current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 1 + (move res cfp-tn))) + +(define-vop (read-control-stack sap-ref) + (:translate di::stack-ref) + (:policy :fast-safe) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:variant :long nil)) + +(define-vop (write-control-stack sap-set) + (:translate di::%set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate)) + (value :scs (descriptor-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:variant :long)) + +(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) + (inst cmp temp) + (inst b :eq bogus) + (inst sll temp (1- (integer-length vm:word-bytes))) + (unless (= lowtag vm:other-pointer-type) + (inst add temp (- lowtag vm:other-pointer-type))) + (inst sub code thing temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst b done) + (move code null-tn))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate di::lra-code-header) + (:variant vm:other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate di::function-code-header) + (:variant vm:function-pointer-type)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate di::make-lisp-obj) + (:args (value :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg))) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg) :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp new file mode 100644 index 000000000..75f839d27 --- /dev/null +++ b/compiler/sparc/float.lisp @@ -0,0 +1,529 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.1 1990/11/30 17:04:42 wlott Exp $ +;;; +;;; This file contains floating point support for the MIPS. +;;; +;;; Written by Rob MacLachlan +;;; Sparc conversion by William Lott. +;;; +(in-package "SPARC") + + +;;;; Move functions: + +(define-move-function (load-single 1) (vop x y) + ((single-stack) (single-reg)) + (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))) + +(define-move-function (store-single 1) (vop x y) + ((single-reg) (single-stack)) + (inst stf x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))) + + +(define-move-function (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset x) vm:word-bytes))) + (inst lddf y nfp offset))) + +(define-move-function (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (let ((nfp (current-nfp-tn vop)) + (offset (* (tn-offset y) vm:word-bytes))) + (inst stdf x nfp offset))) + + + +;;;; Move VOPs: + +(macrolet ((frob (vop sc double-p) + `(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)))) + (:generator 0 + (unless (location= y x) + (inst fmovs y x) + ,@(when double-p + '((inst fmovs-odd y x)))))) + (define-move-vop ,vop :move (,sc) (,sc))))) + (frob single-move single-reg nil) + (frob double-move double-reg t)) + + +(define-vop (move-from-float) + (:args (x :to :save)) + (:results (y)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:variant-vars double-p size type data) + (:generator 13 + (with-fixed-allocation (y ndescr type size) + (if double-p + (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type)) + (inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type)))))) + +(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 vm:single-float-size vm:single-float-type vm:single-float-value-slot) + (frob move-from-double double-reg + t vm:double-float-size vm:double-float-type vm:double-float-value-slot)) + +(macrolet ((frob (name sc double-p value) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:generator 2 + (inst ,(if double-p 'lddf 'ldf) y x + (- (* ,value vm:word-bytes) vm:other-pointer-type)))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg nil vm:single-float-value-slot) + (frob move-to-double double-reg t vm: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)) + (:generator ,(if double-p 2 1) + (sc-case y + (,sc + (unless (location= x y) + (inst fmovs y x) + ,@(when double-p + '((inst fmovs-odd y x))))) + (,stack-sc + (let ((offset (* (tn-offset y) vm:word-bytes))) + (inst ,(if double-p 'stdf 'stf) x nfp offset)))))) + (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) + (:generator ,scost + (inst ,sinst r x y))) + (define-vop (,dname double-float-op) + (:translate ,op) + (:generator ,dcost + (inst ,dinst r x y)))))) + (frob + fadds +/single-float 2 faddd +/double-float 2) + (frob - fsubs -/single-float 2 fsubd -/double-float 2) + (frob * fmuls */single-float 4 fmuld */double-float 5) + (frob / fdivs //single-float 12 fdivd //double-float 19)) + +(macrolet ((frob (name inst translate double-p sc type) + `(define-vop (,name) + (:args (x :scs (,sc))) + (: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 y x) + ,@(when double-p + '((inst fmovs-odd y x))))))) + (frob abs/single-float fabss abs nil single-reg single-float) + (frob abs/double-float fabss abs t double-reg double-float) + (frob %negate/single-float fnegs %negate nil single-reg single-float) + (frob %negate/double-float fnegs %negate t double-reg double-float)) + + +;;;; Comparison: + +(define-vop (float-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:variant-vars format yep nope) + (:policy :fast-safe) + (:note "inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (note-this-location vop :internal-error) + (ecase format + (:single (inst fcmps x y)) + (:double (inst fcmpd x y))) + (inst fb (if not-p nope yep) target) + (inst nop))) + +(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 yep nope sname dname) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant :single ,yep ,nope)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant :double ,yep ,nope))))) + (frob < :l :ge </single-float </double-float) + (frob > :g :le >/single-float >/double-float) + (frob eql :eq :ne eql/single-float eql/double-float)) + + +;;;; Conversion: + +(macrolet ((frob (name translate inst to-sc to-type) + `(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 st x + (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes)) + temp) + (signed-stack + x)))) + (inst ldf y + (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (note-this-location vop :internal-error) + (inst ,inst y y)))))) + (frob %single-float/signed %single-float fitos single-reg single-float) + (frob %double-float/signed %double-float fitod double-reg double-float)) + +(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 y x))))) + (frob %single-float/double-float %single-float fdtos + double-reg double-float single-reg single-float) + (frob %double-float/single-float %double-float fstod + single-reg single-float double-reg double-float)) + +(macrolet ((frob (name from-sc from-type inst) + `(define-vop (,name) + (: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 %unary-truncate) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst ,inst temp x) + (sc-case y + (signed-stack + (inst stf temp (current-nfp-tn vop) + (* (tn-offset y) vm:word-bytes))) + (signed-reg + (inst stf temp (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld y (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)))))))) + (frob %unary-truncate/single-float single-reg single-float fstoi) + (frob %unary-truncate/double-float double-reg double-float fdtoi)) + + +(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 st bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ldf res (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (single-stack + (inst st bits (current-nfp-tn vop) + (* (tn-offset res) vm:word-bytes))))) + (signed-stack + (sc-case res + (single-reg + (inst ldf res (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes))) + (single-stack + (unless (location= bits res) + (inst ld temp (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes)) + (inst st temp (current-nfp-tn vop) + (* (tn-offset res) vm:word-bytes))))))))) + +(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 st hi-bits (current-nfp-tn vop) + (* (tn-offset stack-tn) vm:word-bytes)) + (inst st lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-tn)) vm:word-bytes))) + (when (sc-is res double-reg) + (inst lddf res (current-nfp-tn vop) + (* (tn-offset temp) vm:word-bytes))))) + +(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 stf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (single-stack + (inst ld bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw bits float vm:single-float-value-slot vm:other-pointer-type)))) + (signed-stack + (sc-case float + (single-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset bits) vm:word-bytes)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg) + :load-if (or (sc-is float descriptor-reg double-stack) + (not (sc-is hi-bits signed-stack))))) + (:temporary (:scs (signed-stack)) stack-temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case hi-bits + (signed-reg + (sc-case float + (double-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (double-stack + (inst ld hi-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw hi-bits float vm:double-float-value-slot + vm:other-pointer-type)))) + (signed-stack + (sc-case float + (double-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset hi-bits) vm:word-bytes)))))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg) + :load-if (or (sc-is float descriptor-reg double-stack) + (not (sc-is lo-bits unsigned-stack))))) + (:temporary (:scs (unsigned-stack)) stack-temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case lo-bits + (unsigned-reg + (sc-case float + (double-reg + (inst stf-odd float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst ld lo-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (double-stack + (inst ld lo-bits (current-nfp-tn vop) + (* (tn-offset float) vm:word-bytes))) + (descriptor-reg + (loadw lo-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type)))) + (unsigned-stack + (sc-case float + (double-reg + (inst stf-odd float (current-nfp-tn vop) + (* (tn-offset lo-bits) vm:word-bytes)))))))) + + +;;;; SAP accessors/setters + +(define-vop (sap-ref-single sap-ref) + (:translate sap-ref-single) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:variant :single nil)) + +(define-vop (sap-set-single sap-set) + (:translate %set-sap-ref-single) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate)) + (value :scs (single-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:variant :single)) + +(define-vop (sap-ref-double sap-ref) + (:translate sap-ref-double) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:variant :double nil)) + +(define-vop (sap-set-double sap-set) + (:translate %set-sap-ref-double) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg any-reg zero immediate)) + (value :scs (double-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:variant :double)) + + +;;;; 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) + (:generator 3 + (inst cfc1 res 31) + (inst nop))) + +(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) + (:generator 3 + (inst ctc1 res 31) + (move res new))) + +|# diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp new file mode 100644 index 000000000..ea62df0b7 --- /dev/null +++ b/compiler/sparc/insts.lisp @@ -0,0 +1,612 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.1 1990/11/30 17:04:46 wlott Exp $ +;;; +;;; Description of the SPARC architecture. +;;; +;;; Written by William Lott +;;; + +(in-package "SPARC") +(use-package "ASSEM") +(use-package "EXT") +(use-package "C") + + + +;;;; Formats: + +(define-format (format-1 32) + (op (byte 2 30) :default 1) + (disp (byte 30 0))) + + +(define-format (format-2-immed 32) + (op (byte 2 30) :default 0) + (rd (byte 5 25)) + (op2 (byte 3 22)) + (immed (byte 22 0))) + +(define-format (format-2-branch 32) + (op (byte 2 30) :default 0) + (a (byte 1 29)) + (cond (byte 4 25)) + (op2 (byte 3 22)) + (disp (byte 22 0))) + +(define-format (format-2-unimp 32) + (op (byte 2 30) :default 0) + (ignore (byte 5 25) :default 0) + (op2 (byte 3 22) :default 0) + (data (byte 22 0))) + + +(define-format (format-3-reg 32) + (op (byte 2 30)) + (rd (byte 5 25)) + (op3 (byte 6 19)) + (rs1 (byte 5 14)) + (i (byte 1 13) :default 0) + (asi (byte 8 5) :default 0) + (rs2 (byte 5 0))) + +(define-format (format-3-immed 32) + (op (byte 2 30)) + (rd (byte 5 25)) + (op3 (byte 6 19)) + (rs1 (byte 5 14)) + (i (byte 1 13) :default 1) + (immed (byte 13 0))) + +(define-format (format-3-fpop 32) + (op (byte 2 30)) + (rd (byte 5 25)) + (op3 (byte 6 19)) + (rs1 (byte 5 14)) + (opf (byte 9 5)) + (rs2 (byte 5 0))) + + + +;;;; Special argument types and fixups. + +(define-argument-type reg + :type '(satisfies (lambda (object) + (and (tn-p object) + (or (eq (sc-name (tn-sc object)) 'null) + (eq (sc-name (tn-sc object)) 'zero) + (eq (sb-name (sc-sb (tn-sc object))) + 'registers))))) + :function (lambda (tn) + (case (sc-name (tn-sc tn)) + (null null-offset) + (zero 0) + (t (tn-offset tn))))) + + +(define-argument-type fp-reg + :type '(satisfies (lambda (object) + (and (tn-p object) + (eq (sb-name (sc-sb (tn-sc object))) + 'float-registers)))) + :function tn-offset) + +(define-argument-type odd-fp-reg + :type '(satisfies (lambda (object) + (and (tn-p object) + (eq (sb-name (sc-sb (tn-sc object))) + 'float-registers)))) + :function (lambda (tn) (1+ (tn-offset tn)))) + + +(define-argument-type relative-label + :type 'label + :function (lambda (label) + (ash (- (label-position label) *current-position*) -2))) + + +(eval-when (compile eval load) + (defconstant branch-conditions + '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))) + +(define-argument-type branch-condition + :type '(member . #.branch-conditions) + :function (lambda (cond) (position cond branch-conditions))) + + +(eval-when (compile eval load) + (defconstant branch-fp-conditions + '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))) + + +(define-argument-type branch-fp-condition + :type '(member . #.branch-fp-conditions) + :function (lambda (fp-cond) (position fp-cond branch-fp-conditions))) + + +(define-fixup-type :call) +(define-fixup-type :sethi) +(define-fixup-type :add) + + + +;;;; Instructions. + + + +(eval-when (compile eval) + +(defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store) + `(define-instruction (,name) + (format-3-reg (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :argument reg) + (rs2 :argument reg)) + ,(if (not load-store) + `(format-3-reg (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :same-as rd) + (rs2 :argument reg)) + `(format-3-immed (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :argument reg) + (immed :constant 0))) + (format-3-immed (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :argument reg) + (immed :argument (signed-byte 13))) + (format-3-immed (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :same-as rd) + (immed :argument (signed-byte 13))) + ,@(when (or load-store fixup) + `((format-3-immed (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :argument reg) + (immed :argument add-fixup)) + (format-3-immed (op :constant ,op) + (rd :argument ,dest-kind) + (op3 :constant ,op3) + (rs1 :same-as rd) + (immed :argument add-fixup)))))) + +(setf (macro-function 'define-f3-inst) + (compile nil (function-lambda-expression + (macro-function 'define-f3-inst)))) + +) ; eval-when + +(define-f3-inst ldsb #b11 #b001001 :load-store t) +(define-f3-inst ldsh #b11 #b001010 :load-store t) +(define-f3-inst ldub #b11 #b000001 :load-store t) +(define-f3-inst lduh #b11 #b000010 :load-store t) +(define-f3-inst ld #b11 #b000000 :load-store t) +(define-f3-inst ldd #b11 #b000011 :load-store t) + +(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store t) +(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store t) +(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store t) + +(define-f3-inst stb #b11 #b000101 :load-store t) +(define-f3-inst sth #b11 #b000110 :load-store t) +(define-f3-inst st #b11 #b000100 :load-store t) +(define-f3-inst std #b11 #b000111 :load-store t) + +(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store t) +(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store t) +(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store t) + +(define-f3-inst ldstub #b11 #b001101 :load-store t) +(define-f3-inst swap #b11 #b001111 :load-store t) + + + +(define-f3-inst add #b10 #b000000 :fixup t) +(define-f3-inst addcc #b10 #b010000) +(define-f3-inst addx #b10 #b001000) +(define-f3-inst addxcc #b10 #b011000) + +(define-f3-inst taddcc #b10 #b100000) +(define-f3-inst taddcctv #b10 #b100010) + +(define-f3-inst sub #b10 #b000100) +(define-f3-inst subcc #b10 #b010100) +(define-f3-inst subx #b10 #b001100) +(define-f3-inst subxcc #b10 #b011100) + +(define-f3-inst tsubcc #b10 #b100001) +(define-f3-inst tsubcctv #b10 #b100011) + +(define-f3-inst mulscc #b10 #b100100) + +(define-f3-inst and #b10 #b000001) +(define-f3-inst andcc #b10 #b010001) +(define-f3-inst andn #b10 #b000101) +(define-f3-inst andncc #b10 #b010101) +(define-f3-inst or #b10 #b000010) +(define-f3-inst orcc #b10 #b010010) +(define-f3-inst orn #b10 #b000110) +(define-f3-inst orncc #b10 #b010110) +(define-f3-inst xor #b10 #b000011) +(define-f3-inst xorcc #b10 #b010011) +(define-f3-inst xnor #b10 #b000111) +(define-f3-inst xnorcc #b10 #b010111) + +(define-f3-inst sll #b10 #b100101) +(define-f3-inst srl #b10 #b100110) +(define-f3-inst sra #b10 #b100111) + +(define-instruction (sethi) + (format-2-immed (rd :argument reg) + (op2 :constant #b100) + (immed :argument (or (unsigned-byte 22) (signed-byte 22)))) + (format-2-immed (rd :argument reg) + (op2 :constant #b100) + (immed :argument sethi-fixup))) + +(define-f3-inst save #b10 #b111100) +(define-f3-inst restore #b10 #b111101) + +(define-instruction (b) + (format-2-branch (op :constant #b00) + (a :constant 0) + (cond :argument branch-condition) + (op2 :constant #b010) + (disp :argument relative-label)) + (format-2-branch (op :constant #b00) + (a :constant 0) + (cond :constant #b1000) + (op2 :constant #b010) + (disp :argument relative-label))) + +(define-instruction (ba) + (format-2-branch (op :constant #b00) + (a :constant 1) + (cond :argument branch-condition) + (op2 :constant #b010) + (disp :argument relative-label)) + (format-2-branch (op :constant #b00) + (a :constant 1) + (cond :constant #b1000) + (op2 :constant #b010) + (disp :argument relative-label))) + +(define-instruction (fb) + (format-2-branch (op :constant #b00) + (a :constant 0) + (cond :argument branch-fp-condition) + (op2 :constant #b110) + (disp :argument relative-label))) + + +(define-instruction (jal) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b111000) + (rs1 :argument reg) + (rs2 :argument reg)) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b111000) + (rs1 :constant 0) + (rs2 :argument reg)) + (format-3-immed (op :constant #b10) + (rd :argument reg) + (op3 :constant #b111000) + (rs1 :argument reg) + (immed :argument (signed-byte 13)))) + +(define-instruction (j) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b111000) + (rs1 :argument reg) + (rs2 :argument reg)) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b111000) + (rs1 :argument reg) + (rs2 :constant 0)) + (format-3-immed (op :constant #b10) + (rd :constant 0) + (op3 :constant #b111000) + (rs1 :argument reg) + (immed :argument (signed-byte 13)))) + +(define-instruction (rdy) + (format-3-immed (op :constant #b10) + (rd :argument reg) + (op3 :constant #b101000) + (rs1 :constant 0) + (immed :constant 0))) + +(define-instruction (wry) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b110000) + (rs1 :argument reg) + (rs2 :argument reg)) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b110000) + (rs1 :argument reg) + (rs2 :constant 0)) + (format-3-immed (op :constant #b10) + (rd :constant 0) + (op3 :constant #b110000) + (rs1 :argument reg) + (immed :argument (signed-byte 13)))) + +(define-instruction (unimp) + (format-2-unimp (data :argument (unsigned-byte 22)))) + + +(eval-when (compile eval) + +(defmacro define-unary-fp-inst (name opf &optional odd) + (let ((kind (if odd 'odd-fp-reg 'fp-reg))) + `(define-instruction (,name) + (format-3-fpop (op :constant #b10) + (rd :argument ,kind) + (op3 :constant #b110100) + (rs1 :argument ,kind) + (opf :constant ,opf) + (rs2 :argument ,kind)) + (format-3-fpop (op :constant #b10) + (rd :argument ,kind) + (op3 :constant #b110100) + (rs1 :same-as rd) + (opf :constant ,opf) + (rs2 :argument ,kind))))) + +(defmacro define-binary-fp-inst (name opf &optional (op3 #b110100)) + `(define-instruction (,name) + (format-3-fpop (op :constant #b10) + (rd :argument fp-reg) + (op3 :constant ,op3) + (rs1 :argument fp-reg) + (opf :constant ,opf) + (rs2 :argument fp-reg)) + (format-3-fpop (op :constant #b10) + (rd :argument fp-reg) + (op3 :constant ,op3) + (rs1 :same-as rd) + (opf :constant ,opf) + (rs2 :argument fp-reg)))) + +); eval-when (compile eval) + +(define-unary-fp-inst fitos #b011000100) +(define-unary-fp-inst fitod #b011001000) +(define-unary-fp-inst fitox #b011001100) + +(define-unary-fp-inst fstoir #b011000001) +(define-unary-fp-inst fdtoir #b011000010) +(define-unary-fp-inst fxtoir #b011000011) + +(define-unary-fp-inst fstoi #b011010001) +(define-unary-fp-inst fdtoi #b011010010) +(define-unary-fp-inst fxtoi #b011010011) + +(define-unary-fp-inst fstod #b011001001) +(define-unary-fp-inst fstox #b011001101) +(define-unary-fp-inst fdtos #b011000110) +(define-unary-fp-inst fdtox #b011001110) +(define-unary-fp-inst fxtos #b011000111) +(define-unary-fp-inst fxtod #b011001011) + +(define-unary-fp-inst fmovs #b000000001) +(define-unary-fp-inst fmovs-odd #b000000001 t) +(define-unary-fp-inst fnegs #b000000101) +(define-unary-fp-inst fabss #b000001001) + +(define-unary-fp-inst fsqrts #b000101001) +(define-unary-fp-inst fsqrtd #b000101010) +(define-unary-fp-inst fsqrtx #b000101011) + + +(define-binary-fp-inst fadds #b001000001) +(define-binary-fp-inst faddd #b001000010) +(define-binary-fp-inst faddx #b001000011) +(define-binary-fp-inst fsubs #b001000101) +(define-binary-fp-inst fsubd #b001000110) +(define-binary-fp-inst fsubx #b001000111) + +(define-binary-fp-inst fmuls #b001001001) +(define-binary-fp-inst fmuld #b001001010) +(define-binary-fp-inst fmulx #b001001011) +(define-binary-fp-inst fdivs #b001001101) +(define-binary-fp-inst fdivd #b001001110) +(define-binary-fp-inst fdivx #b001001111) + +(define-binary-fp-inst fcmps #b001010001 #b110101) +(define-binary-fp-inst fcmpd #b001010010 #b110101) +(define-binary-fp-inst fcmpx #b001010011 #b110101) +(define-binary-fp-inst fcmpes #b001010101 #b110101) +(define-binary-fp-inst fcmped #b001010110 #b110101) +(define-binary-fp-inst fcmpex #b001010111 #b110101) + + + + +;;;; Pseudo-instructions, etc. + +(define-pseudo-instruction li 64 (reg value) + (etypecase value + ((signed-byte 13) + (inst add reg zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (let ((hi (ldb (byte 22 10) value)) + (lo (ldb (byte 10 0) value))) + (inst sethi reg hi) + (unless (zerop lo) + (inst add reg lo)))) + (fixup + (inst sethi reg value) + (inst add reg value)))) + +(define-instruction (nop) + (format-2-immed (rd :constant 0) + (op2 :constant #b100) + (immed :constant 0))) + +(define-instruction (cmp) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b010100) + (rs1 :argument reg) + (rs2 :argument reg)) + (format-3-reg (op :constant #b10) + (rd :constant 0) + (op3 :constant #b010100) + (rs1 :argument reg) + (rs2 :constant 0)) + (format-3-immed (op :constant #b10) + (rd :constant 0) + (op3 :constant #b010100) + (rs1 :argument reg) + (immed :argument (signed-byte 13)))) + +(define-instruction (not) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000111) + (rs1 :argument reg) + (rs2 :constant 0)) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000111) + (rs1 :same-as rd) + (rs2 :constant 0))) + +(define-instruction (neg) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000100) + (rs1 :constant 0) + (rs2 :argument reg)) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000100) + (rs1 :constant 0) + (rs2 :same-as rd))) + +(define-instruction (move) + (format-3-reg (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000010) + (rs1 :constant 0) + (rs2 :argument reg))) + + +;;; Instructions for dumping data and header objects. + +(define-format (word-format 32) + (data (byte 32 0))) +(define-instruction (word) + (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32))))) + +(define-format (short-format 16) + (data (byte 16 0))) +(define-instruction (short) + (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) + +(define-format (byte-format 8) + (data (byte 8 0))) +(define-instruction (byte) + (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) + + +(define-format (header-object 32) + (type (byte 8 0)) + (data (byte 24 8) + :default 0 + :function (lambda (ignore) + (declare (ignore ignore)) + (ash (+ *current-position* (component-header-length)) + (- vm:word-shift))))) + +(define-instruction (function-header-word) + (header-object (type :constant vm:function-header-type))) + +(define-instruction (lra-header-word) + (header-object (type :constant vm:return-pc-header-type))) + + + +;;;; Instructions for converting between code objects, functions, and lras + +(eval-when (compile eval) + +(defmacro define-compute-instruction (name calculation) + (let ((add (symbolicate name "-ADD")) + (sethi (symbolicate name "-SETHI")) + (or (symbolicate name "-OR"))) + `(progn + (define-instruction (,add) + (format-3-immed + (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000000) + (rs1 :argument reg) + (immed :argument label + :function (lambda (label) + (let ((result ,calculation)) + (assert (typep result '(signed-byte 13))) + result))))) + (define-instruction (,sethi) + (format-2-immed (rd :argument reg) + (op2 :constant #b100) + (immed :argument label + :function (lambda (label) + (ash ,calculation -10))))) + (define-instruction (,or) + (format-3-immed (op :constant #b10) + (rd :argument reg) + (op3 :constant #b000010) + (rs1 :same-as rd) + (immed :argument label + :function (lambda (label) + (logand ,calculation + (1- (ash 1 10))))))) + (define-pseudo-instruction ,name 96 (dst src label temp) + (cond ((typep ,calculation '(signed-byte 13)) + (inst ,add dst src label)) + (t + (inst ,sethi temp label) + (inst ,or temp label) + (inst add dst src temp))))))) + +); eval-when (compile eval) + + +;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag +(define-compute-instruction compute-code-from-fn + (- vm:other-pointer-type + vm:function-pointer-type + (label-position label) + (component-header-length))) + +;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag +(define-compute-instruction compute-code-from-lra + (- (+ (label-position label) + (component-header-length)))) + +;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag +(define-compute-instruction compute-lra-from-code + (+ (label-position label) + (component-header-length))) + diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp new file mode 100644 index 000000000..fc03e12c7 --- /dev/null +++ b/compiler/sparc/macros.lisp @@ -0,0 +1,458 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.1 1990/11/30 17:04:49 wlott Exp $ +;;; +;;; This file contains various useful macros for generating SPARC code. +;;; +;;; Written by William Lott. +;;; + +(in-package "SPARC") + + +;;; Instruction-like macros. + +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst move ,n-dst ,n-src)))) + +(macrolet + ((frob (op inst shift) + `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) + `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) + (frob loadw ld word-shift) + (frob storew st word-shift)) + +(defmacro load-symbol (reg symbol) + `(inst add ,reg null-tn (static-symbol-offset ,symbol))) + +(macrolet + ((frob (slot) + (let ((loader (intern (concatenate 'simple-string + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst ld ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))) + (defmacro ,storer (reg symbol) + `(inst st ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-type)))))))) + (frob value) + (frob function)) + +(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)) + (ecase (backend-byte-order *target-backend*) + (:little-endian + `(inst ldub ,n-target ,n-source ,n-offset)) + (:big-endian + `(inst ldub ,n-target ,n-source (+ ,n-offset 3)))))) + +;;; Macros to handle the fact that we cannot use the machine native call and +;;; return instructions. + +(defmacro lisp-jump (function) + "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." + `(progn + (inst j ,function (- (ash function-header-code-offset + word-shift) + function-pointer-type)) + (move code-tn ,function))) + +(defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) + "Return to RETURN-PC." + `(progn + (inst j ,return-pc + (- (* (1+ ,offset) word-bytes) other-pointer-type)) + ,(if frob-code + `(move code-tn ,return-pc) + '(inst nop)))) + +(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-reg ,n-stack)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + + +;;;; 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, 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 (,temp-tn) + (inst add ,result-tn alloc-tn other-pointer-type) + (inst add alloc-tn alloc-tn (pad-data-block ,size)) + (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 other-pointer-type) + ,@body)) + + + +;;;; Type testing noise. + +;;; GEN-RANGE-TEST -- internal +;;; +;;; Generate code that branches to TARGET iff REG contains one of VALUES. +;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same +;;; as falling out the bottom. +;;; +(defun gen-range-test (reg target not-target not-p min seperation max values) + (let ((tests nil) + (start nil) + (end nil) + (insts nil)) + (multiple-value-bind (equal less-or-equal greater-or-equal label) + (if not-p + (values :ne :gt :lt not-target) + (values :eq :le :ge target)) + (flet ((emit-test () + (if (= start end) + (push start tests) + (push (cons start end) tests)))) + (dolist (value values) + (cond ((< value min) + (error "~S is less than the specified minimum of ~S" + value min)) + ((> value max) + (error "~S is greater than the specified maximum of ~S" + value max)) + ((not (zerop (rem (- value min) seperation))) + (error "~S isn't an even multiple of ~S from ~S" + value seperation min)) + ((null start) + (setf start value)) + ((> value (+ end seperation)) + (emit-test) + (setf start value))) + (setf end value)) + (emit-test)) + (macrolet ((inst (name &rest args) + `(push (list 'inst ',name ,@args) insts))) + (do ((remaining (nreverse tests) (cdr remaining))) + ((null remaining)) + (let ((test (car remaining)) + (last (null (cdr remaining)))) + (if (atom test) + (progn + (inst cmp reg test) + (if last + (inst b equal target) + (inst b :eq label))) + (let ((start (car test)) + (end (cdr test))) + (cond ((and (= start min) (= end max)) + (warn "The values ~S cover the entire range from ~ + ~S to ~S [step ~S]." + values min max seperation) + (push `(unless ,not-p (inst b ,target)) insts)) + ((= start min) + (inst cmp reg end) + (if last + (inst b less-or-equal target) + (inst b :le label))) + ((= end max) + (inst cmp reg start) + (if last + (inst b greater-or-equal target) + (inst b :ge label))) + (t + (inst cmp reg start) + (inst b :lt (if not-p target not-target)) + (inst cmp reg end) + (if last + (inst b less-or-equal target) + (inst b :le label)))))))))) + (nreverse insts))) + +(defun gen-other-immediate-test (reg target not-target not-p values) + (gen-range-test reg target not-target not-p + (+ other-immediate-0-type lowtag-limit) + (- other-immediate-1-type other-immediate-0-type) + (ash 1 type-bits) + values)) + + +(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs) + (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) + (member odd-fixnum-type lowtags :test #'eql))) + (lowtags (sort (if fixnump + (delete even-fixnum-type + (remove odd-fixnum-type lowtags + :test #'eql) + :test #'eql) + (copy-list lowtags)) + #'<)) + (hdrs (sort (copy-list hdrs) #'<)) + (immed (sort (copy-list immed) #'<))) + (append + (when immed + `((inst and ,temp ,reg type-mask) + ,@(if (or fixnump lowtags hdrs) + (let ((fall-through (gensym))) + `((let (,fall-through (gen-label)) + ,@(gen-other-immediate-test + temp (if not-p not-target target) + fall-through nil immed) + (emit-label ,fall-through)))) + (gen-other-immediate-test temp target not-target not-p immed)))) + (when fixnump + `((inst andcc zero-tn ,reg 3) + ,(if (or lowtags hdrs) + `(inst b :eq ,(if not-p not-target target)) + `(inst b ,(if not-p :ne :eq) ,target)))) + (when (or lowtags hdrs) + `((inst and ,temp ,reg lowtag-mask))) + (when lowtags + (if hdrs + (let ((fall-through (gensym))) + `((let ((,fall-through (gen-label))) + ,@(gen-range-test temp (if not-p not-target target) + fall-through nil + 0 1 (1- lowtag-limit) lowtags) + (emit-label ,fall-through)))) + (gen-range-test temp target not-target not-p 0 1 + (1- lowtag-limit) lowtags))) + (when hdrs + `((inst cmp ,temp other-pointer-type) + (inst b :ne ,(if not-p target not-target)) + (inst nop) + (load-type ,temp ,reg (- other-pointer-type)) + ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) + +(defconstant immediate-types + (list base-character-type unbound-marker-type)) + +(defmacro test-type (register temp target not-p &rest type-codes) + (let* ((type-codes (mapcar #'eval type-codes)) + (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))) + (unless type-codes + (error "Must supply at least on type for test-type.")) + (when (and headers (member other-pointer-type lowtags)) + (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers) + (setf headers nil)) + (when (and immediates + (or (member other-immediate-0-type lowtags) + (member other-immediate-1-type lowtags))) + (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates) + (setf immediates nil)) + (let ((n-reg (gensym)) + (n-temp (gensym)) + (n-target (gensym)) + (not-target (gensym))) + `(let ((,n-reg ,register) + (,n-temp ,temp) + (,n-target ,target) + (,not-target (gen-label))) + (declare (ignorable ,n-temp)) + ,@(if (constantp not-p) + (test-type-aux n-reg n-temp n-target not-target + (eval not-p) lowtags immediates headers) + `((cond (,not-p + ,@(test-type-aux n-reg n-temp n-target not-target t + lowtags immediates headers)) + (t + ,@(test-type-aux n-reg n-temp n-target not-target nil + lowtags immediates headers))))) + (inst nop) + (emit-label ,not-target))))) + + +;;;; 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 unimp ,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 b ,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 ((ndescr-temp) &rest forms) + (let ((label (gensym "LABEL-"))) + `(let ((,label (gen-label))) + (store-symbol-value zero-tn lisp::*pseudo-atomic-interrupted*) + ;; Note: we just use cfp as some not-zero value. + (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*) + ,@forms + (store-symbol-value zero-tn lisp::*pseudo-atomic-atomic*) + (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*) + (inst cmp ,ndescr-temp) + (inst b :eq ,label) + (inst nop) + (inst unimp pending-interrupt-trap) + (emit-label ,label)))) + + + + +(defmacro pad-data-block (words) + `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask)) + + +(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) + &rest identifiers) + (let ((results nil) + (index 0) + (start (eval start)) + (step (eval step))) + (dolist (id identifiers) + (when id + (multiple-value-bind + (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + (push `(defconstant ,(intern (concatenate 'simple-string + (string prefix) + (string root) + (string suffix))) + ,(+ start (* step index)) + ,@docs) + results))) + (incf index)) + `(eval-when (compile load eval) + ,@(nreverse results)))) + diff --git a/compiler/sparc/memory.lisp b/compiler/sparc/memory.lisp new file mode 100644 index 000000000..fa90d7bab --- /dev/null +++ b/compiler/sparc/memory.lisp @@ -0,0 +1,160 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/memory.lisp,v 1.1 1990/11/30 17:04:52 wlott Exp $ +;;; +;;; This file contains the SPARC definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + +;;; 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. Cell-Setf is similar to +;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function +;;; takes its arguments as if it were a setf function (new value first, as +;;; apposed to a setf macro, which takes the new value last). +;;; +(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))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) +;;; +(define-vop (cell-setf) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg) + :target result)) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) +;;; +(define-vop (cell-setf-function) + (:args (value :scs (descriptor-reg any-reg) + :target result) + (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) + +;;; Define-Cell-Accessors -- Interface +;;; +;;; Define accessor VOPs for some cells in an object. If the operation name +;;; is NIL, then that operation isn't defined. If the translate function is +;;; null, then we don't define a translation. +;;; +(defmacro define-cell-accessors (offset lowtag + ref-op ref-trans set-op set-trans) + `(progn + ,@(when ref-op + `((define-vop (,ref-op cell-ref) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + ,@(when set-op + `((define-vop (,set-op cell-setf) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans)))))))) + + +;;; 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))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) + + + +;;;; Indexed references: + +;;; Define-Indexer -- Internal +;;; +;;; Define some VOPs for indexed memory reference. +;;; +(defmacro define-indexer (name write-p op shift) + `(define-vop (,name) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg zero immediate)) + ,@(when write-p + '((value :scs (any-reg descriptor-reg) :target result)))) + (:arg-types * tagged-num ,@(when write-p '(*))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:results (,(if write-p 'result 'value) + :scs (any-reg descriptor-reg))) + (:result-types *) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 5 + (sc-case index + ((immediate zero) + (let ((offset (- (+ (if (sc-is index zero) + 0 + (ash (tn-value index) + (- vm:word-shift ,shift))) + (ash offset vm:word-shift)) + lowtag))) + (etypecase offset + ((signed-byte 13) + (inst ,op value object offset)) + ((or (unsigned-byte 32) (signed-byte 32)) + (inst li temp offset) + (inst ,op value object temp))))) + (t + ,@(unless (zerop shift) + `((inst srl temp index ,shift))) + (inst add temp ,(if (zerop shift) 'index 'temp) + (- (ash offset vm:word-shift) lowtag)) + (inst ,op value object temp))) + ,@(when write-p + '((move result value)))))) + +(define-indexer word-index-ref nil ld 0) +(define-indexer word-index-set t st 0) +(define-indexer halfword-index-ref nil lduh 1) +(define-indexer signed-halfword-index-ref nil ldsh 1) +(define-indexer halfword-index-set t sth 1) +(define-indexer byte-index-ref nil ldub 2) +(define-indexer signed-byte-index-ref nil ldsb 2) +(define-indexer byte-index-set t stb 2) + diff --git a/compiler/sparc/move.lisp b/compiler/sparc/move.lisp new file mode 100644 index 000000000..d4bdbaa29 --- /dev/null +++ b/compiler/sparc/move.lisp @@ -0,0 +1,278 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/move.lisp,v 1.1 1990/11/30 17:04:53 wlott Exp $ +;;; +;;; This file contains the SPARC VM definition of operand loading/saving and +;;; the Move VOP. +;;; +;;; Written by Rob MacLachlan. +;;; SPARC conversion by William Lott. +;;; +(in-package "SPARC") + + +(define-move-function (load-immediate 1) (vop x y) + ((null immediate zero) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (inst li y (fixnum val))) + (null + (move y null-tn)) + (symbol + (load-symbol y val)) + (character + (inst li y (logior (ash (char-code val) type-bits) + base-character-type)))))) + +(define-move-function (load-number 1) (vop x y) + ((immediate zero) + (signed-reg unsigned-reg)) + (inst li y (tn-value x))) + +(define-move-function (load-base-character 1) (vop x y) + ((immediate) (base-character-reg)) + (inst li y (char-code (tn-value x)))) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst li y (sap-int (tn-value x)))) + +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-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-character-stack) (base-character-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (let ((nfp (current-nfp-tn vop))) + (loadw y nfp (tn-offset x)))) + +(define-move-function (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack)) + (store-stack-tn y x)) + +(define-move-function (store-number-stack 5) (vop x y) + ((base-character-reg) (base-character-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (let ((nfp (current-nfp-tn vop))) + (storew 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) + :load-if (not (location= x y)))) + (:effects) + (:affected) + (:generator 0 + (move y x))) + +(define-move-vop move :move + (any-reg descriptor-reg) + (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 zero null)) + (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 y x)) + (control-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) + (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: + +;;; Move a tagged number to an untagged representation. +;;; +(define-vop (move-to-signed/unsigned) + (:args (x :scs (any-reg descriptor-reg constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 4 + (sc-case x + (any-reg + (inst sra y x 2)) + (constant + (inst li y (tn-value x))) + (descriptor-reg + (let ((done (gen-label))) + (inst andcc temp x 3) + (inst b :eq done) + (sc-case y + (signed-reg + (inst sra y x 2)) + (unsigned-reg + (inst srl y x 2))) + + (loadw y x bignum-digits-offset other-pointer-type) + + (emit-label done)))))) + +;;; +(define-move-vop move-to-signed/unsigned :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + + +;;; Move an untagged number to a tagged representation. +;;; +(define-vop (move-from-signed/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) + (:generator 20 + (sc-case y + (any-reg + ;; The results must be a fixnum, so we can just do the shift. + (inst sll y arg 2)) + (descriptor-reg + ;; The results might be a bignum, so we have to make sure. + (move x arg) + (sc-case arg + (signed-reg + (let ((fixnum (gen-label)) + (done (gen-label))) + (inst sra temp x 29) + (inst cmp temp) + (inst b :eq fixnum) + (inst orncc temp zero-tn temp) + (inst b :eq done) + (inst sll y x 2) + + (with-fixed-allocation + (y temp bignum-type (1+ bignum-digits-offset)) + (storew x y bignum-digits-offset other-pointer-type)) + (inst b done) + (inst nop) + + (emit-label fixnum) + (inst sll y x 2) + (emit-label done))) + (unsigned-reg + (let ((done (gen-label)) + (one-word (gen-label))) + (inst sra temp x 29) + (inst cmp temp) + (inst b :eq done) + (inst sll y x 2) + + (pseudo-atomic (temp) + (inst add y alloc-tn other-pointer-type) + (inst add alloc-tn + (pad-data-block (1+ bignum-digits-offset))) + (inst cmp x) + (inst b :ge one-word) + (inst li temp (logior (ash 1 type-bits) bignum-type)) + (inst add alloc-tn + (- (pad-data-block (+ bignum-digits-offset 2)) + (pad-data-block (+ bignum-digits-offset 1)))) + (inst li temp (logior (ash 2 type-bits) bignum-type)) + (emit-label one-word) + (storew temp y 0 other-pointer-type) + (storew x y bignum-digits-offset other-pointer-type)) + (emit-label done)))))))) + +;;; +(define-move-vop move-from-signed/unsigned :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (signed/unsigned-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) + (:generator 1 + (move y x))) +;;; +(define-move-vop signed/unsigned-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-signed/unsigned-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-signed/unsigned-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/sparc/nlx.lisp b/compiler/sparc/nlx.lisp new file mode 100644 index 000000000..7602c99c5 --- /dev/null +++ b/compiler/sparc/nlx.lisp @@ -0,0 +1,306 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/nlx.lisp,v 1.1 1990/11/30 17:04:55 wlott Exp $ +;;; +;;; This file contains the definitions of VOPs used for non-local exit +;;; (throw, lexical exit, etc.) +;;; +;;; Written by Rob MacLachlan +;;; +(in-package "SPARC") + +;;; 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 () + (make-n-tns 5 *any-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (special :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*) + (move special bsp-tn) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move nfp cur-nfp))) + (move nsp nsp-tn) + (load-symbol-value eval lisp::*eval-stack-top*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (special :scs (descriptor-reg)) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg)) + (eval :scs (descriptor-reg))) + (:temporary (:scs (descriptor-reg)) symbol value) + (:vop-var vop) + (:generator 10 + (let ((done (gen-label)) + (skip (gen-label)) + (loop (gen-label))) + + (store-symbol-value catch lisp::*current-catch-block*) + (store-symbol-value eval lisp::*eval-stack-top*) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (move cur-nfp nfp))) + (move nsp-tn nsp) + + (inst cmp special bsp-tn) + (inst b :eq done) + (inst nop) + + (emit-label loop) + (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) + (inst cmp symbol) + (inst b :eq skip) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (storew value symbol vm:symbol-value-slot vm:other-pointer-type) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + (emit-label skip) + (inst add bsp-tn bsp-tn (* -2 vm:word-bytes)) + (inst cmp bsp-tn special) + (inst b :ne loop) + (inst nop) + + (emit-label done)))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res csp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (move res bsp-tn))) + + + +;;;; 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 add block cfp-tn (* (tn-offset tn) vm:word-bytes)) + (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 add result cfp-tn (* (tn-offset tn) vm:word-bytes)) + (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 block result))) + + +;;; 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 add new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes)) + (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) + (:info label nvals) + (:save-p :force-to-stack) + (:generator 30 + (emit-return-pc label) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst cmp count) + (inst b :eq no-values) + (move (tn-ref-tn values) null-tn) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (inst subcc count (fixnum 1)) + (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 b :l default-lab) + (inst subcc count (fixnum 1)) + (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 tn null-tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst b defaulting-done) + (inst nop)))))) + (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) + (:generator 30 + (emit-return-pc label) + (let ((loop (gen-label)) + (done (gen-label))) + + ;; Copy args. + (load-stack-tn dst top) + (move src start) + (move num count) + + ;; Establish results. + (sc-case new-start + (any-reg (move new-start dst)) + (control-stack (store-stack-tn new-start dst))) + (inst cmp num) + (inst b :eq done) + (sc-case new-count + (any-reg (inst move new-count num)) + (control-stack (store-stack-tn new-count num))) + + ;; Copy stuff on stack. + (emit-label loop) + (loadw temp src) + (inst add src src vm:word-bytes) + (storew temp dst) + (inst subcc num (fixnum 1)) + (inst b :ge loop) + (inst add dst dst vm:word-bytes) + + (emit-label done) + (inst move csp-tn dst)))) + + +;;; 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) + (:generator 0 + (emit-return-pc label))) + diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp new file mode 100644 index 000000000..787d51886 --- /dev/null +++ b/compiler/sparc/parms.lisp @@ -0,0 +1,176 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.1 1990/11/30 17:04:57 wlott Exp $ +;;; +;;; This file contains some parameterizations of various VM +;;; attributes for the SPARC. This file is separate from other stuff so +;;; that it can be compiled and loaded earlier. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted to MIPS by William Lott. +;;; + +(in-package "SPARC") +(use-package "C") + +(export '(word-bits byte-bits word-shift word-bytes)) + +(export '(float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit single-float-trapping-nan-bit + double-float-trapping-nan-bit *fixup-values*)) + +(export '(check-cons check-symbol check-fixnum check-unsigned-byte-32 + check-signed-byte-32 check-function check-function-or-symbol)) + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +(setf (backend-name *target-backend*) "SPARC") +(setf (backend-version *target-backend*) "SPARCstation/Mach 0.0") +(setf (backend-fasl-file-type *target-backend*) "sparcf") +(setf (backend-fasl-file-implementation *target-backend*) + sparc-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) 1) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :big-endian) + +); eval-when + + +;;;; Machine Architecture parameters: + +(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)) + +); 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 #x01000000) +(defparameter target-static-space-start #x04000000) +(defparameter target-dynamic-space-start #x06000000) + + + +;;;; Other random constants. + +(export '(halt-trap pending-interrupt-trap error-trap cerror-trap)) + +(defconstant halt-trap 8) +(defconstant pending-interrupt-trap 9) +(defconstant error-trap 10) +(defconstant cerror-trap 11) + + +;;;; Static symbols. + +(export '(static-symbols exported-static-symbols)) + +;;; 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 exported static symbols are a subset of the static symbols that get +;;; exported to the C header file. +;;; +(defparameter static-symbols + '(t + + ;; The C startup code must fill these in. + lisp::lisp-environment-list + lisp::lisp-command-line-list + + ;; Functions that the C code needs to call + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + + ;; 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* + lisp::*pseudo-atomic-atomic* + lisp::*pseudo-atomic-interrupted* + mach::*interrupts-enabled* + mach::*interrupt-pending* + + ;; Static functions. + length + two-arg-+ two-arg-- two-arg-* 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 + )) + +(defparameter exported-static-symbols + (subseq static-symbols 0 (position 'length static-symbols))) + + + +;;;; Assembler parameters: + +;;; The number of bits per element in the assemblers code vector. +;;; +(defparameter *assembly-unit-length* 8) diff --git a/compiler/sparc/pred.lisp b/compiler/sparc/pred.lisp new file mode 100644 index 000000000..3dd37ef3f --- /dev/null +++ b/compiler/sparc/pred.lisp @@ -0,0 +1,46 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/pred.lisp,v 1.1 1990/11/30 17:04:59 wlott Exp $ +;;; +;;; This file contains the VM definition of predicate VOPs for the SPARC. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted by William Lott. +;;; + +(in-package "SPARC") + + +;;;; 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 b dest) + (inst nop))) + + +;;;; Conditional VOPs: + +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg zero null)) + (y :scs (any-reg descriptor-reg zero null))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (inst cmp x y) + (inst b (if not-p :ne :eq) target) + (inst nop))) diff --git a/compiler/sparc/print.lisp b/compiler/sparc/print.lisp new file mode 100644 index 000000000..66361f358 --- /dev/null +++ b/compiler/sparc/print.lisp @@ -0,0 +1,41 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/print.lisp,v 1.1 1990/11/30 17:05:00 wlott Exp $ +;;; +;;; This file contains VOPs for things like printing during %initial-function +;;; before the world is initialized. +;;; +;;; Written by William Lott. + +(in-package "SPARC") + + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg) :target nl0)) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) + (:temporary (:sc any-reg :offset cfunc-offset) cfunc) + (:temporary (:sc interior-reg :offset lip-offset) lip) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + (:vop-var vop) + (:generator 100 + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (move nl0 object) + (inst li cfunc (make-fixup "_debug_print" :foreign)) + (inst li temp (make-fixup "_call_into_c" :foreign)) + (inst jal lip temp) + (inst nop) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + (move result nl0)))) diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp new file mode 100644 index 000000000..824645ca4 --- /dev/null +++ b/compiler/sparc/sap.lisp @@ -0,0 +1,365 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.1 1990/11/30 17:05:01 wlott Exp $ +;;; +;;; This file contains the SPARC VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +;;;; 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))) + (:generator 1 + (loadw 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 (sap :scs (sap-reg) :to :save)) + (:temporary (:scs (non-descriptor-reg)) ndescr) + (:results (res :scs (descriptor-reg))) + (:generator 1 + (with-fixed-allocation (res ndescr sap-type sap-size) + (storew sap res 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 y x))) +;;; +(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 y x)) + (sap-stack + (storew 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 int sap))) + +(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 sap int))) + + + +;;;; 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 add res ptr offset)) + (immediate + (inst add res ptr (tn-value offset)))))) + +(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 sub res ptr1 ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(define-vop (sap-ref) + (:policy :fast-safe) + (:variant-vars size signed) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate))) + (:arg-types system-area-pointer positive-fixnum) + (:results (result)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (let* ((shift (ecase size + (:byte 0) + (:short 1) + ((:long :single :double) 2))) + (offset + (sc-case offset + (zero offset) + (immediate + (let ((offset (ash (tn-value offset) shift))) + (cond ((typep offset '(signed-byte 13)) + offset) + (t + (inst li temp offset) + temp)))) + ((any-reg signed-reg) + (when (sc-is offset any-reg) + (decf shift 2)) + (cond ((plusp shift) + (inst sll temp offset shift) + temp) + ((minusp shift) + (inst sra temp offset (- shift)) + temp) + (t + offset)))))) + (ecase size + (:byte + (if signed + (inst ldsb result sap offset) + (inst ldub result sap offset))) + (:short + (if signed + (inst ldsh result sap offset) + (inst lduh result sap offset))) + (:long + (inst ld result sap offset)) + (:single + (inst ldf result sap offset)) + (:double + (inst lddf result sap offset)))))) + + +(define-vop (sap-set) + (:policy :fast-safe) + (:variant-vars size) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate)) + (value :scs (signed-reg unsigned-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum (:or signed-num unsigned-num)) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:temporary (:scs (non-descriptor-reg)) temp) + (:generator 5 + (let* ((shift (ecase size + (:byte 0) + (:short 1) + ((:long :single :double) 2))) + (offset + (sc-case offset + (zero offset) + (immediate + (let ((offset (ash (tn-value offset) shift))) + (cond ((typep offset '(signed-byte 13)) + offset) + (t + (inst li temp offset) + temp)))) + ((any-reg signed-reg) + (when (sc-is offset any-reg) + (decf shift 2)) + (cond ((plusp shift) + (inst sll temp offset shift) + temp) + ((minusp shift) + (inst sra temp offset (- shift)) + temp) + (t + offset)))))) + (ecase size + (:byte + (inst stb value sap offset) + (move result value)) + (:short + (inst sth value sap offset) + (move result value)) + (:long + (inst st value sap offset) + (move result value)) + (:single + (inst stf value sap offset) + (unless (location= result value) + (inst fmovs result value))) + (:double + (inst stdf value sap offset) + (unless (location= result value) + (inst fmovs result value) + (inst fmovs-odd result value))))))) + + + +(define-vop (sap-system-ref sap-ref) + (:translate sap-ref-sap) + (:results (result :scs (sap-reg))) + (:result-types system-area-pointer) + (:variant :long nil)) + +(define-vop (sap-system-set sap-set) + (:translate %set-sap-ref-sap) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate)) + (value :scs (sap-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum system-area-pointer) + (:results (result :scs (sap-reg))) + (:result-types system-area-pointer) + (:variant :long)) + + + +(define-vop (32bit-system-ref sap-ref) + (:translate sap-ref-32) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:variant :long nil)) + +(define-vop (signed-32bit-system-ref sap-ref) + (:translate signed-sap-ref-32) + (:results (result :scs (signed-reg))) + (:result-types signed-num) + (:variant :long t)) + +(define-vop (32bit-system-set sap-set) + (:translate %set-sap-ref-32) + (:arg-types system-area-pointer positive-fixnum + (:or unsigned-num signed-num)) + (:variant :long)) + + +(define-vop (16bit-system-ref sap-ref) + (:translate sap-ref-16) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:variant :short nil)) + +(define-vop (signed-16bit-system-ref sap-ref) + (:translate signed-sap-ref-16) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:variant :short t)) + +(define-vop (16bit-system-set sap-set) + (:translate %set-sap-ref-16) + (:arg-types system-area-pointer positive-fixnum tagged-num) + (:variant :short)) + + +(define-vop (8bit-system-ref sap-ref) + (:translate sap-ref-8) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:variant :byte nil)) + +(define-vop (signed-8bit-system-ref sap-ref) + (:translate signed-sap-ref-8) + (:results (result :scs (signed-reg))) + (:result-types tagged-num) + (:variant :byte t)) + +(define-vop (8bit-system-set sap-set) + (:translate %set-sap-ref-8) + (:arg-types system-area-pointer positive-fixnum tagged-num) + (:variant :byte)) + + + +;;; 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 add sap vector + (- (* vector-data-offset word-bytes) other-pointer-type)))) + + + +;;;; ### Noise to allow old forms to continue to work until they are gone. + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim ',func) + `(,',func ,@args)))) + (frob 32bit-system-ref sap-ref-32) + (frob unsigned-32bit-system-ref sap-ref-32) + (frob 16bit-system-ref sap-ref-16) + (frob 8bit-system-ref sap-ref-8)) + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim (list 'setf ',func)) + `(setf ,',func ,@args)))) + (frob 32bit-system-set sap-ref-32) + (frob signed-32bit-system-set sap-ref-32) + (frob 16bit-system-set sap-ref-16) + (frob 8bit-system-set sap-ref-8)) diff --git a/compiler/sparc/static-fn.lisp b/compiler/sparc/static-fn.lisp new file mode 100644 index 000000000..cc4ba81de --- /dev/null +++ b/compiler/sparc/static-fn.lisp @@ -0,0 +1,154 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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 (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/static-fn.lisp,v 1.1 1990/11/30 17:05:03 wlott Exp $ +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + + +(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 descriptor-reg :offset cname-offset) cname) + (:temporary (:scs (descriptor-reg)) func) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc any-reg :offset ocfp-offset) old-fp) + (: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 (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (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) + :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 (temp-names) (arg-names)) + (inst li nargs (fixnum ,num-args)) + (load-symbol cname symbol) + (inst ld func cname + (- (ash symbol-raw-function-addr-slot word-shift) + other-pointer-type)) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (inst move old-fp cfp-tn) + (inst move cfp-tn csp-tn) + (inst compute-lra-from-code lra code-tn lra-label temp) + (inst j func (- (ash function-header-code-offset word-shift) + function-pointer-type)) + (inst move code-tn func) + (emit-return-pc lra-label) + (note-this-location vop :unknown-return) + ,(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 + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label))) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)) + ,@(moves (result-names) (temp-names)))))))) + + +) ; eval-when (compile load eval) + + +(macrolet ((frob (num-args num-res) + (static-function-template-vop (eval num-args) (eval num-res)))) + (frob 0 1) + (frob 1 1) + (frob 2 1) + (frob 3 1) + (frob 4 1) + (frob 5 1)) + + +(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/sparc/subprim.lisp b/compiler/sparc/subprim.lisp new file mode 100644 index 000000000..fce7835e9 --- /dev/null +++ b/compiler/sparc/subprim.lisp @@ -0,0 +1,60 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/subprim.lisp,v 1.1 1990/11/30 17:05:04 wlott Exp $ +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + + +;;;; 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) :type random) 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 + (let ((done (gen-label)) + (loop (gen-label)) + (not-list (generate-cerror-code vop object-not-list-error object))) + (move ptr object) + (move count zero-tn) + + (emit-label loop) + + (inst cmp ptr null-tn) + (inst b :eq done) + (inst nop) + + (test-type ptr temp not-list t vm:list-pointer-type) + + (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) + (inst add count count (fixnum 1)) + (test-type ptr temp loop nil vm:list-pointer-type) + + (cerror-call vop done object-not-list-error ptr) + + (emit-label done) + (move result count)))) + + +(define-static-function length (object) :translate length) + diff --git a/compiler/sparc/system.lisp b/compiler/sparc/system.lisp new file mode 100644 index 000000000..d23200008 --- /dev/null +++ b/compiler/sparc/system.lisp @@ -0,0 +1,272 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/system.lisp,v 1.1 1990/11/30 17:05:05 wlott Exp $ +;;; +;;; MIPS VM definitions of various system hacking operations. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Mips conversion by William Lott and Christopher Hoover. +;;; +(in-package "SPARC") + + +;;;; Random pointer comparison VOPs + +(define-vop (pointer-compare) + (:args (x :scs (sap-reg)) + (y :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmp x y) + (inst b (if not-p not-condition condition) target) + (inst nop))) + +(macrolet ((frob (name cond not-cond) + `(progn + (def-primitive-translator ,name (x y) + (warn "Someone used %primitive ~S" ',name) + `(,',name ,x ,y)) + (defknown ,name (t t) boolean (movable foldable flushable)) + (define-vop (,name pointer-compare) + (:translate ,name) + (:variant ,cond ,not-cond))))) + (frob pointer< :ltu :geu) + (frob pointer> :gtu :leu)) + + + +;;;; Random assertions VOPS. + +(define-vop (check-op) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg descriptor-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:policy :fast-safe)) + +(define-vop (check<= check-op) + (:translate system:check<=) + (:generator 3 + (let ((target (generate-error-code vop not-<=-error x y))) + (inst cmp x y) + (inst b :gt target) + (inst nop)))) + +(define-vop (check= check-op) + (:translate system:check=) + (:generator 3 + (let ((target (generate-error-code vop not-<=-error x y))) + (inst cmp x y) + (inst b :ne target) + (inst nop)))) + + + +;;;; 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 result object vm:lowtag-mask))) + +(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 + (let ((other-ptr (gen-label)) + (function-ptr (gen-label)) + (done (gen-label))) + (test-type object ndescr other-ptr nil vm:other-pointer-type) + (test-type object ndescr function-ptr nil vm:function-pointer-type) + (inst andcc result object + (logand vm:other-immediate-0-type vm:other-immediate-1-type)) + (inst b :eq done) + (inst nop) + + (inst b done) + (inst and result object vm:type-mask) + + (emit-label function-ptr) + (load-type result object (- vm:function-pointer-type)) + (inst b done) + (inst nop) + + (emit-label other-ptr) + (load-type result object (- vm:other-pointer-type)) + (inst nop) + + (emit-label done)))) + +(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 vm:other-pointer-type) + (inst srl res res vm:type-bits))) + +(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 vm:function-pointer-type) + (inst srl res res vm:type-bits))) + +(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) :type random) t1 t2) + (:generator 6 + (loadw t1 x 0 vm:other-pointer-type) + (inst and t1 vm:type-mask) + (sc-case data + (any-reg + (inst sll t2 data (- vm:type-bits 2)) + (inst or t1 t2)) + (immediate + (inst or t1 (ash (tn-value data) vm:type-bits))) + (zero)) + (storew t1 x 0 vm:other-pointer-type) + (move res x))) + + +(define-vop (structurify) + (:policy :fast-safe) + (:translate structurify) + (:args (vec :scs (descriptor-reg) :target struct)) + (:results (struct :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) temp) + (:generator 2 + (inst li temp vm:structure-header-type) + (storew temp vec 0 vm:other-pointer-type) + (move struct vec))) + + +(define-vop (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 res ptr 3) + (inst srl res res 1))) + +(define-vop (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 (:type random :scs (non-descriptor-reg)) temp) + (:generator 2 + (sc-case type + (immediate + (inst sll temp val vm:type-bits) + (inst or res temp (tn-value type))) + (t + (inst sra temp type 2) + (inst sll res val (- vm:type-bits 2)) + (inst or res res temp))))) + + +;;;; 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 int alloc-tn))) + +(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 int bsp-tn))) + +(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 int csp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (: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 vm:other-pointer-type) + (inst srl ndescr vm:type-bits) + (inst sll ndescr vm:word-shift) + (inst sub ndescr vm:other-pointer-type) + (inst add sap code ndescr))) + +(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 vm:other-pointer-type) + (inst srl ndescr vm:type-bits) + (inst sll ndescr vm:word-shift) + (inst add ndescr offset) + (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type)) + (inst add func code ndescr))) + + +;;;; Other random VOPs. + + +(defknown mach::do-pending-interrupt () (values)) +(define-vop (mach::do-pending-interrupt) + (:policy :fast-safe) + (:translate mach::do-pending-interrupt) + (:generator 1 + (inst unimp pending-interrupt-trap))) + + +(define-vop (halt) + (:generator 1 + (inst unimp halt-trap))) + diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp new file mode 100644 index 000000000..bcc4328f7 --- /dev/null +++ b/compiler/sparc/type-vops.lisp @@ -0,0 +1,447 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.1 1990/11/30 17:05:06 wlott Exp $ +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the SPARC. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +;;;; Simple type checking and testing: +;;; +;;; These types are represented by a single type code, so are easily +;;; open-coded as a mask and compare. + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) temp) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:type random :scs (non-descriptor-reg)) temp)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) vm: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 result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +); eval-when (compile eval) + + +(def-type-vops fixnump check-fixnum nil object-not-fixnum-error + vm:even-fixnum-type vm:odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error vm:function-pointer-type) + +(def-type-vops listp check-list list + object-not-list-error vm:list-pointer-type) + +#+nil ;; ### Only after we have real structures. +(def-type-vops structurep check-structure structure + object-not-structure vm:structure-pointer-type) + +(def-type-vops structurep check-structure structure + object-not-structure-error vm:structure-header-type)) + +(def-type-vops bignump check-bigunm bignum + object-not-bignum-error vm:bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error vm:ratio-type) + +(def-type-vops complexp check-complex complex + object-not-complex-error vm:complex-type) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error vm:single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error vm:double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error vm:simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error vm:simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm: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 + vm:simple-array-double-float-type) + +(def-type-vops base-char-p check-base-character base-character + object-not-base-character-error vm:base-character-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error vm:sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error vm:weak-pointer-type) + +(def-type-vops array-header-p nil nil nil + vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type + vm:complex-vector-type vm:complex-array-type) + +(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error + vm:function-pointer-type vm:symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + vm:simple-string-type vm:complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + vm:simple-bit-vector-type vm:complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil object-not-vector-error + vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type + vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type + vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type + vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type + vm:simple-array-double-float-type vm:complex-string-type + vm:complex-bit-vector-type vm:complex-vector-type) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type + vm:simple-vector-type vm:simple-array-unsigned-byte-2-type + vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type + vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type + vm:simple-array-single-float-type vm:simple-array-double-float-type) + +(def-type-vops arrayp check-array nil object-not-array-error + vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type + vm:simple-vector-type vm:simple-array-unsigned-byte-2-type + vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type + vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type + vm:simple-array-single-float-type vm:simple-array-double-float-type + vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type + vm:complex-array-type) + +(def-type-vops numberp check-number nil object-not-number-error + vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type + vm:single-float-type vm:double-float-type vm:complex-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + vm:single-float-type vm:double-float-type) + +(def-type-vops realp check-real nil object-not-real-error + vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type + vm:single-float-type vm:double-float-type) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (let ((not-target (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (inst andcc zero-tn value #x3) + (inst b :eq yep) + (test-type value temp nope t vm:other-pointer-type) + (loadw temp value 0 vm:other-pointer-type) + (inst cmp temp (+ (ash 1 vm:type-bits) + vm:bignum-type)) + (inst b (if not-p :ne :eq) target) + (inst nop) + (emit-label not-target))))) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (yep (gen-label))) + (inst andcc temp value #x3) + (inst b :eq yep) + (test-type value temp nope t vm:other-pointer-type) + (loadw temp value 0 vm:other-pointer-type) + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + (inst nop) + (emit-label yep) + (move result value)))) + + +;;; 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. + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (inst andcc temp value #x3) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the header. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it one? + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + (inst nop) + ;; Otherwise, it isn't. + (inst b nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + (inst cmp temp) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst b (if not-p :lt :ge) target) + (inst nop) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + ;; Is it a fixnum? + (inst andcc temp value #x3) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value temp nope t vm:other-pointer-type) + ;; Get the number of digits. + (loadw temp value 0 vm:other-pointer-type) + ;; Is it one? + (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + ;; Otherwise, it isn't. + (inst b :ne nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value vm:bignum-digits-offset vm:other-pointer-type) + ;; positive implies (unsigned-byte 32). + (inst cmp temp) + + (emit-label fixnum) + (inst b :lt nope) + (inst nop) + + (emit-label yep) + (move result value)))) + + + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let* ((drop-thru (gen-label)) + (is-symbol-label (if not-p drop-thru target))) + (inst cmp value null-tn) + (inst b :eq is-symbol-label) + (test-type value temp target not-p vm:symbol-header-type) + (emit-label drop-thru)))) + +(define-vop (check-symbol check-type) + (:generator 12 + (let ((drop-thru (gen-label)) + (error (generate-error-code vop object-not-symbol-error value))) + (inst cmp value null-tn) + (inst b :eq drop-thru) + (test-type value temp error t vm:symbol-header-type) + (emit-label drop-thru) + (move result value)))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let* ((drop-thru (gen-label)) + (is-not-cons-label (if not-p target drop-thru))) + (inst cmp value null-tn) + (inst b :eq is-not-cons-label) + (test-type value temp target not-p vm:list-pointer-type) + (emit-label drop-thru)))) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmp value null-tn) + (inst b :eq error) + (test-type value temp error t vm:list-pointer-type) + (move result value)))) + + +;;;; Function Coercion + +;;; If not a function, get the symbol value and test for that being a +;;; function. Since we test for a function rather than the unbound +;;; marker, this works on NIL. +;;; +(define-vop (coerce-to-function) + (:args (object :scs (descriptor-reg) + :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) + (:temporary (:scs (descriptor-reg)) saved-object) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (let ((not-function-label (gen-label)) + (not-coercable-label (gen-label)) + (done-label (gen-label))) + (test-type object nd-temp not-function-label t + vm:function-pointer-type) + (move result object) + (emit-label done-label) + + (assemble (*elsewhere*) + (emit-label not-function-label) + (test-type object nd-temp not-coercable-label t + vm:symbol-header-type) + (move saved-object object) + (loadw result object vm:symbol-function-slot vm:other-pointer-type) + (test-type result nd-temp done-label nil + vm:function-pointer-type) + (error-call vop undefined-symbol-error saved-object) + + (emit-label not-coercable-label) + (error-call vop object-not-coercable-to-function-error object))))) + +(define-vop (fast-safe-coerce-to-function) + (:args (object :scs (descriptor-reg) + :target result)) + (:results (result :scs (descriptor-reg))) + (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) + (:temporary (:scs (descriptor-reg)) saved-object) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (let ((not-function-label (gen-label)) + (done-label (gen-label))) + (test-type object nd-temp not-function-label t vm:function-pointer-type) + (move result object) + (emit-label done-label) + + (assemble (*elsewhere*) + (emit-label not-function-label) + (move saved-object object) + (loadw result object vm:symbol-function-slot vm:other-pointer-type) + (test-type result nd-temp done-label nil vm:function-pointer-type) + (error-call vop undefined-symbol-error saved-object))))) diff --git a/compiler/sparc/values.lisp b/compiler/sparc/values.lisp new file mode 100644 index 000000000..b32dae5cf --- /dev/null +++ b/compiler/sparc/values.lisp @@ -0,0 +1,89 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice 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 Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/values.lisp,v 1.1 1990/11/30 17:05:10 wlott Exp $ +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by Rob MacLachlan +;;; +;;; Converted for SPARC by William Lott. +;;; + +(in-package "SPARC") + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move csp-tn ptr))) + + +;;; 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) :from :load) + (count :scs (any-reg))) + (:info nvals) + (:temporary (:scs (descriptor-reg)) temp) + (:generator 20 + (inst move start csp-tn) + (inst add csp-tn csp-tn (* nvals vm:word-bytes)) + (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 i)) + (control-stack + (load-stack-tn temp tn) + (storew temp start i))))) + (inst li count (fixnum nvals)))) + +;;; 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 (descriptor-reg)) temp) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (let ((loop (gen-label)) + (done (gen-label))) + + (move list arg) + (move start csp-tn) + + (emit-label loop) + (inst cmp list null-tn) + (inst b :eq done) + (loadw temp list vm:cons-car-slot vm:list-pointer-type) + (loadw list list vm:cons-cdr-slot vm:list-pointer-type) + (inst add csp-tn csp-tn vm:word-bytes) + (storew temp csp-tn -1) + (test-type list ndescr loop nil vm:list-pointer-type) + (error-call vop bogus-argument-to-values-list-error list) + + (emit-label done) + (inst sub count csp-tn start)))) + diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp new file mode 100644 index 000000000..1663ab498 --- /dev/null +++ b/compiler/sparc/vm.lisp @@ -0,0 +1,334 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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 (Scott.Fahlman@CS.CMU.EDU) +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.1 1990/11/30 17:03:26 wlott Exp $ +;;; +;;; This file contains the VM definition for the SPARC. +;;; +;;; Written by William Lott. +;;; +(in-package "SPARC") + + +;;;; Define the registers + +(eval-when (compile eval) + +(defmacro defreg (name offset) + (let ((offset-sym (symbolicate name "-OFFSET"))) + `(progn + (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) + +(defvar *register-names* (make-array 32 :initial-element nil)) + +;; Globals. These are difficult to extract from a sigcontext. +(defreg zero 0) +(defreg alloc 1) +(defreg null 2) +(defreg csp 3) +(defreg cfp 4) +(defreg bsp 5) +(defreg nfp 6) +(defreg cfunc 7) + +;; Outs. These get clobbered when we call into C. +(defreg nl0 8) +(defreg nl1 9) +(defreg nl2 10) +(defreg nl3 11) +(defreg nl4 12) +(defreg nl5 13) +(defreg nsp 14) +(defreg nargs 15) + +;; Locals. These are preserved when we call into C. +(defreg a0 16) +(defreg a1 17) +(defreg a2 18) +(defreg a3 19) +(defreg a4 20) +(defreg a5 21) +(defreg ocfp 22) +(defreg lra 23) + +;; Ins. These are preserved just like locals. +(defreg cname 24) +(defreg lexenv 25) +(defreg l0 26) +(defreg l1 27) +(defreg l2 28) +(defreg code 29) +;; we can't touch reg 30 if we ever want to return +(defreg lip 31) + +(defregset non-descriptor-regs + nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp) + +(defregset descriptor-regs + a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0 l1 l2) + +(defregset register-arg-offsets + a0 a1 a2 a3 a4 a5) + + + +;;;; SB and SC definition: + +(define-storage-base registers :finite :size 32) +(define-storage-base float-registers :finite :size 32) +(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) + + ;; 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) ; (signed-byte 32) + (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32) + (base-character-stack non-descriptor-stack) ; non-descriptor characters. + (sap-stack non-descriptor-stack) ; System area pointers. + (single-stack non-descriptor-stack) ; single-floats + (double-stack non-descriptor-stack :element-size 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-character-reg registers + :locations #.non-descriptor-regs + :constant-scs (immediate) + :save-p t + :alternate-scs (base-character-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 (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + ;; ### Note: We really should have every location listed, but then we + ;; would have to make load-tns work with element-sizes other than 1. + :constant-scs () + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) + ;; ### Note: load-tns don't work with an element-size other than 1. + ;; :element-size 2 + :constant-scs () + :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) + +(defregtn zero any-reg) +(defregtn null descriptor-reg) +(defregtn code descriptor-reg) +(defregtn alloc any-reg) + +(defregtn nargs any-reg) +(defregtn bsp any-reg) +(defregtn csp any-reg) +(defregtn cfp any-reg) +(defregtn ocfp any-reg) +(defregtn nsp any-reg) + + + +;;;; Side-Effect Classes + +(export '(vop-attributes)) + +(def-boolean-attribute vop + any) + + +;;; 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)))) + + +;;;; 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)) + + + +;;; 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