Skip to content
Snippets Groups Projects
alloc.lisp 3.46 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). 
;;; **********************************************************************
;;;
wlott's avatar
wlott committed
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.5 1990/05/25 12:24:49 wlott Exp $
wlott's avatar
wlott committed
;;;
;;; Allocation VOPs for the MIPS port.
;;;
;;; Written by William Lott.
;;; 

wlott's avatar
wlott committed
(in-package "C")


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


(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))
    (inst and boxed ndescr)
    (inst srl unboxed unboxed-arg vm:word-shift)
    (inst addu unboxed unboxed vm:lowtag-mask)
    (inst and unboxed ndescr)
    (pseudo-atomic (ndesrc)
      (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))))