;;; -*- Mode:Common-Lisp; Package:System-Internals; Base:8.; patch-file 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) 1988-1989 Texas Instruments Incorporated. All rights reserved. ;;; This file contains the Lisp-coded support for the Extended Address Space (EAS) ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 01/25/88 HRC original ;;; 10-19-88 RJF/HC Changed EXTENDED-ADDRESS-SPACE-AFTER-COLLECTION-PROCESSING ;;; and EAS-ON with latest EAS changes ;;; 04/25/89 RJF/HRC EAS changes: Changed EAS-ON and EXTENDED-ADDRESS-SPACE ;;; -AFTER-COLLECTION-PROCESSING ;;;;;;;;;;;;;;;;;;;;;; (DEFUN EAS-INITIALIZE () (WHEN (NOT (BOUNDP 'ENTRY-REGION-AREA)) (MAKE-AREA :NAME 'ENTRY-REGION-AREA :REPRESENTATION :STRUCTURE) ;; MAKE THE FIRST REGION NOT USABLE BECAUSE THE MAPS ARE NOT RIGHT. ;; NOW WE FIXUP THE AREA-REGION-BITS THE WAY WE REALLY WANT THEM. (SETF (AREF #'AREA-REGION-BITS ENTRY-REGION-AREA) (%LOGDPB %Region-Meta-Bit-Oldspace %%REGION-OLDSPACE-META-BIT (%LOGDPB %REGION-SPACE-ENTRY %%REGION-SPACE-TYPE (AREA-REGION-BITS ENTRY-REGION-AREA)))) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-ENTRY-REGION-AREA) ENTRY-REGION-AREA)) (WHEN (NOT (BOUNDP 'EXIT-REGION-AREA)) (MAKE-AREA :NAME 'EXIT-REGION-AREA :REPRESENTATION :STRUCTURE :CACHE-INHIBIT 0 ;; DON'T INHIBIT THE CACHE. :GC :STATIC) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-EXIT-REGION-AREA) EXIT-REGION-AREA)) (WHEN (NOT (BOUNDP 'WORLD-RECORD-AREA)) (MAKE-AREA :NAME 'WORLD-RECORD-AREA :CACHE-INHIBIT 0 ;; DON'T INHIBIT THE CACHE. :GC :STATIC) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-WORLD-RECORD-AREA) WORLD-RECORD-AREA)) (WHEN (NOT (BOUNDP 'REGION-WORLD-RECORD)) (SETF REGION-WORLD-RECORD (MAKE-ARRAY SIZE-OF-REGION-ARRAYS :AREA 'EXIT-REGION-AREA :INITIAL-ELEMENT NIL)) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-WORLD-RECORD) REGION-WORLD-RECORD)) (WHEN (NOT (BOUNDP 'REGION-WORLD-LIST-THREAD)) (SETF REGION-WORLD-LIST-THREAD (MAKE-ARRAY SIZE-OF-REGION-ARRAYS :AREA 'EXIT-REGION-AREA :INITIAL-ELEMENT 0)) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-WORLD-LIST-THREAD) REGION-WORLD-LIST-THREAD)) (WHEN (NOT (BOUNDP 'REGION-INTERNAL-EXTERNAL-TRANSLATE-TABLE)) (SETF REGION-INTERNAL-EXTERNAL-TRANSLATE-TABLE (MAKE-ARRAY SIZE-OF-REGION-ARRAYS :AREA 'EXIT-REGION-AREA :INITIAL-ELEMENT 0)) (SETF (SI:SYSTEM-COMMUNICATION-AREA SI:%SYS-COM-INTERNAL-EXTERNAL-TRANSLATE-TABLE) REGION-INTERNAL-EXTERNAL-TRANSLATE-TABLE)) ) (DEFUN FAULTED-TO-FINAL (WORLD-REC) (IF (= (AREF WORLD-REC %WORLD-RECORD-STATE) %FAULTED-IN-STATE) (SETF (AREF WORLD-REC %WORLD-RECORD-STATE) %FINAL-STATE))) (DEFUN EXTENDED-ADDRESS-SPACE-BEFORE-FLIP-PROCESSING () "This function performs various houskeeping functions required by the extended address space feature before a generation 3 collection. This consist of: 1. Make all regions of WORLD-RECORD-AREA usage 0 so that these objects will NOT be exported. 2. Run the list of world records converting all worlds in %FAULTED-IN-STATE to %FINAL-STATE." (DO ((REGION (AREA-REGION-LIST WORLD-RECORD-AREA) (REGION-LIST-THREAD REGION))) ((MINUSP REGION)) (SETF (AREF #'REGION-BITS REGION) (%LOGDPB 0 %%REGION-USAGE (REGION-BITS REGION)))) (IF (LISTP EXTENDED-ADDRESS-SPACE) (MAPC #'FAULTED-TO-FINAL EXTENDED-ADDRESS-SPACE))) (DEFUN STATE-OF-WORLD (WORLD) (AREF WORLD %WORLD-RECORD-STATE)) (DEFUN RELEASE-REGION-LIST (FIRST-REGION AREA) (DO ((REGION-TO-FREE FIRST-REGION (AREF REGION-WORLD-LIST-THREAD REGION-TO-FREE))) ((= 0 REGION-TO-FREE)) (WITHOUT-INTERRUPTS (IF (AND (= region-to-free (area-region-list area)) (= 0 (REGION-LIST-THREAD region-to-free))) ;; Only region in the area. We can't leave area with no regions, ;; so just set REGION-FREE-POINTER to zero AND NIL THE REGION-WORLD-RECORD ENTRY. (SETF (AREF #'REGION-FREE-POINTER REGION-TO-FREE) 0. (AREF REGION-WORLD-RECORD REGION-TO-FREE) NIL) ;; NOT THE ONLY REGION IN THE AREA. MUST FIND THE PREVIOUS REGION IN THE AREA ;; SO WE CAN DELINK REGION-TO-FREE. (DO ((REGION (AREA-REGION-LIST AREA)) (prev-region nil)) ((MINUSP REGION)) (IF (/= REGION REGION-TO-FREE) (SETF PREV-REGION REGION REGION (REGION-LIST-THREAD REGION)) ;; Before freeing region, un-link it from region list. (IF prev-region (SETF (AREF #'REGION-LIST-THREAD prev-region) (REGION-LIST-THREAD region)) (SETF (AREF #'AREA-REGION-LIST area) (REGION-LIST-THREAD region))) ;; Now free up the swap space and return region to free pool. (deallocate-swap-space region-to-free) (%gc-free-region region-to-free) (SETF REGION -1))))))) (DEFUN EXTENDED-ADDRESS-SPACE-AFTER-COLLECTION-PROCESSING () "This function performs various housekeeping functions required by the extended address space feature after a generation 3 collection. This consists of: 1. Run the list of world records to eliminate all world records in state 3. 2. Inspect %CURRENT-WORLD-RECORD and hook new external worlds on the EXTENDED-ADDRESS-SPACE list." (WHEN (LISTP EXTENDED-ADDRESS-SPACE) (DO ((DEAD-WORLD (CAR (MEMBER %FINAL-STATE EXTENDED-ADDRESS-SPACE :KEY #'STATE-OF-WORLD)) (CAR (MEMBER %FINAL-STATE EXTENDED-ADDRESS-SPACE :KEY #'STATE-OF-WORLD)))) ((NOT DEAD-WORLD) (IF (NOT EXTENDED-ADDRESS-SPACE) (SETF EXTENDED-ADDRESS-SPACE T))) (SETF EXTENDED-ADDRESS-SPACE (DELETE DEAD-WORLD EXTENDED-ADDRESS-SPACE)) (RELEASE-REGION-LIST (AREF DEAD-WORLD %ENTRY-REGIONS) ENTRY-REGION-AREA))) (WHEN (/= 0. (LDB %%Q-POINTER (READ-METER '%CURRENT-WORLD-RECORD))) (LET ((NEW-WORLD-LIST NIL)) (DO ((NEW-WORLD (%MAKE-POINTER DTP-ARRAY (%LOGDPB (LDB (BYTE 1. 24.) (READ-METER '%CURRENT-WORLD-RECORD)) (BYTE 1. 24.) (LDB (BYTE 24. 0) (READ-METER '%CURRENT-WORLD-RECORD)))) (AREF NEW-WORLD %WORLD-LINK))) ((NOT NEW-WORLD) (DOLIST (WORLD NEW-WORLD-LIST) (IF (LISTP EXTENDED-ADDRESS-SPACE) (PUSH WORLD EXTENDED-ADDRESS-SPACE) (SETF EXTENDED-ADDRESS-SPACE (CONS WORLD NIL))))) (PUSH NEW-WORLD NEW-WORLD-LIST))))) (DEFUN EAS-ON () (WHEN (AND (NOT EXTENDED-ADDRESS-SPACE) (/= 0 (READ-METER '%MAX-EXTERNAL-WORLD-SIZE))) ;; UNLOCK BAND TRAINED REGIONS. (SI:MAKE-GENERATION-THREE-DYNAMIC) ;; LOCKUP THE GENERATION THREE SYMBOL REGIONS. (SI:MAKE-AREA-REGIONS-STATIC SI:NR-SYM) (SETF EXTENDED-ADDRESS-SPACE T) (SHIFT-GEN-THREE) (SHIFT-GEN-THREE) (SHIFT-GEN-THREE)) ;; TURN TRAINING ON IF IT IS NOT ALREADY ON. (IF (NOT *ADAPTIVE-TRAINING-ENABLED*) (TRAINING-ON)) ;; TURN AUTOMATIC GC ON IF IT IS NOT ALREADY ON. (IF (NOT (GC-ACTIVE-P)) (GC-ON))) (DEFUN SORT-CELLS (&OPTIONAL (EXIT-CELLS NIL)) "Report the status of ENTRY or EXIT cells. If optional argument is nil then ENTRY cells are reported. If T then EXIT cells are reported." (LET ((TOTAL-NUMBER-OF-CELLS 0.) (TOTAL-NUMBER-OF-UNIQUE-CELLS 0.) (WORLD-COUNTER 0.) (INDEX (IF EXIT-CELLS %EXIT-REGIONS %ENTRY-REGIONS))) (IF EXIT-CELLS (FORMAT T "~%REPORT OF EXIT CELL STATUS.") (FORMAT T "~%REPORT OF ENTRY CELL STATUS.")) (DOLIST (WORLD EXTENDED-ADDRESS-SPACE) (INCF WORLD-COUNTER) (LET ((CELL-LIST NIL)) (DO ((REGION (AREF WORLD INDEX) (AREF REGION-WORLD-LIST-THREAD REGION))) ((= REGION 0)) (DO ((ADDR (REGION-ORIGIN REGION) (%MAKE-POINTER-OFFSET DTP-FIX ADDR 1.)) (MAX-ADDR (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION) (REGION-FREE-POINTER REGION)))) ((= ADDR MAX-ADDR)) (IF (/= (%P-LDB %%Q-DATA-TYPE ADDR) DTP-CHARACTER) (PUSH (%MAKE-POINTER DTP-FIX (%P-LDB %%Q-POINTER ADDR)) CELL-LIST)))) (SETF CELL-LIST (SORT CELL-LIST '<)) (DO* ((NUMBER-OF-CELLS 1. (1+ NUMBER-OF-CELLS)) (NUMBER-OF-UNIQUE-CELLS 1.) (PREV-POINTER CELL-LIST (CDR PREV-POINTER)) (CURR-POINTER (CDR CELL-LIST) (CDR CURR-POINTER))) ((NOT CURR-POINTER) (FORMAT T "~%WORLD ~D. NUMBER OF CELLS = ~:D., NUMBER OF UNIQUE CELLS = ~:D." WORLD-COUNTER NUMBER-OF-CELLS NUMBER-OF-UNIQUE-CELLS) (INCF TOTAL-NUMBER-OF-CELLS NUMBER-OF-CELLS) (INCF TOTAL-NUMBER-OF-UNIQUE-CELLS NUMBER-OF-UNIQUE-CELLS)) (IF (/= (CAR PREV-POINTER) (CAR CURR-POINTER)) (INCF NUMBER-OF-UNIQUE-CELLS))))) (FORMAT T "~% TOTAL NUMBER OF CELLS = ~:D., TOTAL NUMBER OF UNIQUE CELLS = ~:D." TOTAL-NUMBER-OF-CELLS TOTAL-NUMBER-OF-UNIQUE-CELLS)))