From 43ca0eb0f70108e2bcd01da617e64cd691672769 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sat, 9 Jun 1990 13:54:31 +0000 Subject: [PATCH] Seperated the automatic primitive object generation stuff into the accessors (still in cell.lisp), the allocation stuff (in alloc.lisp) and the defknowns (in vm-fndb.lisp). This was prompted by the the old loader barfing on the huge form generated when they were all in cell.lisp. --- compiler/generic/vm-fndb.lisp | 34 ++++++- compiler/mips/alloc.lisp | 95 ++++++++++++++++++- compiler/mips/cell.lisp | 170 ++++++++-------------------------- 3 files changed, 164 insertions(+), 135 deletions(-) diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp index f25c2d116..d9462972a 100644 --- a/compiler/generic/vm-fndb.lisp +++ b/compiler/generic/vm-fndb.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.12 1990/06/08 01:18:34 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.13 1990/06/09 13:54:31 wlott Exp $ ;;; ;;; This file defines the machine specific function signatures. ;;; @@ -184,3 +184,35 @@ (simple-unboxed-array (*)) index index) null ()) + + + +;;;; Automatic defknowns for primitive objects. + +(vm:define-for-each-primitive-object (obj) + (collect ((forms)) + (let* ((options (vm:primitive-object-options obj)) + (obj-type (getf options :type t))) + (dolist (slot (vm:primitive-object-slots obj)) + (let* ((name (vm:slot-name slot)) + (slot-opts (vm:slot-options slot)) + (slot-type (getf slot-opts :type t)) + (ref-trans (getf slot-opts :ref-trans)) + (ref-known (getf slot-opts :ref-known)) + (set-trans (getf slot-opts :set-trans)) + (set-known (getf slot-opts :set-known))) + (when ref-known + (if ref-trans + (forms `(defknown (,ref-trans) (,obj-type) ,slot-type + ,ref-known)) + (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S" + name (vm:primitive-object-name obj)))) + (when set-known + (if set-trans + (forms `(defknown (,set-trans) (,obj-type ,slot-type) + ,slot-type ,set-known)) + (error "Can't spec a :set-known with no :set-trans. ~S in ~S" + name (vm:primitive-object-name obj))))))) + (when (forms) + `(progn + ,@(forms))))) diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index aed3aed9e..a99468040 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.7 1990/05/31 03:42:18 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.8 1990/06/09 13:54:24 wlott Exp $ ;;; ;;; Allocation VOPs for the MIPS port. ;;; @@ -16,6 +16,8 @@ (in-package "C") + +;;;; LIST and LIST* (define-vop (list-or-list*) (:args (things :more t)) @@ -74,6 +76,8 @@ (define-vop (list* list-or-list*) (:variant t)) + +;;;; Special purpose inline allocators. (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg)) @@ -99,3 +103,92 @@ (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)))) + + +;;;; Automatic allocators for primitive objects. + +(vm:define-for-each-primitive-object (obj) + (collect ((forms)) + (let* ((options (vm:primitive-object-options obj)) + (obj-type (getf options :type t)) + (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 + (forms + `(define-vop (,alloc-vop) + (:args ,@(mapcar #'(lambda (name) + `(,name :scs (any-reg descriptor-reg))) + (args))) + (:temporary (:scs (non-descriptor-reg) :type random) + ndescr + ,@(when (or need-unbound-marker header + variable-length) + '(temp))) + (:temporary (:scs (descriptor-reg) :to (:result 0) + :target real-result) result) + (:results (real-result :scs (descriptor-reg))) + (:policy :fast-safe) + ,@(when alloc-trans + `((:translate ,alloc-trans))) + (:generator 37 + (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) + (if (integerp header) + header + 0))) + (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) + (move real-result result)))))))) + (when (forms) + `(progn + ,@(forms))))) diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp index 4152f7696..1ae2026af 100644 --- a/compiler/mips/cell.lisp +++ b/compiler/mips/cell.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.35 1990/06/04 05:23:32 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.36 1990/06/09 13:52:14 wlott Exp $ ;;; ;;; This file contains the VM definition of various primitive memory access ;;; VOPs for the MIPS. @@ -22,142 +22,50 @@ ;;;; Data object definition macros. - (vm:define-for-each-primitive-object (obj) (collect ((forms)) (let* ((options (vm:primitive-object-options obj)) - (obj-type (getf options :type t)) - (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)) - (rest-p (vm:slot-rest-p slot)) - (slot-opts (vm:slot-options slot)) - (slot-type (getf slot-opts :type t)) - (ref-trans (getf slot-opts :ref-trans)) - (ref-vop (getf slot-opts :ref-vop ref-trans)) - (ref-known (getf slot-opts :ref-known)) - (set-trans (getf slot-opts :set-trans)) - (setf-vop (getf slot-opts :setf-vop - (when (and (listp set-trans) - (= (length set-trans) 2) - (eq (car set-trans) 'setf)) - (intern (concatenate - 'simple-string - "SET-" - (string (cadr set-trans))))))) - (set-vop (getf slot-opts :set-vop - (if setf-vop nil set-trans))) - (set-known (getf slot-opts :set-known))) - (when ref-known - (if ref-trans - (forms `(defknown (,ref-trans) (,obj-type) ,slot-type - ,ref-known)) - (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S" - name (vm:primitive-object-name obj)))) - (when ref-vop - (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) - (:variant ,offset ,lowtag) - ,@(when ref-trans - `((:translate ,ref-trans)))))) - (when set-known - (if set-trans - (forms `(defknown (,set-trans) (,obj-type ,slot-type) - ,slot-type ,set-known)) - (error "Can't spec a :set-known with no :set-trans. ~S in ~S" - name (vm:primitive-object-name obj)))) - (when (or set-vop setf-vop) - (forms `(define-vop ,(cond ((and rest-p setf-vop) - (error "Can't automatically generate a setf VOP for :rest-p ~ - slots: ~S in ~S" - name - (vm:primitive-object-name obj))) - (rest-p `(,set-vop slot-set)) - (set-vop `(,set-vop cell-set)) - (t `(,setf-vop cell-setf))) - (:variant ,offset ,lowtag) - ,@(when set-trans - `((:translate ,set-trans)))))) - (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 (vm:slot-name slot)) - (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 - (forms - `(define-vop (,alloc-vop) - (:args ,@(mapcar #'(lambda (name) - `(,name :scs (any-reg descriptor-reg))) - (args))) - (:temporary (:scs (non-descriptor-reg) :type random) - ndescr - ,@(when (or need-unbound-marker header - variable-length) - '(temp))) - (:temporary (:scs (descriptor-reg) :to (:result 0) - :target real-result) result) - (:results (real-result :scs (descriptor-reg))) - (:policy :fast-safe) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:generator 37 - (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) - (if (integerp header) - header - 0))) - (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) - (move real-result result)))))))) + (lowtag (vm:primitive-object-lowtag obj))) + (dolist (slot (vm:primitive-object-slots obj)) + (let* ((name (vm:slot-name slot)) + (offset (vm:slot-offset slot)) + (rest-p (vm:slot-rest-p slot)) + (slot-opts (vm:slot-options slot)) + (ref-trans (getf slot-opts :ref-trans)) + (ref-vop (getf slot-opts :ref-vop ref-trans)) + (set-trans (getf slot-opts :set-trans)) + (setf-vop (getf slot-opts :setf-vop + (when (and (listp set-trans) + (= (length set-trans) 2) + (eq (car set-trans) 'setf)) + (intern (concatenate + 'simple-string + "SET-" + (string (cadr set-trans))))))) + (set-vop (getf slot-opts :set-vop + (if setf-vop nil set-trans)))) + (when ref-vop + (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref)) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + (when (or set-vop setf-vop) + (forms `(define-vop ,(cond ((and rest-p setf-vop) + (error "Can't automatically generate a setf VOP for :rest-p ~ + slots: ~S in ~S" + name + (vm:primitive-object-name obj))) + (rest-p `(,set-vop slot-set)) + (set-vop `(,set-vop cell-set)) + (t `(,setf-vop cell-setf))) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans))))))))) (when (forms) `(progn ,@(forms))))) - ;;;; Symbol hacking VOPs: @@ -229,10 +137,6 @@ (loadw value object vm:symbol-function-slot vm:other-pointer-type) (test-simple-type value temp target not-p vm:function-pointer-type))) -#+nil -(def-source-transform makunbound (x) - `(set ,x (%primitive make-immediate-type 0 system:%trap-type))) - (define-vop (fast-symbol-value cell-ref) (:variant vm:symbol-value-slot vm:other-pointer-type) -- GitLab