From 3cedb5c504f7142743a30f8e93fab9da11bdb602 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sun, 26 Jun 2011 18:33:12 +0000 Subject: [PATCH] Use MI interrupt check analysis in i386 back end. Nuke MD copy of it in i386/rules3.scm. --- src/compiler/machines/i386/compiler.pkg | 1 + src/compiler/machines/i386/rules3.scm | 178 ------------------------ 2 files changed, 1 insertion(+), 178 deletions(-) diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 7905398cd..cb2ca90c1 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -666,6 +666,7 @@ USA. "back/lapgn2" ; " " "back/lapgn3" ; " " "back/regmap" ;Hardware register allocator + "back/checks" ;Interrupt checks "machines/i386/lapgen" ;code generation rules "machines/i386/rules1" ; " " " "machines/i386/rules2" ; " " " diff --git a/src/compiler/machines/i386/rules3.scm b/src/compiler/machines/i386/rules3.scm index 7323bf85d..a6da4e2da 100644 --- a/src/compiler/machines/i386/rules3.scm +++ b/src/compiler/machines/i386/rules3.scm @@ -466,184 +466,6 @@ USA. internal-label entry:compiler-interrupt-procedure))) -;; Interrupt check placement -;; -;; The first two procedures are the interface. -;; GET-EXIT-INTERRUPT-CHECKS and GET-ENTRY-INTERRUPT-CHECKS get a list -;; of kinds interrupt check. An empty list implies no check is -;; required. The list can contain these symbols: -;; -;; STACK stack check required here -;; HEAP heap check required here -;; INTERRUPT check required here to avoid loops without checks. -;; -;; The traversal and decision making is done immediately prior to LAP -;; generation (from PRE-LAPGEN-ANALYSIS.) - -(define (get-entry-interrupt-checks) - (get-interupt-checks 'ENTRY-INTERRUPT-CHECKS)) - -(define (get-exit-interrupt-checks) - (get-interupt-checks 'EXIT-INTERRUPT-CHECKS)) - -(define (expect-no-entry-interrupt-checks) - (if (not (null? (get-entry-interrupt-checks))) - (error "No entry interrupt checks expected here" *current-bblock*))) - -(define (expect-no-exit-interrupt-checks) - (if (not (null? (get-exit-interrupt-checks))) - (error "No exit interrupt checks expected here" *current-bblock*))) - -(define (get-interupt-checks kind) - (cond ((cfg-node-get *current-bblock* kind) - => cdr) - (else (error "DETERMINE-INTERRUPT-CHECKS failed" kind)))) - -;; This algorithm finds leaf-procedure-like paths in the rtl control -;; flow graph. If a procedure entry point can only reach a return, it -;; is leaf-like. If a return can only be reached from a procedure -;; entry, it too is leaf-like. -;; -;; If a procedure reaches a procedure call, that could be a loop, so -;; it is not leaf-like. Similarly, if a continuation entry reaches -;; return, that could be a long unwinding of recursion, so a check is -;; needed in case the unwinding does allocation. -;; -;; Typically, true leaf procedures avoid both checks, and trivial -;; cases (like MAP returning '()) avoid the exit check. -;; -;; This could be a lot smarter. For example, a procedure entry does -;; not need to check for interrupts if it reaches call sites of -;; strictly lesser arity; or it could analyze the cycles in the CFG -;; and select good places to break them -;; -;; The algorithm has three phases: (1) explore the CFG to find all -;; entry and exit points, (2) propagate entry (exit) information so -;; that each potential interrupt check point knows what kinds of exits -;; (entrys) it reaches (is reached from), and (3) decide on the kinds -;; of interrupt check that are required at each entry and exit. -;; -;; [TOFU is just a header node for the list of interrupt checks, to -;; distingish () and #F] - -(define (determine-interrupt-checks bblock) - (let ((entries '()) - (exits '())) - - (define (explore bblock) - (or (cfg-node-get bblock 'INTERRUPT-CHECK-EXPLORE) - (begin - (cfg-node-put! bblock 'INTERRUPT-CHECK-EXPLORE #T) - (if (node-previous=0? bblock) - (set! entries (cons bblock entries)) - (if (rtl:continuation-entry? - (rinst-rtl (bblock-instructions bblock))) - ;; previous block is invocation:special-primitive - ;; so it is just an out of line instruction - (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS '(TOFU)))) - - (for-each-previous-node bblock explore) - (for-each-subsequent-node bblock explore) - (if (and (snode? bblock) - (or (not (snode-next bblock)) - (let ((last (last-insn bblock))) - (or (rtl:invocation:special-primitive? last) - (rtl:invocation:primitive? last))))) - (set! exits (cons bblock exits)))))) - - (define (for-each-subsequent-node node procedure) - (if (snode? node) - (if (snode-next node) - (procedure (snode-next node))) - (begin - (procedure (pnode-consequent node)) - (procedure (pnode-alternative node))))) - - (define (propagator for-each-link) - (lambda (node update place) - (let propagate ((node node)) - (let ((old (cfg-node-get node place))) - (let ((new (update old))) - (if (not (equal? old new)) - (begin - (cfg-node-put! node place new) - (for-each-link node propagate)))))))) - - (define upward (propagator for-each-previous-node)) - (define downward (propagator for-each-subsequent-node)) - - (define (setting-flag old) old #T) - - (define (propagate-entry-info bblock) - (let ((insn (rinst-rtl (bblock-instructions bblock)))) - (cond ((or (rtl:continuation-entry? insn) - (rtl:continuation-header? insn)) - (downward bblock setting-flag 'REACHED-FROM-CONTINUATION)) - ((or (rtl:closure-header? insn) - (rtl:ic-procedure-header? insn) - (rtl:open-procedure-header? insn) - (rtl:procedure-header? insn)) - (downward bblock setting-flag 'REACHED-FROM-PROCEDURE)) - (else unspecific)))) - - (define (propagate-exit-info exit-bblock) - (let ((insn (last-insn exit-bblock))) - (cond ((rtl:pop-return? insn) - (upward exit-bblock setting-flag 'REACHES-POP-RETURN)) - (else - (upward exit-bblock setting-flag 'REACHES-INVOCATION))))) - - (define (decide-entry-checks bblock) - (define (checks! types) - (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS (cons 'TOFU types))) - (define (decide-label internal-label) - (let ((object (label->object internal-label))) - (let ((stack? - (if (and (rtl-procedure? object) - (not (rtl-procedure/stack-leaf? object)) - compiler:generate-stack-checks?) - '(STACK) - '()))) - (if (or (cfg-node-get bblock 'REACHES-INVOCATION) - (pair? stack?)) - (checks! (cons* 'HEAP 'INTERRUPT stack?)) - (checks! '()))))) - - (let ((insn (rinst-rtl (bblock-instructions bblock)))) - (cond ((rtl:continuation-entry? insn) (checks! '())) - ((rtl:continuation-header? insn) (checks! '())) - ((rtl:closure-header? insn) - (decide-label (rtl:closure-header-procedure insn))) - ((rtl:ic-procedure-header? insn) - (decide-label (rtl:ic-procedure-header-procedure insn))) - ((rtl:open-procedure-header? insn) - (decide-label (rtl:open-procedure-header-procedure insn))) - ((rtl:procedure-header? insn) - (decide-label (rtl:procedure-header-procedure insn))) - (else - (checks! '(INTERRUPT)))))) - - (define (last-insn bblock) - (rinst-rtl (rinst-last (bblock-instructions bblock)))) - - (define (decide-exit-checks bblock) - (define (checks! types) - (cfg-node-put! bblock 'EXIT-INTERRUPT-CHECKS (cons 'TOFU types))) - (if (rtl:pop-return? (last-insn bblock)) - (if (cfg-node-get bblock 'REACHED-FROM-CONTINUATION) - (checks! '(INTERRUPT)) - (checks! '())) - (checks! '()))) - - (explore bblock) - - (for-each propagate-entry-info entries) - (for-each propagate-exit-info exits) - (for-each decide-entry-checks entries) - (for-each decide-exit-checks exits) - - )) - ;;;; Closures: ;; Since i386 instructions are pc-relative, the GC can't relocate them unless -- 2.25.1