diff --git a/assembly/mips/alloc.lisp b/assembly/mips/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cbe1475b0c638f2c73c662352199383dcd1ed0c9 --- /dev/null +++ b/assembly/mips/alloc.lisp @@ -0,0 +1,93 @@ +;;; -*- Log: code.log; 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/assembly/mips/alloc.lisp,v 1.1 1990/10/29 14:00:54 wlott Exp $ +;;; +;;; Stuff to handle allocating simple objects. +;;; +;;; Written by William Lott. +;;; + +(in-package "C") + +(vm:define-for-each-primitive-object (obj) + (let* ((options (vm:primitive-object-options obj)) + (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 + `(define-assembly-routine + (,alloc-vop + (:cost 35) + ,@(when alloc-trans + `((:translate ,alloc-trans))) + (:policy :fast-safe)) + (,@(let ((arg-offsets (cdr register-arg-offsets))) + (mapcar #'(lambda (name) + (unless arg-offsets + (error "Too many args in ~S" alloc-vop)) + `(:arg ,name (descriptor-reg any-reg) + ,(pop arg-offsets))) + (args))) + (:temp ndescr non-descriptor-reg nl0-offset) + ,@(when (or need-unbound-marker header variable-length) + '((:temp temp non-descriptor-reg nl1-offset))) + (:res result descriptor-reg a0-offset)) + (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) + (symbol-value header))) + (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)))))))