Index: /branches/working-0711/ccl/library/core-files.lisp
===================================================================
--- /branches/working-0711/ccl/library/core-files.lisp	(revision 13144)
+++ /branches/working-0711/ccl/library/core-files.lisp	(revision 13145)
@@ -24,5 +24,5 @@
           core-heap-utilization map-core-areas map-core-pointers
           core-q core-l core-w core-b
-          core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p
+          core-consp core-symbolp core-listp core-nullp core-uvector-p
           core-uvtype core-uvtypep core-uvref core-uvsize
           core-car core-cdr core-object-type core-istruct-type
@@ -33,23 +33,14 @@
           core-symbol-name core-symbol-value core-symbol-package
           core-gethash core-hash-table-count
-          core-lfun-name core-lfun-bits
+          core-lfun-name
           core-find-class
-          core-instance-class
-          core-instance-p
           core-instance-class-name
           core-string-equal
           core-all-processes core-process-name
-          core-find-process-for-id
-          core-print
-          core-print-call-history
           ))
-
-(eval-when (:compile-toplevel :execute)
-  (require "HASHENV" "ccl:xdump;hashenv"))
 
 ;; The intended way to use these facilities is to open up a particular core file once,
 ;; and then repeatedly call functions to examine it.  So for convenience, we keep the
 ;; core file in a global var, rather than making all user functions take an extra arg.
-;; There is nothing intrinsic that would prevent having multiple core files open at once.
 
 (defvar *current-core* nil)
@@ -57,5 +48,4 @@
 
 (defstruct core-info
-  pathname
   sections
   ;; uses either stream or ivector, determined at runtime
@@ -67,5 +57,4 @@
   classes-hash-table-ptr
   lfun-names-table-ptr
-  process-class
   )
 
@@ -97,5 +86,5 @@
     (close-core))
   (let* ((sections (readelf-sections pathname))
-         (core (make-core-info :pathname pathname :sections sections)))
+         (core (make-core-info :sections sections)))
     (ecase method
       (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
@@ -259,5 +248,6 @@
 (defun kernel-global-address (global)
   (check-type global symbol)
-  (+ (target-nil-value) (target::%kernel-global global)))
+  (+ (target-nil-value)
+     (target::%kernel-global (or (find-symbol (symbol-name global) :ccl) global))))
 
 (defun nil-relative-symbol-address (sym)
@@ -400,5 +390,5 @@
 
 
-(declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp))
+(declaim (inline core-consp core-symbolp core-listp core-nullp))
 
 (defun core-consp (ptr)
@@ -407,7 +397,4 @@
 (defun core-symbolp (ptr)
   (eq (logand ptr target::fulltagmask) target::fulltag-symbol))
-
-(defun core-functionp (ptr)
-  (eq (logand ptr target::fulltagmask) target::fulltag-function))
 
 (defun core-listp (ptr)
@@ -674,5 +661,5 @@
              (setf (uvref vec i) (core-w addr (ash i 1))))))))
 
-(defun map-core-pointers (fn &key area)
+(defun map-core-pointers (fn)
   (map-core-areas (lambda (obj)
                     (cond ((core-consp obj)
@@ -693,37 +680,13 @@
                                      (decf len skip)))
                                  (dotimes (i len)
-                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
-                  :area area))
-
-(defun core-find-tra-function (tra)
-  (assert (eq (logand tra target::tagmask) target::tag-tra))
-  (map-core-areas (lambda (obj)
-                    (when (core-uvtypep obj :function)
-                      (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size))
-                             (skip  (core-l addr))
-                             (offset (- tra addr)))
-                        (when (<= 0 offset (ash skip target::word-shift))
-                          (return-from core-find-tra-function (values obj (+ offset (- target::node-size
-                                                                                       (logand obj target::fulltagmask)))))))))))
-
-(defun core-instance-class (obj)
+                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))))
+
+
+(defun core-instance-class-name (obj)
   (when (core-uvtypep obj :slot-vector)
     (setq obj (core-uvref obj slot-vector.instance)))
   (assert (core-uvtypep obj :instance))
-  (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class))
-
-(defun core-instance-p (obj class)
-  (and (core-uvtypep obj :instance)
-       (labels ((matchp (iclass)
-                  (or (eql iclass class)
-                      (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers)
-                              then (core-cdr supers)
-                            while (core-consp supers)
-                            thereis (matchp (core-car supers))))))
-         (matchp (core-instance-class obj)))))
-
-
-(defun core-instance-class-name (obj)
-  (let* ((class (core-instance-class obj))
+  (let* ((wrapper (core-uvref obj instance.class-wrapper))
+         (class (core-uvref wrapper %wrapper-class))
          (class-slots (core-uvref class instance.slots))
          (name (core-uvref class-slots %class.name)))
@@ -869,34 +832,8 @@
             (core-symbol-value (core-find-symbol '*lfun-names*)))))
 
-(defun core-closure-function (fun)
-  (while (and (core-functionp fun)
-              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
-    (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
-      (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
-      (when (core-uvtypep fun :simple-vector)
-        (setq fun (core-uvref fun 0)))
-      #+gz (assert (core-functionp fun))))
-  fun)
-
-    
 (defun core-lfun-name (fn)
-  (assert (core-functionp fn))
-  (flet ((lfun-name (fn)
-           (or (core-gethash fn (core-lfun-names-table-ptr))
-               (let* ((lfbits (core-lfun-bits fn))
-                      (name (if (and (logbitp $lfbits-gfn-bit lfbits)
-                                     (not (logbitp $lfbits-method-bit lfbits)))
-                                (core-uvref (core-uvref fn gf.slots) sgf.name)
-                                (unless (logbitp $lfbits-noname-bit lfbits)
-                                  (core-uvref fn (- (core-uvsize fn) 2))))))
-                 (and name
-                      (not (eql name (%fixnum-address-of (%slot-unbound-marker))))
-                      (not (core-nullp name))
-                      name)))))
-    (or (lfun-name fn)
-        (let ((inner-fn (core-closure-function fn)))
-          (and (core-functionp inner-fn)
-               (not (eql inner-fn fn))
-               (lfun-name inner-fn))))))
+  (assert (core-uvtypep fn :function))
+  (core-gethash fn (core-lfun-names-table-ptr)))
+
 
 (defun core-list (ptr)
@@ -930,254 +867,3 @@
     (core-uvref thread ccl::lisp-thread.tcr)))
 
-(defun core-find-process-for-id (lwp)
-  (loop for proc in (core-all-processes)
-        when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id))
-          return proc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun core-process-class ()
-  (or (core-info-process-class (current-core))
-      (setf (core-info-process-class (current-core))
-            (core-find-class 'process))))
-
-(defun core-print (obj &optional stream depth)
-  ;; TODO: could dispatch on core-object-type...
-  (cond ((core-nullp obj) (format stream "NIL"))
-        ((core-symbolp obj)
-         (core-print-symbol obj stream))
-        ((core-uvtypep obj :function)
-         (core-print-function obj stream))
-        ((core-instance-p obj (core-process-class))
-         (core-print-process obj stream))
-        ((and depth (< (decf depth) 0))
-         (format stream "x~x" obj))
-        ((core-consp obj)
-         (loop for sep = "(" then " "
-               for i from 0 below (or *print-length* 100)
-               while (core-consp obj)
-               do (format stream sep)
-               do (core-print (core-car obj) stream depth)
-               do (setq obj (core-cdr obj)))
-         (unless (core-nullp obj)
-           (format stream " . ")
-           (core-print obj stream depth))
-         (format stream ")"))
-        (t (format stream "#<core ~s x~x>"
-                   (core-object-type obj) obj))))
-
-(defun core-print-symbol (sym stream)
-  (let ((package (core-symbol-package sym)))
-    (cond ((core-nullp package)
-           (format stream "#:"))
-          ((eq package (core-keyword-package))
-           (format stream ":"))
-          (t (let ((pkgname (core-package-name package)))
-               (unless (string-equal pkgname "COMMON-LISP")
-                 (format stream "~a::" pkgname)))))
-    (format stream "~a" (core-symbol-name sym))))
-
-(defun core-lfun-bits (fun)
-  (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift)))
-
-(defun core-print-function (fun stream)
-  (let* ((lfbits (core-lfun-bits fun))
-         (name (core-lfun-name fun)))
-    (format stream "#<")
-    (cond ((or (null name) (core-nullp name))
-           (format stream "Anonymous function"))
-          ((logbitp $lfbits-method-bit lfbits)
-           (assert (core-uvtypep name :instance))
-           (let* ((slot-vector (core-uvref name instance.slots))
-                  (method-qualifiers (core-uvref slot-vector %method.qualifiers))
-                  (method-specializers (core-uvref slot-vector %method.specializers))
-                  (method-name (core-uvref slot-vector %method.name)))
-             (format stream "Method-Function ")
-             (core-print method-name stream)
-             (format stream " ")
-             (unless (core-nullp method-qualifiers)
-               (if (core-nullp (core-cdr method-qualifiers))
-                 (core-print (core-car method-qualifiers) stream)
-                 (core-print method-qualifiers stream))
-               (format stream " "))
-             ;; print specializer list but print names instead of classes.
-             (loop for sep = "(" then " "
-                   while (core-consp method-specializers)
-                   do (format stream sep)
-                   do (let ((spec (core-car method-specializers)))
-                        (if (core-uvtypep spec :instance)
-                          (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream)
-                          (core-print spec stream)))
-                   do (setq method-specializers (core-cdr method-specializers)))
-             (unless (core-nullp method-specializers)
-               (format stream " . ")
-               (core-print method-specializers stream))
-             (format stream ")")))
-          (t
-           (if (logbitp $lfbits-gfn-bit lfbits)
-               (format stream "Generic Function ")
-               (format stream "Function "))
-           (core-print name stream)))
-    (format stream " x~x>" fun)))
-
-(defun core-print-process (proc stream)
-  (format stream "#<~a ~s LWP(~d) #x~x>"
-          (core-instance-class-name proc)
-          (core-process-name proc)
-          (core-q (core-process-tcr proc) target::tcr.native-thread-id)
-          proc))
-
-(defun dwim-core-frame-pointer (tcr &optional end)
-  (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr)))
-         (lexprs (list (core-q (kernel-global-address 'lexpr-return))
-                       (core-q (kernel-global-address 'lexpr-return1v))))
-         (stack-area (core-q tcr target::tcr.vs-area))
-         (fp (core-q stack-area target::area.high))
-         (low (core-q stack-area target::area.low)))
-    (flet ((validp (pp)
-             (let ((tra (core-q pp target::lisp-frame.return-address)))
-               (when (eql tra ret1valn)
-                 (setq tra (core-q pp target::lisp-frame.xtra)))
-               (or (eql (logand tra target::tagmask) target::tag-tra)
-                   (eql tra 0)
-                   (member tra lexprs)))))
-      (decf fp (* 2 target::node-size))
-      (when (and end (<= low end fp))
-        (setq low (- end 8)))
-      (loop while
-            (loop for pp downfrom (- fp target::node-size) above low by target::node-size
-                  do (when (eql (core-q pp target::lisp-frame.backptr) fp)
-                       (when (validp pp)
-                         (return (setq fp pp))))))
-      fp)))
-
-(defun core-stack-frame-values (tcr fp)
-  (let* ((bottom (core-q fp target::lisp-frame.backptr))
-         (top (if (eql 0 (core-q fp target::lisp-frame.return-address))
-                (+ fp target::xcf.size)
-                (+ fp (if (eql (core-q fp target::lisp-frame.return-address)
-                               (kernel-global-address 'ret1valaddr))
-                        target::lisp-frame.size
-                        target::lisp-frame.xtra))))
-         (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db)
-                        until (or (eql db 0) (>= db bottom))
-                        when (<= top db) return db)))
-    (loop for vsp from top below bottom by target::node-size
-          when (eql vsp db-link)
-            ;; The db-link will be followed by var and val, which we'll just collect normally
-            do (setq db-link (core-q db-link) vsp (+ vsp target::node-size))
-            and collect `(:db-link ,db-link)
-          collect (core-q vsp))))
-
-(defun core-print-call-history (process &key (stream t) origin detailed-p)
-  (flet ((fp-backlink (fp vs-end)
-           (let ((backlink (core-q fp target::lisp-frame.backptr)))
-             (when (or (eql backlink 0)
-                       (<= vs-end backlink)
-                       (<= vs-end (core-q backlink target::lisp-frame.backptr)))
-               (setq backlink vs-end))
-             (assert (< fp backlink))
-             backlink))
-         (fp-tra (fp)
-           (let ((tra (core-q fp target::lisp-frame.return-address)))
-             (if (eql tra (core-q (kernel-global-address 'ret1valaddr)))
-               (core-q fp target::lisp-frame.xtra)
-               tra)))
-         (recover-fn (pc)
-           (when (and (eql (logand pc target::tagmask) target::tag-tra)
-                      (eql (core-w pc) target::recover-fn-from-rip-word0)
-                      (eql (core-b pc 2) target::recover-fn-from-rip-byte2))
-             (+ pc target::recover-fn-from-rip-length
-                (- (core-l pc target::recover-fn-from-rip-disp-offset)
-                   #x100000000)))))
-    (format stream "~&")
-    (core-print process stream)
-    (let* ((tcr (core-process-tcr process))
-           (vs-area (core-q tcr target::tcr.vs-area))
-           (vs-end (core-q vs-area target::area.high))
-           (valence (core-q tcr target::tcr.valence))
-           (fp (or origin
-                   ;; TODO: find the registers in the core file!
-                   (case valence
-                     ;; TCR_STATE_LISP
-                     (0 (let ((xp (core-q tcr target::tcr.suspend-context)))
-                          (format stream "~&")
-                          (if (eql xp 0)
-                            (format stream "Unknown lisp context, guessing frame pointer:")
-                            (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn
-                          (if (eql xp 0)
-                            (dwim-core-frame-pointer tcr)
-                            ;; uc_mcontext.gregs[rbp]
-                            (core-q xp (* 15 target::node-size)))))
-                     ;; TCR_STATE_FOREIGN
-                     (1 (format stream "~&In foreign code")
-                        ;; the save-rbp seems to include some non-lisp frames sometimes,
-                        ;; shave them down.
-                        #+no (core-q tcr target::tcr.save-rbp)
-                        (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp)))
-                     ;; TCR_STATE_EXCEPTION_WAIT
-                     (2 (let ((xp (core-q tcr target::tcr.pending-exception-context)))
-                          ;; regs start at index 5, in this order:
-                          ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z
-                          ;; rbp temp0 imm1 imm0 nargs rsp rip
-                          (format stream " exception-wait")
-                          (if (zerop xp)
-                            (format stream "~&context unknown")
-                            (let* ((fn (core-q xp (* 10 target::node-size)))
-                                   (sp (core-q xp (* 20 target::node-size)))
-                                   (ra (core-q sp)))
-                              (if (and (core-functionp fn)
-                                       (and (<= fn ra)
-                                            (< ra (+ fn (* (core-uvsize fn) target::node-size)))))
-                                (progn
-                                  (format stream "~&")
-                                  (core-print fn stream)
-                                  (format stream " + ~d" (- ra fn)))
-                                (progn
-                                  (format stream "~&top of stack = x~x, r13 = " ra)
-                                  (core-print fn stream)))))
-                          (unless (zerop xp)
-                            (core-q xp (* 15 target::node-size))))))
-                   (error "Cannot find frame pointer"))))
-      (unless (<= (core-q vs-area target::area.low) fp vs-end)
-        (error "frame pointer x~x is not in stack area" fp))
-      (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc)
-            do (format stream "~&fp: x~x  pc: x~x : " fp pc)
-            do (cond (fun
-                      (core-print fun stream)
-                      (format stream " + ~d " (- pc fun)))
-                     ((eql pc 0) ;; exception frame
-                      (let* ((nominal-function (core-q fp target::xcf.nominal-function))
-                             (obj (core-q fp target::xcf.containing-object)))
-                        (when (core-functionp nominal-function)
-                          (format stream "exception ")
-                          (core-print nominal-function stream)
-                          (format stream " + ~d"
-                                  (if (eq (- obj target::fulltag-misc)
-                                          (- nominal-function target::fulltag-function))
-                                    (- (core-q fp target::xcf.relative-pc) target::tag-function)
-                                    (let ((pc (core-q fp target::xcf.ra0)))
-                                      (when (eql nominal-function (recover-fn pc))
-                                        (- pc nominal-function))))))))
-                     ((eql pc (core-q (kernel-global-address 'lexpr-return)))
-                      (format stream "lexpr return"))
-                     ((eql pc (core-q (kernel-global-address 'lexpr-return1v)))
-                      (format stream "lexpr1v return"))
-                     (t
-                      (if (eql (logand pc target::tagmask) target::tag-tra)
-                        (format stream " # couldn't recover function")
-                        (unless (core-nullp pc)
-                          (format stream "bad frame!")))
-                      ;; can't trust backlink
-                      (return)))
-               ;; TODO: print stack addressses
-            do (when detailed-p
-                 (loop for val in (core-stack-frame-values tcr fp)
-                       do (format t "~&     ")
-                       do (if (integerp val)
-                            (core-print val stream)
-                            (format t "~a x~x" (car val) (cadr val)))))
-            do (setq fp (fp-backlink fp vs-end))))))
-
-
-)                             ; :x8664-target
+) ; :x8664-target