source: project/release/3/prescheme-compiler/node/node.scm @ 11110

Last change on this file since 11110 was 11110, checked in by Ivan Raikov, 12 years ago

Imported prescheme sources.

File size: 16.1 KB
Line 
1
2; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
3
4; This file contains the definitions of the node tree data structure.
5
6;---------------------------------------------------------------------------
7; Records to represent variables.
8
9(define-record-type variable
10  ((name)        ; Source code name for variable (used for debugging only)
11   (id)          ; Unique numeric identifier     (used for debugging only)
12   (type)        ; Type for variable's value
13   )
14  (binder        ; LAMBDA node which binds this variable
15   (refs '())    ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
16   (flag #f)     ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
17                 ; all users must leave this is #F
18   (flags '())   ; For various annotations, e.g. IGNORABLE
19   (generate #f) ; For whatever code generation wants
20   ))
21
22(define-record-discloser type/variable
23  (lambda (var)
24    (node-hash var)
25    (list 'variable (variable-name var) (variable-id var))))
26
27(define (make-variable name type)
28  (variable-maker name (new-id) type))
29
30(define (make-global-variable name type)
31  (let ((var (make-variable name type)))
32    (set-variable-binder! var #f)
33    var))
34
35(define (global-variable? var)
36  (not (variable-binder var)))
37
38; Every variable has a unique numeric identifier that is used for printing.
39
40(define *variable-id* 0)
41
42(define (new-id)
43  (let ((id *variable-id*))
44    (set! *variable-id* (+ 1 *variable-id*))
45    id))
46
47(define (erase-variable var)
48  (cond ((eq? (variable-id var) '<erased>)
49         (bug "variable ~S already erased" var))
50        (else
51         (set-variable-id! var '<erased>))))
52
53(define *node-hash-table* #f)
54
55(define (reset-node-id)
56  (set! *variable-id* 0)
57  (set! *node-hash-table* (make-table)))
58
59(define (node-hash var-or-lambda)
60  (let ((id (if (variable? var-or-lambda)
61                (variable-id var-or-lambda)
62                (lambda-id var-or-lambda))))
63    (table-set! *node-hash-table* id var-or-lambda)))
64
65(define (node-unhash n)
66  (table-ref *node-hash-table* n))
67
68; The index of VAR in the variables bound by its binder.
69
70(define (variable-index var)
71  (let ((binder (variable-binder var)))
72    (if (not binder)
73        (bug "VARIABLE-INDEX called on global variable ~S" var)
74        (do ((i 0 (+ i 1))
75             (vs (lambda-variables binder) (cdr vs)))
76            ((eq? (car vs) var)
77             i)))))
78
79; Copy an old variable.
80
81(define (copy-variable old)
82  (let ((var (make-variable (variable-name old) (variable-type old))))
83    (set-variable-flags! var (variable-flags old))
84    var))
85
86; An unused variable is either #F or a variable with no references.
87
88(define (used? var)
89  (and var
90       (not (null? (variable-refs var)))))
91
92(define (unused? var)
93  (not (used? var)))
94
95; known values for top-level variables
96
97(define (flag-accessor flag)
98  (lambda (var)
99    (let ((p (flag-assq flag (variable-flags var))))
100      (if p (cdr p) #f))))
101
102(define (flag-setter flag)
103  (lambda (var value)
104    (set-variable-flags! var
105                         (cons (cons flag value)
106                               (variable-flags var)))))
107
108(define (flag-remover flag)
109  (lambda (var)
110    (set-variable-flags! var (filter (lambda (x)
111                                       (or (not (pair? x))
112                                           (not (eq? (car x) flag))))
113                                     (variable-flags var)))))
114 
115(define variable-known-value (flag-accessor 'known-value))
116(define add-variable-known-value! (flag-setter 'known-value))
117(define remove-variable-known-value! (flag-remover 'known-value))
118
119(define variable-simplifier (flag-accessor 'simplifier))
120(define add-variable-simplifier! (flag-setter 'simplifier))
121(define remove-variable-simplifier! (flag-remover 'simplifier))
122
123(define variable-known-lambda (flag-accessor 'known-lambda))
124(define note-known-global-lambda! (flag-setter 'known-lambda))
125
126;----------------------------------------------------------------------------
127; The main record for the node tree
128
129(define-record-type node
130  ((variant)           ; One of LAMBDA, CALL, REFERENCE, LITERAL
131   )
132  ((parent empty)      ; Parent node
133   (index '<free>)     ; Index of this node in parent
134   (simplified? #f)    ; True if it has already been simplified.
135   (flag #f)           ; Useful flag, all users must leave this is #F
136   stuff-0             ; Variant components - each type of node has a different
137   stuff-1             ; use for these fields
138   stuff-2
139   stuff-3
140   ))
141
142(define-record-discloser type/node
143  (lambda (node)
144    `(node ,(node-variant node)
145           . ,(case (node-variant node)
146                ((lambda)
147                 (node-hash node)
148                 (list (lambda-name node) (lambda-id node)))
149                ((call)
150                 (list (primop-id (call-primop node))))
151                ((reference)
152                 (let ((var (reference-variable node)))
153                   (list (variable-name var) (variable-id var))))
154                ((literal)
155                 (list (literal-value node)))
156                (else
157                 '())))))
158
159(define make-node node-maker)
160
161;--------------------------------------------------------------------------
162; EMPTY is used to mark empty parent and child slots in nodes.
163
164(define empty
165  (list 'empty))
166
167(define (empty? obj) (eq? obj empty))
168
169(define (proclaim-empty probe)
170  (cond ((not (empty? probe))
171         (bug "not empty - ~S" probe))))
172
173;----------------------------------------------------------------------------
174; This walks the tree rooted at NODE and removes all pointers that point into
175; this tree from outside.
176
177(define (erase node)
178  (let label ((node node))
179    (cond ((empty? node)
180           #f)
181          (else
182           (case (node-variant node)
183             ((lambda)
184              (label (lambda-body node)))
185             ((call)
186              (walk-vector label (call-args node))))
187           (really-erase node)))))
188
189; This does the following:
190; Checks that this node has not already been removed from the tree.
191;
192; Reference nodes are removed from the refs list of the variable they reference.
193;
194; For lambda nodes, the variables are erased, non-CONT lambdas are removed from
195; the *LAMBDAS* list (CONT lambdas are never on the list).
196;
197; Literal nodes whose values have reference lists are removed from those
198; reference lists.
199
200(define (really-erase node)
201  (cond ((empty? node)
202         #f)
203        (else
204         (cond ((eq? (node-index node) '<erased>)
205                (bug "node erased twice ~S" node))
206               ((reference-node? node)
207                (let ((var (reference-variable node)))
208                  (set-variable-refs! var
209                                      (delq! node (variable-refs var)))))
210               ((lambda-node? node)
211                (for-each (lambda (v)
212                            (if v (erase-variable v)))
213                          (lambda-variables node))
214                (if (neq? (lambda-type node) 'cont)
215                    (delete-lambda node))
216                (set-lambda-variables! node '()))  ; safety
217               ((literal-node? node)
218                (let ((refs (literal-refs node)))
219                  (if refs
220                      (set-literal-reference-list!
221                       refs
222                       (delq! node (literal-reference-list refs)))))))
223;        (erase-type (node-type node))
224         (set-node-index! node '<erased>))))
225
226;---------------------------------------------------------------------------
227; CONNECTING AND DISCONNECTING NODES
228;
229; There are two versions of each of these routines, one for value nodes
230; (LAMBDA, REFERENCE, or LITERAL), and one for call nodes.
231
232; Detach a node from the tree.
233
234(define (detach node)
235  (vector-set! (call-args (node-parent node))
236               (node-index node)
237               empty)
238  (set-node-index! node #f)
239  (set-node-parent! node empty)
240  node)
241
242(define (detach-body node)
243  (set-lambda-body! (node-parent node) empty)
244  (set-node-index! node #f)
245  (set-node-parent! node empty)
246  node)
247
248; Attach a node to the tree.
249
250(define (attach parent index child)
251  (proclaim-empty (node-parent child))
252  (proclaim-empty (vector-ref (call-args parent) index))
253  (vector-set! (call-args parent) index child)
254  (set-node-parent! child parent)
255  (set-node-index! child index)
256  (values))
257
258(define (attach-body parent call)
259  (proclaim-empty (node-parent call))
260  (proclaim-empty (lambda-body parent))
261  (set-lambda-body! parent call)
262  (set-node-parent! call parent)
263  (set-node-index! call '-1)
264  (values))
265
266; Replace node in tree with value of applying proc to node.
267; Note the fact that a change has been made at this point in the tree.
268
269(define (move node proc)
270  (let ((parent (node-parent node))
271        (index (node-index node)))
272    (detach node)
273    (let ((new (proc node)))
274      (attach parent index new)
275      (mark-changed new))))
276
277(define (move-body node proc)
278  (let ((parent (node-parent node)))
279    (detach-body node)
280    (let ((new (proc node)))
281      (attach-body parent new)
282      (mark-changed new))))
283
284; Put CALL into the tree as the body of lambda-node PARENT, making the current
285; body of PARENT the body of lambda-node CONT.
286
287(define (insert-body call cont parent)
288  (move-body (lambda-body parent)
289             (lambda (old-call)
290               (attach-body cont old-call)
291               call)))
292
293; Replace old-node with new-node, noting that a change has been made at this
294; point in the tree.
295
296(define (replace old-node new-node)
297  (let ((index (node-index old-node))
298        (parent (node-parent old-node)))
299    (mark-changed old-node)
300    (erase (detach old-node))
301    (attach parent index new-node)
302    (set-node-simplified?! new-node #f)
303    (values)))
304
305(define (replace-body old-node new-node)
306  (let ((parent (node-parent old-node)))
307    (mark-changed old-node)
308    (erase (detach-body old-node))
309    (attach-body parent new-node)
310    (set-node-simplified?! new-node #f)
311    (values)))
312
313; Starting with the parent of NODE, set the SIMPLIFIED? flags of the
314; ancestors of NODE to be #F.
315
316(define (mark-changed node)
317  (do ((p (node-parent node) (node-parent p)))
318      ((or (empty? p)
319           (not (node-simplified? p))))
320    (set-node-simplified?! p #f)))
321
322;-------------------------------------------------------------------------
323; Syntax for defining the different types of nodes.
324
325(define-syntax define-node-type
326  (lambda (form rename compare)
327    (let ((id (cadr form))
328          (slots (cddr form)))
329      (let ((pred (concatenate-symbol id '- 'node?)))
330        `(begin (define (,pred x)
331                  (eq? ',id (node-variant x)))
332                . ,(do ((i 0 (+ i 1))
333                        (s slots (cdr s))
334                        (r '() (let ((n (concatenate-symbol id '- (car s)))
335                                     (f (concatenate-symbol 'node-stuff- i)))
336                                 `((define-node-field ,n ,pred ,f)
337                                   . ,r))))
338                       ((null? s) (reverse r))))))))
339
340; These are used to rename the NODE-STUFF fields of particular node variants.
341
342(define-syntax define-node-field
343  (lambda (form rename compare)
344    (let ((id (cadr form))
345          (predicate (caddr form))
346          (field (cadddr form)))
347      `(begin
348         (define (,id node)
349           (,field (enforce ,predicate node)))
350         (define (,(concatenate-symbol 'set- id '!) node val)
351           (,(concatenate-symbol 'set- field '!)
352            (enforce ,predicate node)
353            val))))))
354
355;-------------------------------------------------------------------------
356; literals
357
358(define-node-type literal
359  value  ; the value
360  type   ; the type of the value
361  refs   ; either #F or a literal-reference record; only a few types of literal
362  )      ; literal values require reference lists
363
364(define-record-type literal-reference
365  ()
366  ((list '())  ; list of literal nodes that refer to a particular value
367   ))
368
369(define make-literal-reference-list literal-reference-maker)
370
371(define (make-literal-node value type)
372  (let ((node (make-node 'literal)))
373    (set-literal-value! node value)
374    (set-literal-type!  node type)
375    (set-literal-refs!  node #f)
376    node))
377
378(define (copy-literal-node node)
379  (let ((new (make-node 'literal))
380        (refs (literal-refs node)))
381    (set-literal-value! new (literal-value node))
382    (set-literal-type!  new (literal-type  node))
383    (set-literal-refs!  new refs)
384    (if refs (set-literal-reference-list!
385              refs
386              (cons new (literal-reference-list refs))))
387    new))
388
389(define (make-marked-literal value refs)
390  (let ((node (make-node 'literal)))
391    (set-literal-value!   node value)
392    (set-literal-refs!    node refs)
393    (set-literal-reference-list! refs
394                                 (cons node (literal-reference-list refs)))
395    node))
396
397;-------------------------------------------------------------------------
398; These just contain an identifier.
399
400(define-node-type reference
401  variable
402  )
403
404(define (make-reference-node variable)
405  (let ((node (make-node 'reference)))
406    (set-reference-variable! node variable)
407    (set-variable-refs! variable (cons node (variable-refs variable)))
408    node))
409
410; Literal and reference nodes are leaf nodes as they do not contain any other
411; nodes.
412
413(define (leaf-node? n)
414  (or (literal-node? n)
415      (reference-node? n)))
416
417;--------------------------------------------------------------------------
418; Call nodes
419
420(define-node-type call
421  primop     ; the primitive being called
422  args       ; vector of child nodes
423  exits      ; the number of arguments that are continuations
424  source     ; source info
425  )
426
427; Create a call node with primop P, N children and EXITS exits.
428
429(define (make-call-node primop n exits)
430  (let ((node (make-node 'call)))
431    (set-call-primop! node primop)
432    (set-call-args!   node (make-vector n empty))
433    (set-call-exits!  node exits)
434    (set-call-source! node #f)
435    node))
436
437(define (call-arg call index)
438  (vector-ref (call-args call) index))
439
440(define (call-arg-count call)
441  (vector-length (call-args call)))
442
443;----------------------------------------------------------------------------
444; LAMBDA NODES
445
446(define-node-type lambda
447  body       ; the call-node that is the body of the lambda
448  variables  ; a list of variable records with #Fs for ignored positions
449  source     ; source code for the lambda (if any)
450  data       ; a LAMBDA-DATA record (lambdas have more associated data than
451  )          ; the other node types.)
452
453(define-subrecord lambda lambda-data lambda-data
454  ((name)          ; symbol          (for debugging only)
455   id              ; unique integer  (for debugging only)
456   (type))         ; PROC, KNOWN-PROC, CONT, or JUMP (maybe ESCAPE at some point)
457  ((block #f)      ; either a basic-block (for flow analysis) or a code-block
458                   ; (for code generation).
459   (env #f)        ; a record containing lexical environment data
460   (protocol #f)   ; calling protocol from the source language
461   (prev #f)       ; previous node on *LAMBDAS* list
462   (next #f)       ; next node on *LAMBDAS* list
463   ))
464
465; Doubly linked list of all non-CONT lambdas
466(define *lambdas* #f)
467
468(define (initialize-lambdas)
469  (set! *lambdas* (make-lambda-node '*lambdas* 'cont '()))
470  (link-lambdas *lambdas* *lambdas*))
471
472(define (link-lambdas node1 node2)
473  (set-lambda-prev! node2 node1)
474  (set-lambda-next! node1 node2))
475
476(define (add-lambda node)
477  (let ((next (lambda-next *lambdas*)))
478    (link-lambdas *lambdas* node)
479    (link-lambdas node next)))
480
481(define (delete-lambda node)
482  (link-lambdas (lambda-prev node) (lambda-next node))
483  (set-lambda-prev! node #f)
484  (set-lambda-next! node #f))
485
486(define (walk-lambdas proc)
487  (do ((n (lambda-next *lambdas*) (lambda-next n)))
488      ((eq? n *lambdas*))
489    (proc n))
490  (values))
491
492(define (make-lambda-list)
493  (do ((n (lambda-next *lambdas*) (lambda-next n))
494       (l '() (cons n l)))
495      ((eq? n *lambdas*)
496       l)))
497
498(define (add-lambdas nodes)
499  (for-each add-lambda nodes))
500
501;    Create a lambda node.  NAME is used as the name of the lambda node's
502; self variable.  VARS is a list of variables.  The VARIABLE-BINDER slot
503; of each variable is set to be the new lambda node.
504
505(define (make-lambda-node name type vars)
506  (let ((node (make-node 'lambda))
507        (data (lambda-data-maker name (new-id) type)))
508    (set-lambda-body!      node empty)
509    (set-lambda-variables! node vars)
510    (set-lambda-data!      node data)
511    (set-lambda-source!    node #f)
512    (for-each (lambda (var)
513                (if var (set-variable-binder! var node)))
514              vars)
515    (if (neq? type 'cont)
516        (add-lambda node))
517    node))
518
519; Change the type of lambda-node NODE to be TYPE.  This may require adding or
520; deleting NODE from the list *LAMBDAS*.
521
522(define (change-lambda-type node type)
523  (let ((has (lambda-type node)))
524    (cond ((neq? type (lambda-type node))
525           (set-lambda-type! node type)
526           (cond ((eq? type 'cont)
527                  (delete-lambda node))
528                 ((eq? has 'cont)
529                  (add-lambda node)))))
530    (values)))
531
532(define (lambda-variable-count node)
533  (length (lambda-variables node)))
534
535(define (calls-known? node)
536  (neq? (lambda-type node) 'proc))
537
538(define (set-calls-known?! node)
539  (set-lambda-type! node 'known-proc))
540
541(define (proc-lambda? node)
542  (or (eq? 'proc (lambda-type node))
543      (eq? 'known-proc (lambda-type node))))
544
Note: See TracBrowser for help on using the repository browser.