1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Simplifying LET nodes, i.e. calls to the LET primop.
; 1. Change the procedure to a JUMP procedure if necessary.
; 2. Check that the right number of arguments are present.
; 3. Substitute any values that can be substituted without reference to
; how they are used in the body; then remove the call if it is no
; longer necessary.
; 4. Try harder.
(define (simplify-let call)
(let ((proc (call-arg call 0)))
(if (eq? (lambda-type proc) 'jump)
(change-lambda-type proc 'cont))
(cond ((n= (length (lambda-variables proc))
(- (call-arg-count call) 1))
(bug "wrong number of arguments in ~S" call))
((or (null? (lambda-variables proc))
(substitute-let-arguments proc call quick-substitute))
(remove-body call))
(else
(really-simplify-let proc call)))))
; A value can be quickly substituted if it is a leaf node or if it has no
; side-effects and is used only once.
(define (quick-substitute var val)
(or (literal-node? val)
(reference-node? val)
(and (not (side-effects? val))
(null? (cdr (variable-refs var))))))
; Simplify the arguments and then repeatedly simplify the body of PROC
; and try substituting the arguments.
; If all the arguments can be substituted the call node is removed.
;
; SUBSTITUTE-JOIN-ARGUMENTS copies arguments in an attempt to remove
; conditionals via constant folding.
(define (really-simplify-let proc call)
(simplify-args call 1)
(let loop ()
(set-node-simplified?! proc #t)
(simplify-lambda-body proc)
(cond ((substitute-let-arguments proc call slow-substitute)
(remove-body call))
((substitute-join-arguments proc call)
(loop))
((not (node-simplified? proc))
(loop)))))
(define *duplicate-lambda-size* '-1) ; don't duplicate anything
(define *duplicate-jump-lambda-size* 1) ; duplicate one call
(define (slow-substitute var val)
(cond ((or (literal-node? val) (reference-node? val))
#t)
((call-node? val)
(let ((refs (variable-refs var)))
(and (not (null? refs))
(null? (cdr refs))
(or (not (side-effects? val 'allocate))
(and (not (side-effects? val 'allocate 'read))
(not-used-between? val (car refs)))))))
((every? called-node? (variable-refs var))
(simplify-known-cont-calls (variable-refs var) val)
(or (null? (cdr (variable-refs var)))
(case (lambda-type val)
((proc known-proc)
(small-node? val *duplicate-lambda-size*))
((jump)
(small-node? val *duplicate-jump-lambda-size*))
(else
#f))))
(else #f)))
; This only detects the following situation:
; (let (lambda (... var ...) (primop ... var ...))
; ... value ...)
; where the reference to VAR is contained within nested, non-writing calls
; This depends on there being no simple calls with WRITE side-effects
(define (not-used-between? call ref)
(let ((top (lambda-body (call-arg (node-parent call) 0))))
(let loop ((call (node-parent ref)))
(cond ((eq? call top) #t)
((or (not (call-node? call))
(eq? 'write (primop-side-effects (call-primop call))))
#f)
(else (loop (node-parent call)))))))
(define (simplify-known-cont-calls refs l-node)
(case (lambda-type l-node)
((proc)
(determine-lambda-protocol l-node refs))
((cont)
(bug "CONT lambda bound by LET ~S" l-node)))
(if (calls-known? l-node)
(simplify-known-lambda l-node)))
; ($some-RETURN <proc> . <args>)
; =>
; ($JUMP <proc> . <args>)
; could check argument reps as well
(define (add-return-mark call l-node arg-count)
(if (not (= (call-arg-count call) (+ arg-count 1)))
(bug '"call ~S to join ~S has the wrong number of arguments"
call l-node))
(set-call-primop! call (get-primop (enum primop jump))))
; Removed arguments to a lambda-node in call position.
; If any arguments are actually removed
; REMOVE-NULL-ARGUMENTS shortens the argument vector.
(define (substitute-let-arguments node call gone-proc)
(let* ((vec (call-args call))
(c (do ((vars (lambda-variables node) (cdr vars))
(i 1 (+ i 1))
(c 0 (if (keep-var-val (car vars) (vector-ref vec i) gone-proc)
c
(+ 1 c))))
((null? vars) c))))
(cond ((= (+ c 1) (call-arg-count call)) #t)
((= c 0) #f)
(else
(remove-unused-variables node)
(remove-null-arguments call (- (call-arg-count call) c))
#f))))
(define (keep-var-val var val gone-proc)
(cond ((and (unused? var)
(or (not (call-node? val))
(not (side-effects? val 'allocate 'read))))
(erase (detach val))
#f)
((gone-proc var val)
(substitute var val #t)
#f)
(else '#t)))
; VAL is simple enough to be substituted in more than one location if
; its body is a call with all leaf nodes.
; -- no longer used --
;(define (simple-lambda? val)
; (vector-every? (lambda (n)
; (and (not (lambda-node? n))
; (call-args (lambda-body val))))
(define (called-anywhere? var)
(any? called-node? (variable-refs var)))
|
