;;; -*- 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.
;;;
(ext:file-comment
  "$Header: src/assembly/mips/alloc.lisp $")
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;;

(in-package "MIPS")

#+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?
  (inst slt ndescr words (1+ (fixnumize large-object-cutoff)))
  (inst beq ndescr large-alloc-entry)
  (inst nop)

  ;; Round words up to a dual-word.  This is kinda sleazy, changing words like
  ;; 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?
  (inst slt ndescr words (1+ (fixnumize large-object-cutoff)))
  (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)))
       (inst addu csp-tn ,stack-space-needed)
       ,(iterate repeat ((remaining regs) (offset (- word-bytes)))
	  (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)
		   ,(repeat (cdr remaining) (- offset word-bytes))
		   (inst lw ,tn-var csp-tn ,offset)))
	      `(progn ,@body)))
       (inst subu csp-tn ,stack-space-needed))))

(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)

  ;; Disable interrupts.
  (loadw temp mutator-tn mutator-interrupts-disabled-count-slot)
  (inst addu temp temp 1)
  (storew temp mutator-tn mutator-interrupts-disabled-count-slot)

  (with-regs-saved (a1 a2 a3 a4 a5 fdefn lexenv ra)
    (inst li temp (make-fixup "allocate_large_object" :foreign))
    (inst jal (make-fixup "call_into_c" :foreign))
    (inst nop))

  (inst move result temp)

  ;; Re-enable interrupts.
  (loadw temp mutator-tn mutator-interrupts-disabled-count-slot)
  (inst subu temp temp 1)
  (inst bne temp zero-tn done)
  (storew temp mutator-tn mutator-interrupts-disabled-count-slot)
  ;; Check to see if any are pending.
  (loadw temp mutator-tn mutator-interrupt-pending-slot)
  (inst beq temp zero-tn done)
  (inst nop)

  (inst break pending-interrupt-trap)
  DONE)

); #+gengc progn
