From 22c0907a67366e4feddd5a7b2addc8c28f3b5fab Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 8 Dec 1993 17:50:41 +0000 Subject: [PATCH] Several changes: - Closures are allocated differently: the compiler prepares a pattern, the linker finalizes it, the garbage collector relocates it, and the pattern is copied at runtime to make a new closure. - Tighten up the closure code: eliminate the privilege-bit-clearing instruction, and share the closure gc stubs between all the closures in a block. - Add a code segment facility to the linearizer. - Add a padding facility to the assembler. - Compiled code blocks are now aligned to floating-point boundaries so that they can contain embedded floating-point values and closure patterns can be copied using floating-point loads and stores. - Floating-point constants are now embedded in the code area, requiring fewer operations. --- v7/src/compiler/back/bittop.scm | 193 +++++++-- v7/src/compiler/back/bitutl.scm | 161 ++++--- v7/src/compiler/back/lapgn1.scm | 9 +- v7/src/compiler/back/syerly.scm | 8 +- v7/src/compiler/back/syntax.scm | 9 +- v7/src/compiler/base/asstop.scm | 31 +- v7/src/compiler/base/make.scm | 4 +- .../compiler/machines/spectrum/compiler.pkg | 9 +- v7/src/compiler/machines/spectrum/instr2.scm | 47 +- v7/src/compiler/machines/spectrum/lapgen.scm | 10 +- v7/src/compiler/machines/spectrum/lapopt.scm | 25 +- v7/src/compiler/machines/spectrum/rules3.scm | 404 +++++++++++++++--- v7/src/compiler/machines/spectrum/rulflo.scm | 57 ++- 13 files changed, 756 insertions(+), 211 deletions(-) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 8fccebd95..bc7be10ca 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.15 1992/06/12 01:43:44 jinx Exp $ +$Id: bittop.scm,v 1.16 1993/12/08 17:42:47 gjr Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,29 +36,20 @@ MIT in each case. |# ;;; package: (compiler assembler) (declare (usual-integrations)) - + (define *equates*) (define *objects*) (define *entry-points*) -(define *linkage-info*) (define *the-symbol-table*) (define *start-label*) (define *end-label*) -;;; Vector header and NMV header for code section - -(define compiler-output-block-number-of-header-words 2) - -(define starting-pc - (* compiler-output-block-number-of-header-words scheme-object-width)) - ;;;; Assembler top level procedure (define (assemble start-label instructions) (fluid-let ((*equates* (make-queue)) (*objects* (make-queue)) (*entry-points* (make-queue)) - (*linkage-info* (make-queue)) (*the-symbol-table* (make-symbol-table)) (*start-label* start-label) (*end-label* (generate-uninterned-symbol 'END-LABEL-))) @@ -90,8 +81,7 @@ MIT in each case. |# (values count block (queue->list *entry-points*) - (symbol-table->assq-list *the-symbol-table*) - (queue->list *linkage-info*))))))) + (symbol-table->assq-list *the-symbol-table*))))))) (define (relax! directives vars) (define (loop vars count) @@ -109,6 +99,13 @@ MIT in each case. |# count))))) (loop vars 0)) +;;; Vector header and NMV header for code section + +(define compiler-output-block-number-of-header-words 2) + +(define starting-pc + (* compiler-output-block-number-of-header-words scheme-object-width)) + ;;;; Output block generation (define (final-phase directives) @@ -129,8 +126,10 @@ MIT in each case. |# (instruction-initial-position code-block)) code-block)) +#| + (define (assemble-objects code-block) - (let ((objects (queue->list *objects*))) + (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) @@ -152,25 +151,65 @@ MIT in each case. |# (object-new-type (ucode-type compiled-code-block) output-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)) + (objects-length (length objects)) + (total-length (fix:+ 1 (fix:+ objects-length bl))) + (flo-length + (let ((flo-size (fix:quotient float-width scheme-datum-width))) + (fix:quotient (fix:+ total-length (fix:- flo-size 1)) + flo-size))) + (output-block + (object-new-type (ucode-type compiled-code-block) + (flo:vector-cons flo-length)))) + (with-absolutely-no-interrupts + (lambda () + (let ((ob (object-new-type (ucode-type vector) output-block))) + (subvector-fill! ob + (fix:+ bl 1) + (vector-length ob) + #f) + (vector-set! ob 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) + ((ucode-primitive primitive-object-set! 3) + output-block 0 + (object-new-type (ucode-type null) total-length)) + (insert-objects! output-block objects (fix:+ bl 1)) + output-block)))) + +(define (assemble-an-object object) + (case (car object) + ((SCHEME-OBJECT) + ;; (SCHEME-OBJECT ) + (cdr object)) + ((SCHEME-EVALUATION) + ;; (SCHEME-EVALUATION ) + (list (cadr object) (evaluate (caddr object) false))) + (else + (error "assemble-an-object: Unknown kind" + object)))) + (define (insert-objects! v objects where) (cond ((not (null? objects)) - (vector-set! v where (cadar objects)) - (insert-objects! v (cdr objects) (1+ where))) - ((not (= where (vector-length v))) + (system-vector-set! v where (cadar objects)) + (insert-objects! v (cdr objects) (fix:+ where 1))) + ((not (fix:= where (system-vector-length v))) (error "insert-objects!: object phase error" where)) (else unspecific))) - -(define (pad! block pc position) - (let ((l (bit-string-length padding-string))) - (let loop ((to-pad (- (pad pc) pc)) - (position position)) - (if (not (zero? to-pad)) - (if (< to-pad l) - (error "pad!: Bad padding length" to-pad) - (instruction-insert! padding-string block position - (lambda (new-position) - (declare (integrate new-position)) - (loop (- to-pad l) new-position)))))))) (define (assemble-directives! block directives initial-position) @@ -211,14 +250,29 @@ MIT in each case. |# (error "assemble-directives!: phase error" `(PC ,starting-pc ,pc) `(BIT-POSITION ,initial-position ,position))) + ((not (= (symbol-table-value *the-symbol-table* *end-label*) + (->machine-pc (final-pad pc)))) + (error "assemble-directives!: phase error" + `(LABEL ,*end-label*) + `(ACTUAL-PC ,(->machine-pc (final-pad pc))) + `(RESOLVED-PC ,(symbol-table-value + *the-symbol-table* + *end-label*)))) (else - (pad! block pc position)))) + (final-pad! block pc position)))) (if (null? directives) (end-assembly) (let ((this (car directives))) (case (vector-ref this 0) ((LABEL) + (let* ((label (vector-ref this 1)) + (pcdef (symbol-table-value *the-symbol-table* label))) + (if (not (= pcdef (->machine-pc pc))) + (error "assemble-directives!: phase error" + `(LABEL ,label) + `(ACTUAL-PC ,pc) + `(RESOLVED-PC ,pcdef)))) (loop (cdr directives) dir-stack pc pc-stack position last-blabel blabel)) ((TICK) @@ -253,6 +307,20 @@ MIT in each case. |# (block-offset (evaluate `(- ,label ,last-blabel) '()) label last-blabel) (block-offset offset label blabel)))) + ((PADDING) + (let ((remdr (vector-ref this 1)) + (divsr (vector-ref this 2)) + (padding-string (vector-ref this 3))) + (let* ((pc* (->bitstring-pc (paddify (->machine-pc pc) + remdr divsr))) + (pc-diff (- pc* pc)) + (padding-length (bit-string-length padding-string))) + (if (not (zero? (remainder pc-diff padding-length))) + (error "assemble-directives!: Bad padding" + pc this) + (actual-bits (replicate padding-string + (quotient pc-diff padding-length)) + pc-diff))))) (else (error "assemble-directives!: Unknown directive" this)))))) @@ -303,15 +371,16 @@ MIT in each case. |# (loop (cdr to-convert) pcmin pcmax pc-stack group vars)) - + (if (null? to-convert) - (let ((emin (pad pcmin)) + (let ((emin (final-pad pcmin)) (emax (+ pcmax maximum-padding-length))) (symbol-table-define! *the-symbol-table* *end-label* (make-machine-interval emin emax)) (collect-group!) (values (queue->list directives) vars)) + (let ((this (car to-convert))) (cond ((bit-string? this) (process-fixed-width (vector 'CONSTANT this) @@ -356,15 +425,20 @@ MIT in each case. |# ((EQUATE) (add-to-queue! *equates* (cdr this)) (process-trivial-directive)) - ((SCHEME-OBJECT) - (add-to-queue! *objects* (cdr this)) + ((SCHEME-OBJECT SCHEME-EVALUATION) + (add-to-queue! *objects* this) (process-trivial-directive)) ((ENTRY-POINT) (add-to-queue! *entry-points* (cadr this)) (process-trivial-directive)) - ((LINKAGE-INFORMATION) - (add-to-queue! *linkage-info* (cdr this)) - (process-trivial-directive)) + ((PADDING) + (let ((directive (->padding-directive this))) + (new-directive! directive) + (after-padding + directive pcmin pcmax + (lambda (pcmin pcmax) + (loop (cdr to-convert) pcmin pcmax + pc-stack '() vars))))) (else (error "initial-phase: Unknown directive" this)))))))) (loop input starting-pc starting-pc '() '() '()))) @@ -372,7 +446,7 @@ MIT in each case. |# (define (phase-1 directives) (define (loop rem pcmin pcmax pc-stack vars) (if (null? rem) - (let ((emin (pad pcmin)) + (let ((emin (final-pad pcmin)) (emax (+ pcmax maximum-padding-length))) (symbol-table-define! *the-symbol-table* *end-label* @@ -410,6 +484,11 @@ MIT in each case. |# (cons (make-machine-interval pcmin pcmax) pc-stack) (cdr pc-stack)) vars)) + ((PADDING) + (after-padding + this pcmin pcmax + (lambda (pcmin pcmax) + (loop (cdr rem) pcmin pcmax pc-stack vars)))) (else (error "phase-1: Unknown directive" this)))))) (loop directives starting-pc starting-pc '() '())) @@ -471,4 +550,38 @@ MIT in each case. |# (if (null? (cdr l)) (car l) (instruction-append (car l) - (list->bit-string (cdr l))))) \ No newline at end of file + (list->bit-string (cdr l))))) + +(define (replicate bstring n-times) + (let* ((blength (bit-string-length bstring)) + (result (make-bit-string (* n-times blength) false))) + (do ((offset 0 (+ offset blength)) + (ctr 0 (1+ ctr))) + ((>= ctr n-times)) + (bit-substring-move-right! bstring 0 blength result offset)) + result)) + +(define (final-pad! block pc position) + (instruction-insert! + (replicate padding-string + (quotient (- (final-pad pc) pc) + (bit-string-length padding-string))) + block + position + (lambda (new-position) + new-position ; ignored + unspecific))) + +(define (->padding-directive this) + (let ((remdr (cadr this)) + (divsr (caddr this)) + (bstring (if (null? (cdddr this)) + padding-string + (cadddr this)))) + (vector 'PADDING (modulo remdr divsr) divsr bstring))) + +(define-integrable (after-padding directive pcmin pcmax recvr) + (let ((remdr (vector-ref directive 1)) + (divsr (vector-ref directive 2))) + (recvr (->bitstring-pc (paddify (->machine-pc pcmin) remdr divsr)) + (->bitstring-pc (paddify (->machine-pc pcmax) remdr divsr))))) \ No newline at end of file diff --git a/v7/src/compiler/back/bitutl.scm b/v7/src/compiler/back/bitutl.scm index bd9fe4cc7..2d9df58a5 100644 --- a/v7/src/compiler/back/bitutl.scm +++ b/v7/src/compiler/back/bitutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.6 1992/07/05 13:32:27 jinx Exp $ +$Id: bitutl.scm,v 1.7 1993/12/08 17:43:16 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,20 +40,21 @@ MIT in each case. |# ;;;; Extra symbol table operations (define (clear-symbol-table!) - (set! *the-symbol-table* (make-symbol-table))) + (set! *the-symbol-table* (make-symbol-table)) + unspecific) (define (initialize-symbol-table!) (symbol-table-define! *the-symbol-table* *start-label* 0)) (define (finish-symbol-table!) - (define (process-objects obj pcmin pcmax) - (if (null? obj) + (define (process-objects objs pcmin pcmax) + (if (null? objs) 'DONE - (begin + (let ((object (car objs))) (symbol-table-define! *the-symbol-table* - (caar obj) + (cadr object) ; label (make-machine-interval pcmin pcmax)) - (process-objects (cdr obj) + (process-objects (cdr objs) (+ pcmin scheme-object-width) (+ pcmax scheme-object-width))))) @@ -65,10 +66,9 @@ MIT in each case. |# ;; Handle equates (for-each (lambda (equate) - (symbol-table-define! - *the-symbol-table* - (car equate) - (evaluate (cadr equate) false))) + (symbol-table-define! *the-symbol-table* + (car equate) + (evaluate (cadr equate) false))) (queue->list *equates*))) ;;;; Expression evaluation and intervals @@ -82,23 +82,30 @@ MIT in each case. |# ((number? exp) exp) ((not (symbol? exp)) (error "evaluate: bad expression" exp)) - ((eq? exp '*PC*) pc-value) + ((eq? exp '*PC*) + (if (not pc-value) + (error "evaluate: *PC* found with no PC defined")) + pc-value) (else (symbol-table-value *the-symbol-table* exp)))) (inner expression)) -(declare (integrate-operator ->machine-pc make-machine-interval - make-interval interval? - interval-low interval-high)) - -(define (->machine-pc pc) - (declare (integrate pc)) +(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 (make-machine-interval low high) - (declare (integrate low high)) +(define-integrable (make-machine-interval low high) (make-interval (->machine-pc low) (->machine-pc high))) @@ -107,21 +114,17 @@ MIT in each case. |# value (make-interval value value))) -(define (make-interval low high) - (declare (integrate low high)) +(define-integrable (make-interval low high) (vector 'INTERVAL low high)) -(define (interval? obj) - (declare (integrate obj)) +(define-integrable (interval? obj) (and (vector? obj) (eq? (vector-ref obj 0) 'INTERVAL))) -(define (interval-low obj) - (declare (integrate obj)) +(define-integrable (interval-low obj) (vector-ref obj 1)) -(define (interval-high obj) - (declare (integrate obj)) +(define-integrable (interval-high obj) (vector-ref obj 2)) (define (paranoid-quotient dividend divisor) @@ -130,11 +133,8 @@ MIT in each case. |# (integer-divide-quotient result) (error "paranoid-quotient: not a multiple" dividend divisor)))) -(define (pad pcvalue) - (let ((r (remainder pcvalue scheme-object-width))) - (if (zero? r) - pcvalue - (+ pcvalue (- scheme-object-width r))))) +(define (final-pad pcvalue) + (paddify pcvalue 0 scheme-object-width)) ;;;; Operators @@ -151,43 +151,76 @@ MIT in each case. |# ;; Either argument can be an interval -(define ((symmetric scalar) op1 op2) - (if (interval? op1) - (if (interval? op2) - (make-interval (scalar (interval-low op1) (interval-low op2)) - (scalar (interval-high op1) (interval-high op2))) - (make-interval (scalar (interval-low op1) op2) - (scalar (interval-high op1) op2))) - (if (interval? op2) - (make-interval (scalar op1 (interval-low op2)) - (scalar op1 (interval-high op2))) - (scalar op1 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-low op2)) + (+ op1 (interval-high op2)))) + (else + (make-interval (+ (interval-low op1) (interval-low op2)) + (+ (interval-high op1) (interval-high op2))))))) -;; Only the first 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-high op2)) + (- op1 (interval-low op2)))) + (else + (make-interval (- (interval-low op1) (interval-high op2)) + (- (interval-high op1) (interval-low op2))))))) + +;; Only one argument can be an interval, both assumed non-negative. -(define ((asymmetric op) op1 op2) - (if (interval? op1) - (make-interval (op (interval-low op1) op2) - (op (interval-high op1) op2)) - (op op1 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-low op2)) + (* op1 (interval-high op2)))) + (else + (error "evaluate: Both arguments are intervals" '* op1 op2))))) -(define-operator! '+ (symmetric +)) -(define-operator! '- (symmetric -)) +;; Only the first argument can be an interval -(define-operator! '/ (asymmetric paranoid-quotient)) -(define-operator! 'remainder (asymmetric remainder)) +(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))))) -;; Only one argument can be an interval. +(define-operator! '/ (asymmetric '/ paranoid-quotient)) +(define-operator! 'QUOTIENT (asymmetric 'QUOTIENT quotient)) -(define-operator! '* +(define-operator! 'REMAINDER (lambda (op1 op2) - (cond ((interval? op1) - (make-interval (* (interval-low op1) op2) - (* (interval-high op1) op2))) - ((interval? op2) - (make-interval (* op1 (interval-low op2)) - (* op1 (interval-high op2)))) - (else (* 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))))))) ;;;; Variable width expression utilities diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 9dab19a60..4fac026e4 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapgn1.scm,v 4.15 1993/08/26 05:47:34 gjr Exp $ +$Id: lapgn1.scm,v 4.16 1993/12/08 17:43:55 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -319,4 +319,9 @@ MIT in each case. |# (begin (create-edge! current-bblock set-snode-next-edge! bblock) (set-bblock-continuations! current-bblock (list bblock)) - (set-sblock-continuation! current-bblock bblock))))) \ No newline at end of file + (set-sblock-continuation! current-bblock bblock))))) + +(define (lap:comment comment) + (if compiler:generate-lap-files? + (LAP (COMMENT (LAP ,comment))) + (LAP))) \ No newline at end of file diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm index 8a71a634c..9fbc2a652 100644 --- a/v7/src/compiler/back/syerly.scm +++ b/v7/src/compiler/back/syerly.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.8 1991/10/30 20:48:53 cph Exp $ +$Id: syerly.scm,v 1.9 1993/12/08 17:44:21 gjr Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Syntax time instruction expansion +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -52,7 +53,8 @@ MIT in each case. |# (cond ((eq? (car instruction) 'UNQUOTE) (if-not-expanded)) ((memq (car instruction) - '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET)) + '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION + ENTRY-POINT LABEL BLOCK-OFFSET)) (if-expanded (scode/make-combination (scode/make-variable 'DIRECTIVE->INSTRUCTION-SEQUENCE) diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 395f13d73..ad36eac60 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.25 1990/01/18 22:42:14 cph Rel $ +$Id: syntax.scm,v 1.26 1993/12/08 17:44:53 gjr Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; LAP Syntaxer +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -66,7 +67,9 @@ MIT in each case. |# (define (lap:syntax-instruction instruction) (if (memq (car instruction) - '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET)) + '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION + ENTRY-POINT LABEL BLOCK-OFFSET + PADDING)) (list instruction) (let ((match-result (instruction-lookup instruction))) (if (not match-result) diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm index 608f5a7eb..6694c18db 100644 --- a/v7/src/compiler/base/asstop.scm +++ b/v7/src/compiler/base/asstop.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: asstop.scm,v 1.9 1993/11/29 18:38:12 gjr Exp $ +$Id: asstop.scm,v 1.10 1993/12/08 17:45:42 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -98,12 +98,12 @@ MIT in each case. |# (*external-labels*) (*end-of-block-code*) (*next-constant*) - (*interned-constants*) - (*interned-variables*) (*interned-assignments*) - (*interned-uuo-links*) + (*interned-constants*) (*interned-global-links*) (*interned-static-variables*) + (*interned-uuo-links*) + (*interned-variables*) (*label-bindings*) (*code-vector*) (*entry-points*) @@ -117,12 +117,12 @@ MIT in each case. |# (set! *external-labels*) (set! *end-of-block-code*) (set! *next-constant*) - (set! *interned-constants*) - (set! *interned-variables*) (set! *interned-assignments*) - (set! *interned-uuo-links*) + (set! *interned-constants*) (set! *interned-global-links*) (set! *interned-static-variables*) + (set! *interned-uuo-links*) + (set! *interned-variables*) (set! *label-bindings*) (set! *code-vector*) (set! *entry-points*) @@ -133,14 +133,14 @@ MIT in each case. |# (set! *block-associations* '()) (set! *block-label* (generate-label)) (set! *external-labels* '()) - (set! *end-of-block-code* (LAP)) + (set! *end-of-block-code* '()) (set! *next-constant* 0) - (set! *interned-constants* '()) - (set! *interned-variables* '()) (set! *interned-assignments* '()) - (set! *interned-uuo-links* '()) + (set! *interned-constants* '()) (set! *interned-global-links* '()) (set! *interned-static-variables* '()) + (set! *interned-uuo-links* '()) + (set! *interned-variables* '()) unspecific) ;;;; Assembler and linker @@ -150,8 +150,7 @@ MIT in each case. |# "Assembly" (lambda () (with-values (lambda () (assemble *block-label* (last-reference *lap*))) - (lambda (count code-vector labels bindings linkage-info) - linkage-info ;ignored + (lambda (count code-vector labels bindings) (set! *code-vector* code-vector) (set! *entry-points* labels) (set! *label-bindings* bindings) @@ -359,12 +358,12 @@ MIT in each case. |# (set! *entry-label* label) (set! *current-label-number* 0) (set! *next-constant* 0) - (set! *interned-constants* '()) - (set! *interned-variables* '()) (set! *interned-assignments* '()) - (set! *interned-uuo-links* '()) + (set! *interned-constants* '()) (set! *interned-global-links* '()) (set! *interned-static-variables* '()) + (set! *interned-uuo-links* '()) + (set! *interned-variables* '()) (set! *block-label* (generate-label)) (set! *external-labels* '()) (set! *ic-procedure-headers* '()) diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm index 95755072c..13532ca02 100644 --- a/v7/src/compiler/base/make.scm +++ b/v7/src/compiler/base/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 4.102 1993/11/18 01:21:12 cph Exp $ +$Id: make.scm,v 4.103 1993/12/08 17:50:41 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -54,5 +54,5 @@ MIT in each case. |# (initialize-package! '(COMPILER DECLARATIONS))) (add-system! (make-system (string-append "Liar (" architecture-name ")") - 4 101 + 4 102 '()))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/compiler.pkg b/v7/src/compiler/machines/spectrum/compiler.pkg index 0cd8da970..c78872a2c 100644 --- a/v7/src/compiler/machines/spectrum/compiler.pkg +++ b/v7/src/compiler/machines/spectrum/compiler.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compiler.pkg,v 1.45 1993/10/12 07:30:11 cph Exp $ +$Id: compiler.pkg,v 1.46 1993/12/08 17:47:44 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -625,9 +625,14 @@ MIT in each case. |# (parent (compiler lap-syntaxer)) (export (compiler lap-syntaxer) add-end-of-block-code! + add-extra-code! bblock-linearize-lap + extra-code-block/xtra + declare-extra-code-block! + find-extra-code-block linearize-lap - set-current-branches!) + set-current-branches! + set-extra-code-block/xtra!) (export (compiler top-level) *end-of-block-code* linearize-lap)) diff --git a/v7/src/compiler/machines/spectrum/instr2.scm b/v7/src/compiler/machines/spectrum/instr2.scm index c0a44ff3e..5a748740b 100644 --- a/v7/src/compiler/machines/spectrum/instr2.scm +++ b/v7/src/compiler/machines/spectrum/instr2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.5 1993/02/14 00:53:30 gjr Exp $ +$Id: instr2.scm,v 1.6 1993/12/08 17:48:22 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -199,20 +199,30 @@ MIT in each case. |# (1 (vector-ref compl 2)) (5 reg)))))) - (indexed-cache - (macro (keyword opcode extn bit) + (indexed-d-cache + (macro (keyword extn) `(define-instruction ,keyword - (((? compl complx) (INDEX (? index-reg) (? space) (? base))) - (LONG (6 ,opcode) + (((? compl m-val) (INDEX (? index-reg) (? space) (? base))) + (LONG (6 #x01) (5 base) (5 index-reg) (2 space) - (1 (vector-ref compl 0)) - (1 ,bit) - (2 (vector-ref compl 1)) - (4 ,extn) - (1 (vector-ref compl 2)) - (5 #b00000))))))) + (8 ,extn) + (1 compl) + (5 #x0)))))) + + (indexed-i-cache + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl m-val) + (INDEX (? index-reg) (? space sr3) (? base))) + (LONG (6 #x01) + (5 base) + (5 index-reg) + (3 space) + (7 ,extn) + (1 compl) + (5 #x0))))))) (indexed-load LDWX #x03 #x2) (indexed-load LDHX #x03 #x1) @@ -224,11 +234,11 @@ MIT in each case. |# (indexed-store FSTWX #x09 #x8) (indexed-store FSTDX #x0b #x8) - (indexed-cache PDC #x01 #xd 1) - (indexed-cache FDC #x01 #xa 1) - (indexed-cache FIC #x01 #xa 0) - (indexed-cache FDCE #x01 #xb 1) - (indexed-cache FICE #x01 #xb 0)) + (indexed-d-cache PDC #x4e) + (indexed-d-cache FDC #x4a) + (indexed-i-cache FIC #x0a) + (indexed-d-cache FDCE #x4b) + (indexed-i-cache FICE #x0b)) (let-syntax ((scalr-short-load (macro (keyword extn) @@ -714,6 +724,11 @@ Note: Only those currently used by the code generator are implemented. ;;;; Assembler pseudo-ops +(define-instruction USHORT + ((() (? high) (? low)) + (LONG (16 high UNSIGNED) + (16 low UNSIGNED)))) + (define-instruction WORD ((() (? expression)) (LONG (32 expression SIGNED)))) diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm index d3e4ebc2d..da7e70428 100644 --- a/v7/src/compiler/machines/spectrum/lapgen.scm +++ b/v7/src/compiler/machines/spectrum/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 4.45 1993/10/28 04:59:46 gjr Exp $ +$Id: lapgen.scm,v 4.46 1993/12/08 17:48:53 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -695,8 +695,12 @@ MIT in each case. |# flonum-truncate flonum-ceiling flonum-floor - flonum-atan2)) - + flonum-atan2 + compiled-code-bkpt + compiled-closure-bkpt + copy-closure-pattern + copy-multiclosure-pattern)) + ;; There is a NOP here because otherwise the return address would have ;; to be adjusted by the hook code. This gives more flexibility to the ;; compiler since it may be able to eliminate the NOP by moving an diff --git a/v7/src/compiler/machines/spectrum/lapopt.scm b/v7/src/compiler/machines/spectrum/lapopt.scm index 6dcb63635..10b291b03 100644 --- a/v7/src/compiler/machines/spectrum/lapopt.scm +++ b/v7/src/compiler/machines/spectrum/lapopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapopt.scm,v 1.13 1993/07/01 03:14:14 gjr Exp $ +$Id: lapopt.scm,v 1.14 1993/12/08 17:49:18 gjr Exp $ Copyright (c) 1991-1993 Massachusetts Institute of Technology @@ -40,15 +40,13 @@ MIT in each case. |# ;;;; An instruction classifier and decomposer (define-integrable (float-reg reg) - reg ; ignore (+ 32 reg)) (define (classify-instruction instr) - ;; returns: type target source-1 source-2 offset + ;; (values type target source-1 source-2 offset) ;; This needs the following: ;; - Loads with base modification (LDWM) ;; - Third source (indexed loads) - ;; - Floats (let ((opcode (car instr))) (cond ((memq opcode '(ANDCM AND OR XOR UXOR SUB DS SUBT SUBB ADD SH1ADD SH2ADD SH3ADD ADDC @@ -93,7 +91,7 @@ MIT in each case. |# (list-ref instr 2) (cadddr offset) (cadr offset)))) - ((memq opcode '(STWM)) + ((memq opcode '(STWM STWS)) ;; source1 (offset n m target/source) (let* ((offset (list-ref instr 3)) (base (cadddr offset))) @@ -196,7 +194,8 @@ MIT in each case. |# ((memq opcode '(PCR-HOOK)) <>) ((memq opcode '(LABEL EQUATE ENTRY-POINT - EXTERNAL-LABEL BLOCK-OFFSET)) + EXTERNAL-LABEL BLOCK-OFFSET + SCHEME-OBJECT SCHEME-EVALUATION PADDING)) (values 'DIRECTIVE false false false false)) |# (else @@ -204,7 +203,8 @@ MIT in each case. |# (define (offset-fits? offset opcode) (and (number? offset) - (memq opcode '(ldw ldb ldo ldh stw stb sth stwm ldwm)) + (memq opcode '(LDW LDB LDO LDH STW STB STH STWM LDWM + STWS LDWS FLDWS FLDDS FSTWS FSTDS)) (<= -8192 offset 8191))) ;;;; Utilities @@ -247,19 +247,24 @@ MIT in each case. |# ;; (COMBT (<) ...) (and (pair? (cadr instr)) (not (memq (car instr) - '(B BL BV BLR BLE BE))) + '(B BL BV BLR BLE BE + LDWS LDHS LDBS LDCWS + STWS STHS STBS STBYS + FLDWS FLDDS FSTWS FSTDS))) ;; or SGL, or QUAD, but not used now. (not (memq 'DBL (cadr instr))))) (define (find-or-label instrs) (and (not (null? instrs)) - (if (memq (caar instrs) '(COMMENT SCHEME-OBJECT EQUATE)) + (if (memq (caar instrs) + '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE)) (find-or-label (cdr instrs)) instrs))) (define (find-non-label instrs) (and (not (null? instrs)) - (if (memq (caar instrs) '(LABEL COMMENT SCHEME-OBJECT EQUATE)) + (if (memq (caar instrs) + '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE)) (find-non-label (cdr instrs)) instrs))) diff --git a/v7/src/compiler/machines/spectrum/rules3.scm b/v7/src/compiler/machines/spectrum/rules3.scm index f093ff82e..ca9725b87 100644 --- a/v7/src/compiler/machines/spectrum/rules3.scm +++ b/v7/src/compiler/machines/spectrum/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 4.40 1993/07/01 03:23:35 gjr Exp $ +$Id: rules3.scm,v 4.41 1993/12/08 17:49:54 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -483,6 +483,11 @@ MIT in each case. |# (define internal-continuation-code-word (make-code-word #xff #xfc)) +;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface + +(define internal-closure-code-word + (make-code-word #xff #xfa)) + (define (continuation-code-word label) (frame-size->code-word (if label @@ -619,20 +624,29 @@ MIT in each case. |# (if (zero? nentries) (error "Closure header for closure with no entries!" internal-label)) - (let ((rtl-proc (label->object internal-label))) - (let ((gc-label (generate-label)) - (external-label (rtl-procedure/external-label rtl-proc))) - (LAP (LABEL ,gc-label) - ,@(invoke-interface code:compiler-interrupt-closure) - ,@(make-external-label - (internal-procedure-code-word rtl-proc) - external-label) - ;; This code must match the code and count in microcode/cmpint2.h - (DEP () 0 31 2 ,regnum:ble-return) - ,@(address->entry regnum:ble-return) - (STWM () ,regnum:ble-return (OFFSET -4 0 ,regnum:stack-pointer)) - (LABEL ,internal-label) - ,@(interrupt-check internal-label gc-label))))) + + ;; Closures used to use (internal-procedure-code-word rtl-proc) + ;; instead of internal-closure-code-word. + ;; This confused the bkpt utilties and was unnecessary because + ;; these entry points cannot properly be used as return addresses. + + (let* ((rtl-proc (label->object internal-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + (let ((suffix + (lambda (gc-label) + (LAP ,@(make-external-label internal-closure-code-word + external-label) + ,@(address->entry g25) + (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer)) + (LABEL ,internal-label) + ,@(interrupt-check internal-label gc-label))))) + (share-instruction-sequence! + 'CLOSURE-GC-STUB + suffix + (lambda (gc-label) + (LAP (LABEL ,gc-label) + ,@(invoke-interface code:compiler-interrupt-closure) + ,@(suffix gc-label))))))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -662,6 +676,9 @@ MIT in each case. |# (else (cons-multiclosure target nentries size (vector->list entries))))) +#| +;;; Old style closure consing -- Out of line. + (define (%cons-closure target total-size size core) (let* ((flush-reg (require-registers! regnum:first-arg #| regnum:addil-result |# @@ -712,21 +729,7 @@ MIT in each case. |# ,@(load-offset 4 regnum:free-pointer target) ,@(generate-entries 12 entries))))) -;; Magic for compiled entries. - -(define compiled-entry-type-im5 - (let* ((qr (integer-divide (ucode-type compiled-entry) 2)) - (immed (integer-divide-quotient qr))) - (if (or (not (= scheme-type-width 6)) - (not (zero? (integer-divide-remainder qr))) - (not (<= 0 immed #x1F))) - (error "HPPA RTL rules3: closure header rule assumptions violated!")) - (if (<= immed #x0F) - immed - (- immed #x20)))) - -(define-integrable (address->entry register) - (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register))) +;; Utilities for old-style closure consing. (define (load-entry-format code-word gc-offset dest) (load-immediate (+ (* code-word #x10000) @@ -761,6 +764,289 @@ MIT in each case. |# 4 ,regnum:scheme-to-interface-ble) (@PCR ,entry-label))))) +|# + +;; Magic for compiled entries. + +(define compiled-entry-type-im5 + (let* ((qr (integer-divide (ucode-type compiled-entry) 2)) + (immed (integer-divide-quotient qr))) + (if (or (not (= scheme-type-width 6)) + (not (zero? (integer-divide-remainder qr))) + (not (<= 0 immed #x1F))) + (error "HPPA RTL rules3: closure header rule assumptions violated!")) + (if (<= immed #x0F) + immed + (- immed #x20)))) + +(define-integrable (address->entry register) + (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register))) + +;;; New style closure consing using compiler-prepared and +;;; linker-maintained patterns + +;; Compiled code blocks are aligned like floating-point numbers and vectors. +;; That is, the address of their header word is congruent 4 mod 8 + +(define *initial-dword-offset* 4) +(define *closure-padding-bitstring* (make-bit-string 32 false)) + +;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h + +(define *ldil/ble-split* + ;; (expt 2 13) *** + 8192) + +(define *ldil-factor* + ;; (/ *ldil/ble-split* ldil-scale) + 4) + +(define (declare-closure-pattern! pattern) + (add-extra-code! + (or (find-extra-code-block 'CLOSURE-PATTERNS) + (let ((section-label (generate-label)) + (ev-label (generate-label))) + (let ((block (declare-extra-code-block! + 'CLOSURE-PATTERNS + 'LAST + `(((/ (- ,ev-label ,section-label) 4) + . ,ev-label))))) + (add-extra-code! block + (LAP (LABEL ,section-label))) + block))) + (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*) + ,@pattern))) + +(define (generate-closure-entry offset pattern label min max) + (let ((entry-label (rtl-procedure/external-label (label->object label)))) + (LAP (USHORT () + ,(make-procedure-code-word min max) + ,(quotient offset 2)) + ;; This contains an offset -- the linker turns it to an abs. addr. + (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label) + ,*ldil/ble-split*) + ,*ldil-factor*) + 26) + (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label) + ,*ldil/ble-split*) + 5 26)) + (ADDI () -15 31 25)))) + +(define (cons-closure target entry-label min max size) + (let ((offset 8) + (total-size (+ size closure-entry-size)) + (pattern (generate-label))) + + (declare-closure-pattern! + (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label)) + (LABEL ,pattern) + (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure) + total-size)) + ,@(generate-closure-entry offset pattern entry-label min max))) + #| + ;; This version uses ordinary integer instructions + + (let* ((offset* (* 4 (1+ closure-entry-size))) + (target (standard-target! target)) + (temp1 (standard-temporary!)) + (temp2 (standard-temporary!)) + (temp3 (standard-temporary!))) + + (LAP ,@(load-pc-relative-address pattern target 'CODE) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp2) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp3) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer)) + + (LDWS (MA) (OFFSET 4 0 ,target) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target) + (FDC () (INDEX 0 0 ,target)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))) + |# + + #| + ;; This version is faster by using floating-point (doubleword) moves + + (let* ((offset* (* 4 (1+ closure-entry-size))) + (target (standard-target! target)) + (dwtemp1 (flonum-temporary!)) + (dwtemp2 (flonum-temporary!)) + (swtemp (standard-temporary!))) + + (LAP ,@(load-pc-relative-address pattern target 'CODE) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp) + (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1) + (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer)) + (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2) + (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer)) + (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer) + ,target) + (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer)) + (FDC () (INDEX 0 0 ,target)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))) + |# + + ;; This version does the copy out of line, using fp instructions. + + (let* ((hook-label (generate-label)) + (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10 + #| regnum:addil-result |# + regnum:ble-return))) + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target g25) + (LAP ,@flush-reg + ,@(invoke-hook hook:compiler-copy-closure-pattern) + (LABEL ,hook-label) + (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*)) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))))) + +(define (cons-multiclosure target nentries size entries) + ;; nentries > 1 + (let ((offset 12) + (total-size (+ (+ 1 (* closure-entry-size nentries)) size)) + (pattern (generate-label))) + + (declare-closure-pattern! + (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries))) + (LABEL ,pattern) + (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure) + total-size)) + (USHORT () ,nentries 0) + ,@(let make-entries ((entries entries) + (offset offset)) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP ,@(generate-closure-entry offset + pattern + (car entry) + (cadr entry) + (caddr entry)) + ,@(make-entries (cdr entries) + (+ offset + (* 4 closure-entry-size))))))))) + #| + ;; This version uses ordinary integer instructions + + (let ((target (standard-target! target))) + (let ((temp1 (standard-temporary!)) + (temp2 (standard-temporary!)) + (ctr (standard-temporary!)) + (srcptr (standard-temporary!)) + (index (standard-temporary!)) + (loop-label (generate-label))) + + (LAP ,@(load-pc-relative-address pattern srcptr 'CODE) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target) + (LDI () -16 ,index) + (LDI () ,nentries ,ctr) + ;; The loop copies 16 bytes, and the architecture specifies + ;; that a cache line must be a multiple of this value. + ;; Therefore we only need to flush once per loop, + ;; and once more (D only) to take care of phase. + (LABEL ,loop-label) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + (SYNC ()) + (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label)) + (FIC () (INDEX ,index 5 ,regnum:free-pointer)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,regnum:free-pointer)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer)))) + |# + + #| + ;; This version is faster by using floating-point (doubleword) moves + + (let ((target (standard-target! target))) + (let ((dwtemp1 (flonum-temporary!)) + (dwtemp2 (flonum-temporary!)) + (temp (standard-temporary!)) + (ctr (standard-temporary!)) + (srcptr (standard-temporary!)) + (index (standard-temporary!)) + (loop-label (generate-label))) + + (LAP ,@(load-pc-relative-address pattern srcptr 'CODE) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target) + (LDI () -16 ,index) + (LDI () ,nentries ,ctr) + + ;; The loop copies 16 bytes, and the architecture specifies + ;; that a cache line must be a multiple of this value. + ;; Therefore we only need to flush (D) once per loop, + ;; and once more to take care of phase. + ;; We only need to flush the I cache once because it is + ;; newly allocated memory. + + (LABEL ,loop-label) + (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1) + (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2) + (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer)) + (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer)) + (ADDIB (>) -1 ,ctr (@PCR ,loop-label)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp) + (LDI () ,(* -4 (1+ size)) ,index) + (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ())))) + |# + + ;; This version does the copy out of line, using fp instructions. + + (let* ((hook-label (generate-label)) + (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10 + #| regnum:addil-result |# + regnum:ble-return))) + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target g25) + (LAP ,@flush-reg + (LDI () ,nentries 1) + ,@(invoke-hook hook:compiler-copy-multiclosure-pattern) + (LABEL ,hook-label) + (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*)) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))))) ;;;; Entry Header ;;; This is invoked by the top level of the LAP generator. @@ -890,18 +1176,18 @@ MIT in each case. |# (define (generate/constants-block constants references assignments uuo-links global-links static-vars) (let ((constant-info - ;; Note: generate/remote-links depends on all the references (& uuos) - ;; being first! + ;; Note: generate/remote-links depends on all the linkage sections + ;; (references & uuos) being first! (declare-constants 0 (transmogrifly uuo-links) (declare-constants 1 references (declare-constants 2 assignments (declare-constants 3 (transmogrifly global-links) - (declare-constants false - (map (lambda (pair) - (cons false (cdr pair))) - static-vars) - (declare-constants false constants - (cons false (LAP)))))))))) + (declare-closure-patterns + (declare-constants false (map (lambda (pair) + (cons false (cdr pair))) + static-vars) + (declare-constants false constants + (cons false (LAP))))))))))) (let ((free-ref-label (car constant-info)) (constants-code (cdr constant-info)) (debugging-information-label (allocate-constant-label)) @@ -910,7 +1196,8 @@ MIT in each case. |# (+ (if (null? uuo-links) 0 1) (if (null? references) 0 1) (if (null? assignments) 0 1) - (if (null? global-links) 0 1)))) + (if (null? global-links) 0 1) + (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1)))) (values (LAP ,@constants-code ;; Place holder for the debugging info filename @@ -921,26 +1208,45 @@ MIT in each case. |# environment-label free-ref-label n-sections)))) + +(define (declare-constants/tagged tag header constants info) + (define-integrable (wrap tag label value) + (LAP (,tag ,label ,value))) -(define (declare-constants tag constants info) (define (inner constants) (if (null? constants) (cdr info) (let ((entry (car constants))) - (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + (LAP ,@(wrap tag (cdr entry) (car entry)) ,@(inner (cdr constants)))))) - (if (and tag (not (null? constants))) + + (if (and header (not (null? constants))) (let ((label (allocate-constant-label))) (cons label - (inner - `((,(let ((datum (length constants))) - (if (> datum #xffff) - (error "datum too large" datum)) - (+ (* tag #x10000) datum)) - . ,label) - ,@constants)))) + (LAP (SCHEME-OBJECT + ,label + ,(let ((datum (length constants))) + (if (> datum #xffff) + (error "datum too large" datum)) + (+ (* header #x10000) datum))) + ,@(inner constants)))) (cons (car info) (inner constants)))) +(define (declare-constants header constants info) + (declare-constants/tagged 'SCHEME-OBJECT header constants info)) + +(define (declare-closure-patterns info) + (let ((block (find-extra-code-block 'CLOSURE-PATTERNS))) + (if (not block) + info + (declare-constants/tagged 'SCHEME-EVALUATION + 4 + (extra-code-block/xtra block) + info)))) + +(define (declare-evaluations header evals info) + (declare-constants/tagged 'SCHEME-EVALUATION header evals info)) + (define (transmogrifly uuos) (define (inner name assoc) (if (null? assoc) diff --git a/v7/src/compiler/machines/spectrum/rulflo.scm b/v7/src/compiler/machines/spectrum/rulflo.scm index 9093e63f7..3bfdaacb4 100644 --- a/v7/src/compiler/machines/spectrum/rulflo.scm +++ b/v7/src/compiler/machines/spectrum/rulflo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rulflo.scm,v 4.38 1993/07/01 07:48:28 gjr Exp $ +$Id: rulflo.scm,v 4.39 1993/12/08 17:50:21 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -71,9 +71,64 @@ MIT in each case. |# (LAP ,@(object->address source) (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target))))) +;; This is endianness dependent! + +(define (flonum-value->data-decl value) + (let ((high (make-bit-string 32 false)) + (low (make-bit-string 32 false))) + (read-bits! value 32 high) + (read-bits! value 64 low) + (LAP ,@(lap:comment `(FLOAT ,value)) + (UWORD () ,(bit-string->unsigned-integer high)) + (UWORD () ,(bit-string->unsigned-integer low))))) + +(define (flonum->label value) + (let* ((block + (or (find-extra-code-block 'FLOATING-CONSTANTS) + (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS + 'ANYWHERE + '()))) + (add-extra-code! + block + (LAP (PADDING ,(- 0 *initial-dword-offset*) 8))) + block))) + (pairs (extra-code-block/xtra block)) + (place (assoc value pairs))) + (if place + (cdr place) + (let ((label (generate-label))) + (set-extra-code-block/xtra! + block + (cons (cons value label) pairs)) + (add-extra-code! block + (LAP (LABEL ,label) + ,@(flonum-value->data-decl value))) + label)))) + +#| (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.))) (LAP (FCPY (DBL) 0 ,(flonum-target! target)))) +|# + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value)))) + (cond ((not (flo:flonum? fp-value)) + (error "OBJECT->FLOAT: Not a floating-point value" fp-value)) + (compiler:cross-compiling? + (let ((temp (standard-temporary!))) + (LAP ,@(load-constant fp-value temp) + ,@(object->address temp) + (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target))))) + ((flo:= fp-value 0.0) + (LAP (FCPY (DBL) 0 ,(flonum-target! target)))) + (else + (let* ((temp (standard-temporary!)) + (target (flonum-target! target))) + (LAP ,@(load-pc-relative-address (flonum->label fp-value) + temp + 'CONSTANT) + (FLDDS () (OFFSET 0 0 ,temp) ,target)))))) (define-rule statement (ASSIGN (REGISTER (? target)) -- 2.25.1