X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Finsts.lisp;h=f17f4a78fd761bcd645b1176d0df8b8605786dc9;hb=b05ccdd91520249de6b465e226d3708089e541dc;hp=b7a860338203241a06105d5855320ac231aaa202;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/insts.lisp b/src/compiler/alpha/insts.lisp index b7a8603..f17f4a7 100644 --- a/src/compiler/alpha/insts.lisp +++ b/src/compiler/alpha/insts.lisp @@ -1,20 +1,15 @@ -;;; -*- Package: ALPHA -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; - -;;; -;;; ********************************************************************** -;;; -;;; This file contains the instruction set definition for the Alpha. -;;; -;;; Written by Sean Hallgren. -;;; +;;; the instruction set definition for the Alpha -(in-package "SB!VM") +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") ;;;(def-assembler-params ;;; :scheduler-p nil) @@ -22,9 +17,8 @@ ;;; ../x86/insts contains the invocation ;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1) ;;; which apparently was another use of def-assembler-params - -;;;; Utility functions. +;;;; utility functions (defun reg-tn-encoding (tn) (declare (type tn tn) @@ -45,9 +39,8 @@ (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) (error "~S isn't a floating-point register." tn)) (tn-offset tn)))) - -;;;; Initial disassembler setup. +;;;; initial disassembler setup ;; XXX find out what this was supposed to do ;; (sb!disassem:set-disassem-params :instruction-alignment 32) @@ -56,48 +49,49 @@ (defparameter reg-symbols (map 'vector - #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) + (lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) *register-names*)) -(sb!disassem:define-argument-type reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) +(sb!disassem:define-arg-type reg + :printer (lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'registers + regname + dstate)))) (defparameter float-reg-symbols (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n))) + (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n))) 'vector)) -(sb!disassem:define-argument-type fp-reg - :printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) - -(sb!disassem:define-argument-type relative-label +(sb!disassem:define-arg-type fp-reg + :printer (lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +(sb!disassem:define-arg-type relative-label :sign-extend t - :use-label #'(lambda (value dstate) - (declare (type (signed-byte 21) value) - (type sb!disassem:disassem-state dstate)) - (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) + :use-label (lambda (value dstate) + (declare (type (signed-byte 21) value) + (type sb!disassem:disassem-state dstate)) + (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) -;;;; Define-instruction-formats for disassembler. +;;;; DEFINE-INSTRUCTION-FORMATs for the disassembler + (sb!disassem:define-instruction-format (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")")) (op :field (byte 6 26)) @@ -152,7 +146,8 @@ (palcode :field (byte 26 0))) -;;;; Emitters. +;;;; emitters + (define-bitfield-emitter emit-word 16 (byte 16 0)) @@ -180,9 +175,9 @@ (define-bitfield-emitter emit-pal 32 (byte 6 26) (byte 26 0)) - -;;;; Macros for instructions. +;;;; macros for instructions + (macrolet ((define-memory (name op &optional fixup float) `(define-instruction ,name (segment ra disp rb ,@(if fixup '(&optional type))) @@ -249,14 +244,14 @@ '((ra nil :type 'fp-reg))))) (:emitter (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-branch segment ,op - ,@(if float - '((fp-reg-tn-encoding ra)) + (lambda (segment posn) + (emit-branch segment ,op + ,@(if float + '((fp-reg-tn-encoding ra)) '((reg-tn-encoding ra))) - (ash (- (label-position target) - (+ posn 4)) - -2)))))))) + (ash (- (label-position target) + (+ posn 4)) + -2)))))))) (define-branch br #x30) (define-branch bsr #x34) (define-branch blbc #x38) @@ -445,7 +440,7 @@ (define-instruction gentrap (segment code) (:printer call-pal ((palcode #xaa0000))) (:emitter - (emit-lword segment #x000080) + (emit-lword segment #x000081) ;actually bugchk (emit-lword segment code))) (define-instruction-macro move (src dst) @@ -538,57 +533,57 @@ (defun emit-header-data (segment type) (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-lword segment - (logior type - (ash (+ posn (component-header-length)) - (- type-bits word-shift))))))) + (lambda (segment posn) + (emit-lword segment + (logior type + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift))))))) -(define-instruction function-header-word (segment) +(define-instruction simple-fun-header-word (segment) (:cost 0) (:emitter - (emit-header-data segment function-header-type))) + (emit-header-data segment simple-fun-header-widetag))) (define-instruction lra-header-word (segment) (:cost 0) (:emitter - (emit-header-data segment return-pc-header-type))) + (emit-header-data segment return-pc-header-widetag))) (defun emit-compute-inst (segment vop dst src label temp calc) (declare (ignore temp)) (emit-chooser ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. segment 12 3 - #'(lambda (segment posn delta-if-after) - (let ((delta (funcall calc label posn delta-if-after))) - (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) - (emit-back-patch segment 4 - #'(lambda (segment posn) - (assemble (segment vop) - (inst lda dst - (funcall calc label posn 0) - src)))) - t))) - #'(lambda (segment posn) - (assemble (segment vop) - (flet ((se (x n) - (let ((x (logand x (lognot (ash -1 n))))) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)))) - (let* ((value (se (funcall calc label posn 0) 32)) - (low (ldb (byte 16 0) value)) - (tmp1 (- value (se low 16))) - (high (ldb (byte 16 16) tmp1)) - (tmp2 (- tmp1 (se (ash high 16) 32))) - (extra 0)) - (unless (= tmp2 0) - (setf extra #x4000) - (setf tmp1 (- tmp1 #x40000000)) - (setf high (ldb (byte 16 16) tmp1))) - (inst lda dst low src) - (inst ldah dst extra dst) - (inst ldah dst high dst))))))) + (lambda (segment posn delta-if-after) + (let ((delta (funcall calc label posn delta-if-after))) + (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) + (emit-back-patch segment 4 + (lambda (segment posn) + (assemble (segment vop) + (inst lda dst + (funcall calc label posn 0) + src)))) + t))) + (lambda (segment posn) + (assemble (segment vop) + (flet ((se (x n) + (let ((x (logand x (lognot (ash -1 n))))) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)))) + (let* ((value (se (funcall calc label posn 0) 32)) + (low (ldb (byte 16 0) value)) + (tmp1 (- value (se low 16))) + (high (ldb (byte 16 16) tmp1)) + (tmp2 (- tmp1 (se (ash high 16) 32))) + (extra 0)) + (unless (= tmp2 0) + (setf extra #x4000) + (setf tmp1 (- tmp1 #x40000000)) + (setf high (ldb (byte 16 16) tmp1))) + (inst lda dst low src) + (inst ldah dst extra dst) + (inst ldah dst high dst))))))) ;; code = fn - header - label-offset + other-pointer-tag (define-instruction compute-code-from-fn (segment dst src label temp) @@ -596,10 +591,10 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- other-pointer-type - (label-position label posn delta-if-after) - (component-header-length)))))) + (lambda (label posn delta-if-after) + (- other-pointer-lowtag + (label-position label posn delta-if-after) + (component-header-length)))))) ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag ;; = lra - (header + label-offset) @@ -608,9 +603,9 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) + (lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag (define-instruction compute-lra-from-code (segment dst src label temp) @@ -618,6 +613,6 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) + (lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length))))))