Changeset 10461
- Timestamp:
- Aug 13, 2008, 11:41:37 AM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-processes.lisp
r10426 r10461 211 211 (thread-exhausted-p thread)))) 212 212 213 213 ;;; This should be way more concerned about being correct and thread-safe 214 ;;; than about being quick: it's generally only called while printing 215 ;;; or debugging, and there are all kinds of subtle race conditions 216 ;;; here. 214 217 (defun process-whostate (p) 215 218 "Return a string which describes the status of a specified process." 216 (if (process-exhausted-p p) 217 "Exhausted" 218 (let* ((loc nil)) 219 (if (eq p *current-process*) 220 (setq loc (%tcr-binding-location (%current-tcr) '*whostate*)) 221 (let* ((tcr (process-tcr p))) 222 (without-interrupts 223 (unwind-protect 224 (progn 225 (%suspend-tcr tcr) 226 (setq loc (%tcr-binding-location tcr '*whostate*))) 227 (%resume-tcr tcr))))) 228 (if loc 229 (%fixnum-ref loc) 230 (if (eq p *initial-process*) 231 "Active" 232 "Reset"))))) 219 (let* ((ip *initial-process*)) 220 (cond ((eq p *current-process*) 221 (if (%tcr-binding-location (%current-tcr) '*whostate*) 222 *whostate* 223 (if (eq p ip) 224 "Active" 225 "Reset"))) 226 (t 227 (without-interrupts 228 (with-lock-grabbed (*kernel-exception-lock*) 229 (with-lock-grabbed (*kernel-tcr-area-lock*) 230 (let* ((tcr (process-tcr p))) 231 (if tcr 232 (unwind-protect 233 (let* ((loc nil)) 234 (%suspend-tcr tcr) 235 (setq loc (%tcr-binding-location tcr '*whostate*)) 236 (if loc 237 (%fixnum-ref loc) 238 (if (eq p ip) 239 "Active" 240 "Reset"))) 241 (%resume-tcr tcr)) 242 "Exhausted"))))))))) 233 243 234 244 (defun (setf process-whostate) (new p) … … 257 267 (if (eq process *current-process*) 258 268 (symbol-value sym) 259 (symbol-value-in-tcr sym (process-tcr process)))) 269 (let* ((val 270 (without-interrupts 271 (with-lock-grabbed (*kernel-exception-lock*) 272 (with-lock-grabbed (*kernel-tcr-area-lock*) 273 (let* ((tcr (process-tcr process))) 274 (if tcr 275 (symbol-value-in-tcr sym tcr) 276 (%sym-global-value sym)))))))) 277 (if (eq val (%unbound-marker)) 278 ;; This might want to be a CELL-ERROR. 279 (error "~S is unbound in ~S." sym process) 280 val)))) 260 281 261 282 (defun (setf symbol-value-in-process) (value sym process) 262 283 (if (eq process *current-process*) 263 284 (setf (symbol-value sym) value) 264 (setf (symbol-value-in-tcr sym (process-tcr process)) value))) 285 (with-lock-grabbed (*kernel-exception-lock*) 286 (with-lock-grabbed (*kernel-tcr-area-lock*) 287 (let* ((tcr (process-tcr process))) 288 (if tcr 289 (setf (symbol-value-in-tcr sym tcr) value) 290 (%set-sym-global-value sym value))))))) 265 291 266 292
Note: See TracChangeset
for help on using the changeset viewer.