diff --git a/compiler/backend.lisp b/compiler/backend.lisp index 1f2b2d87fe85313b2c891b36c6202ac98b205812..1fef0e3c980d10e5e1cba123a92224a22aff14ad 100644 --- a/compiler/backend.lisp +++ b/compiler/backend.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/backend.lisp,v 1.15 1992/03/07 13:32:25 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.16 1992/03/21 19:39:02 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,76 +18,20 @@ ;;; (in-package "C") -(export '(def-vm-support-routine *backend* *target-backend* *native-backend* - backend-name backend-version backend-fasl-file-type - backend-fasl-file-implementation backend-fasl-file-version - backend-register-save-penalty backend-byte-order - backend-any-primitive-type backend-info-environment - backend-instruction-formats backend-instruction-flavors - backend-assembler-resources backend-special-arg-types - backend-features backend-disassem-params - - ;; The various backends need to call these support routines - make-stack-pointer-tn primitive-type primitive-type-of)) +(export '(*backend* *target-backend* *native-backend* def-vm-support-routine + backend-name backend-version backend-fasl-file-type + backend-fasl-file-implementation backend-fasl-file-version + backend-register-save-penalty backend-byte-order + backend-any-primitive-type backend-info-environment + backend-instruction-formats backend-instruction-flavors + backend-assembler-resources backend-special-arg-types + backend-disassem-params backend-internal-errors + + ;; The various backends need to call these support routines + make-stack-pointer-tn primitive-type primitive-type-of)) -;;;; VM support routine stuff. - -(eval-when (compile eval load) - -(defconstant vm-support-routines - '(;; From VM.LISP - immediate-constant-sc - location-print-name - - ;; From PRIMTYPE.LISP - primitive-type-of - primitive-type - - ;; From C-CALL.LISP - make-call-out-nsp-tn - make-call-out-argument-tns - make-call-out-result-tn - - ;; From CALL.LISP - standard-argument-location - make-return-pc-passing-location - make-old-fp-passing-location - make-old-fp-save-location - make-return-pc-save-location - make-argument-count-location - make-nfp-tn - make-stack-pointer-tn - make-number-stack-pointer-tn - make-unknown-values-locations - select-component-format - - ;; From NLX.LISP - make-nlx-sp-tn - make-dynamic-state-tns - - ;; From SUPPORT.LISP - generate-call-sequence - generate-return-sequence)) - -); eval-when - - -(defmacro def-vm-support-routine (name ll &body body) - (unless (member (intern (string name) (find-package "C")) - vm-support-routines) - (warn "Unknown VM support routine: ~A" name)) - (let ((local-name (symbolicate (backend-name *target-backend*) "-" name))) - `(progn - (defun ,local-name ,ll ,@body) - (setf (,(intern (concatenate 'simple-string "BACKEND-" (string name)) - (find-package "C")) - *target-backend*) - #',local-name)))) - - - -;;;; The actual backend structure. +;;;; The backend structure. (defstruct (backend (:print-function %print-backend)) @@ -103,6 +47,9 @@ (fasl-file-implementation nil) (fasl-file-version nil) + ;; The VM support routines. + (support-routines (make-vm-support-routines) :type vm-support-routines) + ;; The number of references that a TN must have to offset the overhead of ;; saving the TN across a call. (register-save-penalty 0) @@ -174,17 +121,23 @@ (special-arg-types (make-hash-table :test #'eq) :type hash-table) (assembler-resources nil :type list) - ;; The backend specific features list, if any. - (features nil :type list) + ;; The backend specific features list, if any. During a compilation, + ;; *features* is bound to *features* - misfeatures + features. + (%features nil :type list) + (misfeatures nil :type list) ;; Disassembler information. (disassem-params nil :type t) - . #.(mapcar #'(lambda (slot) - `(,slot nil :type (or null function))) - (sort (copy-list vm-support-routines) - #'string< - :key #'symbol-name))) + ;; Mappings between CTYPE structures and the corresponding predicate. + ;; The type->predicate mapping hash is an alist because there is no + ;; such thing as a type= hash table. + (predicate-types (make-hash-table :test #'eq) :type hash-table) + (type-predicates nil :type list) + + ;; Vector of the internal errors defined for this backend, or NIL if + ;; they haven't been installed yet. + (internal-errors nil :type (or simple-vector null))) (defprinter backend @@ -196,46 +149,160 @@ (defvar *target-backend* *native-backend* "The backend we are attempting to compile.") (defvar *backend* *native-backend* - "The backend we are using to compile.") + "The backend we are using to compile with.") -;;;; Generate the stubs. - -(macrolet - ((frob () - `(progn - ,@(mapcar - #'(lambda (name) - `(defun ,name (&rest args) - (apply (or (,(symbolicate "BACKEND-" name) *backend*) - (error "Machine specific support routine ~S ~ - undefined for ~S" - ',name *backend*)) - args))) - vm-support-routines)))) - (frob)) +;;;; VM support routine stuff. + +(eval-when (compile eval) + +(defmacro def-vm-support-routines (&rest routines) + `(progn + (eval-when (compile load eval) + (defparameter vm-support-routines ',routines)) + (defstruct (vm-support-routines + (:print-function %print-vm-support-routines)) + ,@(mapcar #'(lambda (routine) + `(,routine nil :type (or function null))) + routines)) + ,@(mapcar + #'(lambda (name) + `(defun ,name (&rest args) + (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-" name) + (backend-vm-support-routines *backend*)) + (error "Machine specific support routine ~S ~ + undefined for ~S" + ',name *backend*)) + args))) + routines))) + +); eval-when + +(def-vm-support-routines + ;; From VM.LISP + immediate-constant-sc + location-print-name + + ;; From PRIMTYPE.LISP + primitive-type-of + primitive-type + + ;; From C-CALL.LISP + make-call-out-tns + + ;; From CALL.LISP + standard-argument-location + make-return-pc-passing-location + make-old-fp-passing-location + make-old-fp-save-location + make-return-pc-save-location + make-argument-count-location + make-nfp-tn + make-stack-pointer-tn + make-number-stack-pointer-tn + make-unknown-values-locations + select-component-format + + ;; From NLX.LISP + make-nlx-sp-tn + make-dynamic-state-tns + + ;; From SUPPORT.LISP + generate-call-sequence + generate-return-sequence) + +(defprinter vm-support-routines) + +(defmacro def-vm-support-routine (name ll &body body) + (unless (member (intern (string name) (find-package "C")) + vm-support-routines) + (warn "Unknown VM support routine: ~A" name)) + (let ((local-name (symbolicate (backend-name *target-backend*) "-" name))) + `(progn + (defun ,local-name ,ll ,@body) + (setf (,(intern (concatenate 'simple-string + "VM-SUPPORT-ROUTINES-" + (string name)) + (find-package "C")) + (backend-vm-support-routines *target-backend*)) + #',local-name)))) -;;;; Other utility functions for accessing the backend. +;;;; Other utility functions for fiddling with the backend. -(export '(target-featurep backend-featurep native-featurep)) +(export '(backend-features target-featurep backend-featurep native-featurep)) + +(defun backend-features (backend) + "Compute the *FEATURES* list to use with BACKEND." + (union (backend-%features backend) + (set-difference *features* + (backend-misfeatures backend)))) (defun target-featurep (feature) "Same as EXT:FEATUREP, except use the features found in *TARGET-BACKEND*." - (let ((*features* (or (backend-features *target-backend*) - *features*))) + (let ((*features* (backend-features *target-backend*))) (featurep feature))) (defun backend-featurep (feature) "Same as EXT:FEATUREP, except use the features found in *BACKEND*." - (let ((*features* (or (backend-features *target-backend*) - *features*))) + (let ((*features* (backend-features *target-backend*))) (featurep feature))) (defun native-featurep (feature) "Same as EXT:FEATUREP, except use the features found in *NATIVE-BACKEND*." - (let ((*features* (or (backend-features *native-backend*) - *features*))) + (let ((*features* (backend-features *native-backend*))) (featurep feature))) + + +;;; NEW-BACKEND +;;; +;;; Utility for creating a new backend structure for use with cross +;;; compilers. +;;; +(defun new-backend (name features misfeatures) + ;; If VM names a different package, rename that package so that VM doesn't + ;; name it. + (let ((pkg (find-package "VM"))) + (when pkg + (let ((pkg-name (package-name pkg))) + (unless (string= pkg-name name) + (rename-package pkg pkg-name + (remove "VM" (package-nicknames pkg) + :test #'string=)) + (unuse-package pkg "C"))))) + ;; Make sure VM names our package, creating it if necessary. + (let* ((pkg (or (find-package name) + (make-package name :nicknames '("VM")))) + (nicknames (package-nicknames pkg))) + (unless (member "VM" nicknames :test #'string=) + (rename-package pkg name (cons "VM" nicknames))) + ;; And make sure we are using the necessary packages. + (use-package "C" pkg) + (use-package "ASSEM" pkg) + (use-package "EXT" pkg) + (use-package "KERNEL" pkg) + (use-package "SYSTEM" pkg) + (use-package "ALIEN" pkg) + (use-package "C-CALL" pkg)) + ;; Make sure the native info env list is stored in *native-backend* + (unless (backend-info-environment *native-backend*) + (setf (backend-info-environment *native-backend*) *info-environment*)) + ;; Cons up a backend structure, filling in the info-env and features slots. + (let ((backend (make-backend + :name name + :info-environment + (cons (make-info-environment + :name + (concatenate 'string name " backend")) + (remove-if #'(lambda (name) + (let ((len (length name))) + (and (> len 8) + (string= name " backend" + :start1 (- len 8))))) + *info-environment* + :key #'info-env-name)) + :%features features + :misfeatures misfeatures))) + (setf *target-backend* backend)))