Changeset 13085


Ignore:
Timestamp:
Oct 22, 2009, 7:01:09 PM (10 years ago)
Author:
gz
Message:

core file utilities (merged from r13068, r13071, r13084)

Location:
trunk/source
Files:
3 edited
1 copied

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-boot-2.lisp

    r13067 r13085  
    314314      (bin-load-provide "COVER" "cover")
    315315      (bin-load-provide "LEAKS" "leaks")
     316      (bin-load-provide "CORE-FILES" "core-files")
    316317      (bin-load-provide "MCL-COMPAT" "mcl-compat")
    317318      (require "LOOP")
  • trunk/source/lib/compile-ccl.lisp

    r13067 r13085  
    208208    cover
    209209    leaks
     210    core-files
    210211    asdf
    211212    defsystem
  • trunk/source/lib/systems.lisp

    r13067 r13085  
    208208    (cover            "ccl:bin;cover"            ("ccl:library;cover.lisp"))
    209209    (leaks            "ccl:bin;leaks"            ("ccl:library;leaks.lisp"))
     210    (core-files       "ccl:bin;core-files"       ("ccl:library;core-files.lisp"))
    210211 
    211212    (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp"))
  • trunk/source/library/core-files.lisp

    r13068 r13085  
    2727          core-uvtype core-uvtypep core-uvref core-uvsize
    2828          core-car core-cdr core-object-type core-istruct-type
    29           copy-from-core
     29          copy-from-core core-list
    3030          core-keyword-package core-find-package core-find-symbol
    3131          core-package-names core-package-name
     
    3636          core-find-class
    3737          core-instance-class-name
    38           core-string-equal))
     38          core-string-equal
     39          core-all-processes core-process-name
     40          ))
    3941
    4042;; The intended way to use these facilities is to open up a particular core file once,
     
    586588                    (find-package (core-package-name obj)))
    587589               (let ((v (%copy-uvector-from-core obj depth)))
    588                  (format t "~&Copied #x~x, depth=~s symbolp=~s @~x"
    589                          obj depth (symbolp v) (%fixnum-address-of v))
    590590                 (when (and (symbolp v) (<= depth 1))
    591591                   ;; Need to fix up the package slot else it's not useful
    592592                   (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell)))
    593                      (format t "~&pp = ~x" pp)
    594593                     (when (unresolved-address-p pp)
    595594                       (setq pp (copy-from-core pp :depth 1)))
     
    838837
    839838
     839(defun core-list (ptr)
     840  (let ((cars (loop while (core-consp ptr)
     841                    collect (core-car ptr)
     842                    do (setq ptr (core-cdr ptr)))))
     843    (if (core-nullp ptr)
     844      cars
     845      (nconc cars ptr))))
     846
     847(defun core-all-processes ()
     848  (let* ((sym (core-find-symbol 'all-processes))
     849         (closure (core-uvref sym target::symbol.fcell-cell))
     850         (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size))
     851         (imm-end (core-uvsize closure))
     852         (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx)
     853                      when (core-uvtypep imm :value-cell) return imm))
     854         (val (core-uvref vcell target::value-cell.value-cell))
     855         (processes (core-list val)))
     856    processes))
     857
     858(defun core-process-name (proc)
     859  (assert (core-uvtypep proc :instance))
     860  (let ((slots (core-uvref proc ccl::instance.slots)))
     861    (copy-from-core (core-uvref slots 1) :depth 1)))
     862
     863(defun core-process-tcr (proc)
     864  (assert (core-uvtypep proc :instance))
     865  (let* ((slots (core-uvref proc ccl::instance.slots))
     866         (thread (core-uvref slots 2)))
     867    (core-uvref thread ccl::lisp-thread.tcr)))
    840868
    841869) ; :x8664-target
Note: See TracChangeset for help on using the changeset viewer.