From eb63bcaee342dbcfd12022cdaa87b786406fc2a7 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 26 Aug 1993 05:48:53 +0000 Subject: [PATCH] - Move interrupt test on continuation invocation to return point (from continuation entry point). - Share return sequences in a single compiled code block. - Share closure interrupt code. --- v7/src/compiler/back/lapgn1.scm | 46 +++++++++++- v7/src/compiler/base/asstop.scm | 5 +- v7/src/compiler/machines/i386/compiler.pkg | 3 +- v7/src/compiler/machines/i386/rules3.scm | 86 +++++++++++++++------- 4 files changed, 110 insertions(+), 30 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 712a66750..9dab19a60 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lapgn1.scm,v 4.14 1992/12/30 14:13:35 gjr Exp $ +$Id: lapgn1.scm,v 4.15 1993/08/26 05:47:34 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 @@ -279,4 +279,44 @@ MIT in each case. |# (assq (rtl:expression-type (rtl:assign-address rtl)) *assign-rules*))) (or (and rules (pattern-lookup (cdr rules) rtl)) - (pattern-lookup *assign-variable-rules* rtl))))) \ No newline at end of file + (pattern-lookup *assign-variable-rules* rtl))))) + +;;; Instruction sequence sharing mechanisms + +(define *block-associations*) + +(define (block-association token) + (let ((place (assq token *block-associations*))) + (and place (cdr place)))) + +(define (block-associate! token frob) + (set! *block-associations* + (cons (cons token frob) + *block-associations*)) + unspecific) + +;; This can only be used when the instruction sequences are bit-wise identical. +;; In other words, no variable registers, constants, etc. + +(define (share-instruction-sequence! name if-shared generator) + (cond ((block-association name) + => if-shared) + (else + (let ((label (generate-label name))) + (block-associate! name label) + (generator label))))) + +(define (make-new-sblock instructions) + (let ((bblock (make-sblock instructions))) + (node-mark! bblock) + bblock)) + +(define (current-bblock-continue! bblock) + (let ((current-bblock *current-bblock*)) + (if (sblock-continuation current-bblock) + (error "current-bblock-continue! bblock already has a continuation" + current-bblock) + (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 diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm index 54d29a1d6..4fcc2d4d7 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.4 1993/08/22 20:23:22 gjr Exp $ +$Id: asstop.scm,v 1.5 1993/08/26 05:48:53 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -88,6 +88,7 @@ MIT in each case. |# (fluid-let ((*block-label*) (*external-labels*) (*end-of-block-code*) + (*block-associations*) (*next-constant*) (*interned-constants*) (*interned-variables*) @@ -103,6 +104,7 @@ MIT in each case. |# (define (assembler&linker-reset!) (set! *recursive-compilation-results* '()) + (set! *block-associations*) (set! *block-label*) (set! *external-labels*) (set! *end-of-block-code*) @@ -120,6 +122,7 @@ MIT in each case. |# unspecific) (define (initialize-back-end!) + (set! *block-associations* '()) (set! *block-label* (generate-label)) (set! *external-labels* '()) (set! *end-of-block-code* (LAP)) diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg index c66dceac2..824b2ab28 100644 --- a/v7/src/compiler/machines/i386/compiler.pkg +++ b/v7/src/compiler/machines/i386/compiler.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compiler.pkg,v 1.17 1993/08/11 23:36:59 cph Exp $ +$Id: compiler.pkg,v 1.18 1993/08/26 05:46:36 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -612,6 +612,7 @@ MIT in each case. |# lap:make-unconditional-branch lap:syntax-instruction) (export (compiler top-level) + *block-associations* *interned-assignments* *interned-constants* *interned-global-links* diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm index aee3be0c8..0bbffe7bb 100644 --- a/v7/src/compiler/machines/i386/rules3.scm +++ b/v7/src/compiler/machines/i386/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 1.26 1993/07/16 19:27:55 gjr Exp $ +$Id: rules3.scm,v 1.27 1993/08/26 05:45:40 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -44,9 +44,22 @@ MIT in each case. |# (define-rule statement (POP-RETURN) - (LAP ,@(clear-map!) - ,@(clear-continuation-type-code) - (RET))) + (cond ((block-association 'POP-RETURN) + => current-bblock-continue!) + (else + (let ((bblock + (make-new-sblock + (let ((interrupt-label (generate-label 'INTERRUPT))) + (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop) + (JGE (@PCR ,interrupt-label)) + ,@(clear-continuation-type-code) + (RET) + (LABEL ,interrupt-label) + ,@(invoke-hook + entry:compiler-interrupt-continuation-2)))))) + (block-associate! 'POP-RETURN bblock) + (current-bblock-continue! bblock)))) + (clear-map!)) (define-rule statement (INVOCATION:APPLY (? frame-size) (? continuation)) @@ -412,9 +425,13 @@ MIT in each case. |# (define-rule statement (CONTINUATION-HEADER (? internal-label)) + #| (simple-procedure-header (continuation-code-word internal-label) internal-label - entry:compiler-interrupt-continuation)) + entry:compiler-interrupt-continuation) + |# + (make-external-label (continuation-code-word internal-label) + internal-label)) (define-rule statement (IC-PROCEDURE-HEADER (? internal-label)) @@ -523,28 +540,47 @@ MIT in each case. |# 0))) (MOV W (@RO B ,regnum:free-pointer -4) ,temp)))))) +(define closure-share-names + '#( + closure-0-interrupt closure-1-interrupt closure-2-interrupt closure-3-interrupt + closure-4-interrupt closure-5-interrupt closure-6-interrupt closure-7-interrupt + )) + (define (generate/closure-header internal-label nentries entry) nentries ; ignored - (let ((rtl-proc (label->object internal-label))) - (let ((gc-label (generate-label)) - (external-label (rtl-procedure/external-label rtl-proc))) - (if (zero? nentries) - (LAP (EQUATE ,external-label ,internal-label) - ,@(simple-procedure-header - (internal-procedure-code-word rtl-proc) - internal-label - entry:compiler-interrupt-procedure)) - (LAP (LABEL ,gc-label) - ,@(if (zero? entry) - (LAP) - (LAP (ADD W (@R ,esp) (& ,(* 10 entry))))) - ,@(invoke-hook entry:compiler-interrupt-closure) - ,@(make-external-label internal-entry-code-word - external-label) - (ADD W (@R ,esp) - (&U ,(generate/make-magic-closure-constant entry))) - (LABEL ,internal-label) - ,@(interrupt-check internal-label gc-label)))))) + (let* ((rtl-proc (label->object internal-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + (if (zero? nentries) + (LAP (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header + (internal-procedure-code-word rtl-proc) + internal-label + entry:compiler-interrupt-procedure)) + (let ((prefix + (lambda (gc-label) + (LAP (LABEL ,gc-label) + ,@(if (zero? entry) + (LAP) + (LAP (ADD W (@R ,esp) (& ,(* 10 entry))))) + ,@(invoke-hook entry:compiler-interrupt-closure)))) + (suffix + (lambda (gc-label) + (LAP ,@(make-external-label internal-entry-code-word + external-label) + (ADD W (@R ,esp) + (&U ,(generate/make-magic-closure-constant entry))) + (LABEL ,internal-label) + ,@(interrupt-check internal-label gc-label))))) + (if (>= entry (vector-length closure-share-names)) + (let ((gc-label (generate-label))) + (LAP ,@(prefix gc-label) + ,@(suffix gc-label))) + (share-instruction-sequence! + (vector-ref closure-share-names entry) + suffix + (lambda (gc-label) + (LAP ,@(prefix gc-label) + ,@(suffix gc-label))))))))) (define (generate/make-magic-closure-constant entry) (- (make-non-pointer-literal (ucode-type compiled-entry) 0) -- 2.25.1