diff --git a/assembly/mips/wrlist.lisp b/assembly/mips/wrlist.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b38ccce003b6f2df59331876c7a315ce78df75b9 --- /dev/null +++ b/assembly/mips/wrlist.lisp @@ -0,0 +1,259 @@ +;;; -*- Package: MIPS -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/wrlist.lisp,v 1.1 1991/07/26 01:45:53 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the assembly routines for write-list support. +;;; + +(in-package "MIPS") + +(define-assembly-routine + (write-list-record) + ((:arg object descriptor-reg a0-offset) + (:arg offset non-descriptor-reg nl2-offset) + (:arg value descriptor-reg a1-offset) + + (:temp nl0 non-descriptor-reg nl0-offset) + (:temp nl1 non-descriptor-reg nl1-offset) + + (:temp a2 any-reg a2-offset) + (:temp a3 any-reg a3-offset) + (:temp a4 any-reg a4-offset) + (:temp a5 any-reg a5-offset) + (:temp cname any-reg cname-offset) + (:temp lexenv any-reg lexenv-offset) + (:temp l0 any-reg l0-offset) + (:temp l1 any-reg l1-offset) + (:temp l2 any-reg l2-offset) + (:temp l3 any-reg l3-offset) + (:temp nfp any-reg nfp-offset) + (:temp ocfp any-reg ocfp-offset) + (:temp lra any-reg lra-offset)) + + ;; The write into memory and the write into the write-list have to be atomic. + (start-pseudo-atomic) + + TRY-AGAIN + + ;; First, make sure there is space available in the write list. + (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) + (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) + (inst nop) + (inst bne nl0 nl1 space-available) + (inst nop) + + ;; No space, so we have to call out to gengc_FlushWriteList. + + ;; We have to save all the descriptor registers on the stack in case + ;; we end up collecting garbage while in C. + + ;; Save all lisp regs on the stack, so the garbage collector can find them. + (save-regs-on-stack (object value a2 a3 a4 a5 cname lexenv + l0 l1 l2 l3 nfp ocfp code-tn lra null-tn) + + ;; Convert the return address into an offset. We don't have to save l0 + ;; across the call-out because it is one of the saved regs. + (inst subu l0 lip-tn code-tn) + + ;; Decache all the lisp state from the mutator structure. + (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) + (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) + + ;; Indicate that we are now in foreign-function-call land. + (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) + + ;; Turn off pseudo-atomic. + (end-pseudo-atomic nl0) + + ;; Move offset to one of the saved registers. + (inst move l1 offset) + + ;; Allocate the stack frame. + (inst subu nsp-tn nsp-tn (* 4 word-bytes)) + + ;; Restore GP + (inst li null-tn (make-fixup "_gp" :foreign)) + + ;; Call-out to gengc_Allocate, setting up the single argument. + (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) + (inst move nl0 mutator-tn) + + ;; Deallocate the stack frame. + (inst addu nsp-tn nsp-tn (* 4 word-bytes)) + + ;; Restore offset from the saved reg. + (inst move offset l1) + + ;; Trun pseudo-atomic back on. + (start-pseudo-atomic) + + ;; No longer in foreign-foreign-call land. + (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) + + ;; Cache lisp state from the mutator structure. + (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) + (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) + + ;; We can't restore the return address yet, because code hasn't been + ;; restored. But if we wait until after code has been restored, + ;; then l0 will have been trashed. So we have to move the value + ;; out of l0 and into nl0. + (inst move nl0 l0) + + ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) + ) + + ;; Regenerate the return address from the saved offset. + (inst addu lip-tn nl0 code-tn) + + ;; Because we turned off pseudo-atomic, we might have taken an interrupt, + ;; so we can't be sure the write-list will be empty. + (inst b try-again) + (inst nop) + + SPACE-AVAILABLE + + (inst addu nl1 object offset) + (inst sw nl1 nl0) + (inst sw value nl1) + (inst addu nl0 4) + (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) + + (end-pseudo-atomic nl0)) + + +(define-assembly-routine + (set-symbol-function) + ((:arg symbol descriptor-reg a0-offset) + (:arg function descriptor-reg a1-offset) + + (:temp nl0 non-descriptor-reg nl0-offset) + (:temp nl1 non-descriptor-reg nl1-offset) + + (:temp a2 any-reg a2-offset) + (:temp a3 any-reg a3-offset) + (:temp a4 any-reg a4-offset) + (:temp a5 any-reg a5-offset) + (:temp cname any-reg cname-offset) + (:temp lexenv any-reg lexenv-offset) + (:temp l0 any-reg l0-offset) + (:temp l1 any-reg l1-offset) + (:temp l2 any-reg l2-offset) + (:temp l3 any-reg l3-offset) + (:temp nfp any-reg nfp-offset) + (:temp ocfp any-reg ocfp-offset)) + + ;; The write into memory and the write into the write-list have to be atomic. + (start-pseudo-atomic) + + ;; First, check to see if we don't need to make a write-list entry. + (inst srl nl0 symbol 30) + (inst bne nl0 zero-tn just-do-write) + (inst nop) + + TRY-AGAIN + + ;; Now make sure there is space available in the write list. + (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) + (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) + (inst nop) + (inst bne nl0 nl1 space-available) + (inst nop) + + ;; No space, so we have to call out to gengc_FlushWriteList. + + ;; We have to save all the descriptor registers on the stack in case + ;; we end up collecting garbage while in C. + + ;; Save all lisp regs on the stack, so the garbage collector can find them. + (save-regs-on-stack (symbol function a2 a3 a4 a5 cname lexenv + l0 l1 l2 l3 nfp ocfp null-tn) + + ;; Convert the return address into an offset. We don't have to save l0 + ;; across the call-out because it is one of the saved regs. + (inst subu l0 lip-tn code-tn) + + ;; Decache all the lisp state from the mutator structure. + (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) + (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) + + ;; Indicate that we are now in foreign-function-call land. + (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) + + ;; Turn off pseudo-atomic. + (end-pseudo-atomic nl0) + + ;; Allocate the stack frame. + (inst subu nsp-tn nsp-tn (* 4 word-bytes)) + + ;; Restore GP + (inst li null-tn (make-fixup "_gp" :foreign)) + + ;; Call-out to gengc_Allocate, setting up the single argument. + (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) + (inst move nl0 mutator-tn) + + ;; Deallocate the stack frame. + (inst addu nsp-tn nsp-tn (* 4 word-bytes)) + + ;; Trun pseudo-atomic back on. + (start-pseudo-atomic) + + ;; No longer in foreign-foreign-call land. + (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) + + ;; Cache lisp state from the mutator structure. + (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) + (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) + + ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) + ) + + ;; Regenerate the return address from the saved offset. + (inst addu lip-tn l0 code-tn) + + ;; Because we turned off pseudo-atomic, we might have taken an interrupt, + ;; so we can't be sure the write-list will be empty. + (inst b try-again) + (inst nop) + + SPACE-AVAILABLE + + (inst subu nl1 symbol other-pointer-type) + (inst sw nl1 nl0) + (inst addu nl0 4) + (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) + + JUST-DO-WRITE + + (load-type nl0 function (- vm:function-pointer-type)) + (inst nop) + (inst xor nl0 vm:closure-header-type) + (inst beq nl0 zero-tn closure) + (inst xor nl0 (logxor closure-header-type funcallable-instance-header-type)) + (inst beq nl0 zero-tn closure) + (inst xor nl0 (logxor funcallable-instance-header-type function-header-type)) + (inst beq nl0 zero-tn normal-fn) + (inst addu nl1 function + (- (ash vm:function-header-code-offset vm:word-shift) + vm:function-pointer-type)) + (end-pseudo-atomic nl0) + (error-call nil kernel:object-not-function-error function) + + CLOSURE + (inst li nl1 (make-fixup "closure_tramp" :foreign)) + + NORMAL-FN + (storew function symbol symbol-function-slot other-pointer-type) + (storew nl1 symbol symbol-raw-function-addr-slot other-pointer-type) + + (end-pseudo-atomic nl0)) diff --git a/compiler/mips/utils.lisp b/compiler/mips/utils.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b413d600b19f9b3712ddd4fcdf639c25bbd0051b --- /dev/null +++ b/compiler/mips/utils.lisp @@ -0,0 +1,80 @@ +;;; -*- Package: MIPS; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/utils.lisp,v 1.1 1991/07/26 01:44:45 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains various useful utilities for generating MIPS code. +;;; +;;; Written by William Lott and Christopher Hoover. +;;; + +(in-package "MIPS") + + + +;;;; Three Way Comparison + +(defun three-way-comparison (x y condition flavor not-p target temp) + (ecase condition + (:eq + (if not-p + (inst bne x y target) + (inst beq x y target))) + (:lt + (ecase flavor + (:unsigned + (inst sltu temp x y)) + (:signed + (inst slt temp x y))) + (if not-p + (inst beq temp zero-tn target) + (inst bne temp zero-tn target))) + (:gt + (ecase flavor + (:unsigned + (inst sltu temp y x)) + (:signed + (inst slt temp y x))) + (if not-p + (inst beq temp zero-tn target) + (inst bne temp zero-tn target)))) + (inst nop)) + + +;;;; Pseudo-atomic support. + +(defun start-pseudo-atomic () + ;; I don't think that we need to clear the interrupted slot. It should + ;; be clear already. + ;(storew zero-tn mutator-tn mutator-pseudo-atomic-interrupted-slot) + (storew csp-tn mutator-tn mutator-pseudo-atomic-atomic-slot)) + +(defun end-pseudo-atomic (ndescr) + (let ((label (gen-label))) + (storew zero-tn mutator-tn mutator-pseudo-atomic-atomic-slot) + (loadw ndescr mutator-tn mutator-pseudo-atomic-interrupted-slot) + (inst beq ndescr label) + (inst nop) + (inst break pending-interrupt-trap) + (emit-label label))) + + + +;;;; write-list support. + +(defun check-pointer-ages-p (vop value) + (and (sc-is value descriptor-reg) + (let ((option (assoc :check-pointer-ages + (c::lexenv-options + (c::node-lexenv + (c::vop-node vop)))))) + (or (null option) + (cdr option)))))