From 754174ad4eeab88000cdeeb2792ba1fe3af1151f Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sun, 13 Dec 1992 14:47:40 +0000 Subject: [PATCH] Moved all the def-primitive-object stuff into vm-macs.lisp. Fixed all uses of def-primitive-object to correspond to new def-primitive-object. Added start of gengc support. --- compiler/generic/objdef.lisp | 264 +++++++++++++---------------------- 1 file changed, 98 insertions(+), 166 deletions(-) diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp index 8329517b9..40c6b1fa5 100644 --- a/compiler/generic/objdef.lisp +++ b/compiler/generic/objdef.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: VM; Log: C.Log -*- +;;; -*- Package: VM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,12 +7,10 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.20 1992/12/05 21:49:08 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.21 1992/12/13 14:47:40 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.20 1992/12/05 21:49:08 wlott Exp $ -;;; ;;; This file contains the machine independent aspects of the object ;;; representation. ;;; @@ -54,6 +52,11 @@ (in-package "KERNEL") (export '(%set-funcallable-instance-function %make-funcallable-instance)) +(export '(%numerator %denominator %realpart %imagpart + %code-code-size %code-entry-points %code-debug-info + %function-self %function-next %function-name %function-arglist + %function-type)) + (in-package "VM") @@ -136,7 +139,7 @@ byte-code-closure dylan-function-header closure-function-header - return-pc-header + #-gengc return-pc-header #+gengc forwarding-pointer value-cell-header symbol-header base-char @@ -146,6 +149,7 @@ structure-header fdefn) + ;;; The different vector subtypes. ;;; (defenum (:prefix vector- :suffix -subtype) @@ -154,126 +158,13 @@ valid-hashing must-rehash) - - - -;;;; Primitive data objects definition noise. - -(eval-when (compile load eval) - -(defstruct (prim-object-slot - (:conc-name slot-) - (:constructor %make-slot - (name docs rest-p length options)) - (:make-load-form-fun :just-dump-it-normally)) - (name nil :type symbol) - (docs nil :type (or null simple-string)) - (rest-p nil :type (member t nil)) - (offset 0 :type fixnum) - (length 1 :type fixnum) - (options nil :type list)) - -(defun make-slot (name &rest options - &key docs rest-p (length (if rest-p 0 1)) - &allow-other-keys) - (let ((options (copy-list options))) - (remf options :docs) - (remf options :rest-p) - (remf options :length) - (%make-slot name docs rest-p length options))) - -(defstruct (primitive-object - (:make-load-form-fun :just-dump-it-normally)) - (name nil :type symbol) - (header nil :type symbol) - (lowtag nil :type symbol) - (options nil :type list) - (slots nil :type list) - (size 0 :type fixnum) - (variable-length nil :type (member t nil))) - - -(defvar *primitive-objects* nil) - -); eval-when (compile load eval) - - -(defmacro define-primitive-object ((name &rest options - &key header lowtag - &allow-other-keys) - &rest slots) - (setf options (copy-list options)) - (remf options :header) - (remf options :lowtag) - (let ((prim-obj - (make-primitive-object :name name - :header header - :lowtag lowtag - :options options - :slots (mapcar #'(lambda (slot) - (if (atom slot) - (make-slot slot) - (apply #'make-slot - slot))) - slots)))) - (collect ((forms) (exports)) - (let ((offset (if (primitive-object-header prim-obj) 1 0)) - (variable-length nil)) - (dolist (slot (primitive-object-slots prim-obj)) - (when variable-length - (error "~S is anything after a :rest-p t slot." slot)) - (let* ((rest-p (slot-rest-p slot)) - (offset-sym - (intern (concatenate 'simple-string - (string name) - "-" - (string (slot-name slot)) - (if rest-p "-OFFSET" "-SLOT"))))) - (forms `(defconstant ,offset-sym ,offset - ,@(when (slot-docs slot) (list (slot-docs slot))))) - (setf (slot-offset slot) offset) - (exports offset-sym) - (incf offset (slot-length slot)) - (when rest-p (setf variable-length t)))) - (setf (primitive-object-variable-length prim-obj) variable-length) - (unless variable-length - (let ((size (intern (concatenate 'simple-string - (string name) - "-SIZE")))) - (forms `(defconstant ,size ,offset - ,(format nil - "Number of slots used by each ~S~ - ~@[~* including the header~]." - name header))) - (exports size))) - (setf (primitive-object-size prim-obj) offset)) - `(eval-when (compile load eval) - (setf *primitive-objects* - (cons ',prim-obj - (delete ',name *primitive-objects* - :key #'primitive-object-name))) - (export ',(exports)) - ,@(forms))))) - -(defmacro define-for-each-primitive-object ((var) &body body) - (let ((name (gensym))) - `(macrolet ((,name (,var) ,@body)) - ,@(mapcar #'(lambda (x) - `(,name ,x)) - *primitive-objects*)))) - ;;;; The primitive objects themselves. - (define-primitive-object (cons :lowtag list-pointer-type :alloc-trans cons) - (car :ref-vop car :ref-trans car - :setf-vop c::set-car :set-trans c::%rplaca - :init :arg) - (cdr :ref-vop cdr :ref-trans cdr - :setf-vop set-cdr :set-trans c::%rplacd - :init :arg)) + (car :ref-trans car :set-trans c::%rplaca :init :arg) + (cdr :ref-trans cdr :set-trans c::%rplacd :init :arg)) (define-primitive-object (structure :lowtag structure-pointer-type :header structure-header-type @@ -287,10 +178,13 @@ (define-primitive-object (ratio :lowtag other-pointer-type :header ratio-type - :alloc-vop c::make-ratio :alloc-trans %make-ratio) - (numerator :ref-vop numerator :init :arg) - (denominator :ref-vop denominator :init :arg)) + (numerator :ref-known (flushable movable) + :ref-trans %numerator + :init :arg) + (denominator :ref-known (flushable movable) + :ref-trans %denominator + :init :arg)) (define-primitive-object (single-float :lowtag other-pointer-type :header single-float-type) @@ -303,10 +197,9 @@ (define-primitive-object (complex :lowtag other-pointer-type :header complex-type - :alloc-vop c::make-complex :alloc-trans %make-complex) - (real :ref-vop realpart :init :arg) - (imag :ref-vop imagpart :init :arg)) + (real :ref-known (flushable movable) :ref-trans %realpart :init :arg) + (imag :ref-known (flushable movable) :ref-trans %imagpart :init :arg)) (define-primitive-object (array :lowtag other-pointer-type :header t) @@ -349,13 +242,18 @@ (data :rest-p t :c-type "unsigned long")) (define-primitive-object (code :lowtag other-pointer-type :header t) - (code-size :ref-vop c::code-code-size) - (entry-points :ref-vop c::code-entry-points - :set-vop c::set-code-entry-points) + (code-size :ref-known (flushable movable) + :ref-trans %code-code-size) + (entry-points :type (or function null) + :ref-known (flushable) + :ref-trans %code-entry-points + :set-known (unsafe) + :set-trans (setf %code-entry-points)) (debug-info :type t - :ref-trans di::code-debug-info :ref-known (flushable) - :set-vop c::set-code-debug-info) + :ref-trans %code-debug-info + :set-known (unsafe) + :set-trans (setf %code-debug-info)) (trace-table-offset) (constants :rest-p t)) @@ -365,55 +263,53 @@ (function :ref-trans fdefn-function) (raw-addr :c-type "char *")) -(define-primitive-object (function-header :lowtag function-pointer-type - :header function-header-type) - (self :ref-vop c::function-self :set-vop c::set-function-self) - (next :ref-vop c::function-next :set-vop c::set-function-next) - (name :ref-vop c::function-name - :ref-known (flushable) - :ref-trans %function-header-name - :set-vop c::set-function-name) - (arglist :ref-vop c::function-arglist - :ref-known (flushable) - :ref-trans lisp::%function-header-arglist - :set-vop c::set-function-arglist) - (type :ref-vop c::function-type +(define-primitive-object (function :lowtag function-pointer-type + :header function-header-type) + #-gengc (self :ref-trans %function-self :set-trans (setf %function-self)) + #+gengc (entry-point :c-type "char *") + (next :type (or function null) :ref-known (flushable) - :ref-trans lisp::%function-header-type - :set-vop c::set-function-type) + :ref-trans %function-next + :set-known (unsafe) + :set-trans (setf %function-next)) + (name :ref-known (flushable) + :ref-trans %function-name + :set-known (unsafe) + :set-trans (setf %function-name)) + (arglist :ref-known (flushable) + :ref-trans %function-arglist + :set-known (unsafe) + :set-trans (setf %function-arglist)) + (type :ref-known (flushable) + :ref-trans %function-type + :set-known (unsafe) + :set-trans (setf %function-type)) (code :rest-p t :c-type "unsigned char")) +#-gengc (define-primitive-object (return-pc :lowtag other-pointer-type :header t) (return-point :c-type "unsigned char" :rest-p t)) (define-primitive-object (closure :lowtag function-pointer-type - :header closure-header-type - :alloc-vop c::make-closure) - (function :init :arg - :ref-vop c::closure-function - :ref-known (flushable) - :ref-trans %closure-function) - (info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref)) + :header closure-header-type) + #-gengc (function :init :arg :ref-trans %closure-function) + #+gengc (entry-point :c-type "char *") + (info :rest-p t)) (define-primitive-object (funcallable-instance :lowtag function-pointer-type :header funcallable-instance-header-type - :alloc-vop make-funcallable-instance :alloc-trans %make-funcallable-instance) - (function :init :arg - :set-vop set-funcallable-instance-function - :set-trans %set-funcallable-instance-function - :set-known (unsafe)) + #-gengc (function :init :arg + :set-trans %set-funcallable-instance-function) + #+gengc (entry-point :c-type "char *") (info :rest-p t)) (define-primitive-object (value-cell :lowtag other-pointer-type :header value-cell-header-type - :alloc-vop make-value-cell :alloc-trans make-value-cell) - (value :set-vop value-cell-set - :set-trans value-cell-set + (value :set-trans value-cell-set :set-known (unsafe) - :ref-vop value-cell-ref :ref-trans value-cell-ref :ref-known (flushable) :init :arg)) @@ -422,16 +318,13 @@ :header symbol-header-type :alloc-trans make-symbol) (value :set-trans %set-symbol-value - :setf-vop set :init :unbound) unused (plist :ref-trans symbol-plist - :setf-vop %set-symbol-plist :set-trans %set-symbol-plist :init :null) (name :ref-trans symbol-name :init :arg) (package :ref-trans symbol-package - :setf-vop %set-symbol-package :set-trans %set-symbol-package :init :null)) @@ -454,7 +347,7 @@ :set-known (unsafe) :init :arg) (next :c-type "struct weak_pointer *")) - + ;;; Other non-heap data blocks. @@ -477,3 +370,42 @@ (previous-catch :c-type "struct catch_block *") size) +#+gengc +(define-primitive-object (sigcontext-chain) + (scp :c-type "struct sigcontext *") + (next :c-type "struct sigcontext_chain *")) + +#+gengc +(define-primitive-object (mutator) + (thread :c-type "struct thread *") + ;; Signal control magic. + (foreign-fn-call-active :c-type "boolean") + (interrupts-enabled :c-type "boolean") + (interrupt-pending :c-type "boolean") + (pending-signal :c-type "int") + (pending-code :c-type "int") + (pending-mask :c-type "unsigned long") + (sigcontext-chain :c-type "struct sigcontext_chain *") + ;; Stacks. + (control-stack-base :c-type "lispobj *") + (control-stack-pointer :c-type "lispobj *") + (control-stack-end :c-type "lispobj *") + (control-frame-pointer :c-type "lispobj *") + (current-unwind-protect :c-type "struct unwind_block *") + (current-catch-block :c-type "struct catch_block *") + (binding-stack-base :c-type "struct binding *") + (binding-stack-pointer :c-type "struct binding *") + (binding-stack-end :c-type "struct binding *") + (number-stack-base :c-type "char *") + (number-stack-pointer :c-type "char *") + (number-stack-end :c-type "char *") + (eval-stack) + (eval-stack-top) + ;; Allocation stuff. + (nursery-start :c-type "lispobj *") + (nursery-fill-pointer :c-type "lispobj *") + (nursery-end :c-type "lispobj *") + (storebuf-start :c-type "lispobj **") + (storebuf-fill-pointer :c-type "lispobj **") + (storebuf-end :c-type "lispobj **") + (words-consed :c-type "unsigned long")) -- GitLab