From 235a1f90ccf07b19640d1928bd8663f7f1fbc716 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 13 Aug 1987 02:01:16 +0000 Subject: [PATCH] Make instruction sequencing independent of machine byte ordering. --- v7/src/compiler/back/asmmac.scm | 6 +-- v7/src/compiler/back/bittop.scm | 54 ++++++++++++----------- v7/src/compiler/back/insseq.scm | 6 +-- v7/src/compiler/back/syerly.scm | 8 ++-- v7/src/compiler/back/syntax.scm | 8 ++-- v7/src/compiler/machines/bobcat/assmd.scm | 17 ++++++- 6 files changed, 58 insertions(+), 41 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index ec1d8ac30..deee5218b 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.4 1987/07/22 17:15:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.5 1987/08/13 01:59:58 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -76,8 +76,8 @@ MIT in each case. |# (cond ((null? components) (cons (make-constant bit-string) '())) ((car-constant? components) - (compact (bit-string-append (car-constant-value components) - bit-string) + (compact (instruction-append bit-string + (car-constant-value components)) (cdr components))) (else (cons (make-constant bit-string) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 66be6b037..92e5962fe 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.5 1987/07/30 21:26:59 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.6 1987/08/13 02:00:44 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -101,9 +101,6 @@ MIT in each case. |# ;;;; Output block generation -(define (bit-string-insert! b1 b2 position) - (bit-substring-move-right! b1 0 (bit-string-length b1) b2 position)) - (define (final-phase directives) ;; Label values are now integers. (for-each (lambda (pair) @@ -115,11 +112,12 @@ MIT in each case. |# (symbol-table-value *the-symbol-table* *end-label*)) starting-pc)) (output-block (bit-string-allocate (+ scheme-object-width length)))) - (bit-string-insert! + (instruction-insert! (make-nmv-header (quotient length scheme-object-width)) output-block - length) - (assemble-directives! output-block directives length))) + (instruction-initial-position output-block) + (lambda (position) + (assemble-directives! output-block directives position))))) (define (assemble-objects! block) (let ((objects (queue->list *objects*)) @@ -138,25 +136,29 @@ MIT in each case. |# (error "insert-objects!: object phase error" where)) (else v))) -(define (assemble-directives! block directives block-length) +(define (assemble-directives! block directives initial-position) (define (loop directives dir-stack pc pc-stack position last-blabel blabel) (define (actual-bits bits l) - (let ((np (- position l))) - (bit-string-insert! bits block np) - (loop (cdr directives) dir-stack (+ pc l) pc-stack np - last-blabel blabel))) + (instruction-insert! + bits + block position + (lambda (np) + (declare (integrate np)) + (loop (cdr directives) dir-stack (+ pc l) pc-stack np + last-blabel blabel)))) (define (block-offset offset last-blabel blabel) - (let ((np (- position block-offset-width))) - (bit-string-insert! - (block-offset->bit-string offset (eq? blabel *start-label*)) - block np) - (loop (cdr directives) dir-stack - (+ pc block-offset-width) - pc-stack np - last-blabel blabel))) + (instruction-insert! + (block-offset->bit-string offset (eq? blabel *start-label*)) + block position + (lambda (np) + (declare (integrate np)) + (loop (cdr directives) dir-stack + (+ pc block-offset-width) + pc-stack np + last-blabel blabel)))) (define (evaluation handler expression l) (actual-bits (handler @@ -209,11 +211,13 @@ MIT in each case. |# ((not (null? dir-stack)) (loop (car dir-stack) (cdr dir-stack) pc pc-stack position last-blabel blabel)) - ((not (= (+ block-length starting-pc) (+ pc position))) + ((not (= (abs (- position initial-position)) + (- pc starting-pc))) (error "assemble-directives!: phase error" - block-length pc position)) + `(PC ,starting-pc ,pc) + `(BIT-POSITION ,initial-position ,position))) (else (assemble-objects! block)))) - (loop directives '() starting-pc '() block-length + (loop directives '() starting-pc '() initial-position *start-label* *start-label*)) ;;;; Input conversion @@ -429,5 +433,5 @@ MIT in each case. |# (define (list->bit-string l) (if (null? (cdr l)) (car l) - (bit-string-append (list->bit-string (cdr l)) - (car l)))) \ No newline at end of file + (instruction-append (car l) + (list->bit-string (cdr l))))) \ No newline at end of file diff --git a/v7/src/compiler/back/insseq.scm b/v7/src/compiler/back/insseq.scm index 777d8da7e..3057e6b71 100644 --- a/v7/src/compiler/back/insseq.scm +++ b/v7/src/compiler/back/insseq.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.2 1987/07/01 20:48:04 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.3 1987/08/13 02:00:21 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,6 +37,7 @@ MIT in each case. |# (declare (usual-integrations)) (define lap:syntax-instruction) +(define instruction-append) (define (instruction-sequence->directives insts) (if (null? insts) @@ -77,8 +78,7 @@ MIT in each case. |# (else (if (and (bit-string? (cadr seq1)) (bit-string? (caar seq2))) - (let ((result (bit-string-append (caar seq2) - (cadr seq1)))) + (let ((result (instruction-append (cadr seq1) (caar seq2)))) (set-car! (cdr seq1) result) (if (not (eq? (car seq2) (cdr seq2))) (begin (set-cdr! (cdr seq1) (cdr (car seq2))) diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm index 15851b384..aaa566ecd 100644 --- a/v7/src/compiler/back/syerly.scm +++ b/v7/src/compiler/back/syerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.3 1987/07/30 21:27:11 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.4 1987/08/13 02:01:16 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -180,9 +180,9 @@ MIT in each case. |# (if (scode/constant? (cadr inner-operands)) (scode/make-absolute-reference 'CONS) operator) - (cons (bit-string-append - (scode/constant-value (car inner-operands)) - (scode/constant-value (car operands))) + (cons (instruction-append + (scode/constant-value (car operands)) + (scode/constant-value (car inner-operands))) (cdr inner-operands)))) (default)))) (default))))) diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 0b0b1f25e..1749eb247 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.19 1987/07/30 21:27:21 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.20 1987/08/13 01:59:05 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,7 +41,7 @@ MIT in each case. |# (not (null? directives)) (bit-string? (car directives))) (begin (set-car! directives - (bit-string-append (car directives) directive)) + (instruction-append directive (car directives))) directives) (cons directive directives))) @@ -54,7 +54,7 @@ MIT in each case. |# (bit-string? (car directives2))) (begin (set-car! tail - (bit-string-append (car directives2) (car tail))) + (instruction-append (car tail) (car directives2))) (set-cdr! tail (cdr directives2))) (set-cdr! tail directives2)) directives1)))) @@ -122,7 +122,7 @@ MIT in each case. |# (cond ((null? components) (list bit-string)) ((bit-string? (car components)) - (loop2 (bit-string-append (car components) bit-string) + (loop2 (instruction-append bit-string (car components)) (cdr components))) (else (cons bit-string diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm index 0317cad20..30f4b6a18 100644 --- a/v7/src/compiler/machines/bobcat/assmd.scm +++ b/v7/src/compiler/machines/bobcat/assmd.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.31 1987/07/30 21:43:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.32 1987/08/13 01:58:42 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -70,4 +70,17 @@ MIT in each case. |# (define (block-offset->bit-string offset start?) (unsigned-integer->bit-string block-offset-width - (if start? offset (1+ offset)))) \ No newline at end of file + (if start? offset (1+ offset)))) + +;;; Machine dependent instruction order + +(define (instruction-initial-position block) + (bit-string-length block)) + +(define (instruction-insert! bits block position receiver) + (let* ((l (bit-string-length bits)) + (new-position (- position l))) + (bit-substring-move-right! bits 0 l block new-position) + (receiver new-position))) + +(set! instruction-append bit-string-append-reversed) -- 2.25.1