LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031675. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "MONITORS" :DIRECTORY ("REL3-SOURCE" "MEMORY-MANAGEMENT") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758728057. :AUTHOR "REL3" :LENGTH-IN-BYTES 4638. :LENGTH-IN-BLOCKS 5. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    ;;; -*- Mode:Common-Lisp; Package:SI; Base:8.; -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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;;;** (c) Copyright 1980 Massachusetts Institute of Technology **;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;; This file contins the memory monitoring routines (MAR).(DEFVAR *stack-groups-with-mar-set* nil)(DEFUN set-mar-in-stack-group (mar-mode sg)  (SETF (sg-saved-m-flags sg)(%logdpb mar-mode %%m-flags-mar-mode (sg-saved-m-flags sg)))  (SETQ *stack-groups-with-mar-set*(IF (ZEROP mar-mode)    (DELETE (CONS :mar sg) *stack-groups-with-mar-set* :test #'EQUAL)    (CONS (CONS :mar sg) *stack-groups-with-mar-set*)))) (DEFUN set-mar-all-stack-groups (mar-mode)  (LOOP FOR p IN all-processes DO(WHEN (SEND p :active-p)  (LET ((sg (SEND p :stack-group)))    (WHEN (AND sg       (TYPEP sg 'STACK-GROUP)       (NOT (= (sg-state sg) sg-state-awaiting-error-recovery)))      (IF (ZEROP mar-mode)  (unarrest-gc (CONS :mar sg))  (arrest-gc (CONS :mar sg)))      (set-mar-in-stack-group mar-mode sg)))))  )(DEFUN clear-mar (&optional (globally nil))  "Clear out the mar setting.  With GLOBLLY NIL, clears mar mode of currentstack-group only.  With GLOBALLY non-NIL, clear mar in all stack groups whereit has been set."  (DO ((p %mar-low (%POINTER-PLUS p page-size)))      ((%pointer> p %mar-high))    ;; Flush maps if in core.  Does nothing if not in core.    (%change-page-status      p nil (LDB %%region-map-bits (AREF #'region-bits (%region-number p)))))  (SETQ %mar-low -1%mar-high -2)  (IF globally      (LOOP FOR (mar . sg) IN *stack-groups-with-mar-set* DO    (set-mar-in-stack-group 0 sg))      (set-mar-in-stack-group 0 current-stack-group))  (WHEN (AND (FBOUNDP 'resume-gc)     (NULL *stack-groups-with-mar-set*)     (FUNCALL 'resume-gc :mar)))  nil)(ADD-INITIALIZATION "Clear MAR settings" '(CLEAR-MAR t) :warm)(DEFUN set-mar (location mar-mode &optional (n-words 1)(stack-group current-stack-group))  "Set trap on reference to N-WORDS words starting at LOCATION.N-WORDS defaults to 1.  MAR-MODE should be :READ, :WRITE or T, meaning both :READ and :WRITE."  (CHECK-ARG stack-group (OR (TYPEP stack-group 'STACK-GROUP) (EQ stack-group :all))     "A stack-group or the keyword :ALL")  (CHECK-ARG n-words (OR (EQ n-words :object-size) (AND (NUMBERP n-words) (PLUSP n-words)))     "A positive integer or the keyword :OBJECT-SIZE.")  ;; These checks are for the hackers who provide a FIXNUM to set-mar!  (UNLESS (pointer-valid-p location)    (FERROR nil "LOCATION ~a is not a valid virtual memory location" location))  (WHEN (region-oldspace-p (%region-number location))    (FERROR nil "Cannot set MAR in oldspace (LOCATION ~a)" location))  (SETQ mar-mode(SELECT MAR-MODE  (:READ 1)  (:WRITE 2)  ((T) 3)  ((NIL) (FERROR nil "NIL is not a valid MAR-MODE for SET-MAR.  Use CLEAR-MAR instead."))  (OTHERWISE (FERROR NIL "~S is not a valid MAR-MODE" mar-mode))))  (CLEAR-MAR (NEQ stack-group current-stack-group));clear old mar  (WHEN (FBOUNDP 'arrest-gc)    (FUNCALL 'arrest-gc :mar))  (SETQ %mar-low (%POINTER (FOLLOW-CELL-FORWARDING location t)))  (SETQ %mar-high (%POINTER-PLUS %mar-low (1- n-words)))  ;; Assure no "overflow"  (UNLESS (%pointer>= %mar-high %mar-low)    (SETQ %mar-high -1))    ;; If MAR'ed pages are in core, set up h/w maps.  (DO ((p %mar-low (%pointer-plus p page-size)))      ((%pointer> p %mar-high))    (%change-page-status      p nil (%LOGDPB %pht-map-status-mar     (BYTE 4. 3.)     (%LOGLDB %%region-map-bits (AREF #'region-bits (%region-number p))))))  (IF (EQ stack-group :all)      (set-mar-all-stack-groups mar-mode)      (IF (EQ stack-group current-stack-group)  (SETQ %mode-flags (%logdpb mar-mode %%m-flags-mar-mode %mode-flags))  (set-mar-in-stack-group mar-mode stack-group)))  t)(DEFUN mar-mode (&optional (sg current-stack-group))  (LET ((mode (LDB %%m-flags-mar-mode   (IF (EQ sg current-stack-group)       %mode-flags       (sg-saved-m-flags sg)))))     (SELECT mode       (0 'nil)       (1 ':read)       (2 ':write)       (3 't)       (:otherwise (FERROR NIL "The MAR mode, ~d, is invalid." mode)))))ader-Forward   DTP-Body-Forward   DTP-GC-Forward   DTP-GC-Young-Pointer   DTP-External-Value-Cell-Pointer)  )(DEFVAR *misc-types*'(DTP-Self-Ref-Pointer))(DEFVAR *trap-types*'(DTP-Trap   #+elroy DTP-Ones-Trap   #-elroy DTP-Unused-31   DTP-Null))(DEFVAR *unused-types*'(DTP-Free  #-elroy DTP-Unused-31   ));; Other vars(DEFVAR *dtp-list-for-printing* nil)(DEFVAR *cdr-code-list-for-printing* '("<CDR-NORMAL>" "<CDR-ERROR>" "<CDR-NIL>" "<CDR-NEXT>