Skip to content
Snippets Groups Projects
alloc.lisp 7.43 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice 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 Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.13 1990/11/03 03:24:27 wlott Exp $
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 (:scs (non-descriptor-reg) :type random) ndescr)
  (: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 vm:cons-car-slot))
		  `(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 vm:list-pointer-type))))
	     (let ((cons-cells (if star (1- num) num)))
	       (pseudo-atomic (ndescr)
wlott's avatar
wlott committed
		 (inst addu res alloc-tn vm:list-pointer-type)
		 (inst addu alloc-tn alloc-tn
		       (* (vm:pad-data-block vm:cons-size) cons-cells))
		 (move ptr res)
		 (dotimes (i (1- cons-cells))
		   (store-car (tn-ref-tn things) ptr)
		   (setf things (tn-ref-across things))
wlott's avatar
wlott committed
		   (inst addu ptr ptr (vm:pad-data-block vm:cons-size))
		   (storew ptr ptr
			   (- vm:cons-cdr-slot vm:cons-size)
			   vm: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 vm:cons-cdr-slot))
		       (t
			(storew null-tn ptr
				vm:cons-cdr-slot vm: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)
  (:generator 100
    (inst li ndescr (lognot vm:lowtag-mask))
    (inst addu boxed boxed-arg (fixnum (1+ vm:code-constants-offset)))
wlott's avatar
wlott committed
    (inst and boxed ndescr)
    (inst srl unboxed unboxed-arg vm:word-shift)
    (inst addu unboxed unboxed vm:lowtag-mask)
    (inst and unboxed ndescr)
wlott's avatar
wlott committed
    (pseudo-atomic (ndescr)
wlott's avatar
wlott committed
      (inst addu result alloc-tn vm:other-pointer-type)
      (inst addu alloc-tn boxed)
      (inst addu alloc-tn unboxed)
      (inst sll ndescr boxed (- vm:type-bits vm:word-shift))
      (inst or ndescr vm:code-header-type)
      (storew ndescr result 0 vm:other-pointer-type)
      (storew unboxed result vm:code-code-size-slot vm:other-pointer-type)
      (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type)
      (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type))))
  (:args (name :scs (descriptor-reg) :to :eval))
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:results (result :scs (descriptor-reg) :from :argument))
  (:policy :fast-safe)
  (:translate make-symbol)
  (:generator 37
    (with-fixed-allocation (result temp vm:symbol-header-type vm:symbol-size)
      (inst li temp vm:unbound-marker-type)
      (storew temp result vm:symbol-value-slot vm:other-pointer-type)
      (storew temp result vm:symbol-function-slot vm:other-pointer-type)
      (storew temp result vm:symbol-setf-function-slot vm:other-pointer-type)
      (inst li temp (make-fixup "undefined_tramp" :foreign))
      (storew temp result vm:symbol-raw-function-addr-slot
	      vm:other-pointer-type)
      (storew null-tn result vm:symbol-plist-slot vm:other-pointer-type)
      (storew name result vm:symbol-name-slot vm:other-pointer-type)
      (storew null-tn result vm:symbol-package-slot vm:other-pointer-type))))

;;;; Automatic allocators for primitive objects.

(vm:define-for-each-primitive-object (obj)
  (collect ((forms))
    (let* ((options (vm:primitive-object-options obj))
	   (obj-type (getf options :type t))
	   (alloc-trans (getf options :alloc-trans))
	   (alloc-vop (getf options :alloc-vop alloc-trans))
	   (header (vm:primitive-object-header obj))
	   (lowtag (vm:primitive-object-lowtag obj))
	   (size (vm:primitive-object-size obj))
	   (variable-length (vm:primitive-object-variable-length obj))
	   (need-unbound-marker nil))
      (collect ((args) (init-forms))
	(when (and alloc-vop variable-length)
	  (args 'extra-words))
	(dolist (slot (vm:primitive-object-slots obj))
	  (let* ((name (vm:slot-name slot))
		 (offset (vm:slot-offset slot)))
	    (ecase (getf (vm: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) (vm:primitive-object-name obj)))
	(when alloc-vop
	  (forms
	   `(define-vop (,alloc-vop)
	      (:args ,@(mapcar #'(lambda (name)
				   `(,name :scs (any-reg descriptor-reg)))
			       (args)))
	      (:temporary (:scs (non-descriptor-reg) :type random)
			  ndescr
			  ,@(when (or need-unbound-marker header
				      variable-length)
			      '(temp)))
	      (:temporary (:scs (descriptor-reg) :to (:result 0)
				:target real-result) result)
	      (:results (real-result :scs (descriptor-reg)))
	      (:policy :fast-safe)
	      ,@(when alloc-trans
		  `((:translate ,alloc-trans)))
	      (:generator 37
		(pseudo-atomic (ndescr)
		  (inst addu result alloc-tn ,lowtag)
		  ,@(cond ((and header variable-length)
			   `((inst addu temp extra-words
				   (fixnum (1- ,size)))
			     (inst addu alloc-tn alloc-tn temp)
			     (inst sll temp temp
				   (- vm:type-bits vm:word-shift))
			     (inst or temp temp ,header)
			     (storew temp result 0 ,lowtag)
			     (inst addu alloc-tn alloc-tn
				   (+ (fixnum 1) vm:lowtag-mask))
			     (inst li temp (lognot vm:lowtag-mask))
			     (inst and alloc-tn alloc-tn temp)))
			  (variable-length
			   (error ":REST-P T with no header in ~S?"
				  (vm:primitive-object-name obj)))
			  (header
			   `((inst addu alloc-tn alloc-tn
				   (vm:pad-data-block ,size))
			     (inst li temp
				   ,(logior (ash (1- size) vm:type-bits)
			     (storew temp result 0 ,lowtag)))
			  (t
			   `((inst addu alloc-tn alloc-tn
				   (vm:pad-data-block ,size)))))
		  ,@(when need-unbound-marker
		      `((inst li temp vm:unbound-marker-type)))
		  ,@(init-forms)
		  (move real-result result))))))))
    (when (forms)
      `(progn
	 ,@(forms)))))