Skip to content
Snippets Groups Projects
Commit c1d3212f authored by wlott's avatar wlott
Browse files

Supply the backend arg to sc-or-lose and friends when necessary to get

at the runtime info.
parent 5a3328b5
No related branches found
No related tags found
No related merge requests found
......@@ -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)
......
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment