From f48419d9ffe24c9ac5a6ddd2b6f68f358d831ebf Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 21 Sep 1989 01:55:35 +0000 Subject: [PATCH] Upgrade to handle split compiled-code files. Improve constants comparison. --- v7/src/compiler/etc/comcmp.scm | 252 ++++++++++++++++++++++----------- v8/src/compiler/etc/comcmp.scm | 252 ++++++++++++++++++++++----------- 2 files changed, 334 insertions(+), 170 deletions(-) diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm index eaae45a7e..c61765a31 100644 --- a/v7/src/compiler/etc/comcmp.scm +++ b/v7/src/compiler/etc/comcmp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.1 1989/05/26 16:25:32 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -39,85 +39,169 @@ MIT in each case. |# (if (unassigned? compiled-code-block/bytes-per-object) (set! compiled-code-block/bytes-per-object 4)) -(define comcmp:addressing-granularity 8) - (define comcmp:ignore-debugging-info? true) -(define compare-com-files - (let () - -(define (compare-blocks b1 b2) - (let ((l1 (system-vector-length b1)) - (l2 (system-vector-length b2))) - (if (not (fix:= l1 l2)) - `(length ,l1 ,l2) - (or (compare-code-sections b1 b2) - (compare-constant-sections b1 b2))))) - -(define (read-code b s e) - (let ((bs (bit-string-allocate (* comcmp:addressing-granularity (- e s))))) - (read-bits! b (* comcmp:addressing-granularity s) bs) - bs)) - -(define (compare-code-sections b1 b2) - (let ((s1 (compiled-code-block/code-start b1)) - (s2 (compiled-code-block/code-start b2)) - (e1 (compiled-code-block/code-end b1)) - (e2 (compiled-code-block/code-end b2))) - (cond ((not (fix:= s1 s2)) - `(code-start ,s1 ,s2)) - ((not (fix:= e1 e2)) - `(code-end ,e1 ,e2)) - ((not (bit-string=? (read-code b1 s1 e1) - (read-code b2 s2 e2))) - `(code)) - (else - false)))) - -(define (constant-equal? c1 c2) - (if (and (scode-constant? c1) - (scode-constant? c2)) - (equal? (unsyntax c1) (unsyntax c2)) - (equal? c1 c2))) - -(define (compare-constant-sections b1 b2) - (define (loop s e diff) - (cond ((fix:> s e) - (if (null? diff) - false - (cons 'CONSTANTS (reverse! diff)))) - ((not (constant-equal? (system-vector-ref b1 s) - (system-vector-ref b2 s))) - (loop (fix:1+ s) - e - `((,s ,(system-vector-ref b1 s) - ,(system-vector-ref b2 s)) - ,@diff))) - (else - (loop (fix:1+ s) e diff)))) - - ;; Kludge! - (if comcmp:ignore-debugging-info? - (begin - (set-compiled-code-block/debugging-info! b1 '()) - (set-compiled-code-block/debugging-info! b2 '()))) - - (let ((s1 (compiled-code-block/constants-start b1)) - (s2 (compiled-code-block/constants-start b2)) - (e1 (compiled-code-block/constants-end b1)) - (e2 (compiled-code-block/constants-end b2))) - (cond ((not (fix:= s1 s2)) - `(constant-start ,s1 ,s2)) - ((not (fix:= e1 e2)) - `(constant-end ,e1 ,e2)) - (else - (loop s1 e1 '()))))) - -(lambda (f1 f2) - (compare-blocks (compiled-code-address->block (fasload f1)) - (compiled-code-address->block (fasload f2)))) - -)) +(define (compare-com-files f1 f2 #!optional verbose?) + (let ((quiet? (or (default-object? verbose?) (not verbose?))) + (memoizations '())) + + (define (compare-blocks b1 b2) + (memoize! b1 b2 + (lambda () + (let ((l1 (system-vector-length b1)) + (l2 (system-vector-length b2))) + (if (not (= l1 l2)) + `(length ,l1 ,l2) + (or (compare-code-sections b1 b2) + (compare-constant-sections b1 b2))))))) + + (define (memoize! b1 b2 do-it) + (let ((entry (assq b1 memoizations)) + (if-not-found + (lambda () + (let ((result (do-it))) + (let ((entry (assq b1 memoizations))) + (if entry + (let ((entry* (assq b2 (cdr entry)))) + (if entry* + (set-cdr! entry* result) + (set-cdr! entry + (cons (cons b2 result) (cdr entry))))) + (set! memoizations + (cons (list b1 (cons b2 result)) + memoizations)))) + result)))) + (if entry + (let ((entry (assq b2 (cdr entry)))) + (if entry + (cdr entry) + (if-not-found))) + (if-not-found)))) + + (define (compare-code-sections b1 b2) + (let ((s1 (compiled-code-block/code-start b1)) + (s2 (compiled-code-block/code-start b2)) + (e1 (compiled-code-block/code-end b1)) + (e2 (compiled-code-block/code-end b2))) + (cond ((not (= s1 s2)) + `(code-start ,s1 ,s2)) + ((not (= e1 e2)) + `(code-end ,e1 ,e2)) + ((not (bit-string=? (read-code b1 s1 e1) + (read-code b2 s2 e2))) + `(code)) + (else + false)))) + + (define (read-code b s e) + (let ((bs (bit-string-allocate (* addressing-granularity (- e s))))) + (read-bits! b (* addressing-granularity s) bs) + bs)) + + (define addressing-granularity 8) + + (define (compare-constant-sections b1 b2) + ;; Kludge! + (if comcmp:ignore-debugging-info? + (begin + (set-compiled-code-block/debugging-info! b1 '()) + (set-compiled-code-block/debugging-info! b2 '()))) + + (let ((s1 (compiled-code-block/constants-start b1)) + (s2 (compiled-code-block/constants-start b2)) + (e1 (compiled-code-block/constants-end b1)) + (e2 (compiled-code-block/constants-end b2))) + (cond ((not (= s1 s2)) + `(constant-start ,s1 ,s2)) + ((not (= e1 e2)) + `(constant-end ,e1 ,e2)) + (else + (let loop ((s s1) (e e1) (diffs '())) + (cond ((<= s e) + (let ((diff + (compare-constants + s + (system-vector-ref b1 s) + (system-vector-ref b2 s)))) + (cond ((not diff) + (loop (1+ s) e diffs)) + ((eq? (car diff) 'CONSTANTS) + (loop (1+ s) + e + (if (member (cadr diff) diffs) + diffs + (cons (cadr diff) diffs)))) + (else + diff)))) + ((null? diffs) + false) + (else + (cons 'CONSTANTS (reverse! diffs))))))))) + + (define (compare-constants s c1 c2) + (and (not (equal? c1 c2)) + (let ((differ + (lambda () + `(CONSTANTS (,s ,c1 ,c2))))) + (cond ((compiled-code-block? c1) + (if (compiled-code-block? c2) + (compare-blocks c1 c2) + (differ))) + ((compiled-code-address? c1) + (if (and (compiled-code-address? c2) + (= (compiled-entry/offset c1) + (compiled-entry/offset c2))) + (compare-blocks (compiled-entry/block c1) + (compiled-entry/block c2)) + (differ))) + ((quotation? c1) + (if (quotation? c2) + (compare-constants s + (quotation-expression c1) + (quotation-expression c2)) + (differ))) + ((lambda? c1) + (if (lambda? c2) + (lambda-components c1 + (lambda (name required optional rest auxiliary + declarations body) + (lambda-components c1 + (lambda (name* required* optional* rest* + auxiliary* declarations* body*) + (if (and (eqv? name name*) + (equal? required required*) + (equal? optional optional*) + (eqv? rest rest*) + (equal? auxiliary auxiliary*) + (equal? declarations declarations*)) + (compare-constants s body body*) + (differ)))))) + (differ))) + (else + (differ)))))) + + (let ((s1 (fasload f1 quiet?)) + (s2 (fasload f2 quiet?)) + (dbg-info-vector? + (access dbg-info-vector? + (->environment '(RUNTIME COMPILER-INFO)))) + (dbg-info-vector/blocks-vector + (access dbg-info-vector/blocks-vector + (->environment '(RUNTIME COMPILER-INFO))))) + (if (and (comment? s1) (dbg-info-vector? (comment-text s1))) + (if (and (comment? s2) (dbg-info-vector? (comment-text s2))) + (let ((v1 (dbg-info-vector/blocks-vector (comment-text s1))) + (v2 (dbg-info-vector/blocks-vector (comment-text s2)))) + (let ((e1 (vector-length v1)) + (e2 (vector-length v2))) + (if (= e1 e2) + (compare-blocks (vector-ref v1 0) (vector-ref v2 0)) + `(number-of-blocks ,e1 ,e2)))) + '(block-structure)) + (if (and (comment? s2) (dbg-info-vector? (comment-text s2))) + '(block-structure) + (compare-blocks (compiled-code-address->block s1) + (compiled-code-address->block s2))))))) (define (show-differences f1 f2) (define (->name f) @@ -130,20 +214,18 @@ MIT in each case. |# (for-each display (list "*** Files " (->name f1) " and " (->name f2) - " differ : ")) - (if (and (eq? 'CONSTANTS (car result)) - (> (length result) 2)) + " differ: ")) + (if (eq? 'CONSTANTS (car result)) (begin (display "***") (newline) - (display "(CONSTANTS") + (display "(constants") (for-each (lambda (c) (newline) - (display " ") + (display " ") (write c)) (cdr result)) - (newline) (display ")")) (begin (write result) - (display " ***"))))))) + (display " ***"))))))) \ No newline at end of file diff --git a/v8/src/compiler/etc/comcmp.scm b/v8/src/compiler/etc/comcmp.scm index bec635820..105af8855 100644 --- a/v8/src/compiler/etc/comcmp.scm +++ b/v8/src/compiler/etc/comcmp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.1 1989/05/26 16:25:32 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -39,85 +39,169 @@ MIT in each case. |# (if (unassigned? compiled-code-block/bytes-per-object) (set! compiled-code-block/bytes-per-object 4)) -(define comcmp:addressing-granularity 8) - (define comcmp:ignore-debugging-info? true) -(define compare-com-files - (let () - -(define (compare-blocks b1 b2) - (let ((l1 (system-vector-length b1)) - (l2 (system-vector-length b2))) - (if (not (fix:= l1 l2)) - `(length ,l1 ,l2) - (or (compare-code-sections b1 b2) - (compare-constant-sections b1 b2))))) - -(define (read-code b s e) - (let ((bs (bit-string-allocate (* comcmp:addressing-granularity (- e s))))) - (read-bits! b (* comcmp:addressing-granularity s) bs) - bs)) - -(define (compare-code-sections b1 b2) - (let ((s1 (compiled-code-block/code-start b1)) - (s2 (compiled-code-block/code-start b2)) - (e1 (compiled-code-block/code-end b1)) - (e2 (compiled-code-block/code-end b2))) - (cond ((not (fix:= s1 s2)) - `(code-start ,s1 ,s2)) - ((not (fix:= e1 e2)) - `(code-end ,e1 ,e2)) - ((not (bit-string=? (read-code b1 s1 e1) - (read-code b2 s2 e2))) - `(code)) - (else - false)))) - -(define (constant-equal? c1 c2) - (if (and (scode-constant? c1) - (scode-constant? c2)) - (equal? (unsyntax c1) (unsyntax c2)) - (equal? c1 c2))) - -(define (compare-constant-sections b1 b2) - (define (loop s e diff) - (cond ((fix:> s e) - (if (null? diff) - false - (cons 'CONSTANTS (reverse! diff)))) - ((not (constant-equal? (system-vector-ref b1 s) - (system-vector-ref b2 s))) - (loop (fix:1+ s) - e - `((,s ,(system-vector-ref b1 s) - ,(system-vector-ref b2 s)) - ,@diff))) - (else - (loop (fix:1+ s) e diff)))) - - ;; Kludge! - (if comcmp:ignore-debugging-info? - (begin - (set-compiled-code-block/debugging-info! b1 '()) - (set-compiled-code-block/debugging-info! b2 '()))) - - (let ((s1 (compiled-code-block/constants-start b1)) - (s2 (compiled-code-block/constants-start b2)) - (e1 (compiled-code-block/constants-end b1)) - (e2 (compiled-code-block/constants-end b2))) - (cond ((not (fix:= s1 s2)) - `(constant-start ,s1 ,s2)) - ((not (fix:= e1 e2)) - `(constant-end ,e1 ,e2)) - (else - (loop s1 e1 '()))))) - -(lambda (f1 f2) - (compare-blocks (compiled-code-address->block (fasload f1)) - (compiled-code-address->block (fasload f2)))) - -)) +(define (compare-com-files f1 f2 #!optional verbose?) + (let ((quiet? (or (default-object? verbose?) (not verbose?))) + (memoizations '())) + + (define (compare-blocks b1 b2) + (memoize! b1 b2 + (lambda () + (let ((l1 (system-vector-length b1)) + (l2 (system-vector-length b2))) + (if (not (= l1 l2)) + `(length ,l1 ,l2) + (or (compare-code-sections b1 b2) + (compare-constant-sections b1 b2))))))) + + (define (memoize! b1 b2 do-it) + (let ((entry (assq b1 memoizations)) + (if-not-found + (lambda () + (let ((result (do-it))) + (let ((entry (assq b1 memoizations))) + (if entry + (let ((entry* (assq b2 (cdr entry)))) + (if entry* + (set-cdr! entry* result) + (set-cdr! entry + (cons (cons b2 result) (cdr entry))))) + (set! memoizations + (cons (list b1 (cons b2 result)) + memoizations)))) + result)))) + (if entry + (let ((entry (assq b2 (cdr entry)))) + (if entry + (cdr entry) + (if-not-found))) + (if-not-found)))) + + (define (compare-code-sections b1 b2) + (let ((s1 (compiled-code-block/code-start b1)) + (s2 (compiled-code-block/code-start b2)) + (e1 (compiled-code-block/code-end b1)) + (e2 (compiled-code-block/code-end b2))) + (cond ((not (= s1 s2)) + `(code-start ,s1 ,s2)) + ((not (= e1 e2)) + `(code-end ,e1 ,e2)) + ((not (bit-string=? (read-code b1 s1 e1) + (read-code b2 s2 e2))) + `(code)) + (else + false)))) + + (define (read-code b s e) + (let ((bs (bit-string-allocate (* addressing-granularity (- e s))))) + (read-bits! b (* addressing-granularity s) bs) + bs)) + + (define addressing-granularity 8) + + (define (compare-constant-sections b1 b2) + ;; Kludge! + (if comcmp:ignore-debugging-info? + (begin + (set-compiled-code-block/debugging-info! b1 '()) + (set-compiled-code-block/debugging-info! b2 '()))) + + (let ((s1 (compiled-code-block/constants-start b1)) + (s2 (compiled-code-block/constants-start b2)) + (e1 (compiled-code-block/constants-end b1)) + (e2 (compiled-code-block/constants-end b2))) + (cond ((not (= s1 s2)) + `(constant-start ,s1 ,s2)) + ((not (= e1 e2)) + `(constant-end ,e1 ,e2)) + (else + (let loop ((s s1) (e e1) (diffs '())) + (cond ((<= s e) + (let ((diff + (compare-constants + s + (system-vector-ref b1 s) + (system-vector-ref b2 s)))) + (cond ((not diff) + (loop (1+ s) e diffs)) + ((eq? (car diff) 'CONSTANTS) + (loop (1+ s) + e + (if (member (cadr diff) diffs) + diffs + (cons (cadr diff) diffs)))) + (else + diff)))) + ((null? diffs) + false) + (else + (cons 'CONSTANTS (reverse! diffs))))))))) + + (define (compare-constants s c1 c2) + (and (not (equal? c1 c2)) + (let ((differ + (lambda () + `(CONSTANTS (,s ,c1 ,c2))))) + (cond ((compiled-code-block? c1) + (if (compiled-code-block? c2) + (compare-blocks c1 c2) + (differ))) + ((compiled-code-address? c1) + (if (and (compiled-code-address? c2) + (= (compiled-entry/offset c1) + (compiled-entry/offset c2))) + (compare-blocks (compiled-entry/block c1) + (compiled-entry/block c2)) + (differ))) + ((quotation? c1) + (if (quotation? c2) + (compare-constants s + (quotation-expression c1) + (quotation-expression c2)) + (differ))) + ((lambda? c1) + (if (lambda? c2) + (lambda-components c1 + (lambda (name required optional rest auxiliary + declarations body) + (lambda-components c1 + (lambda (name* required* optional* rest* + auxiliary* declarations* body*) + (if (and (eqv? name name*) + (equal? required required*) + (equal? optional optional*) + (eqv? rest rest*) + (equal? auxiliary auxiliary*) + (equal? declarations declarations*)) + (compare-constants s body body*) + (differ)))))) + (differ))) + (else + (differ)))))) + + (let ((s1 (fasload f1 quiet?)) + (s2 (fasload f2 quiet?)) + (dbg-info-vector? + (access dbg-info-vector? + (->environment '(RUNTIME COMPILER-INFO)))) + (dbg-info-vector/blocks-vector + (access dbg-info-vector/blocks-vector + (->environment '(RUNTIME COMPILER-INFO))))) + (if (and (comment? s1) (dbg-info-vector? (comment-text s1))) + (if (and (comment? s2) (dbg-info-vector? (comment-text s2))) + (let ((v1 (dbg-info-vector/blocks-vector (comment-text s1))) + (v2 (dbg-info-vector/blocks-vector (comment-text s2)))) + (let ((e1 (vector-length v1)) + (e2 (vector-length v2))) + (if (= e1 e2) + (compare-blocks (vector-ref v1 0) (vector-ref v2 0)) + `(number-of-blocks ,e1 ,e2)))) + '(block-structure)) + (if (and (comment? s2) (dbg-info-vector? (comment-text s2))) + '(block-structure) + (compare-blocks (compiled-code-address->block s1) + (compiled-code-address->block s2))))))) (define (show-differences f1 f2) (define (->name f) @@ -130,20 +214,18 @@ MIT in each case. |# (for-each display (list "*** Files " (->name f1) " and " (->name f2) - " differ : ")) - (if (and (eq? 'CONSTANTS (car result)) - (> (length result) 2)) + " differ: ")) + (if (eq? 'CONSTANTS (car result)) (begin (display "***") (newline) - (display "(CONSTANTS") + (display "(constants") (for-each (lambda (c) (newline) - (display " ") + (display " ") (write c)) (cdr result)) - (newline) (display ")")) (begin (write result) - (display " ***"))))))) + (display " ***"))))))) \ No newline at end of file -- 2.25.1