From 9d8023c9846fe35c5b5a5cae031cb07e68133a43 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 26 Jul 1991 01:45:53 +0000
Subject: [PATCH] Initial revision

---
 assembly/mips/wrlist.lisp | 259 ++++++++++++++++++++++++++++++++++++++
 compiler/mips/utils.lisp  |  80 ++++++++++++
 2 files changed, 339 insertions(+)
 create mode 100644 assembly/mips/wrlist.lisp
 create mode 100644 compiler/mips/utils.lisp

diff --git a/assembly/mips/wrlist.lisp b/assembly/mips/wrlist.lisp
new file mode 100644
index 000000000..b38ccce00
--- /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 000000000..b413d600b
--- /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)))))
-- 
GitLab