diff --git a/src/server/handle-malloc-dump.el b/src/server/handle-malloc-dump.el new file mode 100644 index 0000000000000000000000000000000000000000..3ab1070607e6f9d936aa082868669b8079c218d9 --- /dev/null +++ b/src/server/handle-malloc-dump.el @@ -0,0 +1,156 @@ +;;;; +;;;; $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)))))