Changeset 13084

Timestamp:

Oct 22, 2009, 11:53:29 AM (15 years ago)

Author:

gz

Message:

add core-all-processes, core-process-name, core-list

File:

• branches/working-0711/ccl/library/core-files.lisp (modified) (3 diffs)

branches/working-0711/ccl/library/core-files.lisp

@@ -27 +27 @@
           core-uvtype core-uvtypep core-uvref core-uvsize
           core-car core-cdr core-object-type core-istruct-type
-          copy-from-core
+          copy-from-core core-list
           core-keyword-package core-find-package core-find-symbol
           core-package-names core-package-name
@@ -36 +36 @@
           core-find-class
           core-instance-class-name
-          core-string-equal))
+          core-string-equal
+          core-all-processes core-process-name
+          ))
 
 ;; The intended way to use these facilities is to open up a particular core file once,
@@ -835 +837 @@
 
 
+(defun core-list (ptr)
+  (let ((cars (loop while (core-consp ptr)
+                    collect (core-car ptr)
+                    do (setq ptr (core-cdr ptr)))))
+    (if (core-nullp ptr)
+      cars
+      (nconc cars ptr))))
+
+(defun core-all-processes ()
+  (let* ((sym (core-find-symbol 'all-processes))
+         (closure (core-uvref sym target::symbol.fcell-cell))
+         (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size))
+         (imm-end (core-uvsize closure))
+         (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx)
+                      when (core-uvtypep imm :value-cell) return imm))
+         (val (core-uvref vcell target::value-cell.value-cell))
+         (processes (core-list val)))
+    processes))
+
+(defun core-process-name (proc)
+  (assert (core-uvtypep proc :instance))
+  (let ((slots (core-uvref proc ccl::instance.slots)))
+    (copy-from-core (core-uvref slots 1) :depth 1)))
+
+(defun core-process-tcr (proc)
+  (assert (core-uvtypep proc :instance))
+  (let* ((slots (core-uvref proc ccl::instance.slots))
+         (thread (core-uvref slots 2)))
+    (core-uvref thread ccl::lisp-thread.tcr)))
 
 ) ; :x8664-target