;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Cold-Load: t; -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; CLtL Section 24.5.2 Other environment inquiries. ;; ;; Ucode/Processor type ;;may 04/20/89 Documented lashup-p, mx-p, and addin-p. ;;jlm 3/31/89 Rearranged TYPE-MP-P to allow Cold Band to boot ;;jlm 3/14/89 Tightened up TYPE-MP-P ;;jlm 2/29/89 Added var *MP-Explorer-slot-numbers* and *MP-CHECK-NEIGHBOR-DELAY-SECONDS* for MP. ;;jlm 2/27/89 Added further support functions for MP. ;;jlm 2/9/89 Added predicate MP-SYSTEM-P and TYPE-MP-P for multi-processor support. ;;ab 04-29-88 o Create variable name for obsolete SYS:PROCESSOR-TYPE-CODE for toolkits ;; that haven't removed its use. ;;ab 02-08-88 o Improve efficiency of run-time predicates. ;;ab 01-12-88 o Work around Genasys bug involving keywords in LROY-QCOM by ;; forcing symbols in *microcode-type-list* to be keywords. ;;ab 01-12-88 o Enhance MICROCODE-TYPE, PROCESSOR-TYPE & friends based on ;; new *microcode-type-list* variable. Implement PROCESSOR-FAMILY fn. ;; o Add support for PHYSICAL-RESOURCE variables for run-time testing ;; in environments with different devices. ;;AB 07-16-87. GET-MICROCODE-NAME moved here from MEMORY-MANAGEMENT;MEMORY-DEBUG & fixed. ;; MICROCODE-TYPE, GET-PROCESSOR-NAME, PROCESSOR-TYPE, MICROCODE-VERSION fns new. ;; Declare PROCESSOR-TYPE-CODE obsolete in future; (PROCESSOR-TYPE) should be ;; used instead (but it doesn't return a number). ;; Fixed MACHINE-TYPE to distinguish between Explorer I and II. ;; Fixed MACHINE-VERSION to name the microcode type. ;; Fixed SOFTWARE-VERSION (& LISP-IMPLEMENTATION-VERSION) to describe Explorer Software ;; version (using new GET-EXPLORER-SOFTWARE-VERSION). ;; SPRS: 5751, 5422, 1860. (PROCLAIM '(SPECIAL *microcode-name-alist* *microcode-type-list* processor-type)) (compiler:make-variable-obsolete processor-type-code "(PROCESSOR-TYPE) and expect a keyword value") ;;ab 4-29-88. For tool kits that still use it. Note this is *NOT* an a-memory variable ;; any longer after release 4.0. (DEFCONSTANT processor-type-code 3.) (DEFUN microcode-type (&optional (microcode-type-code microcode-type-code)) "Returns the microcode type symbol associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (LET ((res (SECOND (ASSOC microcode-type-code *microcode-type-list* :test #'=)))) (WHEN res (VALUES (INTERN res 'keyword))))) (DEFUN get-microcode-name (&optional (microcode-type-code microcode-type-code)) "Returns the microcode type name string associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (DECLARE (VALUES microcode-name)) (LET ((sym (microcode-type microcode-type-code))) (WHEN sym (SYMBOL-NAME sym)))) (DEFUN processor-type (&optional (microcode-type-code microcode-type-code)) "Returns the processor type symbol associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (LET ((res (THIRD (ASSOC microcode-type-code *microcode-type-list* :test #'=)))) (WHEN res (VALUES (INTERN res 'keyword))))) (DEFUN get-processor-name (&optional (microcode-type-code microcode-type-code)) "Returns the processor type name string associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (LET ((type (processor-type microcode-type-code))) (WHEN type (SELECT type (:explorer-i "Explorer I") (:explorer-ii "Explorer II") (:micro-explorer "microExplorer") (:otherwise (STRING-CAPITALIZE (SYMBOL-NAME type) :start 0 :end nil :spaces t))))) ) (DEFUN processor-family (&optional (microcode-type-code microcode-type-code)) "Returns the processor family symbol associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (LET ((res (FOURTH (ASSOC microcode-type-code *microcode-type-list* :test #'=)))) (WHEN res (VALUES (INTERN res 'keyword))))) (DEFUN get-processor-family-name (&optional (microcode-type-code microcode-type-code)) "Returns the processor family name string associated with MICROCODE-TYPE-CODE, or NIL if unknown. MICROCODE-TYPE-CODE defaults to the code for the running microcode." (LET ((family (processor-family microcode-type-code))) (WHEN family (SELECT family (:explorer-i "Explorer I") (:mchip "Explorer Lisp Microprocessor") (:otherwise (STRING-CAPITALIZE (SYMBOL-NAME family) :start 0 :end nil :spaces t))))) ) (DEFUN microcode-version (&aux tem) (format nil "Microcode ~a~a~D~a" (OR (SETQ tem (get-microcode-name)) "") (IF tem " " "") %microcode-version-number (IF (processor-family) (FORMAT nil " for the ~a" (get-processor-family-name)) ""))) (defun machine-type () "Return the generic name for the hardware that we are running on, as a string." (OR (get-processor-name) "Explorer")) (defun machine-version () "Return a string that identifies which hardware and special microcode we are using." (format nil "~A, ~a" (machine-type) (microcode-version))) ;; ;; Software/Environment info (defun lisp-implementation-type () "Return the generic name of this Common Lisp implementation." "TI Common Lisp") (DEFUN explorer-software-version () (LOOP FOR prod IN *defined-products* DO (WHEN (EQ (SEND prod :symbol-name) 'system) (RETURN (FORMAT nil "~a ~d.~d~a" (SEND prod :name) (SEND prod :major-version) (SEND prod :minor-version) (OR (SECOND (ASSOC (product-status prod) *product-status-alist* :test #'EQ)) ""))))) ) (defun lisp-implementation-version (&optional (verbose t)) "Return a string that identifies the version of this particular implementation of Lisp." (with-output-to-string (version) (FORMAT version "~a, ~a." (explorer-software-version) (microcode-version)) (WHEN verbose (FORMAT version " With ") (do ((sys patch-systems-list (cdr sys))) ((null sys)) (let ((system (car sys))) (format version "~A ~D.~D" (patch-name system) (patch-version system) (version-number (first (patch-version-list system))))) (If (CDR sys) (write-string ", " version ) (write-string "." version )))) )) (deff software-version 'lisp-implementation-version) (defun machine-instance () "Return a string that identifies which particular machine this implementation is." (send local-host :name)) (defun software-type () "Return the generic name of the host software, as a string." "TI Common Lisp") (defun short-site-name () "Return the abbreviated name for this site as a string." (or (get-site-option :short-site-name) site-name)) (defun long-site-name () "Return the long name for this site as a string." (or (get-site-option :long-site-name) site-name)) ;;PAD 3/10/87 Added user-name for the next edition of Steele. (defun user-name () (if (and (stringp user-id) (not (zerop (length user-id )))) user-id ())) ;;; ;;; Misc Environment Predicates ;;; (DEFPARAMETER *addin-microcode-type-codes* '(#.%Microcode-Type-Exp2-MX #.%Microcode-Type-Exp2-MX-Disk #.%Microcode-Type-Exp2-MX-No-SIB #.%Microcode-Type-Exp2-MX-Disk-No-SIB #.%Microcode-Type-MX-Ucode )) (DEFUN type-addin-p (&optional (microcode-type microcode-type-code)) (MEMBER microcode-type *addin-microcode-type-codes* :test #'eq)) (DEFUN type-mx-p (&optional (type processor-type)) "Returns T if TYPE (a processor type number) is of type MX; else NIL." (EQL Type %Processor-Type-MX)) (DEFUN type-exp2-p (&optional (type processor-type)) (EQL type %Processor-Type-Exp2)) (DEFUN type-lashup-p (&optional (microcode-type microcode-type-code)) (AND (type-addin-p microcode-type) (NOT (type-mx-p microcode-type)))) (DEFUN type-mp-p () (let ((slots (read-slots-i-own))) (and (logbitp (logxor #xf0 (system-communication-area %SYS-COM-PROCESSOR-SLOT)) slots) (not (= #xffff (logand slots #xffff))) (type-exp2-p) (MEMBER :MP *features*) (MEMBER :SHARED-AREAS *features*) (find-package 'lx) (find-package 'mp) ))) ;jlm 3/31/89 (PROCLAIM '(notinline using-monitor-p)) (DEFUN using-monitor-p () *sib-present*) (DEFVAR *addin-p* nil) (DEFVAR *lashup-p* nil) (DEFVAR *mx-p* nil) (DEFVAR *exp2-p* nil) (DEFVAR *mp-system-p* nil) ;jlm 2/9/89 (DEFVAR *MP-Explorer-slot-numbers* nil) ;jlm 2/28/89 (DEFVAR *MP-CHECK-NEIGHBOR-DELAY-SECONDS* nil) ; jlm 2/28/89 (DEFUN setup-predicate-vars () (SETQ *addin-p* (NOT (NULL (type-addin-p))) *lashup-p* (type-lashup-p) *exp2-p* (type-exp2-p) *mx-p* (type-mx-p) *mp-system-p* (type-mp-p))) ;jlm 2/9/89 (PROCLAIM '(inline addin-p)) (DEFUN addin-p () "Either (LASHUP-P) or (MX-P) is true." ;; may 04/20/89 *addin-p*) (setf (documentation '*addin-p* 'variable) (documentation 'addin-p 'function)) ;; may 04/20/89 (PROCLAIM '(inline lashup-p)) (DEFUN lashup-p () "Running on a SIMULATED microExplorer on Explorer hardware, and NOT (mx-p)." ;; may 04/20/89 *lashup-p*) (setf (documentation '*lashup-p* 'variable) (documentation 'lashup-p 'function)) ;; may 04/20/89 (PROCLAIM '(inline mx-p)) (DEFUN mx-p () "Running on microExplorer hardware and NOT (lashup-p)." ;; may 04/20/89 *mx-p*) (setf (documentation '*mx-p* 'variable) (documentation 'mx-p 'function)) ;; may 04/20/89 (PROCLAIM '(inline exp2-p)) (DEFUN exp2-p () *exp2-p*) (PROCLAIM '(inline mp-system-p)) (DEFUN mp-system-p () *mp-system-p*) ;jlm 2/9/89 ;; Following for MP cool boot support ;jlm 2/27/89 (defun read-slots-i-own () (let ((a-offset (%pointer-plus A-MEMORY-VIRTUAL-ADDRESS (+ %COUNTER-BLOCK-A-MEM-ADDRESS %SLOTS-I-OWN)))) (DPB (%P-LDB %%q-high-half a-offset) %%q-high-half (%P-LDB %%q-low-half a-offset)))) (defun write-slots-i-own (val) (let ((a-offset (%pointer-plus A-MEMORY-VIRTUAL-ADDRESS (+ %COUNTER-BLOCK-A-MEM-ADDRESS %SLOTS-I-OWN)))) (WITHOUT-INTERRUPTS ;Try not to get inconsistent numbers (%p-dpb (LDB %%q-high-half val) %%q-high-half a-offset) (%p-dpb (LDB %%q-low-half val) %%q-low-half a-offset)))) (proclaim '(inline cool-boot-p)) (Defun COOL-BOOT-P () "Returns a T if the system was cool booted, otherwise a NIL is returned." (logbitp 16. (read-Slots-i-Own))) (proclaim '(inline turn-off-cool-boot-p)) (Defun TURN-OFF-COOL-BOOT-P () "Resets the cool boot flag" (write-slots-i-own (dpb 0 (byte 1 16) (read-slots-i-own)))) (proclaim '(inline enable-cool-boot)) (defun ENABLE-COOL-BOOT () "Enable Cool Booting (turn on bit 17 of %SLOTS-I-OWN)." (write-Slots-I-Own (dpb 1 (byte 1 17) (read-Slots-I-Own)))) (proclaim '(inline disable-cool-boot)) (defun disABLE-COOL-BOOT () "Disable Cool Booting (turn off bit 17 of %SLOTS-I-OWN)." (write-Slots-I-Own (dpb 0 (byte 1 17) (read-Slots-I-Own)))) (DEFUN change-slot-owned (operation slot) "Remove SLOT from slots owned by this processor. OPERATION can be either :delete or :add" (UNLESS (AND (NUMBERP slot) (>= slot 0) (<= slot 15)) (FERROR nil "Slot is not in range 0-15.")) (let ((value (read-slots-i-own))) (si:write-slots-i-own (CASE operation (:delete (LOGANDC2 value (EXPT 2 slot))) (:add (LOGIOR (EXPT 2 slot) value)) (t (ferror "~s is not a valid operation." operation)))))) (DEFUN i-own-p (TYPE &aux (found-slot nil)) "Returns slot where a board of type TYPE resides if owned by this processor. TYPE is a 3 char string as found in config rom." (DO* ((Slot #xF0 (+ 1 Slot))) ((OR found-slot (> Slot #xFF))) (SETQ found-slot (AND (Slot-Owned-P Slot) ; Do we own this slot? (STRING-EQUAL type (board-type slot)) (LOGAND #x0f slot)))) found-slot) ;;; ;;; Environment Resource Support ;;; (DEFVAR *disk-present* t) (DEFVAR *sib-present* t) (DEFVAR *nvram-present* t) (DEFVAR *keyboard-present* t) (DEFVAR *mouse-present* t) (DEFVAR *nubus-present* t) (DEFVAR *we-are-nubus-master* t) (DEFVAR *enet-present* t) ;ab 11/28/88 (DEFVAR *sound-present* t) (DEFVAR *real-time-clock-present* t) (DEFUN Setup-Physical-Resources () (LET (bitmap a-off) (WHEN (VARIABLE-BOUNDP %physical-resource-bitmap) (SETQ a-off (%pointer-plus a-memory-virtual-address (+ %counter-block-a-mem-address %physical-resource-bitmap)) bitmap (DPB (%P-LDB %%q-high-half a-off) %%q-high-half (%P-LDB %%q-low-half a-off))) (SETQ *disk-present* (LDB-TEST %%PRB-Disk bitmap) *sib-present* (OR (LDB-TEST %%PRB-SIB-BW bitmap) (LDB-TEST %%PRB-SIB-Color bitmap)) *nvram-present* (LDB-TEST %%PRB-NVRAM bitmap) *keyboard-present* (LDB-TEST %%PRB-Keyboard bitmap) *mouse-present* (LDB-TEST %%PRB-Mouse bitmap) *we-are-nubus-master* (LDB-TEST %%PRB-NuBus-Master bitmap) *nubus-present* (OR (LDB-TEST %%PRB-NuBus-Master bitmap) (LDB-TEST %%PRB-NuBus-Slave bitmap)) *sound-present* *nvram-present* *real-time-clock-present* *nvram-present* *enet-present* (NOT (type-mx-p)) ;ab 11/28/88 ))) (setup-predicate-vars) ;ab 2/8/88 ) ;;; ;;; MX Boot Status ;;; (DEFUN mx-boot-status () (COND ((mx-p) (LDB %%BCR-MX-Boot-Status (%nubus-read processor-slot-number %Mx-Board-Control-Register))) ((lashup-p) ;;Lashup (LDB (BYTE 3 0) (%nubus-read processor-slot-number %ExpII-Flag-Register))) (t nil)) ) (DEFUN set-mx-boot-status (value) (COND ((mx-p) (%nubus-write processor-slot-number %Mx-Board-Control-Register (DPB value %%BCR-MX-Boot-Status (%nubus-read processor-slot-number %Mx-Board-Control-Register))) value) ((lashup-p) ;;Lashup (%nubus-write processor-slot-number %ExpII-Flag-Register (DPB value (BYTE 3 0) (%nubus-read processor-slot-number %ExpII-Flag-Register))) value) (t nil)) ) (DEFSETF mx-boot-status set-mx-boot-status)