+;;;; the instruction set definition for HPPA
+
+;;;; 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)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf sb!assem:*assem-scheduler-p* nil))
-
\f
;;;; Utility functions.
(null null-offset)
(zero zero-offset)
(t
- (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
(tn-offset tn))))
(defun fp-reg-tn-encoding (tn)
dstate))))
(defparameter float-reg-symbols
- (coerce
- (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
- 'vector))
+ #.(coerce
+ (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
+ 'vector))
(sb!disassem:define-arg-type fp-reg
:printer #'(lambda (value stream dstate)
(cond (length-only
(values 0 (1+ length) nil nil))
(t
- (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
- vector (* n-word-bits
- vector-data-offset)
- (* length n-byte-bits))
+ (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+ vector 0 length)
(collect ((sc-offsets)
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
- (error-number (sb!c::read-var-integer vector index)))
+ (error-number (sb!c:read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
- (sc-offsets (sb!c::read-var-integer vector index))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
(declare (ignore inst))
(flet ((nt (x) (if stream (sb!disassem:note x dstate))))
(case (break-im5 chunk dstate)
- (#.sb!vm:error-trap
+ (#.error-trap
(nt "Error trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
- (#.sb!vm:cerror-trap
+ (#.cerror-trap
(nt "Cerror trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
- (#.sb!vm:breakpoint-trap
+ (#.breakpoint-trap
(nt "Breakpoint trap"))
- (#.sb!vm:pending-interrupt-trap
+ (#.pending-interrupt-trap
(nt "Pending interrupt trap"))
- (#.sb!vm:halt-trap
+ (#.halt-trap
(nt "Halt trap"))
- (#.sb!vm:fun-end-breakpoint-trap
+ (#.fun-end-breakpoint-trap
(nt "Function end breakpoint trap"))
)))
(declare (type (or fixup (signed-byte 14))))
(cond ((fixup-p disp)
(note-fixup segment :load disp)
- (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
0)
(t
(dpb (ldb (byte 13 0) disp)
(declare (type (or fixup (signed-byte 5)) disp))
(cond ((fixup-p disp)
(note-fixup segment :load-short disp)
- (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
0)
(t
(dpb (ldb (byte 4 0) disp)
(declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
(cond ((fixup-p value)
(note-fixup segment :hi value)
- (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
+ (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
0)
(t
(logior (ash (ldb (byte 5 2) value) 16)
(declare (type (or fixup (signed-byte 17)) disp))
(cond ((fixup-p disp)
(note-fixup segment :branch disp)
- (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
(values 0 0 0))
(t
(values (ldb (byte 5 11) disp)
(emit-back-patch segment 4
#'(lambda (segment posn)
(let ((disp (label-relative-displacement target posn)))
- (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
+ (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
(multiple-value-bind
(w1 w2 w)
(decompose-branch-disp segment disp)
(emit-back-patch segment 4
#'(lambda (segment posn)
(let ((disp (label-relative-displacement target posn)))
- (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+ (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
(let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
(ldb (byte 1 10) disp)))
(w (ldb (byte 1 11) disp)))
(result-encoding double-p)
(fp-reg-tn-encoding result)
(when side
- (assert double-p)
+ (aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
(reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
(value-encoding double-p)
(fp-reg-tn-encoding value)
(when side
- (assert double-p)
+ (aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
(reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
(result-encoding double-p)
(fp-reg-tn-encoding result)
(when side
- (assert double-p)
+ (aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
(short-disp-encoding segment disp) 0
(value-encoding double-p)
(fp-reg-tn-encoding value)
(when side
- (assert double-p)
+ (aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
(short-disp-encoding segment disp) 0
(multiple-value-bind
(to-encoding to-double-p)
(fp-reg-tn-encoding to)
- (assert (eq from-double-p to-double-p))
+ (aver (eq from-double-p to-double-p))
(emit-fp-class-0-inst segment #x0C from-encoding 0
(+ 2 (or (position op funops)
(error "Bogus FUNOP: ~S" op)))
(multiple-value-bind
(r2-encoding r2-double-p)
(fp-reg-tn-encoding r2)
- (assert (eq r1-double-p r2-double-p))
+ (aver (eq r1-double-p r2-double-p))
(emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
(if r1-double-p 1 0) 2 0 0 cond)))))
(multiple-value-bind
(r2-encoding r2-double-p)
(fp-reg-tn-encoding r2)
- (assert (eq r1-double-p r2-double-p))
+ (aver (eq r1-double-p r2-double-p))
(multiple-value-bind
(result-encoding result-double-p)
(fp-reg-tn-encoding result)
- (assert (eq r1-double-p result-double-p))
+ (aver (eq r1-double-p result-double-p))
(emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
(or (position op fbinops)
(error "Bogus FBINOP: ~S" op))
projects / sbcl.git / blobdiff