;;; -*- 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 (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. ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;; This file contins the memory monitoring routines (MAR). ;;; Edit History ;;; Data Patcher Patch # Description ;;; ------------------------------------------------------------------------------ ;;; 04-24-89 DAB Added all function, variables, flavors and instances that are documented to export list. ;;; 9/24/87 RJF Changed clear-mar to call unarrest-gc instead of ;;; resume-gc ;;; 2/06/89 RJF - SPR 9285 - removed arrest and unarrest of GC in ;;; in set-mar-in-stack-group, wasn't needed here ;;; and it was causing problems. ;;; 3-20-89 RJF - Fixed set-mar to give error if address is in ;;; one of the special EAS region or train space (DEFVAR *stack-groups-with-mar-set* nil) ;;; SPR 7231 : Correctly handle current stack group is setting and clearing ;;;(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-in-stack-group (mar-mode sg) (if (eq sg current-stack-group) (SETQ %mode-flags (%logdpb mar-mode %%m-flags-mar-mode %mode-flags)) (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))) (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 current stack-group only. With GLOBALLY non-NIL, clear mar in all stack groups where it 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 'unarrest-gc) (NULL *stack-groups-with-mar-set*)) (FUNCALL 'unarrest-gc :mar)) ;; (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)) (WHEN (or (region-train-a-p (%region-number location)) (region-train-p (%region-number location)) (region-entry-p (%region-number location)) (region-oldspace-a-p (%region-number location))) (ferror nil "Cannot set MAR in an :train, :entry, :train-a, or :oldspace-a region")) (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))) (IF (EQ stack-group :all) (set-mar-all-stack-groups mar-mode) (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))))) (export 'sys:mar-break 'sys) ; DAB 04-24-89