Skip to content
Snippets Groups Projects
Commit 9734fb44 authored by wlott's avatar wlott
Browse files

Added stuff for new var-alloc and fixed-alloc vops.

parent 6cada56f
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.2 1993/01/15 01:33:03 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -120,78 +120,69 @@ ...@@ -120,78 +120,69 @@
(storew null-tn result fdefn-function-slot other-pointer-type) (storew null-tn result fdefn-function-slot other-pointer-type)
(storew temp result fdefn-raw-addr-slot other-pointer-type)))) (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)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let ((size (+ length closure-info-offset)))
(pseudo-atomic (:extra (pad-data-block size))
(inst move alloc-tn result)
(inst dep function-pointer-type 31 3 result)
(inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
(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 any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 10
(with-fixed-allocation
(result temp value-cell-header-type value-cell-size))
(storew value result value-cell-value-slot other-pointer-type)))
;;;; Automatic allocators for primitive objects. ;;;; Automatic allocators for primitive objects.
(define-for-each-primitive-object (obj) (define-vop (make-unbound-marker)
(collect ((forms)) (:args)
(let* ((options (primitive-object-options obj)) (:results (result :scs (any-reg)))
(alloc-trans (getf options :alloc-trans)) (:generator 1
(alloc-vop (getf options :alloc-vop alloc-trans)) (inst li unbound-marker-type result)))
(header (primitive-object-header obj))
(lowtag (primitive-object-lowtag obj)) (define-vop (fixed-alloc)
(size (primitive-object-size obj)) (:args)
(variable-length (primitive-object-variable-length obj)) (:info name words type lowtag)
(need-unbound-marker nil)) (:ignore name)
(collect ((args) (init-forms)) (:results (result :scs (descriptor-reg)))
(when (and alloc-vop variable-length) (:temporary (:scs (non-descriptor-reg)) temp)
(args 'extra-words)) (:generator 4
(dolist (slot (primitive-object-slots obj)) (pseudo-atomic (:extra (pad-data-block words))
(let* ((name (slot-name slot)) (inst move alloc-tn result)
(offset (slot-offset slot))) (inst dep lowtag 31 3 result)
(ecase (getf (slot-options slot) :init :zero) (when type
(:zero) (inst li (logior (ash (1- words) type-bits) type) temp)
(:null (storew temp result 0 lowtag)))))
(init-forms `(storew null-tn result ,offset ,lowtag)))
(:unbound (define-vop (var-alloc)
(setf need-unbound-marker t) (:args (extra :scs (any-reg)))
(init-forms `(storew temp result ,offset ,lowtag))) (:arg-types positive-fixnum)
(:arg (:info name words type lowtag)
(args name) (:ignore name)
(init-forms `(storew ,name result ,offset ,lowtag)))))) (:results (result :scs (descriptor-reg)))
(when (and (null alloc-vop) (args)) (:temporary (:scs (any-reg)) bytes header)
(error "Slots ~S want to be initialized, but there is no alloc vop ~ (:generator 6
defined for ~S." (inst addi (* (1+ words) word-bytes) extra bytes)
(args) (primitive-object-name obj))) (inst sll bytes (- type-bits 2) header)
(when alloc-vop (inst addi (+ (ash -2 type-bits) type) header header)
(forms (inst dep 0 31 3 bytes)
`(define-vop (,alloc-vop) (pseudo-atomic ()
(:args ,@(mapcar #'(lambda (name) (inst move alloc-tn result)
`(,name :scs (any-reg descriptor-reg))) (inst dep lowtag 31 3 result)
(args))) (storew header result 0 lowtag)
,@(when (or need-unbound-marker header variable-length) (inst add alloc-tn bytes alloc-tn))))
`((:temporary (:scs (non-descriptor-reg)) temp)))
(:results (result :scs (descriptor-reg) :from :load))
(:policy :fast-safe)
,@(when alloc-trans
`((:translate ,alloc-trans)))
(:generator 37
(pseudo-atomic (,@(unless variable-length
`(:extra (pad-data-block ,size))))
(move alloc-tn result)
(inst dep ,lowtag 31 3 result)
,@(cond
((and header variable-length)
`((inst addi (* (1+ ,size) word-bytes) extra-words temp)
(inst dep 0 31 3 temp)
(inst add temp alloc-tn alloc-tn)
(inst sll extra-words (- type-bits word-shift) temp)
(inst addi (+ (ash (1- ,size) type-bits) ,header)
temp temp)
(storew temp result 0 ,lowtag)))
(variable-length
(error ":REST-P T with no header in ~S?"
(primitive-object-name obj)))
(header
`((inst li ,(logior (ash (1- size) type-bits)
(symbol-value header))
temp)
(storew temp result 0 ,lowtag)))
(t
nil))
,@(when need-unbound-marker
`((inst li unbound-marker-type temp)))
,@(init-forms))))))))
(when (forms)
`(progn
,@(forms)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment