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

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

Some updates to the node module.

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