From 23058733c0d0616b384819101d2238d07474a67b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 4 Dec 1987 20:05:24 +0000 Subject: [PATCH] Major redesign of front end of compiler. Continuations are now modeled more exactly by means of a CPS-style analysis. Poppers have been flushed in favor of dynamic links, and optimizations have been added that eliminate the use of static and dynamic links in many cases. --- v7/src/compiler/base/blocks.scm | 247 +++++++++++++++++++++++ v7/src/compiler/base/cfg1.scm | 98 +++++---- v7/src/compiler/base/cfg2.scm | 10 +- v7/src/compiler/base/contin.scm | 120 +++++++++++ v7/src/compiler/base/ctypes.scm | 231 +++++++++++++-------- v7/src/compiler/base/debug.scm | 169 ++++++++++++++++ v7/src/compiler/base/enumer.scm | 120 +++++++++++ v7/src/compiler/base/lvalue.scm | 217 +++++++++++++++++--- v7/src/compiler/base/macros.scm | 169 +++++++++++----- v7/src/compiler/base/object.scm | 183 ++++++++++------- v7/src/compiler/base/proced.scm | 212 ++++++++++++++++++++ v7/src/compiler/base/rvalue.scm | 223 ++++++++++++--------- v7/src/compiler/base/scode.scm | 132 ++++++++++++ v7/src/compiler/base/sets.scm | 30 ++- v7/src/compiler/base/subprb.scm | 159 +++++++++++++++ v7/src/compiler/base/switch.scm | 46 +++++ v7/src/compiler/base/toplev.scm | 343 ++++++++++++++++++++++++++++++++ v7/src/compiler/base/utils.scm | 294 +++++++++++++-------------- 18 files changed, 2469 insertions(+), 534 deletions(-) create mode 100644 v7/src/compiler/base/blocks.scm create mode 100644 v7/src/compiler/base/contin.scm create mode 100644 v7/src/compiler/base/debug.scm create mode 100644 v7/src/compiler/base/enumer.scm create mode 100644 v7/src/compiler/base/proced.scm create mode 100644 v7/src/compiler/base/scode.scm create mode 100644 v7/src/compiler/base/subprb.scm create mode 100644 v7/src/compiler/base/switch.scm create mode 100644 v7/src/compiler/base/toplev.scm diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm new file mode 100644 index 000000000..01a4019f1 --- /dev/null +++ b/v7/src/compiler/base/blocks.scm @@ -0,0 +1,247 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.1 1987/12/04 20:00:46 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Environment model data structures + +(declare (usual-integrations)) + +#| + +Interpreter compatible (hereafter, IC) blocks are vectors with an +implementation dependent number of reserved slots at the beginning, +followed by the variable bindings for that frame, in the usual order. +The parent of such a frame is always an IC block or a global block, +but extracting a pointer to that parent from the frame is again +implementation dependent and possibly a complex operation. During the +execution of an IC procedure, the block pointer is kept in the ENV +register. + +Perfect closure blocks are vectors whose slots contain the values for +the free variables in a closure procedure. The ordering of these +slots is arbitrary. + +Imperfect closure blocks are similar, except that the first slot of +the vector points to the parent, which is always an IC block. + +Stack blocks are contiguous regions of the stack. A stack block +pointer is the address of that portion of the block which is nearest +to the top of the stack (on the 68000, the most negative address in +the block.) + +In closure and stack blocks, variables which the analyzer can +guarantee will not be modified have their values stored directly in +the block. For all other variables, the binding slot in the block +contains a pointer to a cell which contains the value. + +Note that blocks of type CONTINUATION never have any children. This +is because the body of a continuation is always generated separately +from the continuation, and then "glued" into place afterwards. + +|# + +(define-rvalue block + type ;block type (see below) + parent ;lexically enclosing parent + children ;lexically enclosed children + disowned-children ;children whose `parent' used to be this block + frame-size ;for stack-allocated frames, size in words + procedure ;procedure for which this is invocation block, if any + bound-variables ;list of variables bound by this block + free-variables ;list of variables free in this block + declarations ;list of declarations + applications ;list of applications lexically within this block + interned-variables ;alist of interned SCode variable objects + closure-offsets ;for closure block, alist of bound variable offsets + frame ;debugging information (???) + stack-link ;for internal block, adjacent block on stack + ) + +(define *blocks*) + +(define (make-block parent type) + (let ((block + (make-rvalue block-tag (enumeration/name->index block-types type) + parent '() '() false false '() '() '() '() '() '() false + false 'UNKNOWN))) + (if parent + (set-block-children! parent (cons block (block-children parent)))) + (set! *blocks* (cons block *blocks*)) + block)) + +(define-vector-tag-unparser block-tag + (lambda (block) + (write-string "BLOCK") + (let ((procedure (block-procedure block))) + (if (and procedure (rvalue/procedure? procedure)) + (begin (write-string " ") + (write (procedure-label procedure))))))) + +(define-integrable (rvalue/block? rvalue) + (eq? (tagged-vector/tag rvalue) block-tag)) + +(define (add-block-application! block application) + (set-block-applications! block + (cons application (block-applications block)))) + +(define (intern-scode-variable! block name) + (let ((entry (assq name (block-interned-variables block)))) + (if entry + (cdr entry) + (let ((variable (scode/make-variable name))) + (set-block-interned-variables! + block + (cons (cons name variable) (block-interned-variables block))) + variable)))) + +(define block-passed-out? + rvalue-%passed-out?) + +;;;; Block Type + +(define-enumeration block-type + (closure ;heap-allocated closing frame, compiler format + continuation ;continuation invocation frame + expression ;execution frame for expression (indeterminate type) + ic ;interpreter compatible heap-allocated frame + procedure ;invocation frame for procedure (indeterminate type) + stack ;invocation frame for procedure, stack-allocated + )) + +(define-integrable (ic-block? block) + (eq? (block-type block) block-type/ic)) + +(define-integrable (closure-block? block) + (eq? (block-type block) block-type/closure)) + +(define-integrable (stack-block? block) + (eq? (block-type block) block-type/stack)) + +(define-integrable (continuation-block? block) + (eq? (block-type block) block-type/continuation)) + +(define (block/external? block) + (and (stack-block? block) + (not (stack-parent? block)))) + +(define (block/internal? block) + (and (stack-block? block) + (stack-parent? block))) + +(define (stack-parent? block) + (and (block-parent block) + (stack-block? (block-parent block)))) + +(define-integrable (ic-block/use-lookup? block) + (or (rvalue/procedure? (block-procedure block)) + (not compiler:cache-free-variables?))) + +;;;; Block Inheritance + +(define (block-ancestor-or-self? block block*) + (or (eq? block block*) + (block-ancestor? block block*))) + +(define (block-ancestor? block block*) + (define (loop block) + (and block + (or (eq? block block*) + (loop (block-parent block))))) + (loop (block-parent block))) + +(define-integrable (block-child? block block*) + (eq? block (block-parent block*))) + +(define-integrable (block-sibling? block block*) + ;; Assumes that at least one block has a parent. + (eq? (block-parent block) (block-parent block*))) + +(define (block-nearest-common-ancestor block block*) + (let loop + ((join false) + (ancestry (block-ancestry block '())) + (ancestry* (block-ancestry block* '()))) + (if (and (not (null? ancestry)) + (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (car ancestry) (cdr ancestry) (cdr ancestry*)) + join))) + +(define (block-farthest-uncommon-ancestor block block*) + (let loop + ((ancestry (block-ancestry block '())) + (ancestry* (block-ancestry block* '()))) + (and (not (null? ancestry)) + (if (and (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (cdr ancestry) (cdr ancestry*)) + (car ancestry))))) + +(define (block-ancestry block path) + (if (block-parent block) + (block-ancestry (block-parent block) (cons block path)) + (cons block path))) + +(define (stack-block/external-ancestor block) + (let ((parent (block-parent block))) + (if (and parent (stack-block? parent)) + (stack-block/external-ancestor parent) + block))) + +(define (block/external-ancestor block) + (if (stack-block? block) + (stack-block/external-ancestor block) + block)) + +(define (stack-block/ancestor-distance block offset join) + (let loop ((block block) (n offset)) + (if (eq? block join) + n + (loop (block-parent block) + (+ n (block-frame-size block)))))) + +(define (for-each-block-descendent! block procedure) + (let loop ((block block)) + (procedure block) + (for-each loop (block-children block)))) + +(define-integrable (internal-block/parent-known? block) + (not (null? (block-stack-link block)))) + +(define-integrable (stack-block/continuation-lvalue block) + (procedure-continuation-lvalue (block-procedure block))) + +(define (stack-block/static-link? block) + (and (not (null? (block-free-variables block))) + (or (not (stack-block? (block-parent block))) + (not (internal-block/parent-known? block))))) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 6df9701fa..2e10f5cbc 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.150 1987/08/07 17:02:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.1 1987/12/04 20:03:16 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,37 +38,46 @@ MIT in each case. |# ;;;; Node Datatypes -(define cfg-node-tag (make-vector-tag false 'CFG-NODE)) -(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag)) +(define cfg-node-tag (make-vector-tag false 'CFG-NODE false)) +(define cfg-node? (tagged-vector/subclass-predicate cfg-node-tag)) (define-vector-slots node 1 generation previous-edges) -(define-vector-method cfg-node-tag ':DESCRIBE - (lambda (node) - (descriptor-list node generation previous-edges))) +(set-vector-tag-description! + cfg-node-tag + (lambda (node) + (descriptor-list node generation previous-edges))) -(define snode-tag (make-vector-tag cfg-node-tag 'SNODE)) -(define snode? (tagged-vector-subclass-predicate snode-tag)) +(define snode-tag (make-vector-tag cfg-node-tag 'SNODE false)) +(define snode? (tagged-vector/subclass-predicate snode-tag)) (define-vector-slots snode 3 next-edge) (define (make-snode tag . extra) (list->vector (cons* tag false '() false extra))) -(define-vector-method snode-tag ':DESCRIBE - (lambda (snode) - (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode) - (descriptor-list snode next-edge)))) +(set-vector-tag-description! + snode-tag + (lambda (snode) + (append! ((vector-tag-description (vector-tag-parent snode-tag)) snode) + (descriptor-list snode next-edge)))) -(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE)) -(define pnode? (tagged-vector-subclass-predicate pnode-tag)) +(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false)) +(define pnode? (tagged-vector/subclass-predicate pnode-tag)) (define-vector-slots pnode 3 consequent-edge alternative-edge) (define (make-pnode tag . extra) (list->vector (cons* tag false '() false false extra))) -(define-vector-method pnode-tag ':DESCRIBE - (lambda (pnode) - (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode) - (descriptor-list pnode consequent-edge alternative-edge)))) +(set-vector-tag-description! + pnode-tag + (lambda (pnode) + (append! ((vector-tag-description (vector-tag-parent pnode-tag)) pnode) + (descriptor-list pnode consequent-edge alternative-edge)))) + +(define (add-node-previous-edge! node edge) + (set-node-previous-edges! node (cons edge (node-previous-edges node)))) + +(define (delete-node-previous-edge! node edge) + (set-node-previous-edges! node (delq! edge (node-previous-edges node)))) (define (edge-next-node edge) (and edge (edge-right-node edge))) @@ -84,50 +93,51 @@ MIT in each case. |# ;;;; Edge Datatype -(define-vector-slots edge 0 left-node left-connect right-node) - -(define-integrable (make-edge left-node left-connect right-node) - (vector left-node left-connect right-node)) +(define-structure (edge (type vector)) left-node left-connect right-node) (define (create-edge! left-node left-connect right-node) (let ((edge (make-edge left-node left-connect right-node))) (if left-node (left-connect left-node edge)) (if right-node - (let ((previous (node-previous-edges right-node))) - (if (not (memq right-node previous)) - (set-node-previous-edges! right-node (cons edge previous))))))) + (add-node-previous-edge! right-node edge)) + edge)) (define (edge-connect-left! edge left-node left-connect) - (set-edge-left-node! edge left-node) - (set-edge-left-connect! edge left-connect) + (if (edge-left-node edge) + (error "Attempt to doubly connect left node of edge" edge)) (if left-node - (left-connect left-node edge))) + (begin + (set-edge-left-node! edge left-node) + (set-edge-left-connect! edge left-connect) + (left-connect left-node edge)))) (define (edge-connect-right! edge right-node) - (set-edge-right-node! edge right-node) + (if (edge-right-node edge) + (error "Attempt to doubly connect right node of edge" edge)) (if right-node - (let ((previous (node-previous-edges right-node))) - (if (not (memq right-node previous)) - (set-node-previous-edges! right-node (cons edge previous)))))) - -(define (edges-connect-right! edges right-node) - (for-each (lambda (edge) - (edge-connect-right! edge right-node)) - edges)) + (begin + (set-edge-right-node! edge right-node) + (add-node-previous-edge! right-node edge)))) (define (edge-disconnect-left! edge) - (let ((left-node (set-edge-left-node! edge false)) - (left-connect (set-edge-left-connect! edge false))) + (let ((left-node (edge-left-node edge)) + (left-connect (edge-left-connect edge))) (if left-node - (left-connect left-node false)))) + (begin + (set-edge-left-node! edge false) + (set-edge-left-connect! edge false) + (left-connect left-node false))))) (define (edge-disconnect-right! edge) - (let ((right-node (set-edge-right-node! edge false))) + (let ((right-node (edge-right-node edge))) (if right-node - (set-node-previous-edges! right-node - (delq! edge - (node-previous-edges right-node)))))) + (begin + (set-edge-right-node! edge false) + (delete-node-previous-edge! right-node edge))))) + +(define (edges-connect-right! edges right-node) + (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges)) (define (edge-disconnect! edge) (edge-disconnect-left! edge) diff --git a/v7/src/compiler/base/cfg2.scm b/v7/src/compiler/base/cfg2.scm index 90199979c..3fc0aa108 100644 --- a/v7/src/compiler/base/cfg2.scm +++ b/v7/src/compiler/base/cfg2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.3 1987/08/31 21:17:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.1 1987/12/04 20:03:33 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -58,10 +58,8 @@ MIT in each case. |# (edges-connect-right! previous-edges snode) (create-edge! snode set-snode-next-edge! node))) -(define (node->edge node) - (let ((edge (make-edge false false false))) - (edge-connect-right! edge node) - edge)) +(define-integrable (node->edge node) + (create-edge! false false node)) (define-integrable (cfg-entry-edge cfg) (node->edge (cfg-entry-node cfg))) @@ -126,7 +124,7 @@ MIT in each case. |# value))) (define noop-node-tag - (make-vector-tag snode-tag 'NOOP)) + (make-vector-tag snode-tag 'NOOP false)) (define-integrable (make-noop-node) (let ((node (make-snode noop-node-tag))) diff --git a/v7/src/compiler/base/contin.scm b/v7/src/compiler/base/contin.scm new file mode 100644 index 000000000..bb0e6116a --- /dev/null +++ b/v7/src/compiler/base/contin.scm @@ -0,0 +1,120 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.1 1987/12/04 20:00:53 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Continuation datatype + +(declare (usual-integrations)) + +;;; Continuations are a subtype of procedures, whose `type' is +;;; something other than PROCEDURE. + +(define (make-continuation block continuation type) + (let ((block (make-block block 'CONTINUATION))) + (let ((required (list (make-value-variable block)))) + (set-block-bound-variables! block required) + (make-procedure type block 'CONTINUATION required '() false '() '() + (make-fg-noop))))) + +(define-enumeration continuation-type + (effect + predicate + procedure + push + register + value)) + +(define-integrable (procedure-continuation? procedure) + (not (eq? (procedure-type procedure) continuation-type/procedure))) + +(define (rvalue/continuation? rvalue) + (and (rvalue/procedure? rvalue) + (procedure-continuation? rvalue))) + +(define-integrable continuation/type procedure-type) +(define-integrable set-continuation/type! set-procedure-type!) +(define-integrable continuation/block procedure-block) +(define-integrable continuation/closing-block procedure-closing-block) +(define-integrable continuation/entry-node procedure-entry-node) +(define-integrable set-continuation/entry-node! set-procedure-entry-node!) +(define-integrable continuation/combinations procedure-original-rest) +(define-integrable set-continuation/combinations! set-procedure-original-rest!) +(define-integrable continuation/label procedure-label) +(define-integrable continuation/returns procedure-applications) +(define-integrable set-continuation/returns! set-procedure-applications!) +(define-integrable continuation/always-known-operator? + procedure-always-known-operator?) +(define-integrable continuation/dynamic-link? procedure-closing-limit) +(define-integrable set-continuation/dynamic-link?! + set-procedure-closing-limit!) +(define-integrable continuation/lvalues procedure-closure-block) +(define-integrable set-continuation/lvalues! set-procedure-closure-block!) +(define-integrable continuation/offset procedure-closure-offset) +(define-integrable set-continuation/offset! set-procedure-closure-offset!) +(define-integrable continuation/passed-out? procedure-passed-out?) +(define-integrable set-continuation/passed-out?! set-procedure-passed-out?!) + +(define (continuation/register continuation) + (or (procedure-register continuation) + (let ((register (rtl:make-pseudo-register))) + (set-procedure-register! continuation register) + register))) + +(define-integrable (continuation/parameter continuation) + (car (procedure-original-required continuation))) + +(define-integrable return-operator/subproblem? rvalue/procedure?) +(define-integrable return-operator/reduction? rvalue/reference?) + +(define-integrable reduction-continuation/block reference-block) +(define-integrable reduction-continuation/lvalue reference-lvalue) + +(define-integrable (reduction-continuation/popping-limit continuation) + (variable-popping-limit (reference-lvalue continuation))) + +(define (return-operator/popping-limit operator) + (if (return-operator/reduction? operator) + (reduction-continuation/popping-limit operator) + (continuation/closing-block operator))) + +(define (continuation/frame-size continuation) + (cond ((continuation/always-known-operator? continuation) 0) + ((continuation/dynamic-link? continuation) 2) + (else 1))) + +(define (uni-continuation? rvalue) + (and (rvalue/procedure? rvalue) + (procedure-arity-correct? rvalue 1))) + +(define-integrable (uni-continuation/parameter continuation) + (car (procedure-original-required continuation))) \ No newline at end of file diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index d2ea36b65..d9268acea 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.51 1987/08/07 17:03:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.1 1987/12/04 20:03:40 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,102 +36,163 @@ MIT in each case. |# (declare (usual-integrations)) -(define-snode assignment block lvalue rvalue) +;;;; Application + +(define-snode application + type + block + operator + operands + (parallel-node owner) + (operators ;used in simulate-application + arguments) ;used in outer-analysis + operand-values ;set by outer-analysis, used by identify-closure-limits + ) + +(define *applications*) + +(define (make-application type block operator operands) + (let ((application + (make-snode application-tag + type block operator operands false '() '()))) + (set! *applications* (cons application *applications*)) + (add-block-application! block application) + (if (rvalue/reference? operator) + (add-lvalue-application! (reference-lvalue operator) application)) + (make-scfg application '()))) + +(define-vector-tag-unparser application-tag + (lambda (application) + (let ((type (application-type application))) + (cond ((eq? type 'COMBINATION) + (write-string "COMBINATION")) + ((eq? type 'RETURN) + (write-string "RETURN ") + (write (return/operand application))) + (else + (write-string "APPLICATION ") + (write type)))))) + +(define-snode parallel + application-node + subproblems) + +(define *parallels*) + +(define (make-parallel application subproblems) + (let ((parallel (make-snode parallel-tag false subproblems))) + (set-parallel-application-node! parallel application) + (set-application-parallel-node! application parallel) + (set! *parallels* (cons parallel *parallels*)) + (snode->scfg parallel))) + +(define (make-combination block continuation operator operands) + (let ((application + (make-application 'COMBINATION + block + (subproblem-rvalue operator) + (cons continuation + (map subproblem-rvalue operands))))) + (scfg*scfg->scfg! + (make-parallel (cfg-entry-node application) (cons operator operands)) + application))) + +(define-integrable (application/combination? application) + (eq? (application-type application) 'COMBINATION)) + +(define-integrable combination/block application-block) +(define-integrable combination/operator application-operator) +(define-integrable combination/inliner application-arguments) +(define-integrable set-combination/inliner! set-application-arguments!) +(define-integrable combination/frame-size application-operand-values) +(define-integrable set-combination/frame-size! set-application-operand-values!) +(define-integrable combination/inline? combination/inliner) + +(define-integrable (combination/continuation combination) + (car (application-operands combination))) + +(define-integrable (combination/operands combination) + (cdr (application-operands combination))) + +(define-structure (inliner (type vector) (conc-name inliner/)) + (handler false read-only true) + (generator false read-only true) + operands) + +;;; This method of handling constant combinations has the feature that +;;; such combinations are handled exactly like RETURNs by the +;;; procedure classification phase, which occurs after all constant +;;; combinations have been identified. + +(define (combination/constant! combination rvalue) + (let ((continuation (combination/continuation combination))) + (set-application-type! combination 'RETURN) + (set-application-operator! combination continuation) + (set-application-operands! combination (list rvalue)))) + +(define-integrable (make-return block continuation rvalue) + (make-application 'RETURN block continuation (list rvalue))) + +(define-integrable (application/return? application) + (eq? (application-type application) 'RETURN)) + +(define-integrable return/block + application-block) + +(define-integrable return/operator + application-operator) + +(define-integrable (return/operand return) + (car (application-operands return))) + +;;;; Miscellaneous Node Types + +(define-snode assignment + block + lvalue + rvalue) + +(define *assignments*) (define (make-assignment block lvalue rvalue) - (vnode-connect! lvalue rvalue) - (if (variable? lvalue) - (variable-assigned! lvalue)) - (snode->scfg (make-snode assignment-tag block lvalue rvalue))) + (lvalue-connect! lvalue rvalue) + (let ((assignment (make-snode assignment-tag block lvalue rvalue))) + (set! *assignments* (cons assignment *assignments*)) + (snode->scfg assignment))) -(define-snode definition block lvalue rvalue) +(define-snode definition + block + lvalue + rvalue) (define (make-definition block lvalue rvalue) - (vnode-connect! lvalue rvalue) - (if (variable? lvalue) - (variable-assigned! lvalue)) + (lvalue-connect! lvalue rvalue) (snode->scfg (make-snode definition-tag block lvalue rvalue))) -(define-pnode true-test rvalue) +(define-pnode true-test + rvalue) -(define-integrable (make-true-test rvalue) +(define (make-true-test rvalue) (pnode->pcfg (make-pnode true-test-tag rvalue))) -(define-pnode unassigned-test block variable) +(define-snode fg-noop) -(define-integrable (make-unassigned-test block variable) - (pnode->pcfg (make-pnode unassigned-test-tag block variable))) +(define (make-fg-noop) + (snode->scfg (make-snode fg-noop-tag))) -(define-pnode unbound-test block variable) +(define-snode virtual-return + operator + operand) -(define-integrable (make-unbound-test block variable) - (pnode->pcfg (make-pnode unbound-test-tag block variable))) - -(define-snode combination block compilation-type value operator operands - procedures known-operator constant?) -(define *combinations*) - -(define (make-combination block compilation-type value operator operands) - (let ((combination - (make-snode combination-tag block compilation-type value operator - operands '() false false))) - (define (add-vnode-combination! vnode) - (set-vnode-combinations! vnode - (cons combination (vnode-combinations vnode)))) - (set! *combinations* (cons combination *combinations*)) - (set-block-combinations! block - (cons combination (block-combinations block))) - (let ((rvalue (subproblem-value operator))) - (cond ((vnode? rvalue) - (add-vnode-combination! rvalue)) - ((reference? rvalue) - (add-vnode-combination! (reference-variable rvalue))))) - (snode->scfg combination))) - -(define-integrable (combination-compiled-for-predicate? combination) - (eq? 'PREDICATE (combination-compilation-type combination))) - -(define-integrable (combination-compiled-for-effect? combination) - (eq? 'EFFECT (combination-compilation-type combination))) - -(define-integrable (combination-compiled-for-value? combination) - (eq? 'VALUE (combination-compilation-type combination))) - -(define continuation-tag - (make-vector-tag false 'CONTINUATION)) +(define (make-virtual-return operator operand) + (snode->scfg (make-snode virtual-return-tag operator operand))) -(define continuation? - (tagged-vector-predicate continuation-tag)) +(define (make-push block rvalue) + (make-virtual-return (virtual-continuation/make block continuation-type/push) + rvalue)) -(define-vector-slots continuation 1 - rtl-edge - label - frame-pointer-offset - block - rgraph) - -(define *continuations*) - -(define (make-continuation block rgraph) - (let ((continuation - (vector continuation-tag - false - (generate-label 'CONTINUATION) - false - block - rgraph))) - (set! *continuations* (cons continuation *continuations*)) - (set-rgraph-continuations! - rgraph - (cons continuation (rgraph-continuations rgraph))) - (symbol-hash-table/insert! *label->object* - (continuation-label continuation) - continuation) - continuation)) - -(define-unparser continuation-tag - (lambda (continuation) - (write (continuation-label continuation)))) - -(define-integrable (label->continuation label) - (symbol-hash-table/lookup *label->object* label)) \ No newline at end of file +(define-snode pop + continuation) + +(define (make-pop continuation) + (snode->scfg (make-snode pop-tag continuation))) \ No newline at end of file diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm new file mode 100644 index 000000000..66d5e392d --- /dev/null +++ b/v7/src/compiler/base/debug.scm @@ -0,0 +1,169 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.1 1987/12/04 20:00:58 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Debugging Support + +(declare (usual-integrations)) + +(define (po object) + (let ((object (->tagged-vector object))) + (write-line object) + (for-each pp ((tagged-vector/description object) object)))) + +(define (dump-rtl filename) + (write-instructions + (lambda () + (with-output-to-file (pathname-new-type (->pathname filename) "rtl") + (lambda () + (for-each show-rtl-instruction + ((access linearize-rtl rtl-generator-package) + *rtl-graphs*))))))) + +(define (show-rtl rtl) + (pp-instructions + (lambda () + (for-each show-rtl-instruction rtl)))) + +(define (show-bblock-rtl bblock) + (pp-instructions + (lambda () + (bblock-walk-forward (->tagged-vector bblock) + (lambda (rinst) + (show-rtl-instruction (rinst-rtl rinst))))))) + +(define (write-instructions thunk) + (fluid-let ((*show-instruction* write-line) + (*unparser-radix* 16)) + (thunk))) + +(define (pp-instructions thunk) + (fluid-let ((*show-instruction* pp) + ((access *pp-primitives-by-name* scheme-pretty-printer) false) + (*unparser-radix* 16)) + (thunk))) + +(define *show-instruction*) + +(define (show-rtl-instruction rtl) + (if (memq (car rtl) + '(LABEL PROCEDURE-HEAP-CHECK CONTINUATION-HEAP-CHECK SETUP-LEXPR)) + (newline)) + (*show-instruction* rtl)) + +(package (show-fg) + +(define *procedure-queue*) +(define *procedures*) + +(define-export (show-fg) + (fluid-let ((*procedure-queue* (make-queue)) + (*procedures* '())) + (write-string "\n---------- Expression ----------") + (fg/print-object *root-expression*) + (with-new-node-marks + (lambda () + (fg/print-entry-node (expression-entry-node *root-expression*)) + (queue-map! *procedure-queue* + (lambda (procedure) + (if (procedure-continuation? procedure) + (write-string "\n\n---------- Continuation ----------") + (write-string "\n\n---------- Procedure ----------")) + (fg/print-object procedure) + (fg/print-entry-node (procedure-entry-node procedure)))))) + (write-string "\n\n---------- Blocks ----------") + (fg/print-blocks (expression-block *root-expression*)))) + +(define (fg/print-entry-node node) + (if node + (fg/print-node node))) + +(define (fg/print-object object) + (newline) + (po object)) + +(define (fg/print-blocks block) + (fg/print-object block) + (for-each fg/print-object (block-bound-variables block)) + (if (not (block-parent block)) + (for-each fg/print-object (block-free-variables block))) + (for-each fg/print-blocks (block-children block)) + (for-each fg/print-blocks (block-disowned-children block))) + +(define (fg/print-node node) + (if (not (node-marked? node)) (begin + (node-mark! node) + (fg/print-object node) + (cfg-node-case (tagged-vector/tag node) + ((PARALLEL) + (for-each fg/print-subproblem (parallel-subproblems node)) + (fg/print-node (snode-next node))) + ((APPLICATION) + (fg/print-rvalue (application-operator node)) + (for-each fg/print-rvalue (application-operands node))) + ((VIRTUAL-RETURN) + (fg/print-rvalue (virtual-return-operand node)) + (fg/print-node (snode-next node))) + ((POP) + (fg/print-rvalue (pop-continuation node)) + (fg/print-node (snode-next node))) + ((ASSIGNMENT) + (fg/print-rvalue (assignment-rvalue node)) + (fg/print-node (snode-next node))) + ((DEFINITION) + (fg/print-rvalue (definition-rvalue node)) + (fg/print-node (snode-next node))) + ((TRUE-TEST) + (fg/print-rvalue (true-test-rvalue node)) + (fg/print-node (pnode-consequent node)) + (fg/print-node (pnode-alternative node))))))) + +(define (fg/print-rvalue rvalue) + (let ((rvalue (rvalue-known-value rvalue))) + (if (and rvalue + (rvalue/procedure? rvalue) + (not (memq rvalue *procedures*))) + (begin + (set! *procedures* (cons rvalue *procedures*)) + (enqueue! *procedure-queue* rvalue))))) + +(define (fg/print-subproblem subproblem) + (fg/print-object subproblem) + (if (subproblem-canonical? subproblem) + (fg/print-rvalue (subproblem-continuation subproblem))) + (let ((prefix (subproblem-prefix subproblem))) + (if (not (cfg-null? prefix)) + (fg/print-node (cfg-entry-node prefix))))) + +;;; end SHOW-FG +) \ No newline at end of file diff --git a/v7/src/compiler/base/enumer.scm b/v7/src/compiler/base/enumer.scm new file mode 100644 index 000000000..96cb0032f --- /dev/null +++ b/v7/src/compiler/base/enumer.scm @@ -0,0 +1,120 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.1 1987/12/04 20:03:52 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Support for enumerations + +(declare (usual-integrations)) + +;;;; Enumerations + +(define-structure (enumeration + (conc-name enumeration/) + (constructor %make-enumeration)) + (enumerands false read-only true)) + +(define-structure (enumerand + (conc-name enumerand/) + (print-procedure + (standard-unparser 'ENUMERAND + (lambda (enumerand) + (write (enumerand/name enumerand)))))) + (enumeration false read-only true) + (name false read-only true) + (index false read-only true)) + +(define (make-enumeration names) + (let ((enumerands (make-vector (length names)))) + (let ((enumeration (%make-enumeration enumerands))) + (let loop ((names names) (index 0)) + (if (not (null? names)) + (begin + (vector-set! enumerands + index + (make-enumerand enumeration (car names) index)) + (loop (cdr names) (1+ index))))) + enumeration))) + +(define-integrable (enumeration/cardinality enumeration) + (vector-length (enumeration/enumerands enumeration))) + +(define-integrable (enumeration/index->enumerand enumeration index) + (vector-ref (enumeration/enumerands enumeration) index)) + +(define-integrable (enumeration/index->name enumeration index) + (enumerand/name (enumeration/index->enumerand enumeration index))) + +(define (enumeration/name->enumerand enumeration name) + (let ((end (enumeration/cardinality enumeration))) + (let loop ((index 0)) + (if (< index end) + (let ((enumerand (enumeration/index->enumerand enumeration index))) + (if (eqv? (enumerand/name enumerand) name) + enumerand + (loop (1+ index)))) + (error "Unknown enumeration name" name))))) + +(define-integrable (enumeration/name->index enumeration name) + (enumerand/index (enumeration/name->enumerand enumeration name))) + +;;;; Method Tables + +(define-structure (method-table (constructor %make-method-table)) + (enumeration false read-only true) + (vector false read-only true)) + +(define (make-method-table enumeration default-method . method-alist) + (let ((table + (%make-method-table enumeration + (make-vector (enumeration/cardinality enumeration) + default-method)))) + (for-each (lambda (entry) + (define-method-table-entry table (car entry) (cdr entry))) + method-alist) + table)) + +(define (define-method-table-entry name method-table method) + (vector-set! (method-table-vector method-table) + (enumeration/name->index (method-table-enumeration method-table) + name) + method) + name) + +(define (define-method-table-entries names method-table method) + (for-each (lambda (name) + (define-method-table-entry name method-table method)) + names) + names) + +(define-integrable (method-table-lookup method-table index) + (vector-ref (method-table-vector method-table) index)) \ No newline at end of file diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 805e36f3b..c155daf54 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 1.2 1987/07/02 20:45:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.1 1987/12/04 20:03:56 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,15 +32,52 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler DFG Datatypes: Variable Nodes +;;;; Left (Hand Side) Values (declare (usual-integrations)) -(define-vnode variable block name assigned? in-cell? normal-offset - declarations) +(define-root-type lvalue + forward-links ;lvalues that sink values from here + backward-links ;lvalues that source values to here + initial-values ;rvalues that are possible sources + values-cache ;(see `lvalue-values') + known-value ;either #F or the rvalue which is the unique value + applications ;applications whose operators are this lvalue + passed-in? ;true iff this lvalue gets an unknown value + passed-out? ;true iff this lvalue passes its value to unknown place + marks ;attribute marks list (see `lvalue-mark-set?') + ) + +;;; Note that the rvalues stored in `initial-values', `values-cache', +;;; and `known-value' are NEVER references. + +(define *lvalues*) + +(define (make-lvalue tag . extra) + (let ((lvalue + (list->vector + (cons* tag '() '() '() 'NOT-CACHED false '() false false '() + extra)))) + (set! *lvalues* (cons lvalue *lvalues*)) + lvalue)) + +(define (add-lvalue-application! lvalue application) + (set-lvalue-applications! lvalue + (cons application + (lvalue-applications lvalue)))) + +(define-lvalue variable + block ;block in which variable is defined + name ;name of variable [symbol] + assigned? ;true iff variable appears in an assignment + in-cell? ;true iff variable requires cell at runtime + (normal-offset ;offset of variable within `block' + popping-limit) ;popping-limit for continuation variables + declarations ;list of declarations for this variable + ) (define (make-variable block name) - (make-vnode variable-tag block name false false false '())) + (make-lvalue variable-tag block name false false false '())) (define variable-assoc (association-procedure eq? variable-name)) @@ -50,27 +87,157 @@ MIT in each case. |# (cdr (assq variable (block-closure-offsets block))) (variable-normal-offset variable))) -(define-unparser variable-tag +(define-vector-tag-unparser variable-tag (lambda (variable) (write-string "VARIABLE ") (write (variable-name variable)))) -(define-vnode access environment name) - -(define (make-access environment name) - (make-vnode access-tag environment name)) - -(define-vnode temporary type conflicts allocation) - -(define (make-temporary) - (make-vnode temporary-tag false '() false)) - -(define-vnode value-register) - -(define (make-value-register) - (make-vnode value-register-tag)) - -(define-vnode value-ignore) - -(define (make-value-ignore) - (make-vnode value-ignore-tag)) \ No newline at end of file +(define-integrable (lvalue/variable? lvalue) + (eq? (tagged-vector/tag lvalue) variable-tag)) + +(let-syntax + ((define-named-variable + (macro (name) + (let ((symbol + (string->symbol + (string-append "#[" + (string-downcase (symbol->string name)) + "]")))) + `(BEGIN (DEFINE-INTEGRABLE + (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK) + (MAKE-VARIABLE BLOCK ',symbol)) + (DEFINE-INTEGRABLE + (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE) + (EQ? (VARIABLE-NAME LVALUE) ',symbol)) + (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE) + (AND (VARIABLE? LVALUE) + (EQ? (VARIABLE-NAME LVALUE) ',symbol)))))))) + (define-named-variable continuation) + (define-named-variable value)) + +;;;; Linking + +;;; Eventually, links may be triples consisting of a source, a sink, +;;; and a set of paths. Each path will be an ordered sequence of +;;; actions. Actions will keep track of what paths they are part of, +;;; and paths will keep track of what links they are part of. But for +;;; now, this significantly cheaper representation will do. + +(define (lvalue-connect! lvalue rvalue) + (if (rvalue/reference? rvalue) + (lvalue-connect!:lvalue lvalue (reference-lvalue rvalue)) + (lvalue-connect!:rvalue lvalue rvalue))) + +(define (lvalue-connect!:rvalue lvalue rvalue) + (if (not (memq rvalue (lvalue-initial-values lvalue))) + (set-lvalue-initial-values! lvalue + (cons rvalue + (lvalue-initial-values lvalue))))) + +(define (lvalue-connect!:lvalue to from) + (if (not (memq from (lvalue-backward-links to))) + (begin + (set-lvalue-backward-links! to (cons from (lvalue-backward-links to))) + (set-lvalue-forward-links! from (cons to (lvalue-forward-links from))) + (for-each (lambda (from) + (lvalue-connect!:lvalue to from)) + (lvalue-backward-links from)) + (for-each (lambda (to) + (lvalue-connect!:lvalue to from)) + (lvalue-forward-links to))))) + +(define (lvalue-values lvalue) + ;; No recursion is needed here because the dataflow graph is + ;; transitively closed when this is run. + (if (eq? 'NOT-CACHED (lvalue-values-cache lvalue)) + (let ((values + (eq-set-union* (lvalue-initial-values lvalue) + (map lvalue-initial-values + (lvalue-backward-links lvalue))))) + (set-lvalue-values-cache! lvalue values) + values) + (lvalue-values-cache lvalue))) + +(define (reset-lvalue-cache! lvalue) + (set-lvalue-values-cache! lvalue 'NOT-CACHED) + (for-each (lambda (lvalue) + (set-lvalue-values-cache! lvalue 'NOT-CACHED)) + (lvalue-forward-links lvalue))) + +;;;; Attribute Marking + +(define (lvalue-mark-set! lvalue mark) + (if (not (memq mark (lvalue-marks lvalue))) + (set-lvalue-marks! lvalue (cons mark (lvalue-marks lvalue))))) + +(define (lvalue-mark-clear! lvalue mark) + (set-lvalue-marks! lvalue (delq! mark (lvalue-marks lvalue)))) + +(define-integrable (lvalue-mark-set? lvalue mark) + (memq mark (lvalue-marks lvalue))) +#| +(define-integrable (variable-auxiliary! variable) + (set-variable-auxiliary?! variable true)) + +(define (variable-assigned! variable) + (set-variable-assignments! variable (1+ (variable-assignments variable)))) + +(define (variable-assigned? variable) + (> (variable-assignments variable) + (if (variable-auxiliary? variable) 1 0))) +|# +(define-integrable (variable-assigned! variable) + (set-variable-assigned?! variable true)) + +(define (lvalue-integrated? lvalue) + (let ((value (lvalue-known-value lvalue))) + (and value + (or (rvalue/constant? value) + (and (rvalue/procedure? value) + (procedure/open? value)))))) + +(define (lvalue=? lvalue lvalue*) + (or (eq? lvalue lvalue*) + (eq-set-same-set? (lvalue/source-set lvalue) + (lvalue/source-set lvalue*)))) + +(define (lvalue/unique-source lvalue) + (let ((source-set (lvalue/source-set lvalue))) + (and (not (null? source-set)) + (null? (cdr source-set)) + (car source-set)))) + +(define (lvalue/source-set lvalue) + (list-transform-positive + (eq-set-adjoin lvalue (lvalue-backward-links lvalue)) + lvalue/source?)) + +(define (lvalue/external-source-set lvalue) + (list-transform-positive + (eq-set-adjoin lvalue (lvalue-backward-links lvalue)) + lvalue/external-source?)) + +(define (lvalue/source? lvalue) + (or (lvalue/external-source? lvalue) + (lvalue/internal-source? lvalue))) + +(define-integrable (lvalue/external-source? lvalue) + (eq? 'SOURCE (lvalue-passed-in? lvalue))) + +(define-integrable (lvalue/internal-source? lvalue) + (not (null? (lvalue-initial-values lvalue)))) + +(define (variable-in-known-location? block variable) + (let ((definition-block (variable-block variable))) + (or (not (ic-block? definition-block)) + ;; If the block has no procedure, then we know nothing about + ;; the locations of its bindings. + (and (rvalue/procedure? (block-procedure block)) + ;; If IC reference in same block as definition, then + ;; incremental definitions cannot screw us. + (eq? block definition-block) + ;; Make sure that IC variables are bound! A variable + ;; that is not bound by the code being compiled still has + ;; a "definition" block, which is the outermost IC block + ;; of the expression in which the variable is referenced. + (memq variable (block-bound-variables block)))))) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 92e2eecc3..337d10f40 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.61 1987/08/07 17:04:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.1 1987/12/04 20:04:06 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -73,12 +73,6 @@ MIT in each case. |# '())))) (cdr expression))))) -(define enable-integration-declarations - true) - -(define enable-expansion-declarations - true) - (let () (define (parse-define-syntax pattern body if-variable if-lambda) @@ -89,31 +83,34 @@ MIT in each case. |# ((symbol? (car pattern)) (if-lambda pattern body)) (else - (error "Illegal name" parse-define-syntax (car pattern)))))) + (error "Illegal name" (car pattern)))))) ((symbol? pattern) (if-variable pattern body)) (else - (error "Illegal name" parse-define-syntax pattern)))) + (error "Illegal name" pattern)))) (define lambda-list->bound-names - (let ((accumulate - (lambda (lambda-list) - (cons (let ((parameter (car lambda-list))) - (if (pair? parameter) (car parameter) parameter)) - (lambda-list->bound-names (cdr lambda-list)))))) - (named-lambda (lambda-list->bound-names lambda-list) - (cond ((symbol? lambda-list) - lambda-list) - ((null? lambda-list) '()) - ((not (pair? lambda-list)) - (error "Illegal rest variable" lambda-list)) - ((eq? (car lambda-list) - (access lambda-optional-tag lambda-package)) - (if (pair? (cdr lambda-list)) - (accumulate (cdr lambda-list)) - (error "Missing optional variable" lambda-list))) - (else - (accumulate lambda-list)))))) + (letrec ((lambda-list->bound-names + (lambda (lambda-list) + (cond ((null? lambda-list) + '()) + ((pair? lambda-list) + (if (eq? (car lambda-list) + (access lambda-optional-tag lambda-package)) + (if (pair? (cdr lambda-list)) + (accumulate (cdr lambda-list)) + (error "Missing optional variable" lambda-list)) + (accumulate lambda-list))) + ((symbol? lambda-list) + (list lambda-list)) + (else + (error "Illegal rest variable" lambda-list))))) + (accumulate + (lambda (lambda-list) + (cons (let ((parameter (car lambda-list))) + (if (pair? parameter) (car parameter) parameter)) + (lambda-list->bound-names (cdr lambda-list)))))) + lambda-list->bound-names)) (syntax-table-define compiler-syntax-table 'DEFINE-EXPORT (macro (pattern . body) @@ -126,7 +123,7 @@ MIT in each case. |# (syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE (macro (pattern . body) - (if enable-integration-declarations + (if compiler:enable-integration-declarations? (parse-define-syntax pattern body (lambda (name body) `(BEGIN (DECLARE (INTEGRATE ,pattern)) @@ -166,35 +163,53 @@ MIT in each case. |# '*THE-NON-PRINTING-OBJECT* `(BEGIN ,@(loop slots index))))) +(syntax-table-define compiler-syntax-table 'DEFINE-ROOT-TYPE + (macro (type . slots) + (let ((tag-name (symbol-append type '-TAG))) + `(BEGIN (DEFINE ,tag-name + (MAKE-VECTOR-TAG FALSE ',type FALSE)) + (DEFINE ,(symbol-append type '?) + (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name)) + (DEFINE-VECTOR-SLOTS ,type 1 ,@slots) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (DESCRIPTOR-LIST ,type ,@slots))))))) + (let-syntax ((define-type-definition - (macro (name reserved) + (macro (name reserved enumeration) (let ((parent (symbol-append name '-TAG))) `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE ',(symbol-append 'DEFINE- name) (macro (type . slots) (let ((tag-name (symbol-append type '-TAG))) `(BEGIN (DEFINE ,tag-name - (MAKE-VECTOR-TAG ,',parent ',type)) + (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration)) (DEFINE ,(symbol-append type '?) - (TAGGED-VECTOR-PREDICATE ,tag-name)) + (TAGGED-VECTOR/PREDICATE ,tag-name)) (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) - (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE - (LAMBDA (,type) - (APPEND! - ((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type) - (DESCRIPTOR-LIST ,type ,@slots)))))))))))) - (define-type-definition snode 4) - (define-type-definition pnode 5) - (define-type-definition rvalue 1) - (define-type-definition vnode 10)) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (APPEND! + ((VECTOR-TAG-DESCRIPTION ,',parent) ,type) + (DESCRIPTOR-LIST ,type ,@slots)))))))))))) + (define-type-definition snode 4 false) + (define-type-definition pnode 5 false) + (define-type-definition rvalue 2 rvalue-types) + (define-type-definition lvalue 10 false)) (syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST (macro (type . slots) - `(LIST ,@(map (lambda (slot) - (let ((ref-name (symbol-append type '- slot))) - ``(,',ref-name ,(,ref-name ,type)))) - slots)))) + (let ((ref-name (lambda (slot) (symbol-append type '- slot)))) + `(LIST ,@(map (lambda (slot) + (if (pair? slot) + (let ((ref-names (map ref-name slot))) + ``(,',ref-names ,(,(car ref-names) ,type))) + (let ((ref-name (ref-name slot))) + ``(,',ref-name ,(,ref-name ,type))))) + slots))))) (let ((rtl-common (lambda (type prefix components wrap-constructor) @@ -233,16 +248,6 @@ MIT in each case. |# (rtl-common type prefix components (lambda (expression) `(PREDICATE->PRTL ,expression)))))) -(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES - (macro (slot) - (let ((name (symbol-append 'REGISTER- slot))) - (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*))) - `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER) - (VECTOR-REF ,vector REGISTER)) - (DEFINE-INTEGRABLE - (,(symbol-append 'SET- name '!) REGISTER VALUE) - (VECTOR-SET! ,vector REGISTER VALUE))))))) - (syntax-table-define compiler-syntax-table 'UCODE-TYPE (macro (name) (microcode-type name))) @@ -296,4 +301,58 @@ MIT in each case. |# (syntax-table-define compiler-syntax-table 'INST-EA (macro (ea) - (list 'QUASIQUOTE ea))) \ No newline at end of file + (list 'QUASIQUOTE ea))) + +(syntax-table-define compiler-syntax-table 'DEFINE-ENUMERATION + (macro (name elements) + (let ((enumeration (symbol-append name 'S))) + `(BEGIN (DEFINE ,enumeration + (MAKE-ENUMERATION ',elements)) + ,@(map (lambda (element) + `(DEFINE ,(symbol-append name '/ element) + (ENUMERATION/NAME->INDEX ,enumeration ',element))) + elements))))) + +(define (macros/case-macro expression clauses predicate default) + (let ((need-temp? (not (symbol? expression)))) + (let ((expression* + (if need-temp? + (generate-uninterned-symbol) + expression))) + (let ((body + `(COND + ,@(let loop ((clauses clauses)) + (cond ((null? clauses) + (default expression*)) + ((eq? (caar clauses) 'ELSE) + (if (null? (cdr clauses)) + clauses + (error "ELSE clause not last" clauses))) + (else + `(((OR ,@(map (lambda (element) + (predicate expression* element)) + (caar clauses))) + ,@(cdar clauses)) + ,@(loop (cdr clauses))))))))) + (if need-temp? + `(LET ((,expression* ,expression)) + ,body) + body))))) + +(syntax-table-define compiler-syntax-table 'ENUMERATION-CASE + (macro (name expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append name '/ element))) + (lambda (expression) + '())))) + +(syntax-table-define compiler-syntax-table 'CFG-NODE-CASE + (macro (expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append element '-TAG))) + (lambda (expression) + `((ELSE (ERROR "Unknown node type" ,expression))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm index bfdd98611..19e85e810 100644 --- a/v7/src/compiler/base/object.scm +++ b/v7/src/compiler/base/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 1.1 1987/03/19 00:44:29 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.1 1987/12/04 20:04:24 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,95 +36,144 @@ MIT in each case. |# (declare (usual-integrations)) -(define (make-vector-tag parent name) - (let ((tag (cons '() (or parent vector-tag:object)))) - (vector-tag-put! tag ':TYPE-NAME name) - ((access add-unparser-special-object! unparser-package) - tag tagged-vector-unparser) - tag)) - -(define *tagged-vector-unparser-show-hash* - true) - -(define (tagged-vector-unparser object) - (unparse-with-brackets - (lambda () - (write-string "LIAR ") - (if *tagged-vector-unparser-show-hash* - (begin (fluid-let ((*unparser-radix* 10)) - (write (hash object))) - (write-string " "))) - (fluid-let ((*unparser-radix* 16)) - ((vector-method object ':UNPARSE) object))))) - +(define-structure (vector-tag + (constructor %make-vector-tag (parent name index))) + (parent false read-only true) + (name false read-only true) + (index false read-only true) + (%unparser false) + (description false) + (method-alist '())) + +(define make-vector-tag + (let ((root-tag (%make-vector-tag false 'OBJECT false))) + (set-vector-tag-%unparser! + root-tag + (lambda (object) + (write (vector-tag-name (tagged-vector/tag object))))) + (named-lambda (make-vector-tag parent name enumeration) + (let ((tag + (%make-vector-tag (or parent root-tag) + name + (and enumeration + (enumeration/name->index enumeration + name))))) + ((access add-unparser-special-object! unparser-package) + tag + tagged-vector/unparse) + tag)))) + +(define (define-vector-tag-unparser tag unparser) + (set-vector-tag-%unparser! tag unparser) + (vector-tag-name tag)) + +(define (vector-tag-unparser tag) + (or (vector-tag-%unparser tag) + (let ((parent (vector-tag-parent tag))) + (if parent + (vector-tag-unparser parent) + (error "Missing unparser" tag))))) + (define (vector-tag-put! tag key value) - (let ((entry (assq key (car tag)))) + (let ((entry (assq key (vector-tag-method-alist tag)))) (if entry (set-cdr! entry value) - (set-car! tag (cons (cons key value) (car tag)))))) + (set-vector-tag-method-alist! tag + (cons (cons key value) + (vector-tag-method-alist tag)))))) (define (vector-tag-get tag key) - (define (loop tag) - (and (pair? tag) - (or (assq key (car tag)) - (loop (cdr tag))))) (let ((value - (or (assq key (car tag)) - (loop (cdr tag))))) + (or (assq key (vector-tag-method-alist tag)) + (let loop ((tag (vector-tag-parent tag))) + (and tag + (or (assq key (vector-tag-method-alist tag)) + (loop (vector-tag-parent tag)))))))) (and value (cdr value)))) -(define vector-tag:object - (list '())) - -(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT) - -(define-integrable (vector-tag vector) - (vector-ref vector 0)) - -(define (define-vector-method tag name method) +(define (define-vector-tag-method tag name method) (vector-tag-put! tag name method) name) (define (vector-tag-method tag name) (or (vector-tag-get tag name) - (error "Unbound method" tag name))) + (error "Unbound method" name tag))) -(define-integrable (vector-tag-parent-method tag name) - (vector-tag-method (cdr tag) name)) +(define-integrable make-tagged-vector + vector) -(define-integrable (vector-method vector name) - (vector-tag-method (vector-tag vector) name)) +(define-integrable (tagged-vector/tag vector) + (vector-ref vector 0)) -(define (define-unparser tag unparser) - (define-vector-method tag ':UNPARSE unparser)) +(define-integrable (tagged-vector/index vector) + (vector-tag-index (tagged-vector/tag vector))) -(define-integrable make-tagged-vector - vector) +(define-integrable (tagged-vector/unparser vector) + (vector-tag-unparser (tagged-vector/tag vector))) -(define ((tagged-vector-predicate tag) object) +(define (tagged-vector? object) (and (vector? object) (not (zero? (vector-length object))) - (eq? tag (vector-tag object)))) + (let ((tag (tagged-vector/tag object))) + (or (vector-tag? tag) + (type-object? tag))))) + +(define (->tagged-vector object) + (let ((object (if (integer? object) (unhash object) object))) (and (tagged-vector? object) object))) -(define (tagged-vector-subclass-predicate tag) - (define (loop tag*) - (or (eq? tag tag*) - (and (pair? tag*) - (loop (cdr tag*))))) +(define (tagged-vector/predicate tag) (lambda (object) (and (vector? object) (not (zero? (vector-length object))) - (loop (vector-tag object))))) + (eq? tag (tagged-vector/tag object))))) -(define tagged-vector? - (tagged-vector-subclass-predicate vector-tag:object)) - -(define-unparser vector-tag:object +(define (tagged-vector/subclass-predicate tag) (lambda (object) - (write (vector-method object ':TYPE-NAME)))) - -(define (->tagged-vector object) - (or (and (tagged-vector? object) object) - (and (integer? object) - (let ((object (unhash object))) - (and (tagged-vector? object) object))))) \ No newline at end of file + (and (vector? object) + (not (zero? (vector-length object))) + (let loop ((tag* (tagged-vector/tag object))) + (or (eq? tag tag*) + (and (pair? tag*) + (loop (vector-tag-parent tag*)))))))) + +(define (tagged-vector/description object) + (if (tagged-vector? object) + (let ((tag (tagged-vector/tag object))) + (cond ((vector-tag? tag) (vector-tag-description tag)) + ((type-object? tag) (type-object-description tag)) + (else (error "Unknown vector tag" tag)))) + (error "Not a tagged vector" object))) + +(define (type-object-description type-object) + (2d-get type-object type-object-description)) + +(define (set-type-object-description! type-object description) + (2d-put! type-object type-object-description description)) + +(define (standard-unparser name unparser) + (lambda (object) + (unparse-with-brackets + (lambda () + (standard-unparser/prefix object) + (write name) + (if unparser + (begin (write-string " ") + (unparser object))))))) + +(define (tagged-vector/unparse vector) + (unparse-with-brackets + (lambda () + (standard-unparser/prefix vector) + (fluid-let ((*unparser-radix* 16)) + ((tagged-vector/unparser vector) vector))))) + +(define (standard-unparser/prefix object) + (if *tagged-vector-unparse-prefix-string* + (begin (write-string *tagged-vector-unparse-prefix-string*) + (write-string " "))) + (if *tagged-vector-unparse-show-hash* + (begin (write-string (number->string (hash object) 10)) + (write-string " ")))) + +(define *tagged-vector-unparse-prefix-string* "LIAR") +(define *tagged-vector-unparse-show-hash* true) \ No newline at end of file diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm new file mode 100644 index 000000000..1ab8da3bc --- /dev/null +++ b/v7/src/compiler/base/proced.scm @@ -0,0 +1,212 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.1 1987/12/04 20:04:40 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Procedure datatype + +(declare (usual-integrations)) + +(define-rvalue procedure + type ;either PROCEDURE or a continuation type + block ;model of invocation environment [block] + name ;name of procedure [symbol] + required ;list of required parameters [variables] + optional ;list of optional parameters [variables] + rest ;"rest" parameter, if any [variable or false] + names ;list of internal letrec names [variables] + values ;list of internal letrec values [rvalues] + entry-edge ;body of procedure [cfg edge] + original-required ;like `required' but never changed + original-optional ;like `optional' but never changed + original-rest ;like `rest' but never changed + label ;label to identify procedure entry point [symbol] + applications ;list of applications for which this is an operator + always-known-operator? ;true if always known operator of application + closing-limit ;closing limit (see code) + closure-block ;for closure, where procedure is closed [block] + closure-offset ;for closure, offset of procedure in stack frame + register ;for continuation, argument register + ) + +(define *procedures*) + +(define (make-procedure type block name required optional rest names values + scfg) + (map lvalue-connect! names values) + (let ((procedure + (make-rvalue procedure-tag + type block name required optional rest names values + (node->edge (cfg-entry-node scfg)) + (list-copy required) (list-copy optional) rest + (generate-label name) false false false false false + false))) + (set! *procedures* (cons procedure *procedures*)) + (set-block-procedure! block procedure) + procedure)) + +(define-vector-tag-unparser procedure-tag + (lambda (procedure) + (let ((type + (enumeration/index->name continuation-types + (procedure-type procedure)))) + (if (eq? type 'PROCEDURE) + (begin + (write-string "PROCEDURE ") + (write (procedure-label procedure))) + (begin + (write-string "CONTINUATION ") + (write type)))))) + +(define-integrable (rvalue/procedure? rvalue) + (eq? (tagged-vector/tag rvalue) procedure-tag)) + +(define (procedure-arity-correct? procedure argument-count) + (let ((number-required (length (procedure-required procedure)))) + (and (>= argument-count number-required) + (if (procedure-rest procedure) + true + (<= argument-count + (+ number-required + (length (procedure-optional procedure)))))))) + +(define-integrable (procedure-closing-block procedure) + (block-parent (procedure-block procedure))) + +(define-integrable (procedure-continuation-lvalue procedure) + ;; Valid only if (not (procedure-continuation? procedure)) + (car (procedure-required procedure))) + +(define-integrable (procedure-required-arguments procedure) + ;; Valid only if (not (procedure-continuation? procedure)) + (cdr (procedure-required procedure))) + +(define-integrable (procedure-entry-node procedure) + (edge-next-node (procedure-entry-edge procedure))) + +(define (set-procedure-entry-node! procedure node) + (let ((edge (procedure-entry-edge procedure))) + (edge-disconnect-right! edge) + (edge-connect-right! edge node))) + +(define-integrable procedure-passed-out? + rvalue-%passed-out?) + +(define-integrable set-procedure-passed-out?! + set-rvalue-%passed-out?!) + +(define (close-procedure? procedure) + (not (eq? (procedure-closing-limit procedure) + (procedure-closing-block procedure)))) + +(define-integrable (closure-procedure-needs-operator? procedure) + ;; **** When implemented, this must be true if the closure needs its + ;; parent frame since the parent frame is stored in the operator. + true) + +(define (procedure-interface-optimizible? procedure) + (and (stack-block? (procedure-block procedure)) + (procedure-always-known-operator? procedure))) + +(define-integrable (procedure-application-unique? procedure) + (null? (cdr (procedure-applications procedure)))) + +(define (procedure-inline-code? procedure) + (and (procedure-always-known-operator? procedure) + (procedure-application-unique? procedure))) + +(define (open-procedure-needs-static-link? procedure) + (let ((block (procedure-block procedure))) + (let ((parent (block-parent block))) + (and parent + (or (not (stack-block? parent)) + (not (internal-block/parent-known? block))))))) + +;;;; Procedure Types + +;;; IC ("interpreter compatible") procedures are closed procedures +;;; whose environment frames are compatible with those generated by +;;; the interpreter. Both the procedure's frame and all of its +;;; ancestors are interpreter compatible. + +;;; CLOSURE procedures are closed procedures whose frame is a stack +;;; frame. The parent frame of such a procedure may be null, an IC +;;; frame, or a CLOSURE frame (which is a compiler generated, heap +;;; allocated frame). + +;;; OPEN-EXTERNAL procedures are open procedures whose frame is a +;;; stack frame, and whose parent frame is either null, or an IC +;;; frame. These are treated similarly to CLOSURE procedures except +;;; that the stack frame is laid out differently. + +;;; OPEN-INTERNAL procedures are open procedures whose frame and +;;; parent are both stack frames. The parent frame of such a +;;; procedure is created by either a closure or open-external +;;; procedure. + +(define (procedure/type procedure) + (let ((block (procedure-block procedure))) + (enumeration-case block-type (block-type block) + ((STACK) + (cond ((procedure-closure-block procedure) 'CLOSURE) + ((stack-parent? block) 'OPEN-INTERNAL) + (else 'OPEN-EXTERNAL))) + ((IC) 'IC) + ((CLOSURE) (error "Illegal occurrence of CLOSURE block" procedure)) + (else (error "Unknown block type" block))))) + +(define-integrable (procedure/ic? procedure) + (ic-block? (procedure-block procedure))) + +(define-integrable (procedure/closure? procedure) + (procedure-closure-block procedure)) + +(define (procedure/closed? procedure) + (or (procedure/ic? procedure) + (procedure/closure? procedure))) + +(define-integrable (procedure/open? procedure) + (not (procedure/closed? procedure))) + +(define-integrable (procedure/external? procedure) + (block/external? (procedure-block procedure))) + +(define-integrable (procedure/internal? procedure) + (block/internal? (procedure-block procedure))) + +(define (procedure/open-external? procedure) + (and (procedure/open? procedure) + (procedure/external? procedure))) + +(define (procedure/open-internal? procedure) + (and (procedure/open? procedure) + (procedure/internal? procedure))) \ No newline at end of file diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index db33ef18c..90dd26009 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.5 1987/08/07 17:03:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.1 1987/12/04 20:04:48 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,11 +32,65 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler DFG Datatypes: Right (Hand Side) Values +;;;; Right (Hand Side) Values (declare (usual-integrations)) -(define-rvalue constant value) +(define-root-type rvalue + %passed-out?) + +(define (make-rvalue tag . extra) + (list->vector (cons* tag false extra))) + +(define-enumeration rvalue-type + (block + constant + expression + procedure + reference + unassigned-test)) + +(define (rvalue-values rvalue) + (if (rvalue/reference? rvalue) + (reference-values rvalue) + (list rvalue))) + +(define (rvalue-passed-in? rvalue) + (and (rvalue/reference? rvalue) + (reference-passed-in? rvalue))) + +(define (rvalue-passed-out? rvalue) + (if (rvalue/reference? rvalue) + (reference-passed-out? rvalue) + (rvalue-%passed-out? rvalue))) + +(define (rvalue-known-value rvalue) + (if (rvalue/reference? rvalue) + (reference-known-value rvalue) + rvalue)) + +(define (rvalue-known-constant? rvalue) + (let ((value (rvalue-known-value rvalue))) + (and value + (rvalue/constant? value)))) + +(define (rvalue-constant-value rvalue) + (constant-value (rvalue-known-value rvalue))) + +(define (rvalue=? rvalue rvalue*) + (if (rvalue/reference? rvalue) + (if (rvalue/reference? rvalue*) + (lvalue=? (reference-lvalue rvalue) (reference-lvalue rvalue*)) + (eq? (lvalue-known-value (reference-lvalue rvalue)) rvalue*)) + (if (rvalue/reference? rvalue*) + (eq? rvalue (lvalue-known-value (reference-lvalue rvalue*))) + (eq? rvalue rvalue*)))) + +;;;; Constant + +(define-rvalue constant + value) + (define *constants*) (define (make-constant value) @@ -47,104 +101,89 @@ MIT in each case. |# (set! *constants* (cons (cons value constant) *constants*)) constant)))) -(define-unparser constant-tag +(define-vector-tag-unparser constant-tag (lambda (constant) (write-string "CONSTANT ") (write (constant-value constant)))) -(define-rvalue block parent children bound-variables free-variables procedure - declarations type closures combinations interned-variables closure-offsets frame) -(define *blocks*) +(define-integrable (rvalue/constant? rvalue) + (eq? (tagged-vector/tag rvalue) constant-tag)) + +;;;; Reference -(define (make-block parent) - (let ((block - (make-rvalue block-tag parent '() '() '() false - '() 'STACK '() '() '() '() false))) - (if parent - (set-block-children! parent (cons block (block-children parent)))) - (set! *blocks* (cons block *blocks*)) - block)) +(define-rvalue reference + block + lvalue + safe?) -(define-unparser block-tag - (lambda (block) - (write-string "BLOCK") - (let ((procedure (block-procedure block))) - (if procedure - (begin (write-string " ") - (write (procedure-label procedure))))))) +(define (make-reference block lvalue safe?) + (make-rvalue reference-tag block lvalue safe?)) -(define-rvalue reference block variable safe?) +(define-vector-tag-unparser reference-tag + (lambda (reference) + (write-string "REFERENCE ") + (write (variable-name (reference-lvalue reference))))) -(define (make-reference block variable) - (make-rvalue reference-tag block variable false)) +(define-integrable (rvalue/reference? rvalue) + (eq? (tagged-vector/tag rvalue) reference-tag)) -(define (make-safe-reference block variable) - (make-rvalue reference-tag block variable true)) +(define-integrable (reference-values reference) + (lvalue-values (reference-lvalue reference))) -(define-unparser reference-tag - (lambda (reference) - (write-string "REFERENCE ") - (write (variable-name (reference-variable reference))))) +(define-integrable (reference-passed-in? reference) + (lvalue-passed-in? (reference-lvalue reference))) + +(define-integrable (reference-passed-out? reference) + (lvalue-passed-out? (reference-lvalue reference))) + +(define-integrable (reference-known-value reference) + (lvalue-known-value (reference-lvalue reference))) + +(define (reference-to-known-location? reference) + (variable-in-known-location? (reference-block reference) + (reference-lvalue reference))) -(define-rvalue procedure block value fg-edge rgraph externally-visible? - closure-block label external-label name required optional rest - names values auxiliary original-parameters) -(define *procedures*) - -(define (make-procedure block subproblem name required optional rest - names values auxiliary) - (let ((procedure - (make-rvalue procedure-tag block (subproblem-value subproblem) - (cfg-entry-edge (subproblem-cfg subproblem)) - (rgraph-allocate) false false - (generate-label (variable-name name)) - (generate-label) name required optional rest - names values auxiliary (vector required optional rest)))) - (set-block-procedure! block procedure) - (vnode-connect! name procedure) - (set! *procedures* (cons procedure *procedures*)) - (symbol-hash-table/insert! *label->object* - (procedure-label procedure) - procedure) - procedure)) - -(define-integrable (procedure-fg-entry procedure) - (edge-right-node (procedure-fg-edge procedure))) - -(define-integrable (unset-procedure-fg-entry! procedure) - (set-procedure-fg-edge! procedure false)) - -(define-integrable (procedure-original-required procedure) - (vector-ref (procedure-original-parameters procedure) 0)) - -(define-integrable (procedure-original-optional procedure) - (vector-ref (procedure-original-parameters procedure) 1)) - -(define-integrable (procedure-original-rest procedure) - (vector-ref (procedure-original-parameters procedure) 2)) - -(define-unparser procedure-tag - (lambda (procedure) - (write-string "PROCEDURE ") - (write (procedure-label procedure)))) - -(define-integrable (label->procedure label) - (symbol-hash-table/lookup *label->object* label)) +;;; This type is only important while we use the `unassigned?' special +;;; form to perform optional argument defaulting. When we switch over +;;; to the new optional argument proposal we can flush this since the +;;; efficiency of this construct won't matter anymore. + +(define-rvalue unassigned-test + block + lvalue) + +(define (make-unassigned-test block lvalue) + (make-rvalue unassigned-test-tag block lvalue)) + +(define-vector-tag-unparser unassigned-test-tag + (lambda (unassigned-test) + (write-string "UNASSIGNED-TEST ") + (write (unassigned-test-lvalue unassigned-test)))) + +(define-integrable (rvalue/unassigned-test? rvalue) + (eq? (tagged-vector/tag rvalue) unassigned-test-tag)) -(define-rvalue quotation block value fg-edge rgraph label) -(define *quotations*) - -(define (make-quotation block subproblem) - (let ((quotation - (make-rvalue quotation-tag block (subproblem-value subproblem) - (cfg-entry-edge (subproblem-cfg subproblem)) - (rgraph-allocate) - (generate-label 'QUOTATION)))) - (set! *quotations* (cons quotation *quotations*)) - quotation)) - -(define-integrable (quotation-fg-entry quotation) - (edge-right-node (quotation-fg-edge quotation))) - -(define-integrable (unset-quotation-fg-entry! quotation) - (set-quotation-fg-edge! quotation false)) \ No newline at end of file +;;;; Expression + +(define-rvalue expression + block + continuation + entry-edge + label) + +(define *expressions*) + +(define (make-expression block continuation scfg) + (let ((expression + (make-rvalue expression-tag block continuation + (node->edge (cfg-entry-node scfg)) + (generate-label 'EXPRESSION)))) + (set! *expressions* (cons expression *expressions*)) + (set-block-procedure! block expression) + expression)) + +(define-integrable (rvalue/expression? rvalue) + (eq? (tagged-vector/tag rvalue) expression-tag)) + +(define-integrable (expression-entry-node expression) + (edge-next-node (expression-entry-edge expression))) \ No newline at end of file diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm new file mode 100644 index 000000000..73d5ad5b0 --- /dev/null +++ b/v7/src/compiler/base/scode.scm @@ -0,0 +1,132 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.1 1987/12/04 20:04:59 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Interface + +(declare (usual-integrations)) + +(let-syntax ((define-scode-operators + (macro names + `(BEGIN ,@(map (lambda (name) + `(DEFINE ,(symbol-append 'SCODE/ name) + (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))) + names))))) + (define-scode-operators + make-access access? access-components + access-environment access-name + make-assignment assignment? assignment-components + assignment-name assignment-value + make-combination combination? combination-components + combination-operator combination-operands + make-comment comment? comment-components + comment-expression comment-text + make-conditional conditional? conditional-components + conditional-predicate conditional-consequent conditional-alternative + make-declaration declaration? declaration-components + declaration-expression declaration-text + make-definition definition? definition-components + definition-name definition-value + make-delay delay? delay-components + delay-expression + make-disjunction disjunction? disjunction-components + conditional-predicate conditional-alternative + make-in-package in-package? in-package-components + in-package-environment in-package-expression + make-lambda lambda? lambda-components + make-open-block open-block? open-block-components + primitive-procedure? + make-quotation quotation? quotation-expression + make-sequence sequence-actions + symbol? + make-the-environment the-environment? + make-unassigned-object unassigned-object? + make-unassigned? unassigned?? unassigned?-name + make-unbound? unbound?? unbound?-name + make-variable variable? variable-components variable-name + )) + +(define-integrable (scode/make-constant const) + const) + +(define scode/constant? + (access scode-constant? system-global-environment)) + +(define-integrable (scode/constant-value const) + const) + +;;;; Absolute variables and combinations + +(define (scode/make-absolute-reference variable-name) + (scode/make-access '() variable-name)) + +(define (scode/absolute-reference? object) + (and (scode/access? object) + (null? (scode/access-environment object)))) + +(define (scode/absolute-reference-name reference) + (scode/access-name reference)) + +(define (scode/make-absolute-combination name operands) + (scode/make-combination (scode/make-absolute-reference name) operands)) + +(define (scode/absolute-combination? object) + (and (scode/combination? object) + (scode/absolute-reference? (scode/combination-operator object)))) + +(define (scode/absolute-combination-components combination receiver) + (scode/combination-components combination + (lambda (operator operands) + (receiver (scode/absolute-reference-name operator) operands)))) + +(define scode/error-combination? + (type-object-predicate error-combination-type)) + +(define (scode/error-combination-components combination receiver) + (scode/combination-components combination + (lambda (operator operands) + (receiver (car operands) + (let ((irritant (cadr operands))) + (cond ((scode/access? irritant) '()) + ((scode/absolute-combination? irritant) + (scode/absolute-combination-components irritant + (lambda (name operands) + (if (eq? name 'LIST) + operands + (list irritant))))) + (else (list irritant)))))))) + +(define (scode/make-error-combination message operand) + (scode/make-absolute-combination + 'ERROR-PROCEDURE + (list message operand (scode/make-the-environment)))) \ No newline at end of file diff --git a/v7/src/compiler/base/sets.scm b/v7/src/compiler/base/sets.scm index 7c5497fcf..7dfe0ed7e 100644 --- a/v7/src/compiler/base/sets.scm +++ b/v7/src/compiler/base/sets.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 1.2 1987/06/26 02:22:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 4.1 1987/12/04 20:05:03 cph Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -168,4 +168,30 @@ MIT in each case. |# (define (eqv-set-same-set? x y) (and (eqv-set-subset? x y) - (eqv-set-subset? y x))) \ No newline at end of file + (eqv-set-subset? y x))) + +(define (list->eq-set elements) + (if (null? elements) + '() + (eq-set-adjoin (car elements) + (list->eq-set (cdr elements))))) + +(define (list->eqv-set elements) + (if (null? elements) + '() + (eqv-set-adjoin (car elements) + (list->eqv-set (cdr elements))))) + +(define (map->eq-set procedure items) + (let loop ((items items)) + (if (null? items) + '() + (eq-set-adjoin (procedure (car items)) + (loop (cdr items)))))) + +(define (map->eqv-set procedure items) + (let loop ((items items)) + (if (null? items) + '() + (eqv-set-adjoin (procedure (car items)) + (loop (cdr items)))))) \ No newline at end of file diff --git a/v7/src/compiler/base/subprb.scm b/v7/src/compiler/base/subprb.scm new file mode 100644 index 000000000..d0e4ccb2a --- /dev/null +++ b/v7/src/compiler/base/subprb.scm @@ -0,0 +1,159 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.1 1987/12/04 20:05:10 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Subproblem Type + +(declare (usual-integrations)) + +#| + +Subproblems come in two forms, canonical and non-canonical. In a +canonical subproblem, the `prefix' is always exited by a return +statement whose operator is the subproblem's `continuation'. The +`rvalue' is always the parameter of the `continuation'. + +In a non-canonical subproblem, there is no `continuation' -- the +`rvalue' is sufficiently simple that no complex computation is +required to compute its value. Instead, the `prefix' is some setup +code that must be executed for effect, while the value of the +subproblem is just `rvalue'. + +The non-canonical subproblem is used as an optimization by several +parts of the compiler, where better code can be generated if it is +known that the continuation need not be used. + +|# + +(define-structure (subproblem + (constructor make-subproblem + (prefix continuation rvalue))) + (prefix false read-only true) + (continuation false read-only true) + (rvalue false read-only true) + (simple? 'UNKNOWN)) + +(set-type-object-description! + subproblem + (lambda (subproblem) + (descriptor-list subproblem prefix continuation rvalue simple?))) + +(define-integrable (subproblem-entry-node subproblem) + (cfg-entry-node (subproblem-prefix subproblem))) + +(define-integrable (subproblem-canonical? subproblem) + (procedure? (subproblem-continuation subproblem))) + +(define-integrable (subproblem-block subproblem) + ;; This is defined only for non-canonical subproblems. + (virtual-continuation/block (subproblem-continuation subproblem))) + +(define (subproblem-type subproblem) + (let ((continuation (subproblem-continuation subproblem))) + (if (procedure? continuation) + (continuation/type continuation) + (virtual-continuation/type continuation)))) + +(define (set-subproblem-type! subproblem type) + (let ((continuation (subproblem-continuation subproblem))) + (if (procedure? continuation) + (set-continuation/type! continuation type) + (set-virtual-continuation/type! continuation type)))) + +(define-integrable (subproblem-register subproblem) + (continuation*/register (subproblem-continuation subproblem))) + +(define (continuation*/register continuation) + (if (procedure? continuation) + (continuation/register continuation) + (virtual-continuation/register continuation))) + +;;;; Virtual Continuations + +;;; These are constructed in the FG generation phase for the purpose +;;; of delaying generation of real continuations until the last +;;; possible moment. After the FG generation, non-reified virtual +;;; continuations are used to hold several values that normally would +;;; have resided in the real continuation. + +(define-structure (virtual-continuation + (constructor virtual-continuation/%make (block parent type)) + (conc-name virtual-continuation/) + (print-procedure + (standard-unparser 'VIRTUAL-CONTINUATION + (lambda (continuation) + (let ((type (virtual-continuation/type continuation))) + (if type + (write + (enumeration/index->name continuation-types + type)))))))) + block + parent + type) + +(set-type-object-description! + virtual-continuation + (lambda (continuation) + `((VIRTUAL-CONTINUATION/BLOCK ,(virtual-continuation/block continuation)) + (VIRTUAL-CONTINUATION/PARENT ,(virtual-continuation/parent continuation)) + (VIRTUAL-CONTINUATION/TYPE ,(virtual-continuation/type continuation))))) + +(define-integrable (virtual-continuation/make block type) + ;; Used exclusively after FG generation. + (virtual-continuation/%make block false type)) + +(define-integrable (virtual-continuation/reified? continuation) + (not (virtual-continuation/type continuation))) + +(define-integrable virtual-continuation/reification + virtual-continuation/block) + +(define (virtual-continuation/reify! continuation) + ;; This is used only during FG generation when it is decided that we + ;; need a real continuation to handle a subproblem. + (if (virtual-continuation/type continuation) + (let ((reification + (make-continuation (virtual-continuation/block continuation) + (virtual-continuation/parent continuation) + (virtual-continuation/type continuation)))) + (set-virtual-continuation/block! continuation reification) + (set-virtual-continuation/parent! continuation false) + (set-virtual-continuation/type! continuation false) + reification) + (virtual-continuation/block continuation))) + +(define (virtual-continuation/register continuation) + (or (virtual-continuation/parent continuation) + (let ((register (rtl:make-pseudo-register))) + (set-virtual-continuation/parent! continuation register) + register))) \ No newline at end of file diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm new file mode 100644 index 000000000..3cfb3e55a --- /dev/null +++ b/v7/src/compiler/base/switch.scm @@ -0,0 +1,46 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.1 1987/12/04 20:05:15 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Option Switches + +(declare (usual-integrations)) + +(define compiler:enable-integration-declarations? false) +(define compiler:enable-expansion-declarations? false) +(define compiler:preserve-data-structures? true) +(define compiler:code-compression? true) +(define compiler:cache-free-variables? true) +(define compiler:implicit-self-static? false) +(define compiler:cse? true) +(define compiler:open-code-primitives? true) \ No newline at end of file diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm new file mode 100644 index 000000000..2503f8387 --- /dev/null +++ b/v7/src/compiler/base/toplev.scm @@ -0,0 +1,343 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.1 1987/12/04 20:05:18 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Top Level + +(declare (usual-integrations)) + +;;; Global variables +(define *input-scode*) +(define *ic-procedure-headers*) +(define *root-block*) +(define *root-expression*) +(define *rtl-expression*) +(define *rtl-procedures*) +(define *rtl-continuations*) +(define *rtl-graphs*) + +;;; These variable names mistakenly use the format "compiler:..." +;;; instead of the correct format, which is "*...*". Fix it sometime. +(define compiler:continuation-fp-offsets) +(define compiler:external-labels) +(define compiler:label-bindings) + +(define compiler:phase-wrapper false) +(define compiler:compile-time 0) + +(define (compile-bin-file input-string #!optional output-string) + (compiler-pathnames input-string + (and (not (unassigned? output-string)) output-string) + (make-pathname false false false "bin" 'NEWEST) + (lambda (input-pathname output-pathname) + (compile-scode (compiler-fasload input-pathname) + (pathname-new-type output-pathname "brtl") + (pathname-new-type output-pathname "binf"))))) + +(define (compiler-fasload pathname) + (let ((scode + (let ((scode (fasload pathname))) + (if (scode/comment? scode) + (scode/comment-expression scode) + scode)))) + (if (scode/open-block? scode) + (scode/open-block-components scode + (lambda (names declarations body) + (if (null? names) + (scan-defines body + (lambda (names declarations* body) + (make-open-block names + (append declarations declarations*) + body))) + scode))) + (scan-defines scode make-open-block)))) + +(define (compile-procedure procedure) + (scode-eval (compile-scode (procedure-lambda procedure)) + (procedure-environment procedure))) + +(define (compiler-pathnames input-string output-string default transform) + (let ((input-pathname + (pathname->input-truename + (merge-pathnames (->pathname input-string) default)))) + (if (not input-pathname) + (error "File does not exist" input-string)) + (let ((output-pathname + (let ((output-pathname (pathname-new-type input-pathname "com"))) + (if output-string + (merge-pathnames (->pathname output-string) output-pathname) + output-pathname)))) + (newline) + (write-string "Compile File: ") + (write (pathname->string input-pathname)) + (write-string " => ") + (write (pathname->string output-pathname)) + (fasdump (transform input-pathname output-pathname) output-pathname)))) + +(define (compile-scode scode + #!optional + rtl-output-pathname + info-output-pathname) + + (if (unassigned? rtl-output-pathname) + (set! rtl-output-pathname false)) + (if (unassigned? info-output-pathname) + (set! info-output-pathname false)) + + (in-compiler + (lambda () + (set! *input-scode* scode) + (phase/fg-generation) + (phase/simulate-application) + (phase/outer-analysis) + (phase/fold-constants) + (phase/open-coding-analysis) + (phase/operator-analysis) + (phase/identify-closure-limits) + (phase/setup-block-types) + (phase/continuation-analysis) + (phase/simplicity-analysis) + (phase/subproblem-ordering) + (phase/design-environment-frames) + (phase/rtl-generation) + (let ((n-registers + (map (lambda (rgraph) + (- (rgraph-n-registers rgraph) + number-of-machine-registers)) + *rtl-graphs*))) + (newline) + (write-string "Registers used: ") + (write (apply max n-registers)) + (write-string " max, ") + (write (apply min n-registers)) + (write-string " min, ") + (write (/ (apply + n-registers) (length n-registers))) + (write-string " mean")) +#| + (if info-output-pathname + (compiler:info-generation-1 info-output-pathname)) + (compiler:rtl-generation-cleanup) + (if compiler:cse? + (compiler:cse)) + (compiler:lifetime-analysis) + (if compiler:code-compression? + (compiler:code-compression)) + (if rtl-output-pathname + (compiler:rtl-file-output rtl-output-pathname)) + (compiler:register-allocation) + (compiler:rtl-optimization-cleanup) + (compiler:bit-generation) + (compiler:bit-linearization) + (compiler:assemble) + (if info-output-pathname + (compiler:info-generation-2 info-output-pathname)) + (compiler:link) + compiler:expression +|# + ))) + +(define (in-compiler thunk) + (fluid-let ((compiler:compile-time 0) + #|(*input-scode*) + (*current-label-number*) + (*constants*) + (*blocks*) + (*expressions*) + (*procedures*) + (*lvalues*) + (*applications*) + (*parallels*) + (*assignments*) + (*ic-procedure-headers*) + (*root-expression*) + (*root-block*) + (*rtl-expression*) + (*rtl-procedures*) + (*rtl-continuations*) + (*rtl-graphs*) + (compiler:continuation-fp-offsets) + (compiler:external-labels) + (compiler:label-bindings)|#) + (compiler:reset!) + (let ((value (thunk))) +; (compiler:reset!) + (newline) + (write-string "Total compilation time: ") + (write compiler:compile-time) + value))) + +(define (compiler:reset!) + (set! *input-scode*) + (set! *current-label-number*) + (set! *constants*) + (set! *blocks*) + (set! *expressions*) + (set! *procedures*) + (set! *lvalues*) + (set! *applications*) + (set! *parallels*) + (set! *assignments*) + (set! *ic-procedure-headers*) + (set! *root-expression*) + (set! *root-block*) + (set! *rtl-expression*) + (set! *rtl-procedures*) + (set! *rtl-continuations*) + (set! *rtl-graphs*) + (set! compiler:continuation-fp-offsets) + (set! compiler:external-labels) + (set! compiler:label-bindings)) + +(define (compiler-phase name thunk) + (write-line name) + (let ((delta + (let ((start-time (runtime))) + (if compiler:phase-wrapper + (compiler:phase-wrapper thunk) + (thunk)) + (- (runtime) start-time)))) + (set! compiler:compile-time (+ delta compiler:compile-time)) + (newline) + (write-string "Time taken: ") + (write delta))) +#| +(define-macro (last-reference name) + (let ((temp (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,temp name)) + (set! ,name) + ,temp)))) +|# + +(define (phase/fg-generation) + (compiler-phase 'FG-GENERATION + (lambda () + (set! *current-label-number* 0) + (set! *constants* '()) + (set! *blocks* '()) + (set! *expressions* '()) + (set! *procedures* '()) + (set! *lvalues* '()) + (set! *applications* '()) + (set! *parallels* '()) + (set! *assignments* '()) + (set! *root-expression* + ((access construct-graph fg-generator-package) *input-scode*)) + (set! *root-block* (expression-block *root-expression*)) + (if (or (null? *expressions*) + (not (null? (cdr *expressions*)))) + (error "Multiple expressions")) + (set! *expressions*)))) + +(define (phase/simulate-application) + (compiler-phase 'SIMULATE-APPLICATION + (lambda () + ((access simulate-application fg-analyzer-package) + *lvalues* + *applications*)))) + +(define (phase/outer-analysis) + (compiler-phase 'OUTER-ANALYSIS + (lambda () + ((access outer-analysis fg-analyzer-package) + *root-expression* + *procedures* + *applications*)))) + +(define (phase/fold-constants) + (compiler-phase 'FOLD-CONSTANTS + (lambda () + ((access fold-constants fg-analyzer-package) + *lvalues* + *applications*)))) + +(define (phase/open-coding-analysis) + (compiler-phase 'OPEN-CODING-ANALYSIS + (lambda () + ((access open-coding-analysis rtl-generator-package) + *applications*)))) + +(define (phase/operator-analysis) + (compiler-phase 'OPERATOR-ANALYSIS + (lambda () + ((access operator-analysis fg-analyzer-package) + *procedures* + *applications*)))) + +(define (phase/identify-closure-limits) + (compiler-phase 'IDENTIFY-CLOSURE-LIMITS + (lambda () + ((access identify-closure-limits! fg-analyzer-package) + *procedures* + *applications* + *assignments*)))) + +(define (phase/setup-block-types) + (compiler-phase 'SETUP-BLOCK-TYPES + (lambda () + ((access setup-block-types! fg-analyzer-package) + *root-block*)))) + +(define (phase/continuation-analysis) + (compiler-phase 'CONTINUATION-ANALYSIS + (lambda () + ((access continuation-analysis fg-analyzer-package) + *blocks* + *procedures*)))) + +(define (phase/simplicity-analysis) + (compiler-phase 'SIMPLICITY-ANALYSIS + (lambda () + ((access simplicity-analysis fg-analyzer-package) + *parallels*)))) + +(define (phase/subproblem-ordering) + (compiler-phase 'SUBPROBLEM-ORDERING + (lambda () + ((access subproblem-ordering fg-analyzer-package) + *parallels*)))) + +(define (phase/design-environment-frames) + (compiler-phase 'DESIGN-ENVIRONMENT-FRAMES + (lambda () + ((access design-environment-frames! fg-analyzer-package) + *blocks*)))) + +(define (phase/rtl-generation) + (compiler-phase 'RTL-GENERATION + (lambda () + (set! *rtl-procedures* '()) + (set! *rtl-continuations* '()) + (set! *rtl-graphs* '()) + ((access generate/top-level rtl-generator-package) *root-expression*)))) \ No newline at end of file diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 956bfacd7..b6ae61c61 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.92 1987/11/21 18:43:08 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.1 1987/12/04 20:05:24 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -57,6 +57,15 @@ MIT in each case. |# set*-only))))))) (loop set (list-copy set*) receiver))) +(define (discriminate-items items predicate) + (let loop ((items items) (passed '()) (failed '())) + (cond ((null? items) + (return-2 passed failed)) + ((predicate (car items)) + (loop (cdr items) (cons (car items) passed) failed)) + (else + (loop (cdr items) passed (cons (car items) failed)))))) + (define (generate-label #!optional prefix) (if (unassigned? prefix) (set! prefix 'LABEL)) (string->symbol @@ -71,7 +80,7 @@ MIT in each case. |# 'FLUID-LET) (else prefix))) "-" - (number->string (generate-label-number))))) + (number->string (generate-label-number) 10)))) (define *current-label-number*) @@ -103,6 +112,77 @@ MIT in each case. |# (let ((value (thunk))) (write-line (- (runtime) start)) value))) + +(define (list-filter-indices items indices) + (let loop ((items items) (indices indices) (index 0)) + (cond ((null? indices) '()) + ((= (car indices) index) + (cons (car items) + (loop (cdr items) (cdr indices) (1+ index)))) + (else + (loop (cdr items) indices (1+ index)))))) + +(define (there-exists? items predicate) + (let loop ((items items)) + (and (not (null? items)) + (or (predicate (car items)) + (loop (cdr items)))))) + +(define (for-all? items predicate) + (let loop ((items items)) + (or (null? items) + (and (predicate (car items)) + (loop (cdr items)))))) + +(define (all-eq? items) + (if (null? items) + (error "ALL-EQ? undefined for empty set")) + (or (null? (cdr items)) + (for-all? (cdr items) + (let ((item (car items))) + (lambda (item*) + (eq? item item)))))) + +(define (all-eq-map? items map) + (if (null? items) + (error "ALL-EQ-MAP? undefined for empty set")) + (let ((item (map (car items)))) + (if (or (null? (cdr items)) + (for-all? (cdr items) (lambda (item*) (eq? item (map item*))))) + (return-2 true item) + (return-2 false false)))) + +(define (eq-set-union* set sets) + (let loop ((set set) (sets sets) (accum '())) + (if (null? sets) + (eq-set-union set accum) + (loop (car sets) (cdr sets) (eq-set-union set accum))))) + +(package (transitive-closure enqueue-node! enqueue-nodes!) + +(define *queue*) + +(define-export (transitive-closure initialization process-node nodes) + (fluid-let ((*queue* true)) + (if initialization (initialization)) + (set! *queue* nodes) + (let loop () + (if (not (null? *queue*)) + (begin (let ((node (car *queue*))) + (set! *queue* (cdr *queue*)) + (process-node node)) + (loop)))))) + +(define-export (enqueue-node! node) + (if (and (not (eq? *queue* true)) + (not (memq node *queue*))) + (set! *queue* (cons node *queue*)))) + +(define-export (enqueue-nodes! nodes) + (if (not (eq? *queue* true)) + (set! *queue* (eq-set-union nodes *queue*)))) + +) ;;;; Symbol Hash Tables @@ -159,120 +239,25 @@ MIT in each case. |# (define-integrable string-hash-mod (ucode-primitive string-hash-mod)) -;;;; SCode Interface - -(let-syntax ((define-scode-operator - (macro (name) - `(DEFINE ,(symbol-append 'SCODE/ name) - (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))))) - (define-scode-operator access-components) - (define-scode-operator access?) - (define-scode-operator assignment?) - (define-scode-operator assignment-components) - (define-scode-operator assignment-name) - (define-scode-operator assignment-value) - (define-scode-operator combination-components) - (define-scode-operator combination?) - (define-scode-operator comment-expression) - (define-scode-operator comment-text) - (define-scode-operator comment?) - (define-scode-operator conditional-components) - (define-scode-operator definition-components) - (define-scode-operator delay?) - (define-scode-operator delay-expression) - (define-scode-operator disjunction-components) - (define-scode-operator in-package-components) - (define-scode-operator lambda-components) - (define-scode-operator lambda?) - (define-scode-operator make-access) - (define-scode-operator make-assignment) - (define-scode-operator make-combination) - (define-scode-operator make-comment) - (define-scode-operator make-conditional) - (define-scode-operator make-declaration) - (define-scode-operator make-definition) - (define-scode-operator make-disjunction) - (define-scode-operator make-lambda) - (define-scode-operator make-quotation) - (define-scode-operator make-sequence) - (define-scode-operator make-the-environment) - (define-scode-operator make-variable) - (define-scode-operator make-unassigned-object) - (define-scode-operator open-block-components) - (define-scode-operator open-block?) - (define-scode-operator primitive-procedure?) - (define-scode-operator procedure?) - (define-scode-operator quotation-expression) - (define-scode-operator sequence-actions) - (define-scode-operator unassigned-object?) - (define-scode-operator unassigned?-name) - (define-scode-operator unbound?-name) - (define-scode-operator variable-name) - (define-scode-operator variable?)) - -;;; Scode constants - -(define scode/constant? - (access scode-constant? system-global-environment)) - -(define scode/constant? - (access scode-constant? system-global-environment)) - -(define-integrable (scode/constant-value const) - const) - -(define-integrable (scode/make-constant const) - const) - -;;; Abolute variables and combinations - -(define (scode/make-absolute-reference variable-name) - (scode/make-access '() variable-name)) - -(define (scode/absolute-reference? obj) - (and (scode/access? obj) - (scode/access-components - obj - (lambda (environment name) - (null? environment))))) - -(define (scode/absolute-reference-name obj) - (scode/access-components obj (lambda (ignore name) name))) - -(define (scode/make-absolute-combination name operands) - (scode/make-combination (scode/make-absolute-reference name) operands)) - -(define (scode/absolute-combination? obj) - (and (scode/combination? obj) - (scode/combination-components - obj - (lambda (op ops) - (scode/absolute-reference? obj))))) +;;;; Type Codes -(define (scode/absolute-combination-components obj receiver) - (scode/combination-components - obj - (lambda (op ops) - (receiver (scode/absolute-reference-name op) ops)))) - -(define (scode/error-combination-components combination receiver) - (scode/combination-components combination - (lambda (operator operands) - (receiver (car operands) - (let ((irritant (cadr operands))) - (cond ((scode/access? irritant) '()) - ((scode/absolute-combination? irritant) - (scode/absolute-combination-components irritant - (lambda (name operands) - (if (eq? name 'LIST) - operands - (list irritant))))) - (else (list irritant)))))))) - -(define (scode/make-error-combination message operand) - (scode/make-absolute-combination - 'ERROR-PROCEDURE - (list message operand (scode/make-the-environment)))) +(let-syntax ((define-type-code + (macro (var-name #!optional type-name) + (if (unassigned? type-name) (set! type-name var-name)) + `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name) + ',(microcode-type type-name))))) + (define-type-code lambda) + (define-type-code extended-lambda) + (define-type-code procedure) + (define-type-code extended-procedure) + (define-type-code cell) + (define-type-code compiled-expression) + (define-type-code compiler-link) + (define-type-code compiled-procedure) + (define-type-code environment) + (define-type-code stack-environment) + (define-type-code return-address compiler-return-address) + (define-type-code unassigned)) (define (scode/procedure-type-code *lambda) (cond ((primitive-type? type-code:lambda *lambda) @@ -281,33 +266,24 @@ MIT in each case. |# type-code:extended-procedure) (else (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) - -(define (scode/make-let names values body) - (scode/make-combination (scode/make-lambda lambda-tag:let names '() false '() - '() body) - values)) -;;;; Type Codes +;;;; Primitive Procedures -(let-syntax ((define-type-code - (macro (var-name type-name) - `(define-integrable ,var-name ',(microcode-type type-name))))) - -(define-type-code type-code:lambda LAMBDA) -(define-type-code type-code:extended-lambda EXTENDED-LAMBDA) -(define-type-code type-code:procedure PROCEDURE) -(define-type-code type-code:extended-procedure EXTENDED-PROCEDURE) -(define-type-code type-code:cell CELL) -(define-type-code type-code:compiled-expression COMPILED-EXPRESSION) -(define-type-code type-code:compiler-link COMPILER-LINK) -(define-type-code type-code:compiled-procedure COMPILED-PROCEDURE) -(define-type-code type-code:environment ENVIRONMENT) -(define-type-code type-code:stack-environment STACK-ENVIRONMENT) -(define-type-code type-code:return-address COMPILER-RETURN-ADDRESS) -(define-type-code type-code:unassigned UNASSIGNED) -) - -;;; Disgusting hack to replace microcode implementation. +(define (primitive-procedure? object) + (or (eq? compiled-error-procedure object) + (scode/primitive-procedure? object))) + +(define (normal-primitive-procedure? object) + (or (eq? compiled-error-procedure object) + (and (scode/primitive-procedure? object) + (primitive-procedure-safe? object)))) + +(define (primitive-arity-correct? primitive argument-count) + (if (eq? primitive compiled-error-procedure) + (> argument-count 1) + (let ((arity (primitive-procedure-arity primitive))) + (or (= arity -1) + (= arity argument-count))))) (define (primitive-procedure-safe? object) (and (primitive-type? (ucode-type primitive) object) @@ -347,10 +323,6 @@ MIT in each case. |# (define lambda-tag:delay (make-named-tag "DELAY-LAMBDA")) -;; Primitives are non pointers, but need to be updated by the fasloader; -;; they cannot appear as immediate constants in the instruction stream. -;; Therefore, for the purposes of compilation, they are treated as pointers. - (define (non-pointer-object? object) (or (primitive-type? (ucode-type false) object) (primitive-type? (ucode-type true) object) @@ -369,17 +341,23 @@ MIT in each case. |# (eq? object compiled-error-procedure))) (define (operator-constant-foldable? operator) - (memq operator constant-foldable-operators)) - -(define constant-foldable-operators - (list primitive-type primitive-type? - eq? null? pair? number? complex? real? rational? integer? - zero? positive? negative? odd? even? exact? inexact? - = < > <= >= max min - + - * / 1+ -1+ abs quotient remainder modulo integer-divide - gcd lcm floor ceiling truncate round - exp log expt sqrt sin cos tan asin acos atan - (ucode-primitive &+) (ucode-primitive &-) - (ucode-primitive &*) (ucode-primitive &/) - (ucode-primitive &<) (ucode-primitive &>) - (ucode-primitive &=) (ucode-primitive &atan))) \ No newline at end of file + (memq operator constant-foldable-primitives)) + +(define constant-foldable-primitives + (append! + (list-transform-positive + (map (lambda (name) + (lexical-reference system-global-environment name)) + '(PRIMITIVE-TYPE PRIMITIVE-TYPE? + EQ? NULL? PAIR? NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? + ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT? + = < > <= >= MAX MIN + + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE + GCD LCM FLOOR CEILING TRUNCATE ROUND + EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN)) + (access primitive-procedure? system-global-environment)) + (list + (ucode-primitive &+) (ucode-primitive &-) + (ucode-primitive &*) (ucode-primitive &/) + (ucode-primitive &<) (ucode-primitive &>) + (ucode-primitive &=) (ucode-primitive &atan)))) \ No newline at end of file -- 2.25.1