From 54a0138ffb1405ca9a2f42767949c3a1ef89f305 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Tue, 24 Apr 1990 02:58:30 +0000 Subject: [PATCH] Changes for new-assembler. --- assembly/assemfile.lisp | 33 +- compiler/dump.lisp | 100 ++-- compiler/mips/alloc.lisp | 8 +- compiler/mips/arith.lisp | 106 ++--- compiler/mips/array.lisp | 15 +- compiler/mips/call.lisp | 315 ++++++------- compiler/mips/cell.lisp | 42 +- compiler/mips/char.lisp | 4 +- compiler/mips/insts.lisp | 890 ++++++++++++++++++----------------- compiler/mips/macros.lisp | 111 ++--- compiler/mips/memory.lisp | 10 +- compiler/mips/move.lisp | 12 +- compiler/mips/nlx.lisp | 58 ++- compiler/mips/pred.lisp | 8 +- compiler/mips/print.lisp | 12 +- compiler/mips/sap.lisp | 8 +- compiler/mips/static-fn.lisp | 40 +- compiler/mips/subprim.lisp | 8 +- compiler/mips/system.lisp | 26 +- compiler/mips/type-vops.lisp | 53 +-- compiler/mips/values.lisp | 10 +- 21 files changed, 904 insertions(+), 965 deletions(-) diff --git a/assembly/assemfile.lisp b/assembly/assemfile.lisp index 567d65064..804c1998f 100644 --- a/assembly/assemfile.lisp +++ b/assembly/assemfile.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.6 1990/03/29 16:25:41 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.7 1990/04/24 02:55:49 wlott Exp $ ;;; ;;; This file contains the extra code necessary to feed an entire file of ;;; assembly code to the assembler. @@ -24,7 +24,6 @@ (defvar *assembler-routines* nil "A List of (name . label) for every entry point.") - (defun assemble-file (name &key (output-file (make-pathname :defaults name :type "mips-fasl"))) @@ -34,16 +33,19 @@ (*assembler-routines* nil) (won nil)) (unwind-protect - (progn + (let (*code-segment* *elsewhere*) (init-assembler) (load (merge-pathnames name (make-pathname :type "lisp"))) (finish-assembly) (fasl-dump-cold-load-form `(in-package ,(package-name *package*)) *lap-output-file*) - (let ((handle (dump-assembler-routines *code-vector* *next-location* - *assembler-routines* - *lap-output-file*))) - (dump-fixups handle *result-fixups* *lap-output-file*)) + (assemble (*code-segment* nil) + (insert-segment *elsewhere*)) + (let ((length (finalize-segment *code-segment*))) + (dump-assembler-routines *code-segment* + length + *assembler-routines* + *lap-output-file*)) (setq won t)) (close-fasl-file *lap-output-file* (not won))) won)) @@ -220,7 +222,7 @@ `(,label (gen-label))) labels)) (push (cons ',name ,name) *assembler-routines*) - (assemble ',name + (assemble (*code-segment* ',name) (emit-label ,name) (let (,@(mapcar #'(lambda (reg) @@ -231,9 +233,9 @@ :offset ,(reg-spec-offset temp))))) regs)) ,@insts - (inst addiu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type)) - (inst jr lip-tn) - (nop))) + (inst addu lip-tn lra-tn (- vm:word-bytes vm:other-pointer-type)) + (inst j lip-tn) + (inst nop))) (format t "~S assembled~%" ',name)))) (defun arg-or-res-spec (reg) @@ -292,11 +294,10 @@ ,(reg-spec-name arg))) args) (let ((,return-pc-label (gen-label))) - (inst compute-lra-from-code ,return-pc code-tn - ,return-pc-label) - (inst load-assembly-address ,ndescr ',name) - (inst jr ,ndescr) - (nop) + (inst compute-lra-from-code ,return-pc code-tn ,return-pc-label) + (inst li ,ndescr (make-fixup ',name :assembly-routine)) + (inst j ,ndescr) + (inst nop) (emit-return-pc ,return-pc-label)) ,@(mapcar #'(lambda (res) diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 0cfdcdfb1..22511fed6 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.7 1990/04/02 02:53:39 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.8 1990/04/24 02:58:30 wlott Exp $ ;;; ;;; This file contains stuff that knows about dumping FASL files. ;;; @@ -328,11 +328,8 @@ ;;; We dump a trap object as a placeholder for the code vector, which is ;;; actually filled in by the loader. ;;; -(defun dump-code-object (component code-vector code-length node-vector - nodes-length file) - (declare (type component component) (type fasl-file file) - (simple-vector node-vector) - (type unsigned-byte code-length nodes-length)) +(defun dump-code-object (component code-segment code-length file) + (declare (type component component) (type fasl-file file)) (let* ((2comp (component-info component)) (constants (ir2-component-constants 2comp)) (num-consts (length constants))) @@ -356,16 +353,16 @@ (t (patches (cons info i)) (dump-fop 'lisp::fop-misc-trap file))))) + #+nil (:label - (dump-object (+ (label-location (cdr entry)) + (dump-object (+ (label-position (cdr entry)) clc::i-vector-header-size) file)))) (null (dump-fop 'lisp::fop-misc-trap file))))) ;; Dump the debug info. - (let ((info (debug-info-for-component component node-vector - nodes-length))) + (let ((info (debug-info-for-component component))) (dump-object info file) (let ((info-handle (dump-pop file))) (dump-push info-handle file) @@ -381,26 +378,26 @@ (quick-dump-number num-consts 4 file) (quick-dump-number code-length 4 file)))) - (write-string code-vector (fasl-file-stream file) :end code-length) - - (let ((handle (dump-pop file))) + (let ((fixups (emit-code-vector (fasl-file-stream file) code-segment)) + (handle (dump-pop file))) + (dump-fixups handle fixups file) (dolist (patch (patches)) (push (cons handle (cdr patch)) (gethash (car patch) (fasl-file-patch-table file)))) handle)))) -(defun dump-assembler-routines (code-vector length routines file) +(defun dump-assembler-routines (code-segment length routines file) (dump-fop 'lisp::fop-assembler-code file) (quick-dump-number length 4 file) - (write-string code-vector (fasl-file-stream file) :end length) - (dolist (routine routines) - (dump-object (car routine) file) - (dump-fop 'lisp::fop-assembler-routine file) - (quick-dump-number (label-location (cdr routine)) 4 file)) - (dump-pop file)) - - + (let ((fixups (emit-code-vector (fasl-file-stream file) code-segment))) + (dolist (routine routines) + (dump-object (car routine) file) + (dump-fop 'lisp::fop-assembler-routine file) + (quick-dump-number (label-position (cdr routine)) 4 file)) + (let ((handle (dump-pop file))) + (dump-fixups handle fixups file) + handle))) ;;; Dump-Fixups -- Internal ;;; @@ -413,24 +410,36 @@ (type fasl-file file)) (when fixups (dump-push code-handle file) - (dolist (fixup fixups) - (let ((offset (second fixup)) - (value (third fixup))) - (ecase (first fixup) - (:foreign - (assert (stringp value)) - (dump-fop 'lisp::fop-foreign-fixup file) - (quick-dump-number offset 4 file) - (let ((len (length value))) - (assert (< len 256)) - (dump-byte len file) - (dotimes (i len) - (dump-byte (char-code (schar value i)) file)))) - (:assembly - (assert (symbolp value)) - (dump-object value file) - (dump-fop 'lisp::fop-assembler-fixup file) - (quick-dump-number offset 4 file))))) + (dolist (info fixups) + (let* ((kind (first info)) + (fixup (second info)) + (name (fixup-name fixup)) + (flavor (fixup-flavor fixup)) + (offset (third info))) + (ecase kind + (:addi + ;; ### The lui fixup assumes that an addi follows it. + ) + (:lui + (ecase flavor + (:assembly-routine + (assert (symbolp name)) + (dump-object name file) + (dump-fop 'lisp::fop-assembler-fixup file) + (quick-dump-number offset 4 file)) + (:foreign + (assert (stringp name)) + (dump-fop 'lisp::fop-foreign-fixup file) + (quick-dump-number offset 4 file) + (let ((len (length name))) + (assert (< len 256)) + (dump-byte len file) + (dotimes (i len) + (dump-byte (char-code (schar name i)) file)))))) + #+nil + (:jump + ;; ### Need to impliment this. + )))) (dump-fop 'lisp::fop-pop-for-effect file)) (undefined-value)) @@ -454,7 +463,7 @@ (dump-object (entry-info-arguments entry) file) (dump-object (entry-info-type entry) file) (dump-fop 'lisp::fop-function-entry file) - (quick-dump-number (label-location (entry-info-offset entry)) + (quick-dump-number (label-position (entry-info-offset entry)) 4 file) (let ((handle (dump-pop file))) (when (and name (symbolp name)) @@ -480,20 +489,15 @@ ;;; Dump the code, constants, etc. for component. We pass in the assembler ;;; fixups, code vector and node info. ;;; -(defun fasl-dump-component (component code-vector code-length - node-vector nodes-length - fixups file) - (declare (type component component) (type unsigned-byte length) - (list fixups) (type fasl-file file)) +(defun fasl-dump-component (component code-segment length file) + (declare (type component component) (type fasl-file file)) (dump-fop 'lisp::fop-verify-empty-stack file) (dump-fop 'lisp::fop-verify-table-size file) (quick-dump-number (fasl-file-table-free file) 4 file) - (let ((code-handle (dump-code-object component code-vector code-length - node-vector nodes-length file)) + (let ((code-handle (dump-code-object component code-segment length file)) (2comp (component-info component))) - (dump-fixups code-handle fixups file) (dump-fop 'lisp::fop-verify-empty-stack file) (dolist (entry (ir2-component-entries 2comp)) diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index 8ba8c4bbc..b4886807d 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.3 1990/02/28 18:23:33 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.4 1990/04/24 02:55:22 wlott Exp $ ;;; ;;; Allocation VOPs for the MIPS port. ;;; @@ -47,14 +47,14 @@ (storew reg ,list ,slot vm:list-pointer-type)))) (let ((cons-cells (if star (1- num) num))) (pseudo-atomic (ndescr) - (inst addiu res alloc-tn vm:list-pointer-type) - (inst addiu alloc-tn alloc-tn + (inst addu res alloc-tn vm:list-pointer-type) + (inst addu alloc-tn alloc-tn (* (vm:pad-data-block vm: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 addiu ptr ptr (vm:pad-data-block vm:cons-size)) + (inst addu ptr ptr (vm:pad-data-block vm:cons-size)) (storew ptr ptr (- vm:cons-cdr-slot vm:cons-size) vm:list-pointer-type)) diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp index 8890f1eeb..4d311a116 100644 --- a/compiler/mips/arith.lisp +++ b/compiler/mips/arith.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.12 1990/04/24 02:55:38 wlott Exp $ +;;; ;;; This file contains the VM definition arithmetic VOPs for the MIPS. ;;; ;;; Written by Rob MacLachlan @@ -31,14 +33,14 @@ (define-vop (fast-negate/fixnum fixnum-unop) (:translate %negate) (:generator 1 - (inst sub res zero-tn x))) + (inst subu res zero-tn x))) (define-vop (fast-lognot/fixnum fixnum-unop) (:temporary (:scs (any-reg) :type fixnum :to (:result 0)) temp) (:translate lognot) (:generator 1 - (loadi temp (fixnum -1)) + (inst li temp (fixnum -1)) (inst xor res x temp))) @@ -58,61 +60,44 @@ (:affected) (:policy :fast-safe)) -(defmacro define-fixnum-binop ((name translate cost result-type) - op - &key unsigned immed-op function) +(defmacro define-fixnum-binop (name translate cost result-type op + &optional unsigned) `(define-vop (,name fast-binop) (:args (x :target r :scs (any-reg descriptor-reg)) (y :target r - :scs (any-reg descriptor-reg - ,@(when immed-op - (list (if unsigned - 'unsigned-immediate - 'negative-immediate) - 'immediate - 'zero))))) + :scs (any-reg descriptor-reg immediate zero + ,(if unsigned + 'unsigned-immediate + 'negative-immediate)))) (:translate ,translate) (:result-types ,result-type) - ,@(when (eq result-type t) - '((:note "inline fixnum arithmetic"))) + (:note ,(if (eq result-type '*) "inline fixnum arithmetic")) (:generator ,cost (sc-case y ((any-reg descriptor-reg) (inst ,op r x y)) (zero (inst ,op r x zero-tn)) - ,@(when immed-op - `(((immediate - ,(if unsigned 'unsigned-immediate 'negative-immediate)) - (inst ,immed-op r x - (fixnum ,(if function - `(,function (tn-value y)) - '(tn-value y))))))))))) + ((immediate + ,(if unsigned 'unsigned-immediate 'negative-immediate)) + (inst ,op r x + (fixnum (tn-value y)))))))) ;;; Plus and minus. -(define-fixnum-binop (fast-+/fixnum=>fixnum + 1 fixnum) - addu :immed-op addiu)) -(define-fixnum-binop (fast-+/fixnum + 2 t) - add :immed-op addi) +(define-fixnum-binop fast-+/fixnum=>fixnum + 1 fixnum addu) +(define-fixnum-binop fast-+/fixnum + 2 * add) -(define-fixnum-binop (fast--/fixnum=>fixnum - 1 fixnum) - subu :immed-op addiu :function -) -(define-fixnum-binop (fast--/fixnum - 2 t) - sub :immed-op addi :function -) +(define-fixnum-binop fast--/fixnum=>fixnum - 1 fixnum subu) +(define-fixnum-binop fast--/fixnum - 2 * sub) ;;; Logical operatons. -(define-fixnum-binop (fast-logior/fixnum logior 1 *) - or :immed-op ori :unsigned t) - -(define-fixnum-binop (fast-logand/fixnum logand 1 *) - and :immed-op andi :unsigned t) - -(define-fixnum-binop (fast-logxor/fixnum logxor 1 *) - xor :immed-op xori :unsigned t) +(define-fixnum-binop fast-logior/fixnum logior 1 * or t) +(define-fixnum-binop fast-logand/fixnum logand 1 * and t) +(define-fixnum-binop fast-logxor/fixnum logxor 1 * xor t) ;;; Shifting @@ -131,7 +116,6 @@ num) (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) ndesc foo) - (:node-var node) (:generator 3 (sc-case amount ((any-reg descriptor-reg) @@ -143,25 +127,24 @@ (inst sra ndesc amount 2) ;; The fixnum result-type assures us that this shift will not overflow. - (inst sllv result num ndesc) + (inst sll result num ndesc) (emit-label done) - (unassemble - (assemble-elsewhere node - (emit-label negative) - (inst nor ndesc ndesc ndesc) - (inst addiu ndesc ndesc 3) - (inst andi foo ndesc #x1f) - (inst beq foo ndesc very-negative) - - (inst srav ndesc num ndesc) - (b done) - (inst sll result ndesc 2) - - (emit-label very-negative) - (inst sra ndesc num 31) - (b done) - (inst sll result ndesc 2))))) + (assemble (*elsewhere*) + (emit-label negative) + (inst nor ndesc ndesc ndesc) + (inst addu ndesc ndesc 3) + (inst and foo ndesc #x1f) + (inst beq foo ndesc very-negative) + + (inst sra ndesc num ndesc) + (inst b done) + (inst sll result ndesc 2) + + (emit-label very-negative) + (inst sra ndesc num 31) + (inst b done) + (inst sll result ndesc 2)))) (immediate (inst sll result number (tn-value amount))) (negative-immediate @@ -203,9 +186,8 @@ (:temporary (:scs (non-descriptor-reg) :type random) t1 t2) (:results (q :scs (any-reg descriptor-reg)) (r :scs (any-reg descriptor-reg))) - (:node-var node) (:generator 5 - (let ((zero (generate-error-code node di:division-by-zero-error x y))) + (let ((zero (generate-error-code di:division-by-zero-error x y))) (inst beq y zero-tn zero)) (inst sra t1 x 2) (inst sra t2 y 2) @@ -254,7 +236,7 @@ (inst bgez x target) (inst bltz x target))) ((negative-immediate immediate) - (inst slti temp x (fixnum (tn-value y))) + (inst slt temp x (fixnum (tn-value y))) (if not-p (inst beq temp zero-tn target) (inst bne temp zero-tn target))) @@ -263,7 +245,7 @@ (if not-p (inst beq temp zero-tn target) (inst bne temp zero-tn target)))) - (nop))) + (inst nop))) (define-vop (fast-if->/fixnum fast-conditional/fixnum) (:temporary (:type fixnum :scs (any-reg) :from (:argument 0)) temp) @@ -275,7 +257,7 @@ (inst blez x target) (inst bgtz x target))) ((negative-immediate immediate) - (inst slti temp x (fixnum (1+ (tn-value y)))) + (inst slt temp x (fixnum (1+ (tn-value y)))) (if not-p (inst bne temp zero-tn target) (inst beq temp zero-tn target))) @@ -284,7 +266,7 @@ (if not-p (inst beq temp zero-tn target) (inst bne temp zero-tn target)))) - (nop))) + (inst nop))) (define-vop (fast-if-=/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg descriptor-reg)) @@ -297,7 +279,7 @@ (if not-p (inst bne x foo target) (inst beq x foo target))) - (nop))) + (inst nop))) diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp index 9daa5e656..7801491c0 100644 --- a/compiler/mips/array.lisp +++ b/compiler/mips/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.9 1990/04/04 22:37:59 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.10 1990/04/24 02:55:41 wlott Exp $ ;;; ;;; This file contains the MIPS definitions for array operations. ;;; @@ -26,8 +26,8 @@ (:results (result :scs (descriptor-reg))) (:generator 0 (pseudo-atomic (ndescr) - (inst addiu header alloc-tn vm:other-pointer-type) - (inst addiu alloc-tn alloc-tn + (inst addu header alloc-tn vm:other-pointer-type) + (inst addu alloc-tn alloc-tn (* vm:array-dimensions-offset vm:word-bytes)) (inst addu alloc-tn alloc-tn rank) (inst sll ndescr rank vm:type-bits) @@ -68,7 +68,7 @@ (loadw temp x 0 vm:other-pointer-type) (inst sra temp temp vm:type-bits) (inst sll res temp 2) - (inst addiu res res (fixnum (- 1 vm:array-dimensions-offset))))) + (inst addu res res (fixnum (- 1 vm:array-dimensions-offset))))) @@ -82,14 +82,13 @@ (bound :scs (any-reg descriptor-reg)) (index :scs (any-reg descriptor-reg) :target result)) (:results (result :scs (any-reg descriptor-reg))) - (:node-var node) (:temporary (:scs (non-descriptor-reg) :type random) temp) (:generator 5 - (let ((error (generate-error-code node di:invalid-array-index-error + (let ((error (generate-error-code di:invalid-array-index-error array bound index))) (inst sltu temp index bound) (inst beq temp zero-tn error) - (nop) + (inst nop) (move result index)))) @@ -182,7 +181,7 @@ (:temporary (:scs (non-descriptor-reg) :type random) t1 t2) (:generator 6 (loadw t1 x 0 vm:other-pointer-type) - (loadi t2 vm:type-mask) + (inst li t2 vm:type-mask) (inst and t1 t1 t2) (inst sll t2 subtype (- vm:type-bits 2)) (inst or t1 t1 t2) diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp index 4734c5fcb..9cea31091 100644 --- a/compiler/mips/call.lisp +++ b/compiler/mips/call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.4 1990/04/23 16:39:07 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.5 1990/04/24 02:55:54 wlott Exp $ ;;; ;;; This file contains the VM definition of function call for the MIPS. ;;; @@ -125,7 +125,7 @@ (:generator 1 (let ((nfp (current-nfp-tn vop))) (when nfp - (inst addiu val nfp + (inst addu val nfp (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes)))))) @@ -140,12 +140,12 @@ (inst function-header-word) (dotimes (i (1- vm:function-header-code-offset)) (inst word 0)) - (inst addiu csp-tn fp-tn + (inst addu csp-tn fp-tn (* vm:word-bytes (sb-allocated-size 'control-stack))) (let ((nfp-tn (current-nfp-tn vop))) (when nfp-tn (move nfp-tn nsp-tn) - (inst addiu nsp-tn nsp-tn + (inst addu nsp-tn nsp-tn (- (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes))))))) @@ -156,11 +156,11 @@ (:ignore nfp) (:generator 2 (move res csp-tn) - (inst addiu csp-tn csp-tn + (inst addu csp-tn csp-tn (* vm:word-bytes (sb-allocated-size 'control-stack))) (when (ir2-environment-number-stack-p callee) (move nfp nsp-tn) - (inst addiu nsp-tn nsp-tn + (inst addu nsp-tn nsp-tn (- (* (sb-allocated-size 'non-descriptor-stack) vm:word-bytes)))))) @@ -174,7 +174,7 @@ (:generator 2 (when (> nargs register-arg-count) (move res csp-tn) - (inst addiu csp-tn csp-tn (* nargs vm:word-bytes))))) + (inst addu csp-tn csp-tn (* nargs vm:word-bytes))))) @@ -184,8 +184,7 @@ ;;; 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). Node -;;; is the node to use for source context in emitted code. +;;; values that are to be received (should equal the length of Values). ;;; ;;; Move-Temp and Nil-Temp are Descriptor-Reg TNs used as temporaries. ;;; @@ -219,12 +218,12 @@ regs-defaulted sub temp nargs register-arg-count bltz temp default-value-4 ; jump to default code - addiu temp temp -1 + addu temp temp -1 loadw move-temp args-tn 3 ; Move value to correct location. store-stack-tn val4-tn move-temp bltz temp default-value-5 - addiu temp temp -1 + addu temp temp -1 loadw move-temp args-tn 4 store-stack-tn val5-tn move-temp @@ -247,62 +246,60 @@ default-value-5 nop |# ;;; -(defun default-unknown-values (node values nvals move-temp temp lra-label) - (declare (type node node) (type (or tn-ref null) values) +(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)) - (assemble node - (if (<= nvals 1) - (progn - (move csp-tn old-fp-tn) - (nop) - (inst compute-code-from-lra code-tn code-tn lra-label)) - (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label))) - ;; Branch off to the MV case. - (b regs-defaulted) - (inst compute-code-from-lra code-tn code-tn lra-label) - - ;; Do the single value calse. - (inst compute-code-from-lra code-tn code-tn lra-label) - (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) - (loadi nargs-tn (fixnum 1)) - (move old-fp-tn csp-tn)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - (inst addiu 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 bltz temp default-lab) - (inst addiu temp temp (fixnum -1)) - (loadw move-temp args-tn i) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move csp-tn args-tn) - - (unassemble - (assemble-elsewhere node - (dolist (def (defaults)) - (emit-label (car def)) - (store-stack-tn (cdr def) null-tn)) - (b defaulting-done) - (nop)))))))) + (if (<= nvals 1) + (progn + (move csp-tn old-fp-tn) + (inst nop) + (inst compute-code-from-lra code-tn code-tn lra-label)) + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label))) + ;; Branch off to the MV case. + (inst b regs-defaulted) + (inst compute-code-from-lra code-tn code-tn lra-label) + + ;; Do the single value calse. + (inst compute-code-from-lra code-tn code-tn lra-label) + (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 old-fp-tn csp-tn)) + + (emit-label regs-defaulted) + + (when (> nvals register-arg-count) + (inst addu 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 bltz temp default-lab) + (inst addu temp temp (fixnum -1)) + (loadw move-temp args-tn i) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move csp-tn args-tn) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (store-stack-tn (cdr def) null-tn)) + (inst b defaulting-done) + (inst nop)))))) (undefined-value)) @@ -327,33 +324,31 @@ default-value-5 ;;; 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 (node args nargs start count lra-label) - (declare (type node node) (type tn args nargs start count)) - (assemble node - (let ((variable-values (gen-label)) - (done (gen-label))) - (b variable-values) - (inst compute-code-from-lra code-tn code-tn lra-label) - - (inst compute-code-from-lra code-tn code-tn lra-label) - (inst addiu csp-tn csp-tn 4) - (storew (first register-arg-tns) csp-tn -1) - (inst addiu start csp-tn -4) - (loadi count (fixnum 1)) - - (emit-label done) - - (unassemble - (assemble-elsewhere node - (emit-label variable-values) - (do ((arg register-arg-tns (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) - (move start args) - (move count nargs) - (b done) - (nop))))) +(defun receive-unknown-values (args nargs start count lra-label) + (declare (type tn args nargs start count)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (inst b variable-values) + (inst compute-code-from-lra code-tn code-tn lra-label) + + (inst compute-code-from-lra code-tn code-tn lra-label) + (inst addu csp-tn csp-tn 4) + (storew (first register-arg-tns) csp-tn -1) + (inst addu start csp-tn -4) + (inst li count (fixnum 1)) + + (emit-label done) + + (assemble (*elsewhere*) + (emit-label variable-values) + (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)) @@ -364,7 +359,6 @@ default-value-5 (:results (start :scs (descriptor-reg)) (count :scs (descriptor-reg))) - (:node-var node) (:temporary (:sc descriptor-reg :offset args-offset :from :eval :to (:result 0)) values-start) @@ -399,7 +393,6 @@ default-value-5 (:move-args :local-call) (:info arg-locs callee target nvals) (:ignore arg-locs args nfp) - (:node-var node) (:vop-var vop) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:scs (any-reg) :type fixnum) temp) @@ -414,12 +407,11 @@ default-value-5 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (b target) - (nop) + (inst b target) + (inst nop) (emit-return-pc label) (note-this-location vop :unknown-return) - (unassemble - (default-unknown-values node values nvals move-temp temp label)) + (default-unknown-values values nvals move-temp temp label) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -448,13 +440,11 @@ default-value-5 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (b target) - (nop) + (inst b target) + (inst nop) (emit-return-pc label) (note-this-location vop :unknown-return) - (unassemble - (receive-unknown-values node values-start nvals - start count label)) + (receive-unknown-values values-start nvals start count label) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -485,8 +475,8 @@ default-value-5 (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (move callee-nfp nfp))) - (b target) - (nop) + (inst b target) + (inst nop) (note-this-location vop :known-return) (emit-return-pc label) (when cur-nfp @@ -510,8 +500,9 @@ default-value-5 (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (move nsp-tn cur-nfp))) - (move fp-tn old-fp) - (lisp-return return-pc lip))) + (inst addu lip return-pc (- vm:word-bytes vm:other-pointer-type)) + (inst j lip) + (move fp-tn old-fp))) ;;;; Full call: @@ -580,7 +571,6 @@ default-value-5 ,@(unless (eq return :tail) `((:save-p t) - (:node-var node) (:vop-var vop) ,@(unless variable '((:move-args :full-call))))) @@ -655,7 +645,7 @@ default-value-5 (mapcar #'(lambda (name) `(loadw ,name new-fp ,(incf index))) register-arg-names))) - `((loadi nargs-pass (fixnum nargs)))) + `((inst li nargs-pass (fixnum nargs)))) (let (,@(unless (eq return :tail) '((lra-label (gen-label)) @@ -665,14 +655,14 @@ default-value-5 (loadw function lexenv vm:closure-function-slot vm:function-pointer-type) - (inst addiu lip function (- (ash vm:function-header-code-offset + (inst addu lip function (- (ash vm:function-header-code-offset vm:word-shift) vm:function-pointer-type)) ,@(if (eq return :tail) '((move old-fp-pass old-fp) (move return-pc-pass return-pc) - (inst jr lip) + (inst j lip) (move code-tn function)) `((move old-fp-pass fp-tn) ,(if variable @@ -682,23 +672,20 @@ default-value-5 (move fp-tn csp-tn))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (inst jr lip) + (inst j lip) (move code-tn function) (emit-return-pc lra-label))) ,@(ecase return (:fixed '((note-this-location vop :unknown-return) - (unassemble - (default-unknown-values node values nvals - move-temp temp lra-label)) + (default-unknown-values values nvals move-temp temp lra-label) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) (:unknown '((note-this-location vop :unknown-return) - (unassemble - (receive-unknown-values node values-start nvals - start count lra-label)) + (receive-unknown-values values-start nvals start count + lra-label) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) (:tail)))))) @@ -760,22 +747,22 @@ default-value-5 register-arg-names)) ;; Calc SRC, DST, and COUNT - (inst addiu src args (* vm:word-bytes register-arg-count)) - (inst addiu dst fp-tn (* vm:word-bytes register-arg-count)) - (b test) - (inst addiu count nargs (fixnum (- register-arg-count))) + (inst addu src args (* vm:word-bytes register-arg-count)) + (inst addu dst fp-tn (* vm:word-bytes register-arg-count)) + (inst b test) + (inst addu count nargs (fixnum (- register-arg-count))) (emit-label loop) ;; Copy one arg. (loadw temp src) - (inst addiu src src vm:word-bytes) + (inst addu src src vm:word-bytes) (storew temp dst) - (inst addiu dst dst vm:word-bytes) + (inst addu dst dst vm:word-bytes) ;; Are we done? (emit-label test) (inst bgtz count loop) - (inst addiu count count (fixnum -1)) + (inst addu count count (fixnum -1)) ;; We are done. Do the jump. (loadw function lexenv vm:closure-function-slot @@ -823,13 +810,13 @@ default-value-5 (when cur-nfp (move nsp-tn cur-nfp))) (move fp-tn old-fp) - (inst addiu lip return-pc (- (* 3 word-bytes) other-pointer-type)) - (inst jr lip) + (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type)) + (inst j lip) (move code-tn return-pc)) (t - (loadi nargs (fixnum nvals)) + (inst li nargs (fixnum nvals)) (move val-ptr fp-tn) - (inst addiu csp-tn val-ptr (* nvals word-bytes)) + (inst addu csp-tn val-ptr (* nvals word-bytes)) (move fp-tn old-fp) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -896,9 +883,9 @@ default-value-5 (move nsp-tn cur-nfp))) ;; Single case? - (loadi count (fixnum 1)) + (inst li count (fixnum 1)) (inst bne count nvals not-single) - (nop) + (inst nop) ;; Return with one value. (loadw ,(first register-arg-names) start) @@ -906,8 +893,8 @@ default-value-5 (move fp-tn old-fp) ;; Note: we can't use the lisp-return macro, 'cause we want to ;; skip two instructions. - (inst addiu lip return-pc (- (* 3 word-bytes) other-pointer-type)) - (inst jr lip) + (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type)) + (inst j lip) (move code-tn return-pc) ;; Nope, not the single case. @@ -920,23 +907,23 @@ default-value-5 ,@(mapcar #'(lambda (name label) `(progn (inst blez count ,label) - (inst addiu count count (fixnum -1)) + (inst addu count count (fixnum -1)) (loadw ,name src) - (inst addiu src src vm:word-bytes))) + (inst addu src src vm:word-bytes))) register-arg-names label-names) ;; Copy the remaining args to the top of the stack. - (inst addiu dst fp-tn (* vm:word-bytes register-arg-count)) + (inst addu dst fp-tn (* vm:word-bytes register-arg-count)) (emit-label loop) (inst blez count done) - (inst addiu count count (fixnum -1)) + (inst addu count count (fixnum -1)) (loadw temp src) - (inst addiu src src vm:word-bytes) + (inst addu src src vm:word-bytes) (storew temp dst) - (b loop) - (inst addiu dst dst vm:word-bytes) + (inst b loop) + (inst addu dst dst vm:word-bytes) ;; Default some number of registers. ,@(mapcar #'(lambda (name label) @@ -963,11 +950,10 @@ default-value-5 ;;; Fetch the constant pool from the function entry structure. ;;; (define-vop (setup-environment) - (:node-var node) + (:info label) (:generator 5 ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn - code-tn code-tn (block-label (node-block node))))) + (inst compute-code-from-fn code-tn code-tn label))) ;;; Return the current Env as our result, then indirect throught the closure ;;; and the closure-entry to find the constant pool @@ -977,11 +963,10 @@ default-value-5 :to (:result 0)) lexenv) (:results (closure :scs (descriptor-reg))) - (:node-var node) + (:info label) (:generator 6 ;; Fix CODE, cause the function object was passed in. - (inst compute-code-from-fn - code-tn code-tn (block-label (node-block node))) + (inst compute-code-from-fn code-tn code-tn label) ;; Get result. (move closure lexenv))) @@ -1007,12 +992,12 @@ default-value-5 (cond ((zerop fixed) (inst addu csp-tn csp-tn nargs-tn)) (t - (inst addiu count nargs-tn (fixnum (- fixed))) + (inst addu count nargs-tn (fixnum (- fixed))) (inst addu 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 addiu count nargs-tn (fixnum (- register-arg-count)))) + (inst addu count nargs-tn (fixnum (- register-arg-count)))) ;; Everything of interest in registers. (inst blez count do-regs) ;; Initialize dst to be end of stack. @@ -1022,22 +1007,22 @@ default-value-5 (emit-label loop) ;; *--dst = *--src, --count - (inst addiu src src (- vm:word-bytes)) - (inst addiu count count (fixnum -1)) + (inst addu src src (- vm:word-bytes)) + (inst addu count count (fixnum -1)) (loadw temp src) - (inst addiu dst dst (- vm:word-bytes)) + (inst addu dst dst (- vm:word-bytes)) (inst bgtz count 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 addiu count nargs-tn (fixnum (- fixed))) + (inst addu count nargs-tn (fixnum (- fixed))) (do ((i fixed (1+ i))) ((>= i register-arg-count)) ;; Don't deposit any more than there are. (inst beq count zero-tn done) - (inst addiu count count (fixnum -1)) + (inst addu count 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)))) @@ -1076,10 +1061,10 @@ default-value-5 ;; We need to do this atomically. (pseudo-atomic (ndescr) ;; Allocate a cons (2 words) for each item. - (inst addiu result alloc-tn vm:list-pointer-type) + (inst addu result alloc-tn vm:list-pointer-type) (move dst result) (inst addu alloc-tn alloc-tn count) - (b enter) + (inst b enter) (inst addu alloc-tn alloc-tn count) ;; Store the current cons in the cdr of the previous cons. @@ -1089,13 +1074,13 @@ default-value-5 ;; Grab one value and stash it in the car of this cons. (emit-label enter) (loadw temp context) - (inst addiu context context vm:word-bytes) + (inst addu context context vm:word-bytes) (storew temp dst 0 vm:list-pointer-type) ;; Dec count, and if != zero, go back for more. - (inst addiu count count (fixnum -1)) + (inst addu count count (fixnum -1)) (inst bne count zero-tn loop) - (inst addiu dst dst (* 2 vm:word-bytes)) + (inst addu dst dst (* 2 vm:word-bytes)) ;; NIL out the last cons. (storew null-tn dst -1 vm:list-pointer-type)) @@ -1121,7 +1106,7 @@ default-value-5 (context :scs (descriptor-reg)) (count :scs (any-reg descriptor-reg))) (:generator 5 - (inst addiu count supplied (fixnum (- fixed))) + (inst addu count supplied (fixnum (- fixed))) (inst subu context csp-tn count))) @@ -1132,18 +1117,16 @@ default-value-5 (nargs :scs (any-reg descriptor-reg))) (:temporary (:scs (any-reg) :type fixnum) temp) (:info count) - (:node-var node) (:generator 3 - (let ((err-lab (generate-error-code node - di:invalid-argument-count-error + (let ((err-lab (generate-error-code di:invalid-argument-count-error nargs))) (cond ((zerop count) (inst bne nargs zero-tn err-lab) - (nop)) + (inst nop)) (t - (loadi temp (fixnum count)) + (inst li temp (fixnum count)) (inst bne nargs temp err-lab) - (nop)))))) + (inst nop)))))) ;;; Signal an argument count error. ;;; diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp index f53359b83..3933c9755 100644 --- a/compiler/mips/cell.lisp +++ b/compiler/mips/cell.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.30 1990/04/23 16:39:47 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.31 1990/04/24 02:55:58 wlott Exp $ ;;; ;;; This file contains the VM definition of various primitive memory access ;;; VOPs for the MIPS. @@ -120,36 +120,36 @@ `((:translate ,alloc-trans))) (:generator 37 (pseudo-atomic (ndescr) - (inst addiu result alloc-tn ,lowtag) + (inst addu result alloc-tn ,lowtag) ,@(cond ((and header variable-length) - `((inst addiu temp extra-words + `((inst addu temp extra-words (fixnum (1- ,size))) (inst addu alloc-tn alloc-tn temp) (inst sll temp temp (- vm:type-bits vm:word-bits)) - (inst ori temp temp ,header) + (inst or temp temp ,header) (storew temp result 0 ,lowtag) - (inst addiu alloc-tn alloc-tn + (inst addu alloc-tn alloc-tn (+ (fixnum 1) vm:lowtag-mask)) - (loadi temp (lognot vm:lowtag-mask)) + (inst li temp (lognot vm:lowtag-mask)) (inst and alloc-tn alloc-tn temp))) (variable-length (error ":REST-P T with no header in ~S?" (vm:primitive-object-name obj))) (header - `((inst addiu alloc-tn alloc-tn + `((inst addu alloc-tn alloc-tn (vm:pad-data-block ,size)) - (loadi temp - ,(logior (ash (1- size) vm:type-bits) - (if (integerp header) - header - 0))) + (inst li temp + ,(logior (ash (1- size) vm:type-bits) + (if (integerp header) + header + 0))) (storew temp result 0 ,lowtag))) (t - `((inst addiu alloc-tn alloc-tn + `((inst addu alloc-tn alloc-tn (vm:pad-data-block ,size))))) ,@(when need-unbound-marker - `((loadi temp vm:unbound-marker-type))) + `((inst li temp vm:unbound-marker-type))) ,@(init-forms) (move real-result result)))))))) (when (forms) @@ -180,9 +180,9 @@ (move obj-temp object) (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type) (let ((err-lab (generate-error-code node di:unbound-symbol-error obj-temp))) - (inst xori temp value vm:unbound-marker-type) + (inst xor temp value vm:unbound-marker-type) (inst beq temp zero-tn err-lab) - (nop)))) + (inst nop)))) ;;; With Symbol-Function, we check that the result is a function, so NIL is ;;; always un-fbound. @@ -210,11 +210,11 @@ (:translate boundp) (:generator 9 (loadw value object vm:symbol-value-slot vm:other-pointer-type) - (inst xori temp value vm:unbound-marker-type) + (inst xor temp value vm:unbound-marker-type) (if not-p (inst beq temp zero-tn target) (inst bne temp zero-tn target)) - (nop))) + (inst nop))) ;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction @@ -259,7 +259,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:generator 5 (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type) - (inst addiu bsp-tn bsp-tn (* 2 vm:word-bytes)) + (inst addu 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))) @@ -272,7 +272,7 @@ (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 addiu bsp-tn bsp-tn (* -2 vm:word-bytes)))) + (inst addu bsp-tn bsp-tn (* -2 vm:word-bytes)))) (define-vop (unbind-to-here) @@ -294,7 +294,7 @@ (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size)) (emit-label skip) - (inst addiu bsp-tn bsp-tn (* -2 vm:word-bytes)) + (inst addu bsp-tn bsp-tn (* -2 vm:word-bytes)) (inst bne where bsp-tn loop) (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size)) diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp index a48ebedbb..bbae99358 100644 --- a/compiler/mips/char.lisp +++ b/compiler/mips/char.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.5 1990/04/23 16:44:49 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.6 1990/04/24 02:56:01 wlott Exp $ ;;; ;;; This file contains the RT VM definition of character operations. ;;; @@ -39,7 +39,7 @@ (:results (y :scs (any-reg descriptor-reg))) (:generator 1 (inst sll y x vm:type-bits) - (inst ori y y vm:base-character-type))) + (inst or y y vm:base-character-type))) ;;; (define-move-vop move-from-base-character :move (base-character-reg) (any-reg descriptor-reg)) diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp index 4233114e8..81787090d 100644 --- a/compiler/mips/insts.lisp +++ b/compiler/mips/insts.lisp @@ -1,30 +1,35 @@ -;;; -*- Package: C; Log: C.Log -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at +;;; 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 CMU Common Lisp, please -;;; contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). +;;; 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/mips/insts.lisp,v 1.11 1990/03/05 21:06:44 wlott Exp $ -;;; -;;; Assembler instruction definitions for the MIPS R2000. +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/insts.lisp,v 1.12 1990/04/24 02:56:14 wlott Exp $ ;;; -;;; Written by Christopher Hoover +;;; Description of the MIPS architecture. +;;; +;;; Written by William Lott ;;; -(in-package "C") +(in-package "MIPS") +(use-package "ASSEM") -;;; Clear out any old definitions. -;;; -(clrhash *instructions*) -(clrhash *instruction-formats*) +(import '(c::tn-p c::tn-sc c::tn-offset c::sc-sb c::sb-name c::zero-tn + c::registers c::float-registers + c::component-header-length)) -;;;; Formats +;;;; Resources. + +(define-random-resources high low) +(define-register-file ireg 32) +(define-register-file fpreg 32) -(eval-when (compile load eval) + +;;;; Formats. (defconstant special-op #b000000) (defconstant bcond-op #b0000001) @@ -33,460 +38,467 @@ (defconstant cop2-op #b010010) (defconstant cop3-op #b010011) -) ; eval-when - -;;; -;;; Load Store Format -;;; -(def-instruction-format (load-store 4) (rt base &optional (offset 0)) - (op :unsigned 6 :instruction-constant) - (base :unsigned 5 :register) - (rt :unsigned 5 :register) - (offset :signed 16 :immediate)) - -;;; -;;; Signed Immediate Format -;;; -(def-instruction-format (signed-immed 4) (rt rs immed) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (immed :signed 16 :immediate)) - -;;; -;;; Unsigned Immediate Format -;;; -(def-instruction-format (unsigned-immed 4) (rt rs immed) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (immed :unsigned 16 :immediate)) - -;;; -;;; LUI Special Format -;;; -(def-instruction-format (lui-special 4) (rt immed) - (op :unsigned 6 :instruction-constant) - (rt :unsigned 5 :constant 0) - (rt :unsigned 5 :register) - (immed :unsigned 16 :immediate)) - -;;; -;;; Jump (J) Format -;;; -(def-instruction-format (jump 4) (target) - (op :unsigned 6 :instruction-constant) - (target :unsigned 26 :branch #'(lambda (x) (ash x -2)))) ; This isn't right - -;;; -;;; JR Special Format -;;; -(def-instruction-format (jr-special 4) (rs) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (zero :unsigned 15 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; JALR Special Format -;;; -(def-instruction-format (jalr-special 4) (rd rs) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (zero-1 :unsigned 5 :constant 0) - (rd :unsigned 5 :register) - (zero-2 :unsigned 5 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; Branch Format -;;; -(def-instruction-format (branch 4) (rs offset) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (zero :unsigned 5 :constant 0) - (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2)))) - -;;; -;;; Branch-2 Format -;;; -(def-instruction-format (branch-2 4) (rs rt offset) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2)))) - -;;; -;;; Branch-Z Format -;;; -(def-instruction-format (branch-z 4) (rs offset) - (bcond :unsigned 6 :constant bcond-op) - (rs :unsigned 5 :register) - (op :unsigned 5 :instruction-constant) - (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2)))) - -;;; -;;; R3 Format -;;; -(def-instruction-format (r3 4) (rd rs rt) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (rd :unsigned 5 :register) - (zero :unsgined 5 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; MF Format -;;; -(def-instruction-format (mf 4) (rd) - (special :unsigned 6 :constant special-op) - (zero-1 :unsigned 10 :constant 0) - (rd :unsigned 5 :register) - (zero-2 :unsigned 5 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; MT Format -;;; -(def-instruction-format (mt 4) (rs) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (zero :unsigned 15 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; Mult Format -;;; -(def-instruction-format (mult 4) (rs rt) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (zero :unsigned 10 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; Shift Format -;;; -(def-instruction-format (shift 4) (rd rt shamt) - (special :unsigned 6 :constant special-op) - (zero :unsgined 5 :constant 0) - (rt :unsigned 5 :register) - (rd :unsigned 5 :register) - (shamt :unsigned 5 :immediate) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; Shift-Var Format -;;; -(def-instruction-format (shift-var 4) (rd rt rs) - (special :unsigned 6 :constant special-op) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (rd :unsigned 5 :register) - (zero :unsigned 5 :constant 0) - (op :unsigned 6 :instruction-constant)) - -;;; -;;; BREAK-Special Format -;;; -(def-instruction-format (break-special 4) (code) - (special :unsigned 6 :constant special-op) - (code :unsigned 10 :immediate) ; The MIPS assembler only uses half the bits. - (unused :unsigned 10 :constant 0) - (op :unsigned 6 :instruction-constant)) -;;; -;;; SYSCALL-Special Format -;;; -(def-instruction-format (syscall-special 4) () - (special :unsigned 6 :constant special-op) - (zero :unsigned 20 :constant 0) - (op :unsigned 6 :instruction-constant)) +(define-format (immediate 32) + (op (byte 6 26)) + (rs (byte 5 21) :use ireg) + (rt (byte 5 16) :clobber ireg) + (immediate (byte 16 0))) - -;;;; Instructions - -(def-instruction j-inst jump :op #b00010) -(def-instruction jal-inst jump :op #b00011) -(def-instruction jr jr-special :op #b001000) -(def-instruction jalr jalr-special :op #b001001) -(def-instruction beq-inst branch-2 :op #b000100) -(def-instruction bne-inst branch-2 :op #b000101) -(def-instruction blez-inst branch :op #b000110) -(def-instruction bgtz-inst branch :op #b000111) - -(def-instruction addi signed-immed :op #b001000) -(def-instruction addiu signed-immed :op #b001001) -(def-instruction slti signed-immed :op #b001010) -(def-instruction sltiu signed-immed :op #b001011) -(def-instruction andi unsigned-immed :op #b001100) -(def-instruction ori unsigned-immed :op #b001101) -(def-instruction xori unsigned-immed :op #b001110) -(def-instruction lui lui-special :op #b001111) - -(def-instruction lb load-store :op #b100000) -(def-instruction lh load-store :op #b100001) -(def-instruction lwl load-store :op #b100010) -(def-instruction lw load-store :op #b100011) -(def-instruction lbu load-store :op #b100100) -(def-instruction lhu load-store :op #b100101) -(def-instruction lwr load-store :op #b100110) - -(def-instruction sb load-store :op #b101000) -(def-instruction sh load-store :op #b101001) -(def-instruction swl load-store :op #b101010) -(def-instruction sw load-store :op #b101011) -(def-instruction swr load-store :op #b101110) - -(def-instruction sll shift :op #b000000) -(def-instruction srl shift :op #b000010) -(def-instruction sra shift :op #b000011) -(def-instruction sllv shift-var :op #b000100) -(def-instruction srlv shift-var :op #b000110) -(def-instruction srav shift-var :op #b000111) - -(def-instruction syscall syscall-special :op #b001100) -(def-instruction break break-special :op #b001101) - -(def-instruction mfhi mf :op #b010000) -(def-instruction mthi mt :op #b010001) -(def-instruction mflo mf :op #b010010) -(def-instruction mtlo mt :op #b010011) - -(def-instruction mult mult :op #b011000) -(def-instruction multu mult :op #b011001) -(def-instruction div mult :op #b011010) -(def-instruction divu mult :op #b011011) - -(def-instruction add r3 :op #b100000) -(def-instruction addu r3 :op #b100001) -(def-instruction sub r3 :op #b100010) -(def-instruction subu r3 :op #b100011) -(def-instruction and r3 :op #b100100) -(def-instruction or r3 :op #b100101) -(def-instruction xor r3 :op #b100110) -(def-instruction nor r3 :op #b100111) - -(def-instruction slt r3 :op #b101010) -(def-instruction sltu r3 :op #b101011) - -(def-instruction bltz-inst branch-z :op #b00000) -(def-instruction bltzal-inst branch-z :op #b10000) - -(def-instruction bgez-inst branch-z :op #b00001) -(def-instruction bgezal-inst branch-z :op #b10001) +(define-format (jump 32) + (op (byte 6 26)) + (target (byte 26 0))) - -;;;; Branches +(define-format (register 32) + (op (byte 6 26)) + (rs (byte 5 21) :use ireg) + (rt (byte 5 16) :use ireg) + (rd (byte 5 11) :clobber ireg) + (shamt (byte 5 6) :default 0) + (funct (byte 6 0))) -(defmacro most-positive-twos-complement-number (n-bits) - `(1- (ash 1 (1- ,n-bits)))) -(defmacro most-negative-twos-complement-number (n-bits) - `(- (ash 1 (1- ,n-bits)))) +(define-format (break 32) + (op (byte 6 26) :default special-op) + (code (byte 10 16)) + (subcode (byte 10 6) :default 0) + (funct (byte 6 0) :default #b001101)) -;;; -;;; ### These two aren't right -;;; -(def-branch j (label) label - (0 (ash 1 28) (j-inst label))) -;;; -(def-branch jal (label) label - (0 (ash 1 28) (jal-inst label))) - - -(def-branch beq (rs rt label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (beq-inst rs rt label))) - -(def-branch bne (rs rt label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bne-inst rs rt label))) - -(def-branch blez (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (blez-inst rs label))) - -(def-branch bgtz (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bgtz-inst rs label))) - -(def-branch bltz (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bltz-inst rs label))) - -(def-branch bltzal (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bltzal-inst rs label))) - -(def-branch bgez (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bgez-inst rs label))) - -(def-branch bgezal (rs label) label - ((most-negative-twos-complement-number 18) - (most-positive-twos-complement-number 18) - (bgezal-inst rs label))) -;;;; Pseduo Instructions to Support Component Dumping - -(defun component-header-length (&optional (component *compile-component*)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) - (ash (logandc2 (1+ num-consts) 1) word-shift))) - - -;;; COMPUTE-CODE-FROM-FN -;;; -;;; code = fn - fn-tag - header - label-offset + other-pointer-tag -;;; -(def-instruction-format (compute-code-from-fn-format 4) (rt rs label) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (label :signed 16 - :label #'(lambda (label-offset instr-offset) - (declare (ignore instr-offset)) - (- other-pointer-type function-pointer-type label-offset - (component-header-length))))) - -(def-instruction compute-code-from-fn compute-code-from-fn-format - :op #b001001) - - -;;; COMPUTE-CODE-FROM-LRA -;;; -;;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag -;;; -(def-instruction-format (compute-code-from-lra-format 4) (rt rs label) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (label :signed 16 - :label #'(lambda (label-offset instr-offset) - (declare (ignore instr-offset)) - (- (+ label-offset (component-header-length)))))) - -(def-instruction compute-code-from-lra compute-code-from-lra-format - :op #b001001) - - -;;; COMPUTE-LRA-FROM-CODE -;;; -;;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag -;;; -(def-instruction-format (compute-lra-from-code-format 4) (rt rs label) - (op :unsigned 6 :instruction-constant) - (rs :unsigned 5 :register) - (rt :unsigned 5 :register) - (label :signed 16 - :label #'(lambda (label-offset instr-offset) - (declare (ignore instr-offset)) - (+ label-offset (component-header-length))))) +;;;; Special argument types and fixups. -(def-instruction compute-lra-from-code compute-lra-from-code-format - :op #b001001) +(defun register-p (object) + (and (tn-p object) + (eq (sb-name (sc-sb (tn-sc object))) 'registers))) +(define-argument-type register + :type (satisfies register-p) + :function tn-offset) -;;; -;;; LRA-HEADER-WORD, FUNCTION-HEADER-WORD -;;; - -(def-instruction-format (header-word-format 4) () - (data :unsigned 24 :calculation #'(lambda (posn) - (ash (+ posn (component-header-length)) - (- vm:word-shift)))) - (type :unsigned 8 :instruction-constant)) +(defun fp-reg-p (object) + (and (tn-p object) + (eq (sb-name (sc-sb (tn-sc object))) + 'float-registers))) -(def-instruction lra-header-word header-word-format - :type vm:return-pc-header-type) +(define-argument-type fp-reg + :type (satisfies fp-reg-p) + :function tn-offset) -(def-instruction function-header-word header-word-format - :type vm:function-header-type) +(defun label-offset (label) + (1- (ash (- (label-position label) *current-position*) -2))) -;;; LOAD-FOREIGN-ADDRESS and LOAD-FOREIGN-VALUE -;;; -;;; This ``instruction'' emits a LUI followed by either an ADDIU, LW, or SW -;;; -(def-instruction-format (load-foreign-format 8) (rt symbol) - ;; We need to switch the order of the two instructions because the MIPS - ;; is little-endian. - (op2 :unsigned 6 :instruction-constant) - (rt :unsigned 5 :register) - (rt :unsigned 5 :register) - (filler :unsigned 16 :constant 0) - (op1 :unsigned 6 :constant #b001111) - (rt :unsigned 5 :register) - (rt :unsigned 5 :register) - (symbol :unsigned 16 :fixup :foreign)) +(define-argument-type relative-label + :type label + :function label-offset) -(def-instruction load-foreign-address load-foreign-format - :op2 #b001001) -(def-instruction load-foreign-value load-foreign-format - :op2 #b100011) +(define-fixup-type :jump) +(define-fixup-type :lui) +(define-fixup-type :addi) -(def-instruction store-foreign-value load-foreign-format - :op2 #b101011) + +;;;; Instructions. + + +(defmacro define-math-inst (name r3 imm &optional imm-type function fixup) + `(define-instruction (,name) + ,@(when imm + `((immediate (op :constant ,imm) + (rt :argument register) + (rs :same-as rt) + (immediate :argument (,(case imm-type + (:signed 'signed-byte) + (:unsigned 'unsigned-byte)) + 16) + ,@(when function + `(:function ,function)))) + (immediate (op :constant ,imm) + (rt :argument register) + (rs :argument register) + (immediate :argument (,(case imm-type + (:signed 'signed-byte) + (:unsigned 'unsigned-byte)) + 16) + ,@(when function + `(:function ,function)))))) + ,@(when (and imm fixup) + `((immediate (op :constant ,imm) + (rt :argument register) + (rs :same-as rt) + (immediate :argument addi-fixup)) + (immediate (op :constant ,imm) + (rt :argument register) + (rs :argument register) + (immediate :argument addi-fixup)))) + ,@(when r3 + `((register (op :constant special-op) + (rd :argument register) + (rs :argument register) + (rt :argument register) + (funct :constant ,r3)) + (register (op :constant special-op) + (rd :argument register) + (rs :same-as rd) + (rt :argument register) + (funct :constant ,r3)))))) + +(define-math-inst add #b100000 #b001000 :signed) +(define-math-inst addu #b100001 #b001001 :signed nil t) +(define-math-inst sub #b100010 #b001000 :signed -) +(define-math-inst subu #b100011 #b001001 :signed -) +(define-math-inst and #b100100 #b001100 :unsigned) +(define-math-inst or #b100101 #b001101 :unsigned) +(define-math-inst xor #b100110 #b001110 :unsigned) +(define-math-inst nor #b100111 #b001111 :unsigned) + +(define-math-inst slt #b101010 #b001010 :signed) +(define-math-inst sltu #b101011 #b001011 :signed) + +(define-instruction (beq) + (immediate (op :constant #b000100) + (rs :argument register) + (rt :constant 0) + (immediate :argument relative-label)) + (immediate (op :constant #b000100) + (rs :argument register) + (rt :argument register) + (immediate :argument relative-label))) + +(define-instruction (bne) + (immediate (op :constant #b000101) + (rs :argument register) + (rt :constant 0) + (immediate :argument relative-label)) + (immediate (op :constant #b000101) + (rs :argument register) + (rt :argument register) + (immediate :argument relative-label))) + +(define-instruction (blez) + (immediate (op :constant #b000110) + (rs :argument register) + (rt :constant 0) + (immediate :argument relative-label))) + +(define-instruction (bgtz) + (immediate (op :constant #b000111) + (rs :argument register) + (rt :constant 0) + (immediate :argument relative-label))) + +(define-instruction (bltz) + (immediate (op :constant bcond-op) + (rs :argument register) + (rt :constant #b00000) + (immediate :argument relative-label))) + +(define-instruction (bgez) + (immediate (op :constant bcond-op) + (rs :argument register) + (rt :constant #b00001) + (immediate :argument relative-label))) + +(define-instruction (bltzal) + (immediate (op :constant bcond-op) + (rs :argument register) + (rt :constant #b01000) + (immediate :argument relative-label))) + +(define-instruction (bgezal) + (immediate (op :constant bcond-op) + (rs :argument register) + (rt :constant #b01001) + (immediate :argument relative-label))) + +(define-instruction (break) + (break (code :argument (unsigned-byte 10))) + (break (code :argument (unsigned-byte 10)) + (subcode :argument (unsigned-byte 10)))) + +(define-instruction (div :clobber (low high)) + (register (op :constant special-op) + (rs :argument register) + (rt :argument register) + (rd :constant 0) + (funct :constant #b011010))) + +(define-instruction (divu :clobber (low high)) + (register (op :constant special-op) + (rs :argument register) + (rt :argument register) + (rd :constant 0) + (funct :constant #b011011))) + +(define-instruction (j) + (register (op :constant special-op) + (rs :argument register) + (rt :constant 0) + (rd :constant 0) + (funct :constant #b001000)) + (jump (op :constant #b000010) + (target :argument jump-fixup))) + +(define-instruction (jal) + (register (op :constant special-op) + (rs :argument register) + (rt :constant 0) + (rd :constant 31) + (funct :constant #b001001)) + (register (op :constant special-op) + (rd :argument register) + (rs :argument register) + (rt :constant 0) + (funct :constant #b001001)) + (jump (op :constant #b000011) + (target :argument jump-fixup))) + + +(defmacro define-load/store-instruction (name op) + `(define-instruction (,name) + (immediate (op :constant ,op) + (rs :argument register) + (rt :argument register) + (immediate :argument (signed-byte 16))) + (immediate (op :constant ,op) + (rs :argument register) + (rt :argument register) + (immediate :argument addi-fixup)) + (immediate (op :constant ,op) + (rs :argument register) + (rt :argument register) + (immediate :constant 0)))) + +(define-load/store-instruction lb #b100000) +(define-load/store-instruction lh #b100001) +(define-load/store-instruction lwl #b100010) +(define-load/store-instruction lw #b100011) +(define-load/store-instruction lbu #b100100) +(define-load/store-instruction lhu #b100101) +(define-load/store-instruction lwr #b100110) +(define-load/store-instruction sb #b101000) +(define-load/store-instruction sh #b101001) +(define-load/store-instruction swl #b101010) +(define-load/store-instruction sw #b101011) +(define-load/store-instruction swr #b101110) + +(define-instruction (lui) + (immediate (op :constant #b001111) + (rs :constant 0) + (rt :argument register) + (immediate :argument (or (unsigned-byte 16) (signed-byte 16)))) + (immediate (op :constant #b001111) + (rs :constant 0) + (rt :argument register) + (immediate :argument lui-fixup))) + + +(define-instruction (mfhi :use high) + (register (op :constant special-op) + (rd :argument register) + (rs :constant 0) + (rt :constant 0) + (funct :constant #b010000))) + +(define-instruction (mthi :clobber high) + (register (op :constant special-op) + (rd :argument register) + (rs :constant 0) + (rt :constant 0) + (funct :constant #b010001))) + +(define-instruction (mflo :use low) + (register (op :constant special-op) + (rd :argument register) + (rs :constant 0) + (rt :constant 0) + (funct :constant #b010010))) + +(define-instruction (mtlo :clobber low) + (register (op :constant special-op) + (rd :argument register) + (rs :constant 0) + (rt :constant 0) + (funct :constant #b010011))) + + +(define-instruction (mult :clobber (low high)) + (register (op :constant special-op) + (rs :argument register) + (rt :argument register) + (rd :constant 0) + (funct :constant #b011000))) + +(define-instruction (multu :clobber (low high)) + (register (op :constant special-op) + (rs :argument register) + (rt :argument register) + (rd :constant 0) + (funct :constant #b011001))) + +(define-instruction (sll) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000000)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000000)) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :argument register) + (funct :constant #b000100)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :argument register) + (funct :constant #b000100))) + +(define-instruction (sra) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000011)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000011)) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :argument register) + (funct :constant #b000111)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :argument register) + (funct :constant #b000111))) + +(define-instruction (srl) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000010)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :constant 0) + (shamt :argument (unsigned-byte 5)) + (funct :constant #b000010)) + (register (op :constant special-op) + (rd :argument register) + (rt :argument register) + (rs :argument register) + (funct :constant #b000110)) + (register (op :constant special-op) + (rd :argument register) + (rt :same-as rd) + (rs :argument register) + (funct :constant #b000110))) + +(define-instruction (syscall) + (register (op :constant special-op) + (rd :constant 0) + (rt :constant 0) + (rs :constant 0) + (funct :constant #b001100))) -;;; LOAD-ASSEMBLY-ADDRESS and LOAD-ASSEMBLY-VALUE -;;; -;;; This ``instruction'' emits a LUI followed by either an ADDIU, LW, or SW. -;;; The difference is that we use :assembly fixups. -;;; -(def-instruction-format (load-assembly-format 8) (rt symbol) - ;; We need to switch the order of the two instructions because the MIPS - ;; is little-endian. - (op2 :unsigned 6 :instruction-constant) - (rt :unsigned 5 :register) - (rt :unsigned 5 :register) - (filler :unsigned 16 :constant 0) - (op1 :unsigned 6 :constant #b001111) - (rt :unsigned 5 :register) - (rt :unsigned 5 :register) - (symbol :unsigned 16 :fixup :assembly)) + +;;;; Pseudo-instructions + +(define-pseudo-instruction li 64 (reg value) + (etypecase value + ((unsigned-byte 16) + (inst or reg zero-tn value)) + ((signed-byte 16) + (inst addu reg zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (inst lui reg (ldb (byte 16 16) value)) + (let ((low (ldb (byte 16 0) value))) + (unless (zerop low) + (inst or reg low)))) + (fixup + (inst lui reg value) + (inst addu reg value)))) + +(define-instruction (b) + (immediate (op :constant #b000100) + (rs :constant 0) + (rt :constant 0) + (immediate :argument relative-label))) + +(define-instruction (nop) + (register (op :constant 0) + (rd :constant 0) + (rt :constant 0) + (rs :constant 0) + (funct :constant 0))) + +(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) + (word-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) + +(define-format (byte-format 8) + (data (byte 8 0))) +(define-instruction (byte) + (word-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) -(def-instruction load-assembly-address load-assembly-format - :op2 #b001001) -(def-instruction load-assembly-value load-assembly-format - :op2 #b100011) + +;;;; Function and LRA Headers emitters and calculation stuff. -(def-instruction store-assembly-value load-assembly-format - :op2 #b101011) +(defun header-data (ignore) + (declare (ignore ignore)) + (ash (+ *current-position* (component-header-length)) (- vm:word-shift))) +(define-format (header-object 32) + (type (byte 8 0)) + (data (byte 24 8) :default 0 :function header-data)) +(define-instruction (function-header-word) + (header-object (type :constant #x5e))) -;;; BYTE, SHORT, and WORD instructions. -;;; -;;; These instructions emit a byte, short, or word in the instruction -;;; stream. If you use them, be sure to use (align 2) afterwords to -;;; assure that additional code gets properly aligned. +(define-instruction (lra-header-word) + (header-object (type :constant #x66))) -(def-instruction-format (byte-format 1) (value) - (value :unsigned 8 :immediate)) -(def-instruction byte byte-format) -(def-instruction-format (short-format 2) (value) - (value :unsigned 16 :immediate)) -(def-instruction short short-format) +(define-pseudo-instruction compute-code-from-fn 64 (code fn label) + ;; code = fn - fn-tag - header - label-offset + other-pointer-tag + (let ((offset (- vm:other-pointer-type + vm:function-pointer-type + (label-position label) + (component-header-length)))) + (inst addu code fn offset))) -(def-instruction-format (word-format 4) (value) - (value :unsigned 32 :immediate)) -(def-instruction word word-format) +(define-pseudo-instruction compute-code-from-lra 64 (code lra label) + ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag + (let ((offset (- (+ (label-position label) (component-header-length))))) + (inst addu code lra offset))) +(define-pseudo-instruction compute-lra-from-code 64 (lra code label) + ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag + (let ((offset (+ (label-position label) (component-header-length)))) + inst addu lra code offset)) diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp index fd0c14940..a67296948 100644 --- a/compiler/mips/macros.lisp +++ b/compiler/mips/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.29 1990/04/23 16:45:03 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.30 1990/04/24 02:56:19 wlott Exp $ ;;; ;;; This file contains various useful macros for generating MIPS code. ;;; @@ -29,11 +29,6 @@ ;;; Instruction-like macros. - -(defmacro nop () - "Emit a nop." - '(inst sll zero-tn zero-tn 0)) - (defmacro move (dst src &optional (always-emit-code-p nil)) "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)." @@ -44,38 +39,18 @@ `(unless (location= ,n-dst ,n-src) (inst addu ,n-dst ,n-src zero-tn))))) -(defmacro b (label) - "Unconditional branch" - `(inst beq zero-tn zero-tn ,label)) - - (defmacro def-mem-op (op inst shift load) `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) `(progn (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)) - ,,@(when load '('(nop)))))) + ,,@(when load '('(inst nop)))))) ;;; (def-mem-op loadw lw word-shift t) (def-mem-op storew sw word-shift nil) -(defmacro loadi (reg const) - (once-only ((n-reg reg) - (n-const const)) - `(cond ((<= #x-8000 ,n-const #x7fff) - (inst addi ,n-reg zero-tn ,n-const)) - ((<= #x8000 ,n-const #xffff) - (inst ori ,n-reg zero-tn ,n-const)) - ((<= #x-80000000 ,n-const #xffffffff) - (inst lui ,n-reg (ldb (byte 16 16) ,n-const)) - (let ((low (ldb (byte 16 0) ,n-const))) - (unless (zerop low) - (inst ori ,n-reg ,n-reg low)))) - (t - (error "Constant ~D cannot be loaded." ,n-const))))) - (defmacro load-symbol (reg symbol) - `(inst addi ,reg null-tn (vm:static-symbol-offset ,symbol))) + `(inst add ,reg null-tn (vm:static-symbol-offset ,symbol))) (macrolet ((frob (slot) @@ -97,7 +72,7 @@ (+ (vm:static-symbol-offset ',symbol) (ash ,',offset vm:word-shift) (- vm:other-pointer-type))) - (nop))) + (inst nop))) (defmacro ,storer (reg symbol) `(inst sw ,reg null-tn (+ (vm:static-symbol-offset ',symbol) @@ -125,17 +100,17 @@ (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - (inst addiu ,lip ,function (- (ash vm:function-header-code-offset + (inst addu ,lip ,function (- (ash vm:function-header-code-offset vm:word-shift) vm:function-pointer-type)) - (inst jr ,lip) + (inst j ,lip) (move code-tn ,function))) (defmacro lisp-return (return-pc lip) "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn - (inst addiu ,lip ,return-pc (- vm:word-bytes vm:other-pointer-type)) - (inst jr ,lip) + (inst addu ,lip ,return-pc (- vm:word-bytes vm:other-pointer-type)) + (inst j ,lip) (move code-tn ,return-pc))) (defmacro emit-return-pc (label) @@ -204,7 +179,7 @@ (if ,n-not-p (inst beq ,n-temp zero-tn ,n-target) (inst bne ,n-temp zero-tn ,n-target)))) - (nop)))) + (inst nop)))) ;;;; Simple Type Checking Macros @@ -212,12 +187,12 @@ (defmacro simple-test-tag (register temp target not-p tag-type tag-mask) `(progn (unless (zerop ,tag-mask) - (inst andi ,temp ,register ,tag-mask)) - (inst xori ,temp ,temp ,tag-type) + (inst and ,temp ,register ,tag-mask)) + (inst xor ,temp ,temp ,tag-type) (if ,not-p (inst bne ,temp zero-tn ,target) (inst beq ,temp zero-tn ,target)) - (nop))) + (inst nop))) (defmacro simple-test-simple-type (register temp target not-p type-code) "Emit conditional code that test whether Register holds an object with @@ -260,7 +235,7 @@ (simple-test-tag ,n-register ,n-temp not-other-label t vm:other-pointer-type vm:lowtag-mask) (load-type ,n-temp ,n-register (- vm:other-pointer-type)) - (nop) + (inst nop) (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p ,n-type-code 0) (emit-label out-label)))))) @@ -297,7 +272,7 @@ (macrolet ((frob (value) `(let ((diff (+ (- ,value) last-type-code))) (unless (zerop diff) - (emit `(inst addi ,temp ,temp ,diff)) + (emit `(inst add ,temp ,temp ,diff)) (setf last-type-code ,value))))) (do* ((types tag-types (cdr types)) (type (car types) (car types)) @@ -330,9 +305,9 @@ ,in-label ; squelch possible warning ,out-label (unless (zerop ,tag-mask) - (inst andi ,temp ,register ,tag-mask)) + (inst and ,temp ,register ,tag-mask)) ,@(emit) - (nop) + (inst nop) (emit-label drop-through))))) (defmacro test-hairy-type (register temp target not-p &rest types) @@ -381,7 +356,7 @@ `((simple-test-tag ,n-register ,n-temp not-other-label t vm:other-pointer-type vm:lowtag-mask) (load-type ,n-temp ,n-register (- vm:other-pointer-type)) - (nop) + (inst nop) (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p ,header-word-types 0))) (emit-label out-label)))))) @@ -473,52 +448,48 @@ (emit-error-break vm:error-trap error-code values))) - (defmacro cerror-call (label error-code &rest values) "Cause a continuable error. If the error is continued, execution resumes at LABEL." `(progn - (b ,label) + (inst b ,label) ,@(emit-error-break vm:cerror-trap error-code values))) -(defmacro generate-error-code (node error-code &rest values) - "Generate-Error-Code Node Error-code Value* - Emit code for an error with the specified Error-Code and context Values. - Node is used for source context." - `(unassemble - (assemble-elsewhere ,node - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,error-code ,@values) - start-lab)))) - -(defmacro generate-cerror-code (node error-code &rest values) - "Generate-CError-Code Node Error-code Value* +(defmacro generate-error-code (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 ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (error-code &rest values) + "Generate-CError-Code Error-code Value* Emit code for a continuable error with the specified Error-Code and - context Values. Node is used for source context. If the error is continued, - execution resumes after the GENERATE-CERROR-CODE form." + 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) - (unassemble - (assemble-elsewhere ,node - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,continue ,error-code ,@values) - ,error)))))) + (assemble (*elsewhere*) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,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))) - (inst andi flags-tn flags-tn (lognot (ash 1 interrupted-flag))) - (inst ori flags-tn flags-tn (ash 1 atomic-flag)) + (inst and flags-tn flags-tn (logxor (ash 1 interrupted-flag) #Xffff)) + (inst or flags-tn flags-tn (ash 1 atomic-flag)) ,@forms - (inst andi flags-tn flags-tn (lognot (ash 1 atomic-flag))) - (inst andi ,ndescr-temp flags-tn (ash 1 interrupted-flag)) + (inst and flags-tn flags-tn (logxor (ash 1 atomic-flag) #Xffff)) + (inst and ,ndescr-temp flags-tn (ash 1 interrupted-flag)) (inst beq ,ndescr-temp zero-tn ,label) - (nop) + (inst nop) (inst break vm:pending-interrupt-trap) (emit-label ,label)))) diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp index 49b306cac..2a8447194 100644 --- a/compiler/mips/memory.lisp +++ b/compiler/mips/memory.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.6 1990/03/29 21:51:56 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.7 1990/04/24 02:56:11 wlott Exp $ ;;; ;;; This file contains the MIPS definitions of some general purpose memory ;;; reference VOPs inherited by basic memory reference operations. @@ -127,16 +127,16 @@ lowtag)) ,(if write-p '(move result value) - '(nop))) + '(inst nop))) (t ,@(if (zerop shift) - `((inst add lip object index)) + `((inst addu lip object index)) `((inst srl temp index ,shift) - (inst add lip temp object))) + (inst addu lip temp object))) (inst ,op value lip (- (ash offset word-shift) lowtag)) ,(if write-p '(move result value) - '(nop))))))) + '(inst nop))))))) (define-indexer word-index-ref nil lw 0) (define-indexer word-index-set t sw 0) diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp index 806310a12..ff03824c8 100644 --- a/compiler/mips/move.lisp +++ b/compiler/mips/move.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.12 1990/04/23 16:45:09 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.13 1990/04/24 02:56:22 wlott Exp $ ;;; ;;; This file contains the MIPS VM definition of operand loading/saving and ;;; the Move VOP. @@ -25,23 +25,23 @@ (let ((val (tn-value x))) (etypecase val (integer - (loadi y (fixnum val))) + (inst li y (fixnum val))) (null (move y null-tn)) (symbol (load-symbol y val)) (character - (loadi y (logior (ash (char-code val) type-bits) - base-character-type)))))) + (inst li y (logior (ash (char-code val) type-bits) + base-character-type)))))) (define-move-function (load-number 1) (vop x y) ((null unsigned-immediate immediate zero negative-immediate random-immediate) (signed-reg unsigned-reg)) - (loadi y (tn-value x))) + (inst li y (tn-value x))) (define-move-function (load-base-character 1) (vop x y) ((immediate-base-character) (base-character-reg)) - (loadi y (char-code (tn-value x)))) + (inst li y (char-code (tn-value x)))) (define-move-function (load-constant 5) (vop x y) ((constant) (any-reg descriptor-reg)) diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp index 0a7620df0..2df18402b 100644 --- a/compiler/mips/nlx.lisp +++ b/compiler/mips/nlx.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.7 1990/04/23 16:45:11 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.8 1990/04/24 02:56:24 wlott Exp $ ;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) @@ -81,7 +81,7 @@ (move nsp-tn nsp) (inst beq special bsp-tn done) - (nop) + (inst nop) (emit-label loop) (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) @@ -90,9 +90,9 @@ (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 addiu bsp-tn bsp-tn (* -2 vm:word-bytes)) + (inst addu bsp-tn bsp-tn (* -2 vm:word-bytes)) (inst bne bsp-tn special loop) - (nop) + (inst nop) (emit-label done)))) @@ -120,7 +120,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 22 - (inst addiu result fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu result fp-tn (* (tn-offset tn) vm:word-bytes)) (load-symbol-value temp lisp::*current-unwind-protect-block*) (storew temp result vm:unwind-block-current-uwp-slot) (storew fp-tn result vm:unwind-block-current-cont-slot) @@ -141,7 +141,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) (:generator 44 - (inst addiu result fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu result fp-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 fp-tn result vm:catch-block-current-cont-slot) @@ -164,7 +164,7 @@ (:args (tn)) (:temporary (:scs (descriptor-reg)) new-uwp) (:generator 7 - (inst addiu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes)) + (inst addu new-uwp fp-tn (* (tn-offset tn) vm:word-bytes)) (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) @@ -198,7 +198,6 @@ (:temporary (:scs (descriptor-reg)) move-temp) (:info label nvals) (:save-p :force-to-stack) - (:node-var node) (:generator 30 (emit-return-pc label) (cond ((zerop nvals)) @@ -218,30 +217,29 @@ (defaults (cons default-lab tn)) (inst beq count zero-tn default-lab) - (inst addiu count count (fixnum -1)) + (inst addu count 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))))) - + ((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) - (unassemble - (assemble-elsewhere node - (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))))) - (b defaulting-done) - (nop))))))) + (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)))))) (move csp-tn sp))) @@ -274,11 +272,11 @@ ;; Copy stuff on stack. (emit-label loop) (loadw temp src) - (inst addiu src src (fixnum 1)) + (inst addu src src (fixnum 1)) (storew temp dst) - (inst addiu num num (fixnum -1)) + (inst addu num num (fixnum -1)) (inst bne num zero-tn loop) - (inst addiu dst dst (fixnum 1)) + (inst addu dst dst (fixnum 1)) (emit-label done) (move csp-tn dst)))) diff --git a/compiler/mips/pred.lisp b/compiler/mips/pred.lisp index 8d2ae540d..3a4c19d6b 100644 --- a/compiler/mips/pred.lisp +++ b/compiler/mips/pred.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.3 1990/03/06 19:39:09 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.4 1990/04/24 02:56:27 wlott Exp $ ;;; ;;; This file contains the VM definition of predicate VOPs for the MIPS. ;;; @@ -27,8 +27,8 @@ (define-vop (branch) (:info dest) (:generator 5 - (b dest) - (nop))) + (inst b dest) + (inst nop))) ;;;; Conditional VOPs: @@ -54,6 +54,6 @@ (if not-p (inst bne x-prime y-prime target) (inst beq x-prime y-prime target))) - (nop))) + (inst nop))) diff --git a/compiler/mips/print.lisp b/compiler/mips/print.lisp index 1a0913bc4..5f6228dbb 100644 --- a/compiler/mips/print.lisp +++ b/compiler/mips/print.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.1 1990/03/18 23:45:13 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.2 1990/04/24 02:56:30 wlott Exp $ ;;; ;;; This file contains temporary printing utilities and similar noise. ;;; @@ -26,14 +26,14 @@ (:temporary (:scs (any-reg) :type fixnum) temp) (:generator 0 (let ((lra-label (gen-label))) - (inst addiu nsp-tn nsp-tn -16) + (inst addu nsp-tn nsp-tn -16) (storew object nsp-tn 0) - (inst load-foreign-address v0 "print") - (inst load-foreign-address temp "call_into_c") - (inst jr temp) + (inst li v0 (make-fixup "print" :foreign)) + (inst li temp (make-fixup "call_into_c" :foreign)) + (inst j temp) (inst compute-lra-from-code lra code lra-label) (align vm:lowtag-bits) (emit-label lra-label) (inst lra-header-word) - (inst addiu nsp-tn nsp-tn 16) + (inst addu nsp-tn nsp-tn 16) (move result v0)))) diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp index a198baf66..9f1c46a72 100644 --- a/compiler/mips/sap.lisp +++ b/compiler/mips/sap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.3 1990/04/23 16:45:19 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.4 1990/04/24 02:56:32 wlott Exp $ ;;; ;;; This file contains the MIPS VM definition of SAP operations. ;;; @@ -41,9 +41,9 @@ (:generator 1 (move sap x) (pseudo-atomic (ndescr) - (inst addiu y alloc-tn vm:other-pointer-type) - (inst addiu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size)) - (loadi ndescr (logior (ash vm:sap-size vm:type-bits) vm:sap-type)) + (inst addu y alloc-tn vm:other-pointer-type) + (inst addu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size)) + (inst li ndescr (logior (ash vm:sap-size vm:type-bits) vm:sap-type)) (storew y ndescr 0 vm:other-pointer-type) (storew y sap vm:sap-pointer-slot vm:other-pointer-type)))) ;;; diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp index 5807d205e..3841b8cbb 100644 --- a/compiler/mips/static-fn.lisp +++ b/compiler/mips/static-fn.lisp @@ -7,7 +7,7 @@ ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.5 1990/04/23 16:45:22 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.6 1990/04/24 02:56:34 wlott Exp $ ;;; ;;; This file contains the VOPs and macro magic necessary to call static ;;; functions. @@ -22,7 +22,6 @@ (:save-p t) (:policy :fast-safe) (:variant-vars symbol) - (:node-var node) (:temporary (:scs (any-reg)) temp) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc descriptor-reg :offset lra-offset) lra) @@ -87,7 +86,7 @@ (:generator ,(+ 50 num-args num-results) (let ((lra-label (gen-label))) ,@(moves (temp-names) (arg-names)) - (loadi nargs (fixnum ,num-args)) + (inst li nargs (fixnum ,num-args)) (load-symbol cname symbol) (loadw lexenv cname vm:symbol-function-slot vm:other-pointer-type) (move old-fp fp-tn) @@ -97,25 +96,21 @@ vm:function-pointer-type) (lisp-jump function lip) (emit-return-pc lra-label) - (unassemble - ,(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 node - ,(if (zerop num-results) - nil - 'values) - ,num-results - move-temp temp lra-label)))) + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values + ,(if (zerop num-results) nil 'values) + ,num-results move-temp temp lra-label)))) ,@(moves (result-names) (temp-names)))))))) @@ -135,6 +130,7 @@ ,(static-function-template-name (length args) (length results))) (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) ,@(when translate `((:translate ,translate))) ,@(when policy diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp index cda7e1685..7b94f18a7 100644 --- a/compiler/mips/subprim.lisp +++ b/compiler/mips/subprim.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.4 1990/04/01 18:05:07 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.5 1990/04/24 02:56:39 wlott Exp $ ;;; ;;; Linkage information for standard static functions, and random vops. ;;; @@ -29,12 +29,10 @@ count) (:results (result :scs (any-reg descriptor-reg))) (:policy :fast-safe) - (:node-var node) (:generator 50 (let ((done (gen-label)) (loop (gen-label)) - (not-list (generate-cerror-code node di:object-not-list-error - object))) + (not-list (generate-cerror-code di:object-not-list-error object))) (move ptr object) (move count zero-tn) @@ -46,7 +44,7 @@ (simple-test-simple-type ptr temp not-list t vm:list-pointer-type) (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type) - (inst addiu count count (fixnum 1)) + (inst addu count count (fixnum 1)) (simple-test-simple-type ptr temp loop nil vm:list-pointer-type) (cerror-call done di:object-not-list-error ptr) diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp index ec3b72731..b1757ee2e 100644 --- a/compiler/mips/system.lisp +++ b/compiler/mips/system.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.8 1990/03/21 23:32:43 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.9 1990/04/24 02:56:44 wlott Exp $ ;;; ;;; MIPS VM definitions of various system hacking operations. ;;; @@ -78,20 +78,20 @@ (shift (gen-label))) (simple-test-simple-type object ndescr other-ptr nil vm:other-pointer-type) - (inst andi ndescr object (logand (logeqv vm:other-immediate-0-type - vm:other-immediate-1-type) - vm:lowtag-mask)) - (inst xori ndescr ndescr (logand vm:other-immediate-0-type - vm:other-immediate-1-type)) + (inst and ndescr object (logand (logeqv vm:other-immediate-0-type + vm:other-immediate-1-type) + vm:lowtag-mask)) + (inst xor ndescr ndescr (logand vm:other-immediate-0-type + vm:other-immediate-1-type)) (inst bne ndescr zero-tn shift) - (inst andi ndescr object vm:lowtag-mask) - - (b shift) - (inst andi ndescr object vm:type-mask) - + (inst and ndescr object vm:lowtag-mask) + + (inst b shift) + (inst and ndescr object vm:type-mask) + (emit-label other-ptr) (load-type ndescr object) - + (emit-label shift) (inst sll result ndescr 2)))) @@ -112,7 +112,7 @@ (sc-case type ((immediate unsigned-immediate) (inst sll temp val vm:type-bits) - (inst ori res temp (tn-value type))) + (inst or res temp (tn-value type))) (t (inst sra temp type 2) (inst sll res val (- vm:type-bits 2)) diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp index 88aa23896..53296091f 100644 --- a/compiler/mips/type-vops.lisp +++ b/compiler/mips/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.9 1990/03/28 23:21:28 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.10 1990/04/24 02:56:47 wlott Exp $ ;;; ;;; This file contains the VM definition of type testing and checking VOPs ;;; for the RT. @@ -31,10 +31,9 @@ (:results (result :scs (any-reg descriptor-reg))) (:variant-vars type-code error-code) - (:node-var node) (:temporary (:type random :scs (non-descriptor-reg)) temp) (:generator 4 - (let ((err-lab (generate-error-code node error-code value))) + (let ((err-lab (generate-error-code error-code value))) (test-simple-type value temp err-lab t type-code) (move result value)))) @@ -105,9 +104,8 @@ (define-vop (check-fixnum check-simple-type) (:ignore type-code error-code) (:generator 3 - (let ((err-lab (generate-error-code node di:object-not-fixnum-error - value))) - (inst andi temp value #x3) + (let ((err-lab (generate-error-code di:object-not-fixnum-error value))) + (inst and temp value #x3) (inst bne temp zero-tn err-lab) (move result value t)))) @@ -117,11 +115,11 @@ (:ignore type-code) (:translate ext:fixnump) (:generator 3 - (inst andi temp value #x3) + (inst and temp value #x3) (if not-p (inst bne temp zero-tn target) (inst beq temp zero-tn target)) - (nop))) + (inst nop))) ;;;; Hairy type tests: @@ -144,8 +142,7 @@ :target res)) (:results (res :scs (any-reg descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) temp) - (:node-var node)) + (:temporary (:type random :scs (non-descriptor-reg)) temp)) (macrolet ((frob (pred-name check-name error-code &rest types) (let ((cost (* (+ (length types) @@ -161,8 +158,8 @@ ,@(when check-name `((define-vop (,check-name check-hairy-type) (:generator ,cost - (let ((err-lab (generate-error-code - node ,error-code obj))) + (let ((err-lab (generate-error-code ,error-code + obj))) (test-hairy-type obj temp err-lab t ,@types)) (move res obj))))))))) @@ -247,7 +244,7 @@ ,@body)) (define-vop (,check-name check-list-symbol) (:generator 8 - (let ((target (generate-error-code node ,error-code obj)) + (let ((target (generate-error-code ,error-code obj)) (not-p t)) ,@body (move res obj))))))) @@ -256,7 +253,7 @@ (let* ((drop-thru (gen-label)) (is-symbol-label (if not-p drop-thru target))) (inst beq obj null-tn is-symbol-label) - (nop) + (inst nop) (test-simple-type obj temp target not-p vm:symbol-header-type) (emit-label drop-thru))) @@ -264,7 +261,7 @@ (let* ((drop-thru (gen-label)) (is-not-cons-label (if not-p target drop-thru))) (inst beq obj null-tn is-not-cons-label) - (nop) + (inst nop) (test-simple-type obj temp target not-p vm:list-pointer-type) (emit-label drop-thru)))) @@ -279,7 +276,6 @@ (:args (object :scs (descriptor-reg) :target result)) (:results (result :scs (descriptor-reg))) - (:node-var node) (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) (:temporary (:scs (descriptor-reg)) saved-object) (:generator 0 @@ -291,16 +287,15 @@ (move result object) (emit-label done-label) - (unassemble - (assemble-elsewhere node - (emit-label not-function-label) - (test-simple-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-simple-type result nd-temp done-label nil - vm:function-pointer-type) - (error-call di:undefined-symbol-error saved-object) - - (emit-label not-coercable-label) - (error-call di:object-not-coercable-to-function-error object)))))) + (assemble (*elsewhere*) + (emit-label not-function-label) + (test-simple-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-simple-type result nd-temp done-label nil + vm:function-pointer-type) + (error-call di:undefined-symbol-error saved-object) + + (emit-label not-coercable-label) + (error-call di:object-not-coercable-to-function-error object))))) diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp index a7fdc0f4e..46e99fef2 100644 --- a/compiler/mips/values.lisp +++ b/compiler/mips/values.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.6 1990/04/03 03:01:51 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.7 1990/04/24 02:56:51 wlott Exp $ ;;; ;;; This file contains the implementation of unknown-values VOPs. ;;; @@ -46,7 +46,7 @@ start-temp) (:generator 20 (move start-temp csp-tn) - (inst addi csp-tn csp-tn (* nvals vm:word-bytes)) + (inst addu csp-tn csp-tn (* nvals vm:word-bytes)) (do ((val vals (tn-ref-across val)) (i 0 (1+ i))) ((null val)) @@ -58,7 +58,7 @@ (load-stack-tn temp tn) (storew temp start-temp i))))) (move start start-temp) - (loadi count (fixnum nvals)))) + (inst li count (fixnum nvals)))) ;;; Push a list of values on the stack, returning Start and Count as used in @@ -84,11 +84,11 @@ (inst beq list null-tn done) (loadw temp list vm:cons-car-slot vm:list-pointer-type) (loadw list list vm:cons-cdr-slot vm:list-pointer-type) - (inst addiu csp-tn csp-tn vm:word-bytes) + (inst addu csp-tn csp-tn vm:word-bytes) (storew temp csp-tn -1) (test-simple-type list ndescr loop nil vm:list-pointer-type) (error-call di:bogus-argument-to-values-list-error list) (emit-label done) - (inst sub count csp-tn start)))) + (inst subu count csp-tn start)))) -- GitLab