Skip to content
Snippets Groups Projects
Commit 72ca7fdf authored by wlott's avatar wlott
Browse files

Got rid of all DEFSLOTS, as DEFINE-PRIMITIVE-OBJECT supersedes it. We now

just use ``DEFINE-FOR-ALL-PRIMITIVE-OBJECTS'' to define the necessary vops.
parent fc493fce
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.23 1990/03/19 17:16:54 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.24 1990/03/19 23:19:48 wlott Exp $
;;; ;;;
;;; This file contains the VM definition of various primitive memory access ;;; This file contains the VM definition of various primitive memory access
;;; VOPs for the MIPS. ;;; VOPs for the MIPS.
...@@ -17,318 +17,116 @@ ...@@ -17,318 +17,116 @@
;;; Converted by William Lott. ;;; Converted by William Lott.
;;; ;;;
(in-package "VM")
(export '(cons-structure cons-size cons-car-slot cons-cdr-slot
bignum-structure bignum-base-size bignum-digits-offset
ratio-structure ratio-size ratio-numerator-slot
ratio-denominator-slot
single-float-structure single-float-size single-float-value-slot
double-float-structure double-float-size double-float-value-slot
complex-structure complex-size complex-real-slot complex-imag-slot
array-structure array-base-size array-fill-pointer-slot
array-elements-slot array-data-slot array-displacement-slot
array-displaced-p-slot array-dimensions-offset
vector-structure vector-base-size vector-length-slot
vector-data-offset
code-structure code-code-size-slot code-entry-points-slot
code-debug-info-slot code-constants-offset
function-header-structure function-header-self-slot
function-header-next-slot function-header-name-slot
function-header-arglist-slot function-header-type-slot
function-header-code-offset
return-pc-structure return-pc-return-point-offset
closure-structure closure-base-size closure-function-slot
closure-info-offset
value-cell-structure value-cell-size value-cell-value-slot
symbol-structure symbol-size symbol-value-slot
symbol-function-slot symbol-plist-slot symbol-name-slot
symbol-package-slot
sap-structure sap-size sap-pointer-slot
binding-structure binding-size binding-symbol-slot binding-value-slot
unwind-block-structure unwind-block-size
unwind-block-current-uwp-slot unwind-block-current-cont-slot
unwind-block-current-code-slot unwind-block-entry-pc-slot
catch-block-structure catch-block-size
catch-block-current-uwp-slot catch-block-current-cont-slot
catch-block-current-code-slot catch-block-entry-pc-slot
catch-block-tag-slot catch-block-previous-catch-slot
catch-block-size-slot
))
(in-package "C") (in-package "C")
;;;; Data object definition macros. ;;;; Data object definition macros.
(eval-when (compile eval load)
(defun parse-slot (slot) (vm:define-for-each-primitive-object (obj)
(multiple-value-bind (collect ((forms))
(name props) (let* ((options (vm:primitive-object-options obj))
(if (atom slot) (alloc-trans (getf options :alloc-trans))
(values slot nil) (alloc-vop (getf options :alloc-vop alloc-trans))
(values (car slot) (cdr slot))) (header (vm:primitive-object-header obj))
(values name (lowtag (vm:primitive-object-lowtag obj))
(getf props :rest) (size (vm:primitive-object-size obj))
(getf props :c-type "lispobj") (variable-length (vm:primitive-object-variable-length obj))
(getf props :length 1) (need-unbound-marker nil))
(getf props :ref-vop) (collect ((args) (init-forms))
(getf props :ref-trans) (when (and alloc-vop variable-length)
(getf props :set-vop) (args 'extra-words))
(getf props :setf-vop) (dolist (slot (vm:primitive-object-slots obj))
(getf props :set-trans) (let* ((name (vm:slot-name slot))
(getf props :docs) (offset (vm:slot-offset slot))
(getf props :init :zero))))) (rest-p (vm:slot-rest-p slot))
(slot-opts (vm:slot-options slot))
(defmacro defslots ((name &key header (lowtag 0) alloc-vop alloc-trans) (ref-trans (getf slot-opts :ref-trans))
&rest slots) (ref-vop (getf slot-opts :ref-vop ref-trans))
(let ((compile-time nil) (set-trans (getf slot-opts :set-trans))
(load-time nil) (set-vop (getf slot-opts :set-vop))
(index (if header 1 0)) (setf-vop (getf slot-opts :setf-vop
(slot-names (if header '((header :c-type "lispobj")))) (if set-vop nil set-trans))))
(did-rest nil) (when ref-vop
(init-forms nil) (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
(init-args nil) (:variant ,offset ,lowtag)
(need-unbound-marker nil)) ,@(when ref-trans
(dolist (slot slots) `((:translate ,ref-trans))))))
(when did-rest (when (or set-vop setf-vop)
(error "Rest slot ~S in defslots of ~S is not the last one." (forms `(define-vop ,(cond (rest-p `(,set-vop slot-set))
did-rest name)) (set-vop `(,set-vop cell-set))
(multiple-value-bind (t `(,setf-vop cell-setf)))
(slot-name rest c-type length ref-vop ref-trans (:variant ,offset ,lowtag)
set-vop setf-vop set-trans docs init) ,@(when set-trans
(parse-slot slot) `((:translate ,set-trans))))))
(let ((const (intern (concatenate 'simple-string (ecase (getf (vm:slot-options slot) :init :zero)
(string name) (:zero)
"-" (:null
(string slot-name) (init-forms `(storew null-tn result ,offset ,lowtag)))
(if rest "-OFFSET" "-SLOT"))))) (:unbound
(push `(defconstant ,const (setf need-unbound-marker t)
,index (init-forms `(storew temp result ,offset ,lowtag)))
,@(if docs (list docs))) (:arg
compile-time) (args (vm:slot-name slot))
(when (or set-vop setf-vop) (init-forms `(storew ,name result ,offset ,lowtag))))))
(push `(define-vop ,(cond (rest `(,set-vop slot-set)) (when (and (null alloc-vop) (args))
(set-vop `(,set-vop cell-set)) (error "Slots ~S want to be initialized, but there is no alloc vop ~
(t `(,setf-vop cell-setf))) defined for ~S."
(:variant ,const ,lowtag) (args) (vm:primitive-object-name obj)))
,@(when set-trans (when alloc-vop
`((:translate ,set-trans)))) (forms
load-time)) `(define-vop (,alloc-vop)
(when ref-vop (:args ,@(mapcar #'(lambda (name)
(push `(define-vop (,ref-vop ,(if rest 'slot-ref 'cell-ref)) `(,name :scs (any-reg descriptor-reg)))
(:variant ,const ,lowtag) (args)))
,@(when ref-trans (:temporary (:scs (non-descriptor-reg) :type random)
`((:translate ,ref-trans)))) ndescr
load-time)) ,@(when (or need-unbound-marker header
(case init variable-length)
(:zero) '(temp)))
(:null (:temporary (:scs (descriptor-reg) :to (:result 0)
(push `(storew null-tn result ,const ,lowtag) init-forms)) :target real-result) result)
(:unbound (:results (real-result :scs (descriptor-reg)))
(setf need-unbound-marker t) (:policy :fast-safe)
(push `(storew temp result ,const ,lowtag) init-forms)) ,@(when alloc-trans
(:arg `((:translate ,alloc-trans)))
(push slot-name init-args) (:generator 37
(push `(storew ,slot-name result ,const ,lowtag) init-forms)))) (pseudo-atomic (ndescr)
(push `(,slot-name :c-type ,c-type (inst addiu result alloc-tn ,lowtag)
,@(if rest '(:rest t))) ,@(cond ((and header variable-length)
slot-names) `((inst addiu temp extra-words
(if rest (fixnum (1- ,size)))
(setf did-rest slot-name) (inst addu alloc-tn alloc-tn temp)
(incf index length)))) (inst sll temp temp
(let ((size (intern (concatenate 'simple-string (- vm:type-bits vm:word-bits))
(string name) (inst ori temp temp ,header)
(if did-rest "-BASE-SIZE" "-SIZE"))))) (storew temp result 0 ,lowtag)
(push `(defconstant ,size ,index (inst addiu alloc-tn alloc-tn
,(format nil (+ (fixnum 1) vm:lowtag-mask))
"Number of slots used by each ~S~ (loadi temp (lognot vm:lowtag-mask))
~@[~* including the header~]~ (inst and alloc-tn alloc-tn temp)))
~@[~* excluding any data~]." (variable-length
name header did-rest)) (error ":REST-P T with no header in ~S?"
compile-time) (vm:primitive-object-name obj)))
(when alloc-vop (header
(push `(define-vop (,alloc-vop) `((inst addiu alloc-tn alloc-tn
(:args ,@(when did-rest (vm:pad-data-block ,size))
`((extra-words :scs (any-reg descriptor-reg)))) (loadi temp
,@(mapcar #'(lambda (name) ,(logior (ash (1- size) vm:type-bits)
`(,name :scs (any-reg descriptor-reg))) (if (integerp header)
(nreverse init-args))) header
(:temporary (:scs (non-descriptor-reg) :type random) 0)))
ndescr (storew temp result 0 ,lowtag)))
,@(when (or need-unbound-marker header did-rest) (t
'(temp))) `((inst addiu alloc-tn alloc-tn
(:temporary (:scs (descriptor-reg) :to (:result 0) (vm:pad-data-block ,size)))))
:target real-result) result) ,@(when need-unbound-marker
(:results (real-result :scs (descriptor-reg))) `((loadi temp vm:unbound-marker-type)))
(:policy :fast-safe) ,@(init-forms)
,@(when alloc-trans (move real-result result))))))))
`((:translate ,alloc-trans))) (when (forms)
(:generator 37 `(progn
(pseudo-atomic (ndescr) ,@(forms)))))
(inst addiu result alloc-tn ,lowtag)
,@(cond ((and header did-rest)
`((inst addiu temp extra-words
(fixnum (1- ,size)))
(inst addu alloc-tn alloc-tn temp)
(inst sll temp temp
(- vm:type-bits vm:word-bits))
(inst ori temp temp ,header)
(storew temp result 0 ,lowtag)
(inst addiu alloc-tn alloc-tn
(+ (fixnum 1) vm:lowtag-mask))
(loadi temp (lognot vm:lowtag-mask))
(inst and alloc-tn alloc-tn temp)))
(did-rest
(error ":REST T with no header in ~S?" name))
(header
`((inst addiu alloc-tn alloc-tn
(vm:pad-data-block ,size))
(loadi temp
(logior (ash (1- ,size) vm:type-bits)
,header))
(storew temp result 0 ,lowtag)))
(t
`((inst addiu alloc-tn alloc-tn
(vm:pad-data-block ,size)))))
,@(when need-unbound-marker
`((loadi temp vm:unbound-marker-type)))
,@(nreverse init-forms)
(move real-result result))))
load-time)))
`(progn
(eval-when (compile load eval)
,@(nreverse compile-time))
,@(nreverse load-time)
(defconstant ,(intern (concatenate 'simple-string
(string name)
"-STRUCTURE"))
',(reverse slot-names)))))
(defslots (cons :lowtag list-pointer-type
:alloc-vop cons-vop :alloc-trans cons)
(car :ref-vop car :ref-trans car
:setf-vop set-car :set-trans %rplaca
:init :arg)
(cdr :ref-vop cdr :ref-trans cdr
:setf-vop set-cdr :set-trans %rplacd
:init :arg))
(defslots (bignum :lowtag other-pointer-type :header bignum-type)
(digits :rest t :c-type "long"))
(defslots (ratio :lowtag other-pointer-type :header ratio-type
:alloc-vop make-ratio)
(numerator :ref-vop numerator :init :arg)
(denominator :ref-vop denominator :init :arg))
(defslots (single-float :lowtag other-pointer-type :header single-float-type)
(value :c-type "float"))
(defslots (double-float :lowtag other-pointer-type :header double-float-type)
(value :c-type "double" :length 2))
(defslots (complex :lowtag other-pointer-type :header complex-type
:alloc-vop make-complex)
(real :ref-vop realpart :init :arg)
(imag :ref-vop imagpart :init :arg))
(defslots (array :lowtag other-pointer-type :header t)
fill-pointer
elements
data
displacement
displaced-p
(dimensions :rest t))
(defslots (vector :lowtag other-pointer-type :header t)
(length :ref-vop vector-length)
(data :rest t :c-type "unsigned long"))
(defslots (code :lowtag other-pointer-type :header t)
code-size
entry-points
debug-info
(constants :rest t))
(defslots (function-header :lowtag function-pointer-type
:header function-header-type)
self
next
name
arglist
type
(code :rest t :c-type "unsigned char"))
(defslots (return-pc :lowtag other-pointer-type :header t)
(return-point :c-type "unsigned char" :rest t))
(defslots (closure :lowtag function-pointer-type :header closure-header-type
:alloc-vop make-closure)
(function :init :arg)
(info :rest t :set-vop closure-init :ref-vop closure-ref))
(defslots (value-cell :lowtag other-pointer-type :header value-cell-header-type
:alloc-vop make-value-cell)
(value :set-vop value-cell-set :ref-vop value-cell-ref :init :arg))
(defslots (symbol :lowtag other-pointer-type :header symbol-header-type
:alloc-vop make-symbol-vop :alloc-trans make-symbol)
(value :setf-vop set :set-trans set :init :unbound)
(function :setf-vop set-symbol-function :set-trans %sp-set-definition
:init :unbound)
(plist :ref-vop symbol-plist :ref-trans symbol-plist
:setf-vop set-symbol-plist :set-trans %sp-set-plist
:init :null)
(name :ref-vop symbol-name :ref-trans symbol-name :init :arg)
(package :ref-vop symbol-package :ref-trans symbol-package
:setf-vop set-package :init :null))
(defslots (sap :lowtag other-pointer-type :header sap-header-type)
(pointer :c-type "char *"))
;;; Other non-heap data blocks.
(defslots (binding)
value
symbol)
(defslots (unwind-block)
current-uwp
current-cont
current-code
entry-pc)
(defslots (catch-block)
current-uwp
current-cont
current-code
entry-pc
tag
previous-catch
size)
......
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