Skip to content
Snippets Groups Projects
alloc.lisp 6.97 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: MIPS -*-
wlott's avatar
wlott committed
;;;
;;; **********************************************************************
ram's avatar
ram committed
;;; 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/alloc.lisp,v 1.18 1992/08/02 20:24:36 wlott Exp $")
ram's avatar
ram committed
;;;
wlott's avatar
wlott committed
;;; **********************************************************************
;;;
;;; Allocation VOPs for the MIPS port.
;;;
;;; Written by William Lott.
;;; 

wlott's avatar
wlott committed
(define-vop (list-or-list*)
  (:args (things :more t))
  (:temporary (:scs (descriptor-reg) :type list) ptr)
  (:temporary (:scs (descriptor-reg)) temp)
  (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
	      res)
  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
wlott's avatar
wlott committed
  (:info num)
  (:results (result :scs (descriptor-reg)))
  (:variant-vars star)
  (:policy :safe)
  (:generator 0
    (cond ((zerop num)
	   (move result null-tn))
	  ((and star (= num 1))
	   (move result (tn-ref-tn things)))
	  (t
	   (macrolet
	       ((store-car (tn list &optional (slot cons-car-slot))
wlott's avatar
wlott committed
		  `(let ((reg
			  (sc-case ,tn
			    ((any-reg descriptor-reg) ,tn)
			    (zero zero-tn)
			    (null null-tn)
			    (control-stack
			     (load-stack-tn temp ,tn)
			     temp))))
		     (storew reg ,list ,slot list-pointer-type))))
wlott's avatar
wlott committed
	     (let ((cons-cells (if star (1- num) num)))
	       (pseudo-atomic (pa-flag
			       :extra (* (pad-data-block cons-size)
					 cons-cells))
		 (inst or res alloc-tn list-pointer-type)
		 (move ptr res)
		 (dotimes (i (1- cons-cells))
		   (store-car (tn-ref-tn things) ptr)
		   (setf things (tn-ref-across things))
		   (inst addu ptr ptr (pad-data-block cons-size))
			   (- cons-cdr-slot cons-size)
			   list-pointer-type))
wlott's avatar
wlott committed
		 (store-car (tn-ref-tn things) ptr)
		 (cond (star
			(setf things (tn-ref-across things))
			(store-car (tn-ref-tn things) ptr cons-cdr-slot))
				cons-cdr-slot list-pointer-type)))
		 (assert (null (tn-ref-across things)))
		 (move result res))))))))
wlott's avatar
wlott committed

(define-vop (list list-or-list*)
  (:variant nil))

(define-vop (list* list-or-list*)
  (:variant t))
wlott's avatar
wlott committed


;;;; Special purpose inline allocators.
wlott's avatar
wlott committed

(define-vop (allocate-code-object)
  (:args (boxed-arg :scs (any-reg))
	 (unboxed-arg :scs (any-reg)))
  (:results (result :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
wlott's avatar
wlott committed
  (:generator 100
    (inst li ndescr (lognot lowtag-mask))
    (inst addu boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot)))
wlott's avatar
wlott committed
    (inst and boxed ndescr)
    (inst srl unboxed unboxed-arg word-shift)
    (inst addu unboxed unboxed lowtag-mask)
wlott's avatar
wlott committed
    (inst and unboxed ndescr)
    (pseudo-atomic (pa-flag)
      (inst or result alloc-tn other-pointer-type)
wlott's avatar
wlott committed
      (inst addu alloc-tn boxed)
      (inst addu alloc-tn unboxed)
      (inst sll ndescr boxed (- type-bits word-shift))
      (inst or ndescr code-header-type)
      (storew ndescr result 0 other-pointer-type)
      (storew unboxed result code-code-size-slot other-pointer-type)
      (storew null-tn result code-entry-points-slot other-pointer-type)
      (storew null-tn result code-debug-info-slot other-pointer-type))))
wlott's avatar
wlott committed
(define-vop (make-fdefn)
  (:policy :fast-safe)
  (:translate make-fdefn)
  (:args (name :scs (descriptor-reg) :to :eval))
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
  (:results (result :scs (descriptor-reg) :from :argument))
    (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size)
wlott's avatar
wlott committed
      (storew name result fdefn-name-slot other-pointer-type)
      (storew null-tn result fdefn-function-slot other-pointer-type)
      (inst li temp (make-fixup "undefined_tramp" :foreign))
wlott's avatar
wlott committed
      (storew temp result fdefn-raw-addr-slot other-pointer-type))))

;;;; Automatic allocators for primitive objects.

(define-for-each-primitive-object (obj)
  (let* ((options (primitive-object-options obj))
	 (alloc-trans (getf options :alloc-trans))
	 (alloc-vop (getf options :alloc-vop alloc-trans))
	 (header (primitive-object-header obj))
	 (lowtag (primitive-object-lowtag obj))
	 (size (primitive-object-size obj))
	 (variable-length (primitive-object-variable-length obj))
	 (need-unbound-marker nil))
    (collect ((args) (init-forms))
      (when (and alloc-vop variable-length)
	(args 'extra-words))
      (dolist (slot (primitive-object-slots obj))
	(let* ((name (slot-name slot))
	       (offset (slot-offset slot)))
	  (ecase (getf (slot-options slot) :init :zero)
	    (:zero)
	    (:null
	     (init-forms `(storew null-tn result ,offset ,lowtag)))
	    (:unbound
	     (setf need-unbound-marker t)
	     (init-forms `(storew temp result ,offset ,lowtag)))
	    (:arg
	     (args name)
	     (init-forms `(storew ,name result ,offset ,lowtag))))))
      (when (and (null alloc-vop) (args))
	(error "Slots ~S want to be initialized, but there is no alloc vop ~
		defined for ~S."
	       (args) (primitive-object-name obj)))
      (when alloc-vop
	`(define-vop (,alloc-vop)
	   (:args ,@(mapcar #'(lambda (name)
				`(,name :scs (any-reg descriptor-reg)))
			    (args)))
	   (:temporary (:scs (non-descriptor-reg))
		       ,@(when (or header need-unbound-marker)
			   '(temp))
		       ,@(when variable-length '(temp2)))
	   (:temporary (:scs (descriptor-reg) :to (:result 0)
			     :target real-result) result)
	   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
	   (:results (real-result :scs (descriptor-reg)))
	   (:policy :fast-safe)
	   ,@(when alloc-trans
	       `((:translate ,alloc-trans)))
	   (:generator ,(+ 4
			   (length (init-forms))
			   (if header 2 0)
			   (if variable-length 6 0)
			   (if need-unbound-marker 1 0))
	     (pseudo-atomic
		 (pa-flag :extra ,(if variable-length
				      0
				      `(pad-data-block ,size)))
	       (inst or result alloc-tn ,lowtag)
	       ,@(cond ((and header variable-length)
			`((inst addu temp extra-words (fixnum (1+ ,size)))
			  (inst li temp2 (lognot lowtag-mask))
			  (inst and temp temp2)
			  (inst addu alloc-tn temp)
			  (inst addu temp extra-words (fixnum (1- ,size)))
			  (inst sll temp (- type-bits word-shift))
			  (inst or temp temp ,header)
			  (storew temp result 0 ,lowtag)))
		       (variable-length
			(error ":REST-P T with no header in ~S?"
			       (primitive-object-name obj)))
		       (header
				,(logior (ash (1- size) type-bits)
					 (symbol-value header)))
			  (storew temp result 0 ,lowtag))))
	       ,@(when need-unbound-marker
		   `((inst li temp unbound-marker-type)))
	       ,@(init-forms)
	       (move real-result result))))))))