alloc.lisp 4.9 KB
Newer Older
1
;;; -*- Package: MIPS -*-
wlott's avatar
wlott committed
2 3
;;;
;;; **********************************************************************
4 5 6 7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/mips/alloc.lisp $")
wlott's avatar
wlott committed
9
;;;
10
;;; **********************************************************************
wlott's avatar
wlott committed
11 12 13 14 15 16
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;;

17
(in-package "MIPS")
wlott's avatar
wlott committed
18

wlott's avatar
wlott committed
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
#+gengc
(progn

#+assembler
(defparameter large-alloc-entry (gen-label))

#+assembler
(define-assembly-routine
    var-alloc
    ((:arg lowtag unsigned-reg nl0-offset)
     (:arg header unsigned-reg nl1-offset)
     (:arg words any-reg nargs-offset)

     (:temp ndescr non-descriptor-reg nl2-offset)

     (:res result descriptor-reg a0-offset))

  ;; Is it a large object?
37
  (inst slt ndescr words (1+ (fixnumize large-object-cutoff)))
wlott's avatar
wlott committed
38 39 40
  (inst beq ndescr large-alloc-entry)
  (inst nop)

rtoy's avatar
rtoy committed
41
  ;; Round words up to a dual-word.  This is kinda sleazy, changing words like
wlott's avatar
wlott committed
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
  ;; this.  But we can because the vop thinks it is temporary.
  (inst addu words (+ (1- (ash 1 lowtag-bits))
		      (* vector-data-offset word-bytes)))
  (inst li ndescr (lognot lowtag-mask))
  (inst and words ndescr)

  ;; And allocate it in the nursery.
  (without-scheduling ()
    (inst or result alloc-tn lowtag)
    (inst sw header alloc-tn)
    (inst addu alloc-tn alloc-tn words)))

(define-assembly-routine
    (allocate-vector
     (:policy :fast-safe)
     (:translate allocate-vector)
     (:arg-types positive-fixnum positive-fixnum positive-fixnum))
    ((:arg type unsigned-reg nl1-offset)
     (:arg length any-reg nl2-offset)
     (:arg words any-reg nargs-offset)

     (:temp ndescr non-descriptor-reg nl0-offset)
     (:temp cfunc unsigned-reg cfunc-offset)
     (:temp nl4 unsigned-reg nl4-offset)

     (:res result descriptor-reg a0-offset))

  (progn cfunc nl4) ; ignore em

  ;; Add in space for the header word and length.
  (inst addu words (* vector-data-offset word-bytes))

  ;; Is it a large object?
75
  (inst slt ndescr words (1+ (fixnumize large-object-cutoff)))
wlott's avatar
wlott committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
  (inst beq ndescr large-alloc-entry)
  ;; Load ndescr with other-pointer-type because if we take the branch, we
  ;; need nl0 loaded with the desired lowtag.
  (inst li ndescr other-pointer-type)

  ;; Round words up to a dual-word.  This is kinda sleezy, changing words like
  ;; this.  But we can because the vop thinks it is temporary.
  (inst addu words (1- (ash 1 lowtag-bits)))
  (inst li ndescr (lognot lowtag-mask))
  (inst and words ndescr)

  ;; And allocate it.
  (without-scheduling ()
    (inst or result alloc-tn other-pointer-type)
    (storew type alloc-tn)
    (storew length alloc-tn vector-length-slot)
    (inst addu alloc-tn words)))

#+assembler
(defmacro with-regs-saved ((&rest regs) &body body)
  (let ((stack-space-needed (* (logandc2 (1+ (length regs)) 1) word-bytes))
	(sc-var (gensym "DESCRIPTOR-REG-SC-")))
    `(let ((,sc-var (sc-or-lose 'descriptor-reg)))
99 100
       (inst addu csp-tn ,stack-space-needed)
       ,(iterate repeat ((remaining regs) (offset (- word-bytes)))
wlott's avatar
wlott committed
101 102 103 104 105 106 107 108 109
	  (if remaining
	      (let* ((reg (car remaining))
		     (tn-var (gensym (concatenate 'string (symbol-name reg)
						  "-TN-")))
		     (reg-offset (symbolicate reg "-OFFSET")))
		`(let ((,tn-var
			(make-random-tn :kind :normal :sc ,sc-var
					:offset ,reg-offset)))
		   (inst sw ,tn-var csp-tn ,offset)
110
		   ,(repeat (cdr remaining) (- offset word-bytes))
wlott's avatar
wlott committed
111 112
		   (inst lw ,tn-var csp-tn ,offset)))
	      `(progn ,@body)))
113
       (inst subu csp-tn ,stack-space-needed))))
wlott's avatar
wlott committed
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134

(define-assembly-routine
    (large-alloc
     (:info name)
     (:ignore name nl4 temp))
    ((:arg words any-reg nargs-offset)
     (:arg lowtag unsigned-reg nl0-offset)
     (:arg header any-reg nl1-offset)
     (:arg next-word any-reg nl2-offset)

     (:temp temp unsigned-reg cfunc-offset)
     (:temp nl4 unsigned-reg nl4-offset)

     (:res result descriptor-reg a0-offset))

  (progn words lowtag header next-word nl4)

  ;; var-alloc and allocate-vector jump to here if the result is going to
  ;; be large.
  (emit-label large-alloc-entry)

wlott's avatar
wlott committed
135 136
  ;; Disable interrupts.
  (loadw temp mutator-tn mutator-interrupts-disabled-count-slot)
137
  (inst addu temp temp 1)
wlott's avatar
wlott committed
138
  (storew temp mutator-tn mutator-interrupts-disabled-count-slot)
wlott's avatar
wlott committed
139 140

  (with-regs-saved (a1 a2 a3 a4 a5 fdefn lexenv ra)
141 142
    (inst li temp (make-fixup "allocate_large_object" :foreign))
    (inst jal (make-fixup "call_into_c" :foreign))
wlott's avatar
wlott committed
143 144 145 146
    (inst nop))

  (inst move result temp)

wlott's avatar
wlott committed
147 148
  ;; Re-enable interrupts.
  (loadw temp mutator-tn mutator-interrupts-disabled-count-slot)
149 150
  (inst subu temp temp 1)
  (inst bne temp zero-tn done)
wlott's avatar
wlott committed
151
  (storew temp mutator-tn mutator-interrupts-disabled-count-slot)
152
  ;; Check to see if any are pending.
wlott's avatar
wlott committed
153
  (loadw temp mutator-tn mutator-interrupt-pending-slot)
154 155 156 157 158
  (inst beq temp zero-tn done)
  (inst nop)

  (inst break pending-interrupt-trap)
  DONE)
wlott's avatar
wlott committed
159 160

); #+gengc progn