home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / etc / comcmp.scm < prev    next >
Text File  |  1999-12-20  |  8KB  |  266 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: comcmp.scm,v 1.6 1999/12/20 23:07:27 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Compiled code binary comparison program
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (if (unassigned? compiled-code-block/bytes-per-object)
  27.     (set! compiled-code-block/bytes-per-object 4))
  28.  
  29. (define-macro (ucode-type name)
  30.   (microcode-type name))
  31.  
  32. (define comcmp:ignore-debugging-info? true)
  33. (define comcmp:show-differing-blocks? false)
  34.  
  35. (define (compare-code-blocks b1 b2)
  36.   (let ((memoizations '()))
  37.     (define (equal? x y)
  38.       (or (eq? x y)
  39.       (if (object-type? (object-type x) y)
  40.           (cond ((object-type? (ucode-type cell) y)
  41.              (equal? (cell-contents x) (cell-contents y)))
  42.             ((object-type? (ucode-type list) y)
  43.              (and (equal? (car x) (car y))
  44.               (equal? (cdr x) (cdr y))))
  45.             ((object-type? (ucode-type character-string) y)
  46.              (string=? x y))
  47.             ((object-type? (ucode-type vector-1b) y)
  48.              (bit-string=? x y))
  49.             ((number? y)
  50.              (and (= x y)
  51.               (boolean=? (exact? x) (exact? y))))
  52.             ((pathname? x)
  53.              (and (pathname? y)
  54.               (pathname=? x y)))
  55.             ((object-type? (ucode-type vector) y)
  56.              (let ((size (vector-length x)))
  57.                (and (= size (vector-length y))
  58.                 (let loop ((index 0))
  59.                   (or (= index size)
  60.                   (and (equal? (vector-ref x index)
  61.                            (vector-ref y index))
  62.                        (loop (1+ index))))))))
  63.             ((compiled-code-block? x)
  64.              (not (compare-blocks x y false)))
  65.             ((compiled-code-address? x)
  66.              (and (= (compiled-entry/offset x)
  67.                  (compiled-entry/offset y))
  68.               (not (compare-blocks
  69.                 (compiled-entry/block x)
  70.                 (compiled-entry/block y)
  71.                 false))))
  72.             (else
  73.              false))
  74.           (and (number? x)
  75.            (number? y)
  76.            (= x y)
  77.            (boolean=? (exact? x) (exact? y))))))
  78.  
  79.     (define (compare-blocks b1 b2 top-level?)
  80.       (memoize! b1 b2
  81.         (let ((core
  82.                (lambda ()
  83.              (let ((l1 (system-vector-length b1))
  84.                    (l2 (system-vector-length b2)))
  85.                (if (not (= l1 l2))
  86.                    `(length ,l1 ,l2)
  87.                    (or (compare-code-sections b1 b2)
  88.                    (compare-constant-sections b1 b2)))))))
  89.           (if (or top-level?
  90.               (not comcmp:show-differing-blocks?))
  91.               core
  92.               (lambda ()
  93.             (let ((result (core)))
  94.               (if result
  95.                   (begin
  96.                 (newline)
  97.                 (write `(subblocks ,b1 ,b2 ,result))))
  98.               result))))))
  99.  
  100.     (define (memoize! b1 b2 do-it)
  101.       (let ((entry (assq b1 memoizations))
  102.         (if-not-found
  103.          (lambda ()
  104.            (let ((result (do-it)))
  105.          (let ((entry (assq b1 memoizations)))
  106.            (if entry
  107.                (let ((entry* (assq b2 (cdr entry))))
  108.              (if entry*
  109.                  (set-cdr! entry* result)
  110.                  (set-cdr! entry
  111.                        (cons (cons b2 result) (cdr entry)))))
  112.                (set! memoizations
  113.                  (cons (list b1 (cons b2 result))
  114.                    memoizations))))
  115.          result))))
  116.     (if entry
  117.         (let ((entry (assq b2 (cdr entry))))
  118.           (if entry
  119.           (cdr entry)
  120.           (if-not-found)))
  121.         (if-not-found))))
  122.  
  123.     (define (compare-code-sections b1 b2)
  124.       (let ((s1 (compiled-code-block/code-start b1))
  125.         (s2 (compiled-code-block/code-start b2))
  126.         (e1 (compiled-code-block/code-end b1))
  127.         (e2 (compiled-code-block/code-end b2)))
  128.     (cond ((not (= s1 s2))
  129.            `(code-start ,s1 ,s2))
  130.           ((not (= e1 e2))
  131.            `(code-end ,e1 ,e2))
  132.           ((not (bit-string=? (read-code b1 s1 e1)
  133.                   (read-code b2 s2 e2)))
  134.            `(code))
  135.           (else
  136.            false))))
  137.  
  138.     (define (read-code b s e)
  139.       (let ((bs (bit-string-allocate (* addressing-granularity (- e s)))))
  140.     (read-bits! b (* addressing-granularity s) bs)
  141.     bs))
  142.  
  143.     (define addressing-granularity 8)
  144.  
  145.     (define (compare-constant-sections b1 b2)
  146.       ;; Kludge!
  147.       (if comcmp:ignore-debugging-info?
  148.       (begin
  149.         (set-compiled-code-block/debugging-info! b1 '())
  150.         (set-compiled-code-block/debugging-info! b2 '())))
  151.  
  152.       (let ((s1 (compiled-code-block/constants-start b1))
  153.         (s2 (compiled-code-block/constants-start b2))
  154.         (e1 (compiled-code-block/constants-end b1))
  155.         (e2 (compiled-code-block/constants-end b2)))
  156.     (cond ((not (= s1 s2))
  157.            `(constant-start ,s1 ,s2))
  158.           ((not (= e1 e2))
  159.            `(constant-end ,e1 ,e2))
  160.           (else
  161.            (let loop ((s s1) (e e1) (diffs '()))
  162.          (cond ((<= s e)
  163.             (let ((diff
  164.                    (compare-constants
  165.                 s
  166.                 (system-vector-ref b1 s)
  167.                 (system-vector-ref b2 s))))
  168.               (cond ((not diff)
  169.                  (loop (1+ s) e diffs))
  170.                 ((eq? (car diff) 'CONSTANTS)
  171.                  (loop (1+ s)
  172.                        e
  173.                        (if (member (cadr diff) diffs)
  174.                        diffs
  175.                        (cons (cadr diff) diffs))))
  176.                 (else
  177.                  diff))))
  178.                ((null? diffs)
  179.             false)
  180.                (else
  181.             (cons 'CONSTANTS (reverse! diffs)))))))))
  182.  
  183.     (define (compare-constants s c1 c2)
  184.       (and (not (equal? c1 c2))
  185.        (let ((differ
  186.           (lambda ()
  187.             `(CONSTANTS (,s ,c1 ,c2)))))
  188.          (cond ((quotation? c1)
  189.             (if (quotation? c2)
  190.             (compare-constants s
  191.                        (quotation-expression c1)
  192.                        (quotation-expression c2))
  193.             (differ)))
  194.            ((LAMBDA? C1)
  195.             (if (lambda? c2)
  196.             (lambda-components c1
  197.               (lambda (name required optional rest auxiliary
  198.                     declarations body)
  199.                 (lambda-components c1
  200.                   (lambda (name* required* optional* rest*
  201.                          auxiliary* declarations* body*)
  202.                 (if (and (eqv? name name*)
  203.                      (equal? required required*)
  204.                      (equal? optional optional*)
  205.                      (eqv? rest rest*)
  206.                      (equal? auxiliary auxiliary*)
  207.                      (equal? declarations declarations*))
  208.                     (compare-constants s body body*)
  209.                     (differ))))))
  210.             (differ)))
  211.            (else
  212.             (differ))))))
  213.     (compare-blocks b1 b2 true)))
  214.  
  215. (define (compare-com-files f1 f2 #!optional verbose?)
  216.   (let ((quiet? (or (default-object? verbose?) (not verbose?))))
  217.  
  218.     (let ((s1 (fasload f1 quiet?))
  219.       (s2 (fasload f2 quiet?))
  220.       (dbg-info-vector?
  221.        (access dbg-info-vector?
  222.            (->environment '(RUNTIME COMPILER-INFO))))
  223.       (dbg-info-vector/blocks-vector
  224.        (access dbg-info-vector/blocks-vector
  225.            (->environment '(RUNTIME COMPILER-INFO)))))
  226.       (if (and (comment? s1) (dbg-info-vector? (comment-text s1)))
  227.       (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
  228.           (let ((v1 (dbg-info-vector/blocks-vector (comment-text s1)))
  229.             (v2 (dbg-info-vector/blocks-vector (comment-text s2))))
  230.         (let ((e1 (vector-length v1))
  231.               (e2 (vector-length v2)))
  232.           (if (= e1 e2)
  233.               (compare-code-blocks (vector-ref v1 0) (vector-ref v2 0))
  234.               `(number-of-blocks ,e1 ,e2))))
  235.           '(block-structure))
  236.       (if (and (comment? s2) (dbg-info-vector? (comment-text s2)))
  237.           '(block-structure)
  238.           (compare-code-blocks (compiled-code-address->block s1)
  239.                    (compiled-code-address->block s2)))))))
  240.  
  241. (define (show-differences f1 f2)
  242.   (define (->name f)
  243.     (enough-namestring (merge-pathnames f)))
  244.  
  245.   (let ((result (compare-com-files f1 f2)))
  246.     (if (pair? result)
  247.     (begin
  248.       (newline)
  249.       (for-each display
  250.             (list "*** Files " (->name f1)
  251.               " and " (->name f2)
  252.               " differ: "))
  253.       (if (eq? 'CONSTANTS (car result))
  254.           (begin
  255.         (display "***")
  256.         (newline)
  257.         (display "(constants")
  258.         (for-each (lambda (c)
  259.                 (newline)
  260.                 (display "  ")
  261.                 (write c))
  262.               (cdr result))
  263.         (display ")"))
  264.           (begin
  265.         (write result)
  266.         (display " ***")))))))