1
#| inline.jl -- function inlining
3
$Id: inline.jl,v 1.22 2001/08/08 06:00:22 jsh Exp $
5
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
7
This file is part of librep.
9
librep is free software; you can redistribute it and/or modify it
10
under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2, or (at your option)
14
librep is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
GNU General Public License for more details.
19
You should have received a copy of the GNU General Public License
20
along with librep; see the file COPYING. If not, write to
21
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
24
(declare (unsafe-for-call/cc))
26
(define-structure rep.vm.compiler.inline
28
(export compile-lambda-inline
34
rep.vm.compiler.modules
36
rep.vm.compiler.bindings)
38
(define inline-depth (make-fluid 0)) ;depth of lambda-inlining
39
(defconst max-inline-depth 8)
41
(defun push-inline-args (lambda-list args #!optional pushed-args-already tester)
44
(if (not pushed-args-already)
45
;; First of all, evaluate each argument onto the stack
47
(compile-form-1 (car args))
49
arg-count (1+ arg-count)))
50
;; Args already on stack
52
arg-count pushed-args-already))
53
;; Now the interesting bit. The args are on the stack, in
54
;; reverse order. So now we have to scan the lambda-list to
55
;; see what they should be bound to.
60
(mapc tester (get-lambda-vars lambda-list))
63
((symbolp lambda-list)
64
(setq bind-stack (cons (cons lambda-list args-left) bind-stack))
67
(case (car lambda-list)
68
((#!optional &optional) (setq state 'optional))
69
((#!rest &rest) (setq state 'rest))
70
;; XXX implement keyword params
71
((#!key) (compiler-error "can't inline `#!key' parameters"))
75
(compiler-error "required arg `%s' missing"
77
(setq bind-stack (cons (car lambda-list) bind-stack)
78
args-left (1- args-left))))
81
(let ((def (cdar lambda-list)))
83
(compile-form-1 (car def))
84
(emit-insn '(push ())))
86
(setq args-left (1- args-left)))
87
(setq bind-stack (cons (or (caar lambda-list)
88
(car lambda-list)) bind-stack)))
90
(setq bind-stack (cons (cons (car lambda-list) args-left)
94
(setq lambda-list (cdr lambda-list)))
96
(compiler-warning 'parameters
97
"%d unused %s to lambda expression"
98
args-left (if (= args-left 1) "parameter" "parameters")))
99
(cons args-left bind-stack))))
101
(defun pop-inline-args (bind-stack args-left setter)
102
;; Bind all variables
104
(if (consp (car bind-stack))
106
(compile-constant '())
107
(unless (null (cdr (car bind-stack)))
109
((= i (cdr (car bind-stack))))
112
(setter (car (car bind-stack))))
113
(setter (car bind-stack)))
115
(setq bind-stack (cdr bind-stack)))
116
;; Then pop any args that weren't used.
117
(while (> args-left 0)
120
(setq args-left (1- args-left))))
122
;; This compiles an inline lambda, i.e. FUN is something like
123
;; (lambda (LAMBDA-LIST...) BODY...)
124
;; If PUSHED-ARGS-ALREADY is true it should be a count of the number
125
;; of arguments pushed onto the stack (in reverse order). In this case,
127
(defun compile-lambda-inline (fun args #!optional pushed-args-already
129
(setq fun (compiler-macroexpand fun))
130
(when (>= (fluid-set inline-depth (1+ (fluid inline-depth)))
132
(fluid-set inline-depth 0)
133
(compiler-error "can't inline more than %d nested functions"
136
((lambda-list (nth 1 fun))
137
(body (nthcdr 2 fun))
138
(out (push-inline-args
139
lambda-list args pushed-args-already test-variable-bind))
140
(args-left (car out))
141
(bind-stack (cdr out)))
145
;; Set up the body for compiling, skip any interactive form or
147
(while (and (consp body)
148
(or (stringp (car body))
149
(and (consp (car body))
150
(eq (car (car body)) 'interactive))))
151
(setq body (cdr body)))
153
;; Now we have a list of things to bind to, in the same order
154
;; as the stack of evaluated arguments. The list has items
155
;; SYMBOL, (SYMBOL . ARGS-TO-BIND), or (SYMBOL . nil)
158
(emit-insn '(init-bind))
160
(pop-inline-args bind-stack args-left (lambda (x)
163
(call-with-lambda-record name lambda-list 0
165
(fix-label (lambda-label (current-lambda)))
166
(set-lambda-inlined (current-lambda) t)
167
(compile-body body return-follows)))
168
(emit-insn '(unbind))
170
;; Nothing to bind to. Just pop the evaluated args and
172
(while (> args-left 0)
175
(setq args-left (1- args-left)))
176
(call-with-lambda-record name lambda-list 0
178
(fix-label (lambda-label (current-lambda)))
179
(set-lambda-inlined (current-lambda) t)
180
(compile-body body return-follows))))))
181
(fluid-set inline-depth (1- (fluid inline-depth)))))
183
(define (pop-between top bottom)
184
(or (and (>= top bottom) (>= bottom 0))
186
(error "Invalid stack pointers: %d, %d" top bottom))
187
(when (/= top bottom)
189
(emit-insn '(pop-all))
190
(do ((sp top (1- sp)))
192
(emit-insn '(pop))))))
194
(define (unbind-between top bottom)
195
(cond ((= bottom -1) (emit-insn '(unbindall-0)))
197
(unless (<= top bottom)
198
(emit-insn '(unbindall))))
199
(t (do ((bp top (1- bp)))
201
(emit-insn '(unbind))))))
203
(defun compile-tail-call (lambda-record args)
204
(let* ((out (push-inline-args (lambda-args lambda-record)
205
args nil test-variable-ref))
206
(args-left (car out))
207
(bind-stack (cdr out)))
212
(when (binding-enclosed-p var)
214
(get-lambda-vars (lambda-args lambda-record)))
216
;; some of the parameter bindings may have been captured,
217
;; so rebind all of them
219
(unbind-between (fluid current-b-stack)
220
;; the 1- is so that the frame of
221
;; the function itself is also removed
222
(1- (lambda-bp lambda-record)))
223
(emit-insn '(init-bind))
224
(pop-inline-args bind-stack args-left emit-binding))
225
;; none of the bindings are captured, so just modify them
226
(pop-inline-args bind-stack args-left emit-varset)
227
(unbind-between (fluid current-b-stack)
228
(lambda-bp lambda-record)))
229
;; force the stack pointer to what it should be
230
(pop-between (fluid current-stack) (lambda-sp lambda-record))
231
(emit-insn `(jmp ,(lambda-label lambda-record))))))))
added
removed
lisp/rep/vm/compiler/inline.jl
