From 55f017981b4a8769f3d338a901647e7a9d18ebc5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 23 Dec 1993 11:14:25 +0000 Subject: [PATCH] Reimplement interval arithmetic and assembler relaxation code. New arithmetic uses geometric model to get more accurate results. Relaxation has been changed to eliminate assumption that if the low bound of an interval doesn't fit, then no point within the interval will fit. This assumption was proven incorrect by an example on the MIPS. --- v7/src/compiler/back/bittop.scm | 170 +++++------- v7/src/compiler/back/bitutl.scm | 469 ++++++++++++++++++-------------- 2 files changed, 329 insertions(+), 310 deletions(-) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 1262a8ca0..b24d305a7 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: bittop.scm,v 1.20 1993/12/18 21:43:01 cph Exp $ +$Id: bittop.scm,v 1.21 1993/12/23 11:14:19 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -54,7 +54,7 @@ MIT in each case. |# (*start-label* start-label) (*end-label* (generate-uninterned-symbol 'END-LABEL-))) (initialize-symbol-table!) - (with-values + (call-with-values (lambda () (initial-phase (if (null? instructions) @@ -95,7 +95,7 @@ MIT in each case. |# (finish-symbol-table!) (if (null? vars) count - (with-values (lambda () (phase-2 widening? vars)) + (call-with-values (lambda () (phase-2 widening? vars)) (lambda (any-modified? number-of-vars) (cond (any-modified? (continue false count)) @@ -115,49 +115,21 @@ MIT in each case. |# ;;;; Output block generation (define (final-phase directives) - ;; Label values are now integers. + ;; Convert label values to integers: (for-each (lambda (pair) - (let ((val (binding-value (cdr pair)))) - (if (interval? val) - (set-binding-value! (cdr pair) (interval-low val))))) + (set-binding-value! + (cdr pair) + (interval-final-value (binding-value (cdr pair))))) (symbol-table-bindings *the-symbol-table*)) (let ((code-block - (bit-string-allocate (- (* addressing-granularity - (symbol-table-value *the-symbol-table* - *end-label*)) + (bit-string-allocate (- (->bitstring-pc + (symbol-table-value *the-symbol-table* + *end-label*)) starting-pc)))) - (assemble-directives! - code-block - directives - (instruction-initial-position code-block)) + (assemble-directives! code-block + directives + (instruction-initial-position code-block)) code-block)) - -#| - -(define (assemble-objects code-block) - (let ((objects (map assemble-an-object (queue->list *objects*)))) - (if compiler:cross-compiling? - (vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width) - (let* ((bl (quotient (bit-string-length code-block) - scheme-object-width)) - (non-pointer-length - ((ucode-primitive make-non-pointer-object) bl)) - (output-block (make-vector (1+ (+ (length objects) bl))))) - (with-absolutely-no-interrupts - (lambda () - (vector-set! output-block 0 - ((ucode-primitive primitive-object-set-type) - (ucode-type manifest-nm-vector) - non-pointer-length)))) - (write-bits! output-block - ;; After header just inserted. - (* scheme-object-width 2) - code-block) - (insert-objects! output-block objects (1+ bl)) - (object-new-type (ucode-type compiled-code-block) - output-block))))) - -|# (define (assemble-objects code-block) (let ((objects (map assemble-an-object (queue->list *objects*)))) @@ -350,9 +322,7 @@ MIT in each case. |# (add-to-queue! directives dir)) (define (process-label! label) - (symbol-table-define! *the-symbol-table* - (cadr label) - (make-machine-interval pcmin pcmax)) + (set-label-value! (cadr label) pcmin pcmax) (new-directive! (list->vector label))) (define (process-fixed-width directive width) @@ -366,12 +336,12 @@ MIT in each case. |# (define (process-variable-width directive) (new-directive! directive) - (variable-width-lengths directive - (lambda (minl maxl) - (loop (cdr to-convert) - (+ pcmin minl) (+ pcmax maxl) - pc-stack '() - (cons directive vars))))) + (call-with-values (lambda () (variable-width-lengths directive)) + (lambda (minl maxl) + (loop (cdr to-convert) + (+ pcmin minl) (+ pcmax maxl) + pc-stack '() + (cons directive vars))))) (define (process-trivial-directive) (loop (cdr to-convert) @@ -381,9 +351,7 @@ MIT in each case. |# (if (null? to-convert) (let ((emin (final-pad pcmin)) (emax (+ pcmax maximum-padding-length))) - (symbol-table-define! *the-symbol-table* - *end-label* - (make-machine-interval emin emax)) + (set-label-value! *end-label* emin emax) (collect-group!) (values (queue->list directives) vars)) @@ -408,7 +376,7 @@ MIT in each case. |# (vector 'VARIABLE-WIDTH-EXPRESSION (cadr this) (if (null? pc-stack) - (make-machine-interval pcmin pcmax) + (label->machine-interval pcmin pcmax) (car pc-stack)) (map list->vector (cddr this))))) ((GROUP) @@ -416,7 +384,8 @@ MIT in each case. |# (loop (append (cdr this) (cons '(TICK-OFF) (cdr to-convert))) pcmin pcmax - (cons (make-machine-interval pcmin pcmax) pc-stack) + (cons (label->machine-interval pcmin pcmax) + pc-stack) '() vars)) ((TICK-OFF) (new-directive! (vector 'TICK false)) @@ -456,16 +425,12 @@ MIT in each case. |# (emax (if (not widening?) (+ pcmax maximum-padding-length) emin))) - (symbol-table-define! *the-symbol-table* - *end-label* - (make-machine-interval emin emax)) + (set-label-value! *end-label* emin emax) vars) (let ((this (car rem))) (case (vector-ref this 0) ((LABEL) - (symbol-table-define! *the-symbol-table* - (vector-ref this 1) - (make-machine-interval pcmin pcmax)) + (set-label-value! (vector-ref this 1) pcmin pcmax) (loop (cdr rem) pcmin pcmax pc-stack vars)) ((FIXED-WIDTH-GROUP) (let ((l (vector-ref this 1))) @@ -477,21 +442,20 @@ MIT in each case. |# ((VARIABLE-WIDTH-EXPRESSION) (vector-set! this 2 (if (null? pc-stack) - (make-machine-interval pcmin pcmax) + (label->machine-interval pcmin pcmax) (car pc-stack))) - (variable-width-lengths - this - (lambda (minl maxl) - (loop (cdr rem) - (+ pcmin minl) - (+ pcmax (if widening? minl maxl)) - pc-stack - (cons this vars))))) + (call-with-values (lambda () (variable-width-lengths this)) + (lambda (minl maxl) + (loop (cdr rem) + (+ pcmin minl) + (+ pcmax (if widening? minl maxl)) + pc-stack + (cons this vars))))) ((TICK) (loop (cdr rem) pcmin pcmax (if (vector-ref this 1) - (cons (make-machine-interval pcmin pcmax) pc-stack) + (cons (label->machine-interval pcmin pcmax) pc-stack) (cdr pc-stack)) vars)) ((PADDING) @@ -504,43 +468,41 @@ MIT in each case. |# (loop directives starting-pc starting-pc '() '())) (define (phase-2 widening? vars) - (define (loop vars modified? count) + (let loop ((vars vars) (modified? #f) (count 0)) (if (null? vars) (values modified? count) - (let ((var (car vars))) - (let ((interval (->interval - (evaluate (vector-ref var 1) - (vector-ref var 2))))) - (with-values - (lambda () - (process-variable var - widening? - (interval-low interval) - (interval-high interval))) - (lambda (determined? filtered?) - (loop (cdr vars) - (or modified? filtered?) - (if determined? count (1+ count))))))))) - (loop vars false 0)) + (call-with-values + (lambda () + (let ((var (car vars))) + (call-with-values + (lambda () + (interval-values (evaluate (vector-ref var 1) + (vector-ref var 2)))) + (lambda (low high) + (process-variable var widening? low high))))) + (lambda (determined? filtered?) + (loop (cdr vars) + (or modified? filtered?) + (if determined? count (+ count 1)))))))) (define (process-variable var widening? minval maxval) - (define (loop sels dropped-some?) - (cond ((null? sels) - (error "variable-width-expression: minimum value is too large" - var minval)) - ((not (selector/fits? minval (car sels))) - (loop (cdr sels) true)) - ((selector/fits? maxval (car sels)) - (cond ((not widening?) - (variable-width->fixed! var (car sels))) - (dropped-some? - (vector-set! var 3 sels))) - (values true dropped-some?)) - (dropped-some? - (vector-set! var 3 sels) - (values false true)) - (else (values false false)))) - (loop (vector-ref var 3) false)) + (let loop ((dropped-some? #f)) + (let ((sels (vector-ref var 3))) + (if (null? sels) + (error "Variable-width field cannot be resolved:" var)) + (let ((low (selector/low (car sels))) + (high (selector/high (car sels)))) + (cond ((and (or (null? low) (<= low minval)) + (or (null? high) (<= maxval high))) + (if (not widening?) + (variable-width->fixed! var (car sels))) + (values #t dropped-some?)) + ((and (or (null? low) (<= low maxval)) + (or (null? high) (<= minval high))) + (values #f dropped-some?)) + (else + (vector-set! var 3 (cdr sels)) + (loop #t))))))) (define (variable-width->fixed! var sel) (let* ((l (selector/length sel)) diff --git a/v7/src/compiler/back/bitutl.scm b/v7/src/compiler/back/bitutl.scm index 2d9df58a5..218f7a470 100644 --- a/v7/src/compiler/back/bitutl.scm +++ b/v7/src/compiler/back/bitutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: bitutl.scm,v 1.7 1993/12/08 17:43:16 gjr Exp $ +$Id: bitutl.scm,v 1.8 1993/12/23 11:14:25 cph Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -37,7 +37,23 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Extra symbol table operations +(define-integrable (make-queue) + (cons '() '())) + +(define-integrable (queue->list queue) + (car queue)) + +(define (add-to-queue! queue entry) + (let ((new (cons entry '()))) + (if (null? (cdr queue)) + (set-car! queue new) + (set-cdr! (cdr queue) new)) + (set-cdr! queue new))) + +(define-integrable (set-label-value! name low high) + (symbol-table-define! *the-symbol-table* + name + (label->machine-interval low high))) (define (clear-symbol-table!) (set! *the-symbol-table* (make-symbol-table)) @@ -47,31 +63,47 @@ MIT in each case. |# (symbol-table-define! *the-symbol-table* *start-label* 0)) (define (finish-symbol-table!) - (define (process-objects objs pcmin pcmax) - (if (null? objs) - 'DONE - (let ((object (car objs))) - (symbol-table-define! *the-symbol-table* - (cadr object) ; label - (make-machine-interval pcmin pcmax)) - (process-objects (cdr objs) - (+ pcmin scheme-object-width) - (+ pcmax scheme-object-width))))) - - ;; Handle scheme objects - (let ((val (symbol-table-value *the-symbol-table* *end-label*))) - (process-objects (queue->list *objects*) - (* addressing-granularity (interval-low val)) - (* addressing-granularity (interval-high val)))) - - ;; Handle equates + (call-with-values + (lambda () + (interval-values (symbol-table-value *the-symbol-table* *end-label*))) + (lambda (low high) + (do ((objects (queue->list *objects*) (cdr objects)) + (pcmin (->bitstring-pc low) (+ pcmin scheme-object-width)) + (pcmax (->bitstring-pc high) (+ pcmax scheme-object-width))) + ((null? objects)) + (set-label-value! (cadar objects) pcmin pcmax)))) (for-each (lambda (equate) (symbol-table-define! *the-symbol-table* (car equate) - (evaluate (cadr equate) false))) + (evaluate (cadr equate) #f))) (queue->list *equates*))) + +(define (variable-width-lengths v) + (let ((sel (vector-ref v 3))) + (if (null? sel) + (error "Bad variable width directive:" v)) + (let ((l (selector/length (car sel)))) + (let loop ((selectors (cdr sel)) (min l) (max l)) + (if (null? selectors) + (values min max) + (let ((this (selector/length (car selectors)))) + (cond ((< this min) (loop (cdr selectors) this max)) + ((> this max) (loop (cdr selectors) min this)) + (else (loop (cdr selectors) min max))))))))) + +(define-integrable (selector/handler sel) + (vector-ref sel 0)) + +(define-integrable (selector/length sel) + (vector-ref sel 1)) + +(define-integrable (selector/low sel) + (vector-ref sel 2)) + +(define-integrable (selector/high sel) + (vector-ref sel 3)) -;;;; Expression evaluation and intervals +;;;; Expression Evaluation (define (evaluate expression pc-value) (define (inner exp) @@ -90,202 +122,227 @@ MIT in each case. |# (symbol-table-value *the-symbol-table* exp)))) (inner expression)) +(define (find-operator keyword) + (let ((place (assq keyword operators))) + (if (null? place) + (error "evaluate: unknown operator:" keyword)) + ((cdr place)))) + +(define operators + `((+ . ,(lambda () interval:+)) + (- . ,(lambda () interval:-)) + (* . ,(lambda () interval:*)) + (/ . ,(lambda () interval:/)) + (QUOTIENT . ,(lambda () interval:quotient)) + (REMAINDER . ,(lambda () interval:remainder)))) + (define-integrable (->machine-pc pc) (paranoid-quotient pc addressing-granularity)) (define-integrable (->bitstring-pc pc) (* pc addressing-granularity)) -(define (paddify pc-val remdr divsr) - (let ((aremdr (remainder pc-val divsr))) - (+ pc-val - (if (<= aremdr remdr) - (- remdr aremdr) - (+ remdr (- divsr aremdr)))))) - -;; Machine intervals are always in addressing units. - -(define-integrable (make-machine-interval low high) - (make-interval (->machine-pc low) - (->machine-pc high))) - -(define (->interval value) - (if (interval? value) - value - (make-interval value value))) - -(define-integrable (make-interval low high) - (vector 'INTERVAL low high)) - -(define-integrable (interval? obj) - (and (vector? obj) - (eq? (vector-ref obj 0) 'INTERVAL))) - -(define-integrable (interval-low obj) - (vector-ref obj 1)) - -(define-integrable (interval-high obj) - (vector-ref obj 2)) - (define (paranoid-quotient dividend divisor) (let ((result (integer-divide dividend divisor))) - (if (zero? (integer-divide-remainder result)) - (integer-divide-quotient result) - (error "paranoid-quotient: not a multiple" dividend divisor)))) + (if (not (zero? (integer-divide-remainder result))) + (error "paranoid-quotient: not a multiple" dividend divisor)) + (integer-divide-quotient result))) (define (final-pad pcvalue) (paddify pcvalue 0 scheme-object-width)) - -;;;; Operators - -(define operators '()) -(define (define-operator! keyword procedure) - (set! operators `((,keyword . ,procedure) ,@operators))) - -(define (find-operator keyword) - (let ((place (assq keyword operators))) - (if (null? place) - (error "evaluate: unknown operator" keyword) - (cdr place)))) - -;; Either argument can be an interval - -(define-operator! '+ - (lambda (op1 op2) - (cond ((not (interval? op2)) - (if (not (interval? op1)) - (+ op1 op2) - (make-interval (+ (interval-low op1) op2) - (+ (interval-high op1) op2)))) - ((not (interval? op1)) - (make-interval (+ op1 (interval-low op2)) - (+ op1 (interval-high op2)))) - (else - (make-interval (+ (interval-low op1) (interval-low op2)) - (+ (interval-high op1) (interval-high op2))))))) - -(define-operator! '- - (lambda (op1 op2) - (cond ((not (interval? op2)) - (if (not (interval? op1)) - (- op1 op2) - (make-interval (- (interval-low op1) op2) - (- (interval-high op1) op2)))) - ((not (interval? op1)) - (make-interval (- op1 (interval-high op2)) - (- op1 (interval-low op2)))) - (else - (make-interval (- (interval-low op1) (interval-high op2)) - (- (interval-high op1) (interval-low op2))))))) +(define (paddify pc-val remdr divsr) + (let ((aremdr (remainder pc-val divsr))) + (+ pc-val + (if (<= aremdr remdr) + (- remdr aremdr) + (+ remdr (- divsr aremdr)))))) -;; Only one argument can be an interval, both assumed non-negative. - -(define-operator! '* - (lambda (op1 op2) - (cond ((not (interval? op2)) - (if (not (interval? op1)) - (* op1 op2) - (make-interval (* (interval-low op1) op2) - (* (interval-high op1) op2)))) - ((not (interval? op1)) - (make-interval (* op1 (interval-low op2)) - (* op1 (interval-high op2)))) - (else - (error "evaluate: Both arguments are intervals" '* op1 op2))))) - -;; Only the first argument can be an interval - -(define ((asymmetric name op) op1 op2) - (cond ((interval? op2) - (error "evaluate: Second operand is an interval" name op1 op2)) - ((not (interval? op1)) - (op op1 op2)) - (else - (make-interval (op (interval-low op1) op2) - (op (interval-high op1) op2))))) - -(define-operator! '/ (asymmetric '/ paranoid-quotient)) -(define-operator! 'QUOTIENT (asymmetric 'QUOTIENT quotient)) - -(define-operator! 'REMAINDER - (lambda (op1 op2) - (cond ((interval? op2) - (error "evaluate: Second operand is an interval" - 'REMAINDER op1 op2)) - ((not (interval? op1)) - (remainder op1 op2)) - (else - (let ((rlow (remainder (interval-low op1) op2)) - (rhigh (remainder (interval-high op1) op2))) - (if (> rlow rhigh) - (make-interval rhigh rlow) - (make-interval rlow rhigh))))))) +;;;; Interval Arithmetic + +(define-structure (interval (constructor %make-interval)) + (offset #f read-only #t) + (segset #f read-only #t)) + +(define-integrable (label->machine-interval low high) + (make-interval 0 + (list (make-segment (make-point (->machine-pc low) + (->machine-pc high)) + 1)))) + +(define (make-interval offset segset) + (if (null? segset) + offset + (%make-interval offset segset))) + +(define (interval-values interval) + (if (interval? interval) + (let loop + ((result-1 (interval-offset interval)) + (result-2 (interval-offset interval)) + (base-1 0) + (base-2 0) + (segset (interval-segset interval))) + (if (null? segset) + (if (<= result-1 result-2) + (values result-1 result-2) + (values result-2 result-1)) + (let ((position-1 (segment-min (car segset))) + (position-2 (segment-max (car segset))) + (k (segment-coeff (car segset)))) + (loop (+ result-1 (* (- position-1 base-1) k)) + (+ result-2 (* (- position-2 base-2) k)) + position-1 + position-2 + (cdr segset))))) + (values interval interval))) + +(define (interval-final-value interval) + (if (interval? interval) + (let loop + ((result (interval-offset interval)) + (base 0) + (segset (interval-segset interval))) + (if (null? segset) + result + (let ((position (segment-min (car segset))) + (k (segment-coeff (car segset)))) + (loop (+ result (* (- position base) k)) + position + (cdr segset))))) + interval)) -;;;; Variable width expression utilities - -(define (variable-width-lengths v receiver) - (define (loop selectors min max) - (cond ((null? selectors) - (receiver min max)) - ((< (selector/length (car selectors)) min) - (loop (cdr selectors) - (selector/length (car selectors)) - max)) - ((> (selector/length (car selectors)) max) - (loop (cdr selectors) - min - (selector/length (car selectors)))) - (else - (loop (cdr selectors) min max)))) - (let ((sel (vector-ref v 3))) - (if (null? sel) - (error "variable-width-lengths: Bad variable width directive" v) - (loop (cdr sel) - (selector/length (car sel)) - (selector/length (car sel)))))) - -(define (selector/fits? val sel) - (let ((low (selector/low sel)) - (high (selector/high sel))) - (and (or (false? low) (<= low val)) - (or (false? high) (<= val high))))) - -(declare (integrate-operator selector/high selector/low - selector/handler selector/length)) - -(define (selector/high sel) - (declare (integrate sel)) - (vector-ref sel 3)) - -(define (selector/low sel) - (declare (integrate sel)) - (vector-ref sel 2)) - -(define (selector/length sel) - (declare (integrate sel)) - (vector-ref sel 1)) - -(define (selector/handler sel) - (declare (integrate sel)) - (vector-ref sel 0)) +(define (interval:+ a b) + (if (interval? a) + (if (interval? b) + (make-interval (+ (interval-offset a) (interval-offset b)) + (segset:+ (interval-segset a) (interval-segset b))) + (make-interval (+ (interval-offset a) b) (interval-segset a))) + (if (interval? b) + (make-interval (+ a (interval-offset b)) (interval-segset b)) + (+ a b)))) + +(define (interval:- a b) + (if (interval? a) + (if (interval? b) + (make-interval (- (interval-offset a) (interval-offset b)) + (segset:- (interval-segset a) (interval-segset b))) + (make-interval (- (interval-offset a) b) (interval-segset a))) + (if (interval? b) + (make-interval (- a (interval-offset b)) + (segset:negate (interval-segset b))) + (- a b)))) + +(define (interval:* a b) + (if (interval? a) + (if (interval? b) + (error "Can't multiply two intervals:" a b) + (make-interval (* (interval-offset a) b) + (segset:scale (interval-segset a) b))) + (if (interval? b) + (make-interval (* (interval-offset b) a) + (segset:scale (interval-segset b) a)) + (* a b)))) + +;;; Integer division on intervals is hard because the numerator of the +;;; division is a summation. For exact division we can just check the +;;; sum of the result to make sure it's an integer. QUOTIENT and +;;; REMAINDER can't be done at all unless we constrain the remainder +;;; of the high and low values to be the same. + +(define (interval:/ a b) + (if (interval? b) + (error "Can't divide by an interval:" b)) + (if (interval? a) + (let ((result + (make-interval (/ (interval-offset a) b) + (segset:scale (interval-segset a) (/ 1 b))))) + (if (not + (call-with-values (lambda () (interval-values result)) + (lambda (low high) + (and (integer? low) + (integer? high))))) + (error "Interval division not exact:" a b)) + result) + (paranoid-quotient a b))) + +(define (interval:quotient a b) + (if (or (interval? a) (interval? b)) + (error "QUOTIENT doesn't do intervals:" a b)) + (quotient a b)) + +(define (interval:remainder a b) + (if (or (interval? a) (interval? b)) + (error "REMAINDER doesn't do intervals:" a b)) + (remainder a b)) -;;;; Random utilities - -;;; Queues - -(declare (integrate-operator make-queue queue->list)) - -(define (make-queue) - (cons '() '())) - -(define (queue->list queue) - (declare (integrate queue)) - (car queue)) - -(define (add-to-queue! queue entry) - (let ((new (cons entry '()))) - (if (null? (cdr queue)) - (set-car! queue new) - (set-cdr! (cdr queue) new)) - (set-cdr! queue new))) \ No newline at end of file +;;; A segment consists of an ending point and a coefficient. +;;; The ending point has a minimum and maximum non-negative integer value. +;;; The coefficient is an integer. +;;; min(s1)=min(s2) iff max(s1)=max(s2) +;;; min(s1)