From 2f18a3094284914a845290f052aa9a491f19ebc0 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 17 Feb 1988 19:14:05 +0000 Subject: [PATCH] 1) Make assembler pad with ILLEGAL instructions. 2) Make the continuations for special primitive invocations not do a heap/interrupt check. --- v7/src/compiler/back/bittop.scm | 122 ++++++++++-------- v7/src/compiler/machines/bobcat/assmd.scm | 50 ++++--- .../compiler/machines/bobcat/make.scm-68040 | 6 +- v7/src/compiler/machines/bobcat/rules3.scm | 14 +- v7/src/compiler/rtlbase/rtlty1.scm | 3 +- v7/src/compiler/rtlgen/rtlgen.scm | 20 ++- v7/src/compiler/rtlopt/rcse1.scm | 3 +- 7 files changed, 135 insertions(+), 83 deletions(-) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 92e5962fe..ff7ece1bc 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.6 1987/08/13 02:00:44 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.7 1988/02/17 19:12:25 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -135,15 +135,25 @@ MIT in each case. |# ((not (= where (system-vector-size v))) (error "insert-objects!: object phase error" where)) (else v))) + +(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) (define (loop directives dir-stack pc pc-stack position last-blabel blabel) (define (actual-bits bits l) - (instruction-insert! - bits - block position + (instruction-insert! bits block position (lambda (np) (declare (integrate np)) (loop (cdr directives) dir-stack (+ pc l) pc-stack np @@ -168,55 +178,61 @@ MIT in each case. |# (car pc-stack)))) l)) - (cond ((not (null? directives)) - (let ((this (car directives))) - (case (vector-ref this 0) - ((LABEL) - (loop (cdr directives) dir-stack pc pc-stack position - last-blabel blabel)) - ((TICK) - (loop (cdr directives) dir-stack - pc - (if (vector-ref this 1) - (cons (->machine-pc pc) pc-stack) - (cdr pc-stack)) - position - last-blabel blabel)) - ((FIXED-WIDTH-GROUP) - (loop (vector-ref this 2) (cons (cdr directives) dir-stack) - pc pc-stack - position - last-blabel blabel)) - ((CONSTANT) - (let ((bs (vector-ref this 1))) - (actual-bits bs (bit-string-length bs)))) - ((EVALUATION) - (evaluation (vector-ref this 3) - (vector-ref this 1) - (vector-ref this 2))) - ((VARIABLE-WIDTH-EXPRESSION) - (let ((sel (car (vector-ref this 3)))) - (evaluation (variable-handler-wrapper (selector/handler sel)) - (vector-ref this 1) - (selector/length sel)))) - ((BLOCK-OFFSET) - (let* ((label (vector-ref this 1)) - (offset (evaluate `(- ,label ,blabel) '()))) - (if (> offset maximum-block-offset) - (block-offset (evaluate `(- ,label ,last-blabel) '()) - label last-blabel) - (block-offset offset label blabel)))) - (else - (error "assemble-directives!: Unknown directive" this))))) - ((not (null? dir-stack)) - (loop (car dir-stack) (cdr dir-stack) pc pc-stack position - last-blabel blabel)) - ((not (= (abs (- position initial-position)) - (- pc starting-pc))) - (error "assemble-directives!: phase error" - `(PC ,starting-pc ,pc) - `(BIT-POSITION ,initial-position ,position))) - (else (assemble-objects! block)))) + (define (end-assembly) + (cond ((not (null? dir-stack)) + (loop (car dir-stack) (cdr dir-stack) pc pc-stack position + last-blabel blabel)) + ((not (= (abs (- position initial-position)) + (- pc starting-pc))) + (error "assemble-directives!: phase error" + `(PC ,starting-pc ,pc) + `(BIT-POSITION ,initial-position ,position))) + (else + (pad! block pc position) + (assemble-objects! block)))) + + (if (null? directives) + (end-assembly) + (let ((this (car directives))) + (case (vector-ref this 0) + ((LABEL) + (loop (cdr directives) dir-stack pc pc-stack position + last-blabel blabel)) + ((TICK) + (loop (cdr directives) dir-stack + pc + (if (vector-ref this 1) + (cons (->machine-pc pc) pc-stack) + (cdr pc-stack)) + position + last-blabel blabel)) + ((FIXED-WIDTH-GROUP) + (loop (vector-ref this 2) (cons (cdr directives) dir-stack) + pc pc-stack + position + last-blabel blabel)) + ((CONSTANT) + (let ((bs (vector-ref this 1))) + (actual-bits bs (bit-string-length bs)))) + ((EVALUATION) + (evaluation (vector-ref this 3) + (vector-ref this 1) + (vector-ref this 2))) + ((VARIABLE-WIDTH-EXPRESSION) + (let ((sel (car (vector-ref this 3)))) + (evaluation (variable-handler-wrapper (selector/handler sel)) + (vector-ref this 1) + (selector/length sel)))) + ((BLOCK-OFFSET) + (let* ((label (vector-ref this 1)) + (offset (evaluate `(- ,label ,blabel) '()))) + (if (> offset maximum-block-offset) + (block-offset (evaluate `(- ,label ,last-blabel) '()) + label last-blabel) + (block-offset offset label blabel)))) + (else + (error "assemble-directives!: Unknown directive" this)))))) + (loop directives '() starting-pc '() initial-position *start-label* *start-label*)) diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm index 30f4b6a18..caf824501 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.32 1987/08/13 01:58:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.33 1988/02/17 19:12:01 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,48 +36,62 @@ MIT in each case. |# (declare (usual-integrations)) -(declare (integrate addressing-granularity scheme-object-width - maximum-padding-length - maximum-block-offset block-offset-width)) +(declare + (integrate addressing-granularity + scheme-object-width + endianness + maximum-padding-length + maximum-block-offset + block-offset-width) + (integrate-operator block-offset->bit-string + instruction-initial-position + instruction-insert!)) (define addressing-granularity 8) (define scheme-object-width 32) +(define endianness 'BIG) ;; Instruction length is always a multiple of 16 +;; Pad with ILLEGAL instructions + (define maximum-padding-length 16) +(define padding-string + (unsigned-integer->bit-string 16 #b0100101011111100)) + ;; Block offsets are always words + (define maximum-block-offset (- (expt 2 16) 2)) (define block-offset-width 16) -(define make-nmv-header) -(let () - -(set! make-nmv-header -(named-lambda (make-nmv-header n) - (bit-string-append (unsigned-integer->bit-string 24 n) - nmv-type-string))) +(define (block-offset->bit-string offset start?) + (declare (integrate offset start?)) + (unsigned-integer->bit-string block-offset-width + (+ offset + (if start? 0 1)))) -(define nmv-type-string - (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))) +(define make-nmv-header + (let ((nmv-type-string + (unsigned-integer->bit-string 8 (microcode-type + 'MANIFEST-NM-VECTOR)))) -) + (named-lambda (make-nmv-header n) + (bit-string-append (unsigned-integer->bit-string 24 n) + nmv-type-string)))) (define (object->bit-string object) (bit-string-append (unsigned-integer->bit-string 24 (primitive-datum object)) (unsigned-integer->bit-string 8 (primitive-type object)))) - -(define (block-offset->bit-string offset start?) - (unsigned-integer->bit-string block-offset-width - (if start? offset (1+ offset)))) ;;; Machine dependent instruction order (define (instruction-initial-position block) + (declare (integrate block)) (bit-string-length block)) (define (instruction-insert! bits block position receiver) + (declare (integrate block position receiver)) (let* ((l (bit-string-length bits)) (new-position (- position l))) (bit-substring-move-right! bits 0 l block new-position) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index c28924d35..b03984606 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 4.4 1988/01/06 17:57:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -44,11 +44,11 @@ MIT in each case. |# (make-environment (define :name "Liar (Bobcat 68020)") (define :version 4) - (define :modification 4) + (define :modification 5) (define :files) (define :rcs-header - "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.4 1988/01/06 17:57:03 cph Exp $") + "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.5 1988/02/17 19:10:57 jinx Exp $") (define :files-lists (list diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 11f7d8ce5..50bc13886 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.2 1987/12/30 10:53:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.3 1988/02/17 19:11:22 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -162,11 +162,11 @@ MIT in each case. |# (if (= how-far 1) (LAP (MOV L (@AO 7 4) (@AO 7 8)) (MOV L (@A+ 7) (@A 7))) - (let ((i (lambda () + (let ((i (lambda (dis) (INST (MOV L (@A+ 7) - ,(offset-reference a7 (-1+ how-far))))))) - (LAP ,(i) - ,(i) + ,(offset-reference a7 dis)))))) + (LAP ,(i (-1+ how-far)) + ,(i (-1+ how-far)) ,@(increment-anl 7 (- how-far 2)))))) (else (generate/move-frame-up frame-size (offset-reference a7 offset)))))) @@ -311,6 +311,10 @@ MIT in each case. |# ,@(make-external-label internal-label) (CMP L ,reg:compiled-memtop (A 5)) (B GE B (@PCR ,gc-label))))) + +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (LAP ,@(make-external-label internal-label))) (define (procedure-header procedure gc-label) (let ((internal-label (rtl-procedure/label procedure)) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 0a7067cf7..4f962d21c 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.2 1987/12/30 07:07:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.3 1988/02/17 19:13:26 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -59,6 +59,7 @@ MIT in each case. |# (define-rtl-predicate unassigned-test % expression) (define-rtl-statement assign % address expression) +(define-rtl-statement continuation-entry rtl: continuation) (define-rtl-statement continuation-heap-check rtl: continuation) (define-rtl-statement procedure-heap-check rtl: procedure) (define-rtl-statement setup-lexpr rtl: procedure) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index e35ae7d7e..b15c072b2 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.2 1987/12/30 07:10:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.3 1988/02/17 19:12:51 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -107,6 +107,20 @@ MIT in each case. |# (generate/node (procedure-entry-node procedure)) true)) +(define (operator/needs-no-heap-check? op) + (and (rvalue/constant? op) + (let ((obj (constant-value op))) + (and (normal-primitive-procedure? obj) + (special-primitive-handler obj))))) + +(define (continuation/avoid-check? continuation) + (and (null? (continuation/returns continuation)) + (for-all? + (continuation/combinations continuation) + (lambda (combination) + (let ((op (rvalue-known-value (combination/operator combination)))) + (and op (operator/needs-no-heap-check? op))))))) + (define (generate/continuation continuation) (let ((label (continuation/label continuation))) (transmit-values @@ -114,7 +128,9 @@ MIT in each case. |# (continuation/entry-node continuation) (lambda (node) (scfg-append! - (rtl:make-continuation-heap-check label) + (if (continuation/avoid-check? continuation) + (rtl:make-continuation-entry label) + (rtl:make-continuation-heap-check label)) (generate/continuation-entry/ic-block continuation) (if (block/dynamic-link? (continuation/closing-block continuation)) diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index 8cf9020b0..7d0ce252e 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.4 1987/12/31 07:01:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.5 1988/02/17 19:14:05 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -262,6 +262,7 @@ MIT in each case. |# (define-cse-method 'POP-RETURN method/noop) (define-cse-method 'PROCEDURE-HEAP-CHECK method/noop) (define-cse-method 'CONTINUATION-HEAP-CHECK method/noop) +(define-cse-method 'CONTINUATION-ENTRY method/noop) (define-cse-method 'INVOCATION:APPLY method/noop) (define-cse-method 'INVOCATION:JUMP method/noop) (define-cse-method 'INVOCATION:LEXPR method/noop) -- 2.25.1