diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index 8cddf25f282a3bb82c974a2c9f09e112805fa1d2..8fd40ebe3e21554358b811c3c4fdd6d00880638b 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -7,7 +7,7 @@ ;;; 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 $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.19 1992/12/13 15:21:29 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -121,82 +121,70 @@ (inst li temp (make-fixup "undefined_tramp" :foreign)) (storew temp result fdefn-raw-addr-slot other-pointer-type)))) +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + (pseudo-atomic (pa-flag :extra (pad-data-block size)) + (inst or result alloc-tn function-pointer-type) + (inst li temp (logior (ash (1- size) type-bits) closure-header-type)) + (storew temp result 0 function-pointer-type))) + (storew function result closure-function-slot function-pointer-type))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result pa-flag temp value-cell-header-type value-cell-size)) + (storew value result value-cell-value-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 - `((inst li temp - ,(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)))))))) +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst li result unbound-marker-type))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:generator 4 + (pseudo-atomic (pa-flag :extra (pad-data-block words)) + (inst or result alloc-tn lowtag) + (when type + (inst li temp (logior (ash (1- words) type-bits) type)) + (storew temp result 0 lowtag))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:scs (any-reg)) temp1 temp2) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:generator 6 + (pseudo-atomic (pa-flag) + (inst or result alloc-tn lowtag) + (inst addu temp1 extra (fixnum (1- words))) + (inst sll temp2 temp2 (- type-bits 2)) + (inst or temp2 temp2 type) + (storew temp2 result 0 lowtag) + (inst li temp2 (lognot lowtag-mask)) + (inst and temp1 temp1 temp2) + (inst addu alloc-tn alloc-tn temp1))))