From 30a49e226af758923be2e6cca0d295017db8bf9a Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 22 Jul 1987 17:17:01 +0000 Subject: [PATCH] The assembler now chooses the right length for branch instructions. --- v7/src/compiler/back/asmmac.scm | 4 +- v7/src/compiler/back/bittop.scm | 27 ++- v7/src/compiler/back/bitutl.scm | 6 +- v7/src/compiler/back/syntax.scm | 48 ++++- v7/src/compiler/machines/bobcat/inerly.scm | 31 +-- v7/src/compiler/machines/bobcat/insmac.scm | 101 ++++++--- v7/src/compiler/machines/bobcat/instr3.scm | 198 +++++++----------- .../compiler/machines/bobcat/make.scm-68040 | 6 +- 8 files changed, 242 insertions(+), 179 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index 311c88340..ec1d8ac30 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.3 1987/07/08 22:00:25 jinx Exp $ +$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 $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -44,7 +44,7 @@ MIT in each case. |# (lambda (pattern actions) (if (null? actions) (error "DEFINE-INSTRUCTION: Too few forms") - (parse-word (car actions) (cdr actions)))))))) + (parse-instruction (car actions) (cdr actions) false))))))) (define (compile-database cases procedure) `(LIST diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 4cb15eec7..47cc424b4 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.2 1987/07/16 10:14:16 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.3 1987/07/22 17:14:09 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -179,8 +179,8 @@ MIT in each case. |# (vector-ref this 1) (vector-ref this 2))) ((VARIABLE-WIDTH-EXPRESSION) - (let ((sel (vector-ref this 3))) - (evaluation (selector/handler sel) + (let ((sel (car (vector-ref this 3)))) + (evaluation (variable-handler-wrapper (selector/handler sel)) (vector-ref this 1) (selector/length sel)))) (else @@ -269,11 +269,11 @@ MIT in each case. |# ((VARIABLE-WIDTH-EXPRESSION) (process-variable-width (vector 'VARIABLE-WIDTH-EXPRESSION - (cadr directive) + (cadr this) (if (null? pc-stack) (make-machine-interval pcmin pcmax) (car pc-stack)) - (map list->vector (cddr directive))))) + (map list->vector (cddr this))))) ((GROUP) (new-directive! (vector 'TICK true)) (loop (append (cdr this) @@ -304,7 +304,7 @@ MIT in each case. |# (define (phase-1 directives) (define (loop rem pcmin pcmax pc-stack vars) (if (null? rem) - (let ((ecmin (pad pcmin)) + (let ((emin (pad pcmin)) (emax (+ pcmax maximum-padding-length))) (symbol-table-define! *the-symbol-table* *end-label* @@ -386,8 +386,21 @@ MIT in each case. |# (v (vector 'EVALUATION (vector-ref var 1) ; Expression (selector/length sel) - (selector/handler sel)))) + (variable-handler-wrapper (selector/handler sel))))) (vector-set! var 0 'FIXED-WIDTH-GROUP) (vector-set! var 1 l) (vector-set! var 2 (list v)) (vector-set! var 3 '()))) + +(define (variable-handler-wrapper handler) + (lambda (value) + (let ((l (handler value))) + (if (null? l) + (bit-string-allocate 0) + (list->bit-string l))))) + +(define (list->bit-string l) + (if (null? (cdr l)) + (car l) + (bit-string-append (car l) + (list->bit-string (cdr l))))) \ No newline at end of file diff --git a/v7/src/compiler/back/bitutl.scm b/v7/src/compiler/back/bitutl.scm index 8807e07b3..fa38f0935 100644 --- a/v7/src/compiler/back/bitutl.scm +++ b/v7/src/compiler/back/bitutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.1 1987/07/15 03:00:44 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.2 1987/07/22 17:14:31 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -224,11 +224,11 @@ MIT in each case. |# (declare (integrate sel)) (vector-ref sel 1)) -(define (selector/handler sel) +(define (selector/length sel) (declare (integrate sel)) (vector-ref sel 2)) -(define (selector/length sel) +(define (selector/handler sel) (declare (integrate sel)) (vector-ref sel 3)) diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index d83f58f14..96fc42491 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.16 1987/07/15 02:57:43 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.17 1987/07/22 17:15:00 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -69,13 +69,13 @@ MIT in each case. |# (define instructions '()) - + (define (integer-syntaxer expression coercion-type size) (let ((coercion (make-coercion-name coercion-type size))) (if (integer? expression) `',((lexical-reference coercion-environment coercion) expression) - `(SYNTAX-EVALUATION ,expression ,coercion)))) - + `(SYNTAX-EVALUATION ,expression ,coercion)))) + (define (syntax-evaluation expression coercion) (if (integer? expression) (coercion expression) @@ -121,6 +121,46 @@ MIT in each case. |# (receiver (car components) false)) (else (receiver components true))))))) +;;;; Variable width expression processing + +(define (choose-clause value clauses) + (define (in-range? value low high) + (and (or (null? low) + (<= low value)) + (or (null? high) + (<= value high)))) + + (cond ((null? clauses) + (error "choose-clause: value out of range" value)) + ((in-range? value (caar clauses) (cadar clauses)) + (car clauses)) + (else (choose-clause (cdr clauses))))) + +(define (variable-width-expression-syntaxer name expression clauses) + (if (integer? expression) + (let ((chosen (choose-clause expression clauses))) + `(let ((,name ,expression)) + (declare (integrate ,name)) + ,(cadddr chosen))) + `(LIST + (SYNTAX-VARIABLE-WIDTH-EXPRESSION + ,expression + (LIST + ,@(map (LAMBDA (clause) + `(LIST ,(car clause) + ,(cadr clause) + ,(caddr clause) + (LAMBDA (,name) + ,(cadddr clause)))) + clauses)))))) + +(define (syntax-variable-width-expression expression clauses) + (if (integer? expression) (let ((chosen (choose-clause expression clauses))) + ((cadddr chosen) expression)) + (cons* 'VARIABLE-WIDTH-EXPRESSION + expression + clauses))) + ;;;; Coercion Machinery (define (make-coercion-name coercion-type size) diff --git a/v7/src/compiler/machines/bobcat/inerly.scm b/v7/src/compiler/machines/bobcat/inerly.scm index 68215a020..de88dbbc8 100644 --- a/v7/src/compiler/machines/bobcat/inerly.scm +++ b/v7/src/compiler/machines/bobcat/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.2 1987/07/01 21:02:47 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.3 1987/07/22 17:16:22 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -48,20 +48,21 @@ MIT in each case. |# (syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION (macro (opcode . patterns) `(set! early-instructions - (cons (list ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-word (cadr pattern) - (cddr pattern) - true))))))) - patterns)) + (cons + (list ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + true))))))) + patterns)) early-instructions)))) (syntax-table-define early-syntax-table 'EXTENSION-WORD diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 8931448a2..0fb264e91 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.121 1987/07/21 18:34:23 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.122 1987/07/22 17:16:31 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -128,31 +128,71 @@ MIT in each case. |# ;;;; Utility procedures -(define (parse-word expression tail #!optional early?) +(define (parse-instruction expression tail early?) (define (kernel) - (expand-descriptors (cdr expression) - (lambda (instruction size src dst) - (if (zero? (remainder size 16)) - (let ((code - (let ((code - (let ((code (if dst `(,@dst '()) '()))) - (if src - `(,@src ,code) - code)))) - (if (null? tail) - code - `(,(if (null? code) 'CONS 'CONS-SYNTAX) - ,(car tail) - ,code))))) - `(,(if (null? code) 'CONS 'CONS-SYNTAX) - ,(optimize-group-syntax instruction - (if (unassigned? early?) false early?)) - ,code)) - (error "PARSE-WORD: Instructions must be 16 bit multiples" size))))) + (case (car expression) + ((WORD) + (parse-word expression tail)) + ((GROWING-WORD) + (parse-growing-word expression tail)) + (else + (error "PARSE-INSTRUCTION: unknown expression" expression)))) + (if (or (unassigned? early?) (not early?)) - (kernel) + (with-normal-selectors kernel) (with-early-selectors kernel))) +;;; Variable width instruction parsing + +(define (parse-growing-word expression tail) + (if (not (null? tail)) + (error "PARSE-GROWING-WORD: non null tail" tail)) + (let ((binding (cadr expression))) + (variable-width-expression-syntaxer + (car binding) + (cadr binding) + (map (lambda (clause) + (if (not (null? (cddr clause))) + (error "PARSE-GROWING-WORD: Extension found in clause" clause)) + (expand-descriptors + (cdadr clause) + (lambda (instruction size src dst) + (if (not (zero? (remainder size 16))) + (error "PARSE-GROWING-WORD: Instructions must be 16 bit multiples" + size) + (list (caar clause) ; Range low + (cadar clause) ; Range high + size ; Width in bits + (collect-word instruction src dst '())))))) + (cddr expression))))) + +;;;; Fixed width instruction parsing + +(define (parse-word expression tail) + (expand-descriptors (cdr expression) + (lambda (instruction size src dst) + (if (zero? (remainder size 16)) + (collect-word instruction src dst tail) + (error "PARSE-WORD: Instructions must be 16 bit multiples" size))))) + +(define (collect-word instruction src dst tail) + (let ((code + (let ((code + (let ((code (if dst `(,@dst '()) '()))) + (if src + `(,@src ,code) + code)))) + (cond ((null? tail) code) + ((null? (cdr tail)) + `(,(if (null? code) 'CONS 'CONS-SYNTAX) + ,(car tail) + ,code)) + (else + (error "PARSE-WORD: multiple tail elements" tail)))))) + `(,(if (null? code) 'CONS 'CONS-SYNTAX) + ,(optimize-group-syntax instruction early-instruction-parsing?) + ,code))) + (define (expand-descriptors descriptors receiver) (if (null? descriptors) (receiver '() 0 false false) @@ -175,20 +215,33 @@ MIT in each case. |# destination) destination*)))))))) +;;;; Hooks for early instruction processing + +(define early-instruction-parsing? false) (define ea-keyword-selector 'EA-KEYWORD) (define ea-categories-selector 'EA-CATEGORIES) (define ea-mode-selector 'EA-MODE) (define ea-register-selector 'EA-REGISTER) (define ea-extension-selector 'EA-EXTENSION) +(define (with-normal-selectors handle) + (fluid-let ((early-instruction-parsing? false) + (ea-keyword-selector 'EA-KEYWORD) + (ea-categories-selector 'EA-CATEGORIES) + (ea-mode-selector 'EA-MODE) + (ea-register-selector 'EA-REGISTER) + (ea-extension-selector 'EA-EXTENSION)) + (handle))) + (define (with-early-selectors handle) - (fluid-let ((ea-keyword-selector 'EA-KEYWORD-EARLY) + (fluid-let ((early-instruction-parsing? true) + (ea-keyword-selector 'EA-KEYWORD-EARLY) (ea-categories-selector 'EA-CATEGORIES-EARLY) (ea-mode-selector 'EA-MODE-EARLY) (ea-register-selector 'EA-REGISTER-EARLY) (ea-extension-selector 'EA-EXTENSION-EARLY)) (handle))) - + (define (expand-descriptor descriptor receiver) (let ((size (car descriptor)) (expression (cadr descriptor)) diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm index 6019cacb0..a26121fcc 100644 --- a/v7/src/compiler/machines/bobcat/instr3.scm +++ b/v7/src/compiler/machines/bobcat/instr3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.12 1987/07/17 15:49:06 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.13 1987/07/22 17:16:43 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,129 +37,85 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Control Transfer +;;;; Control Transfer: Branch instructions ;; The size U (unknown, undecided?) means that the assembler should -;; choose the right size. For the time being it is the same as W. - -(define-instruction B - (((? c cc) B (@PCO (? o))) - (WORD (4 #b0110) - (4 c) - (8 o SIGNED))) - - (((? c cc) B (@PCR (? l))) - (WORD (4 #b0110) - (4 c) - (8 l SHORT-LABEL))) - - (((? c cc) W (@PCO (? o))) - (WORD (4 #b0110) - (4 c) - (8 #b00000000)) - (immediate-word o)) - - (((? c cc) W (@PCR (? l))) - (WORD (4 #b0110) - (4 c) - (8 #b00000000)) - (relative-word l)) - - ;; 68020 only - - (((? c cc) L (@PCO (? o))) - (WORD (4 #b0110) - (4 cc) - (8 #b11111111)) - (immediate-long o)) - - (((? c cc) L (@PCR (? l))) - (WORD (4 #b0110) - (4 cc) - (8 #b11111111)) - (relative-long l)) - - (((? c cc) U (@PCO (? o))) - (WORD (4 #b0110) - (4 c) - (8 #b00000000)) - (immediate-word o)) - - (((? c cc) U (@PCR (? l))) - (WORD (4 #b0110) - (4 c) - (8 #b00000000)) - (relative-word l))) - -(define-instruction BRA - ((B (@PCO (? o))) - (WORD (8 #b01100000) - (8 o SIGNED))) - - ((B (@PCR (? l))) - (WORD (8 #b01100000) - (8 l SHORT-LABEL))) - - ((W (@PCO (? o))) - (WORD (16 #b0110000000000000)) - (immediate-word o)) - - ((W (@PCR (? l))) - (WORD (16 #b0110000000000000)) - (relative-word l)) - - ;; 68020 only - - ((L (@PCO (? o))) - (WORD (16 #b0110000011111111)) - (immediate-long o)) - - ((L (@PCR (? l))) - (WORD (16 #b0110000011111111)) - (relative-long l)) - - ((U (@PCO (? o))) - (WORD (16 #b0110000000000000)) - (immediate-word o)) - - ((U (@PCR (? l))) - (WORD (16 #b0110000000000000)) - (relative-word l))) +;; choose the right size. + +;; When the displacement goes to 0, a NOP is issued. +;; The instruction is hard to remove because of the workings of the +;; branch tensioner. Note that the NOP ``kludge'' is not correct for +;; the BSR instruction. + +(let-syntax + ((define-branch-instruction + (macro (opcode prefix . field) + `(define-instruction ,opcode + ((,@prefix B (@PCO (? o))) + (WORD ,@field + (8 o SIGNED))) + + ((,@prefix B (@PCR (? l))) + (WORD ,@field + (8 l SHORT-LABEL))) + + ((,@prefix W (@PCO (? o))) + (WORD ,@field + (8 #b00000000)) + (immediate-word o)) + + ((,@prefix W (@PCR (? l))) + (WORD ,@field + (8 #b00000000)) + (relative-word l)) + + ;; 68020 only + + ((,@prefix L (@PCO (? o))) + (WORD ,@field + (8 #b11111111)) + (immediate-long o)) + + ((,@prefix L (@PCR (? l))) + (WORD ,@field + (8 #b11111111)) + (relative-long l)) -(define-instruction BSR - ((B (@PCO (? o))) - (WORD (8 #b01100001) - (8 o SIGNED))) - - ((B (@PCR (? o))) - (WORD (8 #b01100001) - (8 o SHORT-LABEL))) - - ((W (@PCO (? o))) - (WORD (16 #b0110000100000000)) - (immediate-word o)) - - ((W (@PCR (? l))) - (WORD (16 #b0110000100000000)) - (relative-word l)) - - ;; 68020 onlyu - - ((L (@PCO (? o))) - (WORD (16 #b0110000111111111)) - (immediate-long o)) - - ((L (@PCR (? l))) - (WORD (16 #b0110000111111111)) - (relative-long l)) - - ((U (@PCO (? o))) - (WORD (16 #b0110000100000000)) - (immediate-word o)) - - ((U (@PCR (? l))) - (WORD (16 #b0110000100000000)) - (relative-word l))) + ((,@prefix U (@PCO (? o))) + (GROWING-WORD (disp o) + ((0 0) + (WORD (16 #b0100111001110001))) ; NOP + ((-128 127) + (WORD ,@field + (8 disp SIGNED))) + ((-32768 32767) + (WORD ,@field + (8 #b00000000) + (16 disp SIGNED))) + ((() ()) + (WORD ,@field + (8 #b11111111) + (32 disp SIGNED))))) + + ((,@prefix U (@PCR (? l))) + (GROWING-WORD (disp `(- ,l (+ *PC* 2))) + ((0 0) + (WORD (16 #b0100111001110001))) ; NOP + ((-128 127) + (WORD ,@field + (8 disp SIGNED))) + ((-32768 32767) + (WORD ,@field + (8 #b00000000) + (16 disp SIGNED))) + ((() ()) + (WORD ,@field + (8 #b11111111) + (32 disp SIGNED))))))))) + + (define-branch-instruction B ((? c cc)) (4 #b0110) (4 c)) + (define-branch-instruction BRA () (8 #b01100000)) + (define-branch-instruction BSR () (8 #b01100001))) (define-instruction DB (((? c cc) (D (? rx)) (@PCO (? o))) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 14d719e65..619dee4ed 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.35 1987/07/21 18:34:56 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.36 1987/07/22 17:17:01 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,11 +46,11 @@ MIT in each case. |# (make-environment (define :name "Liar (Bobcat 68020)") (define :version 1) - (define :modification 35) + (define :modification 36) (define :files) ; (parse-rcs-header -; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.35 1987/07/21 18:34:56 jinx Exp $" +; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.36 1987/07/22 17:17:01 jinx Exp $" ; (lambda (filename version date time zone author state) ; (set! :version (car version)) ; (set! :modification (cadr version)))) -- 2.25.1