diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp index b227b908a5645e81456dcf6a60e8d0d9e6d02401..e6c04355f4b83b252d87ed08ed5087eaab2d86ed 100644 --- a/compiler/mips/c-call.lisp +++ b/compiler/mips/c-call.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/c-call.lisp,v 1.2 1990/11/03 18:13:36 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.3 1990/11/13 22:59:51 wlott Exp $ ;;; ;;; This file contains the VOPs and other necessary machine specific support ;;; routines for call-out to C. @@ -16,10 +16,13 @@ ;;; (in-package "MIPS") +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) + (sc-number-or-lose sc-name *backend*) + offset)) + (def-vm-support-routine make-call-out-nsp-tn () - (make-wired-tn (primitive-type-or-lose 'positive-fixnum) - (sc-number-or-lose 'any-reg) - nsp-offset)) + (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)) (def-vm-support-routine make-call-out-argument-tns (arg-types) (let ((stack-frame-size 0) @@ -31,60 +34,58 @@ (ecase name ((unsigned-byte port) (if (< stack-frame-size 4) - (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) - (sc-number-or-lose 'unsigned-reg) - (+ stack-frame-size 4))) - (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) - (sc-number-or-lose 'unsigned-stack) - stack-frame-size))) + (tns (my-make-wired-tn 'unsigned-byte-32 + 'unsigned-reg + (+ stack-frame-size 4))) + (tns (my-make-wired-tn 'unsigned-byte-32 + 'unsigned-stack + stack-frame-size))) (incf stack-frame-size) (setf did-int-arg t)) (signed-byte (if (< stack-frame-size 4) - (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32) - (sc-number-or-lose 'signed-reg) - (+ stack-frame-size 4))) - (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32) - (sc-number-or-lose 'signed-stack) - stack-frame-size))) + (tns (my-make-wired-tn 'signed-byte-32 + 'signed-reg + (+ stack-frame-size 4))) + (tns (my-make-wired-tn 'signed-byte-32 + 'signed-stack + stack-frame-size))) (incf stack-frame-size) (setf did-int-arg t)) (system-area-pointer (if (< stack-frame-size 4) - (tns (make-wired-tn (primitive-type-or-lose - 'system-area-pointer) - (sc-number-or-lose 'sap-reg) - (+ stack-frame-size 4))) - (tns (make-wired-tn (primitive-type-or-lose - 'system-area-pointer) - (sc-number-or-lose 'sap-stack) - stack-frame-size))) + (tns (my-make-wired-tn 'system-area-pointer + 'sap-reg + (+ stack-frame-size 4))) + (tns (my-make-wired-tn 'system-area-pointer + 'sap-stack + stack-frame-size))) (incf stack-frame-size) (setf did-int-arg t)) (double-float ;; Round to a dual-word. (setf stack-frame-size (logandc2 (1+ stack-frame-size) 1)) (cond ((>= stack-frame-size 4) - (tns (make-wired-tn (primitive-type-or-lose 'double-float) - (sc-number-or-lose 'double-stack) - stack-frame-size))) + (tns (my-make-wired-tn 'double-float + 'double-stack + stack-frame-size))) ((and (not did-int-arg) (< float-args 2)) - (tns (make-wired-tn (primitive-type-or-lose 'double-float) - (sc-number-or-lose 'double-reg) - (+ (* float-args 2) 12)))) + (tns (my-make-wired-tn 'double-float + 'double-reg + (+ (* float-args 2) 12)))) (t (error "Can't put floats in int regs yet."))) (incf stack-frame-size 2) (incf float-args)) (single-float (cond ((>= stack-frame-size 4) - (tns (make-wired-tn (primitive-type-or-lose 'single-float) - (sc-number-or-lose 'single-stack) - stack-frame-size))) + (tns (my-make-wired-tn 'single-float + 'single-stack + stack-frame-size))) ((and (not did-int-arg) (< float-args 2)) - (tns (make-wired-tn (primitive-type-or-lose 'single-float) - (sc-number-or-lose 'single-reg) - (+ (* float-args 2) 12)))) + (tns (my-make-wired-tn 'single-float + 'single-reg + (+ (* float-args 2) 12)))) (t (error "Can't put floats in int regs yet."))) (incf stack-frame-size) @@ -96,25 +97,16 @@ (let ((name (if (consp type) (car type) type))) (ecase name ((unsigned-byte port) - (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) - (sc-number-or-lose 'unsigned-reg) - 2)) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg 2)) (signed-byte - (make-wired-tn (primitive-type-or-lose 'signed-byte-32) - (sc-number-or-lose 'signed-reg) - 2)) + (my-make-wired-tn 'signed-byte-32 'signed-reg 2)) (system-area-pointer - (make-wired-tn (primitive-type-or-lose 'system-area-pointer) - (sc-number-or-lose 'sap-reg) - 2)) + (my-make-wired-tn 'system-area-pointer 'sap-reg 2)) (double-float - (make-wired-tn (primitive-type-or-lose 'double-float) - (sc-number-or-lose 'double-reg) - 0)) + (my-make-wired-tn 'double-float 'double-reg 0)) (single-float - (make-wired-tn (primitive-type-or-lose 'single-float) - (sc-number-or-lose 'single-reg) - 0))))) + (my-make-wired-tn 'single-float 'single-reg 0))))) + (define-vop (foreign-symbol-address) (:info foreign-symbol) diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp index 6f8c56aca0f001019a265998aee875a01c6ceba9..8d51611d89f61f8464d75bf120da57d9898517ba 100644 --- a/compiler/mips/vm.lisp +++ b/compiler/mips/vm.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/vm.lisp,v 1.37 1990/11/07 13:17:37 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.38 1990/11/13 23:00:46 wlott Exp $ ;;; ;;; This file contains the VM definition for the MIPS R2000 and the new ;;; object format. @@ -297,32 +297,32 @@ (def-vm-support-routine immediate-constant-sc (value) (typecase value ((integer 0 0) - (sc-number-or-lose 'zero)) + (sc-number-or-lose 'zero *backend*)) (null - (sc-number-or-lose 'null)) + (sc-number-or-lose 'null *backend*)) ((integer #x-1FFF #x-0001) - (sc-number-or-lose 'negative-immediate)) + (sc-number-or-lose 'negative-immediate *backend*)) ((integer 0 #x1FFE) - (sc-number-or-lose 'immediate)) + (sc-number-or-lose 'immediate *backend*)) ((integer #x1FFF #x3FFE) - (sc-number-or-lose 'unsigned-immediate)) + (sc-number-or-lose 'unsigned-immediate *backend*)) (symbol (if (vm:static-symbol-p value) - (sc-number-or-lose 'random-immediate) + (sc-number-or-lose 'random-immediate *backend*) nil)) (#-new-compiler (signed-byte 30) #+new-compiler fixnum - (sc-number-or-lose 'random-immediate)) + (sc-number-or-lose 'random-immediate *backend*)) #+new-compiler (system-area-pointer - (sc-number-or-lose 'immediate-sap)) + (sc-number-or-lose 'immediate-sap *backend*)) (character #-new-compiler (if (string-char-p value) - (sc-number-or-lose 'immediate-base-character) + (sc-number-or-lose 'immediate-base-character *backend*) nil) #+new-compiler - (sc-number-or-lose 'immediate-base-character)))) + (sc-number-or-lose 'immediate-base-character *backend*)))) ;;;; Function Call Parameters