handle-malloc-dump.el

;;;;
;;;; $Id: handle-malloc-dump.el,v 1.1 1991/09/21 12:09:35 ceder Exp $
;;;; Copyright (C) 1991  Lysator Academic Computer Association.
;;;;
;;;; This file is part of the LysKOM server.
;;;; 
;;;; LysKOM is free software; you can redistribute it and/or modify it
;;;; under the terms of the GNU General Public License as published by 
;;;; the Free Software Foundation; either version 1, or (at your option) 
;;;; any later version.
;;;; 
;;;; LysKOM is distributed in the hope that it will be useful, but WITHOUT
;;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;;;; for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with LysKOM; see the file COPYING.  If not, write to
;;;; Lysator, c/o ISY, Linkoping University, S-581 83 Linkoping, SWEDEN,
;;;; or the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
;;;; MA 02139, USA.
;;;;
;;;; Please mail bug reports to bug-lyskom@lysator.liu.se. 
;;;;


;;; block - each block that is active is stored on a dll. The dll
;;; contains blocks. Each block consists of 'addr' - the base addr of
;;; the block - and 'marker' - a marker that points to the backtrace.

;;; Constructor:

(defun create-block (addr
			    marker)
  "Create a block from ADDR and MARKER."
  (cons
   'BLOCK
   (vector addr marker )))


;;; Selectors:

(defun block->addr (block)
  "Get addr from BLOCK."
  (elt (cdr block) 0))

(defun block->marker (block)
  "Get marker from BLOCK."
  (elt (cdr block) 1))


;;; Modifiers:

(defun set-block->addr (block newval)
  "Set addr in BLOCK to NEWVAL."
  (aset (cdr block) 0 newval))

(defun set-block->marker (block newval)
  "Set marker in BLOCK to NEWVAL."
  (aset (cdr block) 1 newval))



;;; Predicate:

(defun block-p (object)
  "Return t if OBJECT is a block."
  (eq (car-safe object) 'BLOCK))


			    
(defvar mstack nil
  "A dll that holds all currently active memory blocks.")

(defvar illegal-free nil
  "A dll that holds all illegal free attempts.")

(defun resolve-trace ()
  "Search the current buffer, and output any erroneous
mallocs/reallocs/frees to *Result*."
  (interactive)
  (setq mstack (dll-create))
  (setq illegal-free (dll-create))
  (goto-char (point-min))
  (while (re-search-forward "^--- \\(.*\\) ---$" nil 'foo)
    (let* ((fn (buffer-substring (match-beginning 1) (match-end 1)))
	   (btstart (match-end 0))
	   (btend (progn (re-search-forward "^==== end ====")
			 (match-beginning 0))))
	   
      (message fn)
      (cond
       ((string= fn "malloc")
	(beginning-of-line 0)
	(allocate))
       ((string= fn "free")
	(beginning-of-line 0)
	(free))
       ((string= fn "realloc")
	(beginning-of-line -1)
	(free)
	(beginning-of-line 2)
	(allocate)))))
  (report-stacks))

(defun get-number ()
  "Get the last hex-string on this line, as a string."
  (re-search-forward "0x[0-9a-f]*$")
  (buffer-substring (match-beginning 0) (match-end 0)))

(defun allocate ()
  "Add an unresolved allocation to mstack."
  (dll-enter-first mstack
		   (create-block (get-number)
				 (point))))

(defun free ()
  "Resolve an allocation from mstack."
  (let ((addr (get-number))
	(node (dll-nth mstack 0)))
    (while (and node
		(not (string= addr
			      (block->addr (dll-element mstack node)))))
      (setq node (dll-next mstack node)))
    (if node
	(dll-delete mstack node)
      (dll-enter-first illegal-free (create-block addr (point))))))

(defun report-stacks ()
  (save-window-excursion
    (pop-to-buffer "*Result*" t)
    (erase-buffer)
    (insert "Forgotten mallocs:\n\n"))
  (report-stack mstack)
  (save-window-excursion
    (pop-to-buffer "*Result*" t)
    (insert "\n\nIllegal frees:\n\n"))
  (report-stack illegal-free))

  

(defun report-stack (stack)
  (let ((gdb-buf (current-buffer))
	(node (dll-nth stack 0)))
    (while node
      (goto-char (block->marker (dll-element stack node)))
      (re-search-backward "^---")
      (let* ((b (point))
	     (e (progn
		  (re-search-forward "====$")
		  (point))))
	(save-excursion
	  (set-buffer "*Result*")
	  (insert (format "From char %d:\n" b))
	  (insert-buffer-substring gdb-buf (1- b) (1+ e))))
      (setq node (dll-next stack node)))))