;;;; ;;;; $Id: handle-malloc-dump.el,v 1.12 2003/08/23 16:38:17 ceder Exp $ ;;;; Copyright (C) 1991-1995, 1999, 2003 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 report bugs at http://bugzilla.lysator.liu.se/. ;;;; ;;;; See ram-smalloc.c for instructions on how to use this file. (require 'dll) ;;; 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))))) ;;; Batch mode analysis (defvar gdb-tty nil) (defvar gdb-proc nil) (defvar gdb-buffer nil) (defvar lyskomd-pid nil) (defvar trace-done nil) (defun trace-collect-data (proc data) (princ data (process-mark proc))) (defun trace-expect (re) (goto-char trace-last-match) (if (re-search-forward re nil t) (progn (set-marker trace-last-match (match-end 0)) (match-beginning 0)))) (defun trace-wait-for (proc regexp) (while (null (save-excursion (set-buffer (process-buffer proc)) (trace-expect regexp))) (accept-process-output proc 1))) (defun trace-process-get-tty (proc data) (save-excursion (set-buffer (process-buffer proc)) (trace-collect-data proc data) (if (trace-expect "\\(/dev\\S-*\\)$") (progn (setq gdb-tty (match-string 1)) (message "Tracing using gdb on tty %s" gdb-tty) (set-process-filter proc nil))))) (defun trace-runtest-filter (proc data) (save-excursion (set-buffer (process-buffer proc)) (trace-collect-data proc data) (if (trace-expect "Please attach to lyskomd pid \\([0-9]+\\) and hit RETURN$") (progn (setq lyskomd-pid (string-to-int (match-string 1))) (message "Attaching to lyskomd pid %d" lyskomd-pid) (set-process-filter proc nil))))) (defun trace-runtest-sentinel (proc state) (setq trace-done t)) (defun trace-make-process-buffer (name) (let ((buf (get-buffer-create name))) (save-excursion (set-buffer buf) (erase-buffer) (make-local-variable 'trace-last-match) (setq trace-last-match (copy-marker (point-min-marker)))) buf)) (defun usage () (message "\ Usage: emacs -batch -l handle-malloc-dump.el --test arg [options] Options: --help Show this help message --tool arg Use arg as --tool argument for runtest (optional) --test arg Run the test case arg with runtest (REQUIRED) --output arg Append the results to file arg (optional) ")) (defun trace-memory () (let ((tool-to-test "lyskomd") (test-to-run nil) (output-file nil) (arg nil) (done nil) (result nil)) (while (and command-line-args-left (not done)) (setq arg (car command-line-args-left)) (cond ((string= arg "--usage") (setq command-line-args-left (cdr command-line-args-left)) (setq tool-to-test nil) (setq done t) (usage)) ((string= arg "--tool") (setq tool-to-test (car (cdr command-line-args-left))) (setq command-line-args-left (cdr (cdr command-line-args-left)))) ((string= arg "--test") (setq test-to-run (car (cdr command-line-args-left))) (setq command-line-args-left (cdr (cdr command-line-args-left)))) ((string= arg "--output") (setq output-file (car (cdr command-line-args-left))) (setq command-line-args-left (cdr (cdr command-line-args-left)))) (t (setq done t)))) (if tool-to-test (progn (if (null test-to-run) (usage) (setq result (trace-run-programs tool-to-test test-to-run)) (cond ((null output-file) (message "%s" result)) (t (let ((tmp (get-buffer-create "*tmp*"))) (set-buffer tmp) (insert result) (append-to-file (point-min) (point-max) output-file))))))))) (defun trace-run-programs (tool-to-test test-to-run) (setq lyskomd-pid nil) (setq gdb-tty nil) (setq trace-done nil) (let ((gdb-buffer (trace-make-process-buffer "*gdb*")) (runtest-buffer (trace-make-process-buffer "*runtest*"))) ;; Start gdb, load the macros, THEN find out which tty we are on ;; If we don't do it in this order, we might end up starting ;; the test case before the breakpoints are in place. Strange, ;; but true. (setq gdb-proc (start-process "gdb" gdb-buffer "gdb" "../lyskomd")) (setq gdb-buffer (get-buffer-create "*gdb*")) (set-process-filter gdb-proc 'trace-process-get-tty) (process-send-string gdb-proc "source ../trace-mem.gdb\n") (process-send-string gdb-proc "shell echo `tty`\n") (while (null gdb-tty) (accept-process-output gdb-proc)) ;; Start runtest with the selected test case. Wait until we see ;; the PID. Wait for gdb to attach to the process! (setq runtest-proc (start-process "runtest" runtest-buffer "runtest" "--srcdir=." (format "--tool=%s" tool-to-test) test-to-run "ATTACH=yes" (format "MEMTRACE=%s" gdb-tty))) (set-process-filter runtest-proc 'trace-runtest-filter) (set-process-sentinel runtest-proc 'trace-runtest-sentinel) (while (null lyskomd-pid) (accept-process-output runtest-proc)) (process-send-string gdb-proc (format "attach %s\n" lyskomd-pid)) (process-send-string gdb-proc "continue\n") (message "Waiting for gdb to resume lyskomd") (trace-wait-for gdb-proc "Continuing") ;; Start the test case, and wait for it to terminate. (message "Running test case %s" test-to-run) (process-send-string runtest-proc "\n") (while (null trace-done) (accept-process-output)) ;; Wait for all the data to be printed in the gdb buffer (trace-wait-for gdb-proc "Program exited") ;; Resolve the trace (set-process-buffer gdb-proc nil) (message "Resolving trace...") (resolve-trace) (set-buffer "*Result*") (buffer-substring))) ;; If running in batch mode, start things right away (if noninteractive (progn (message "Automatic lyskomd memory trace analysis") (trace-memory)))