1 |
|
;;; CMPCALL Function call. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
|
24 |
|
(defvar *ifuncall* nil) |
25 |
|
|
26 |
|
|
27 |
|
(eval-when (compile eval) |
28 |
|
(defmacro link-arg-p (x) |
29 |
|
`(let ((.u ,x)) |
30 |
|
(not (member .u '(character boolean long-float short-float))))) |
31 |
|
) |
32 |
|
|
33 |
|
(defun fast-link-proclaimed-type-p (fname &optional args) |
34 |
|
(and |
35 |
|
(symbolp fname) |
36 |
|
(and (< (the fixnum(length args)) 64) |
37 |
|
(or (and (get fname 'fixed-args) |
38 |
|
(listp args)) |
39 |
|
(and |
40 |
|
(get fname 'proclaimed-function) |
41 |
|
(link-arg-p (get fname 'proclaimed-return-type)) |
42 |
|
(dolist (v (get fname 'proclaimed-arg-types) t) |
43 |
|
(or (eq v '*)(link-arg-p v) (return nil)))))))) |
44 |
|
|
45 |
|
(si::putprop 'funcall 'c2funcall-aux 'wholec2) |
46 |
|
(si:putprop 'call-lambda 'c2call-lambda 'c2) |
47 |
|
(si:putprop 'call-global 'c2call-global 'c2) |
48 |
|
|
49 |
|
;;Like macro-function except it searches the lexical environment, |
50 |
|
;;to determine if the macro is shadowed by a function or a macro. |
51 |
|
(defun cmp-macro-function (name &aux fd) |
52 |
|
(cond ((setq fd (c1local-fun name)) |
53 |
|
(if (eq (car fd) 'call-local) nil fd)) |
54 |
|
(t (macro-function name)))) |
55 |
|
|
56 |
|
(defun c1funob (fun &aux fd) |
57 |
|
;;; NARGS is the number of arguments. If the number is unknown, (e.g. |
58 |
|
;;; in case of APPLY), then NARGS should be NIL. |
59 |
|
(cond ((and (consp fun) |
60 |
|
(symbolp (car fun)) |
61 |
|
(cmp-macro-function (car fun))) |
62 |
|
(setq fun (cmp-macroexpand fun)))) |
63 |
|
(or |
64 |
|
(and |
65 |
|
(consp fun) |
66 |
|
(or (and (eq (car fun) 'quote) |
67 |
|
(not (endp (cdr fun))) |
68 |
|
(endp (cddr fun)) |
69 |
|
(or (and (consp (cadr fun)) |
70 |
|
(not (endp (cdadr fun))) |
71 |
|
(eq (caadr fun) 'lambda) |
72 |
|
(let ((*vars* nil) (*funs* nil) (*blocks* nil) |
73 |
|
(*tags* nil)) |
74 |
|
(let ((lambda-expr (c1lambda-expr (cdadr fun)))) |
75 |
|
(list 'call-lambda (cadr lambda-expr) |
76 |
|
lambda-expr)))) |
77 |
|
(and (symbolp (cadr fun)) |
78 |
|
(or (and (setq fd (c1local-fun (cadr fun))) |
79 |
|
(eq (car fd) 'call-local) |
80 |
|
fd) |
81 |
|
(list 'call-global |
82 |
|
(make-info |
83 |
|
:sp-change |
84 |
|
(null (get (cadr fun) 'no-sp-change))) |
85 |
|
(cadr fun))) |
86 |
|
))) |
87 |
|
(and (eq (car fun) 'function) |
88 |
|
(not (endp (cdr fun))) |
89 |
|
(endp (cddr fun)) |
90 |
|
(or (and (consp (cadr fun)) |
91 |
|
(eq (caadr fun) 'lambda) |
92 |
|
(not (endp (cdadr fun))) |
93 |
|
(let ((lambda-expr (c1lambda-expr (cdadr fun)))) |
94 |
|
(list 'call-lambda (cadr lambda-expr) lambda-expr)) |
95 |
|
) |
96 |
|
(and (symbolp (cadr fun)) |
97 |
|
(or (and (setq fd (c1local-fun (cadr fun))) |
98 |
|
(eq (car fd) 'call-local) |
99 |
|
fd) |
100 |
|
(list 'call-global |
101 |
|
(make-info |
102 |
|
:sp-change |
103 |
|
(null (get (cadr fun) 'no-sp-change))) |
104 |
|
(cadr fun))) |
105 |
|
))))) |
106 |
|
(let ((x (c1expr fun)) (info (make-info :sp-change t))) |
107 |
|
(add-info info (cadr x)) |
108 |
|
(list 'ordinary info x)) |
109 |
|
)) |
110 |
|
|
111 |
|
|
112 |
|
(defun c2funcall-aux(form &aux (info (cadr form)) |
113 |
|
(funob (caddr form)) |
114 |
|
(args (cadddr form)) |
115 |
|
(loc (nth 4 form))) |
116 |
|
(c2funcall funob args loc info)) |
117 |
|
|
118 |
|
(defvar *use-sfuncall* t) |
119 |
|
(defvar *super-funcall* nil) |
120 |
|
|
121 |
|
(defun c2funcall (funob args &optional loc info) |
122 |
|
|
123 |
|
;;; Usually, ARGS holds a list of forms, which are arguments to the |
124 |
|
;;; function. If, however, the arguments are already pushed on the stack, |
125 |
|
;;; ARGS should be set to the symbol ARGS-PUSHED. |
126 |
|
(case (car funob) |
127 |
|
(call-global (c2call-global (caddr funob) args loc t)) |
128 |
|
(call-local (c2call-local (cddr funob) args)) |
129 |
|
(call-lambda (c2call-lambda (caddr funob) args)) |
130 |
|
(ordinary ;;; An ordinary expression. In this case, if |
131 |
|
;;; arguments are already pushed on the stack, then |
132 |
|
;;; LOC cannot be NIL. Callers of C2FUNCALL must be |
133 |
|
;;; responsible for maintaining this condition. |
134 |
|
(let ((*vs* *vs*) (form (caddr funob))) |
135 |
|
(declare (object form)) |
136 |
|
(cond ((and (listp args) |
137 |
|
*use-sfuncall* |
138 |
|
;;Determine if only one value at most is required: |
139 |
|
(or |
140 |
|
(eq *value-to-go* 'trash) |
141 |
|
(and (consp *value-to-go*) |
142 |
|
(eq (car *value-to-go*) 'var)) |
143 |
|
(and info (equal (info-type info) '(values t))) |
144 |
|
)) |
145 |
|
(c2funcall-sfun form args info) |
146 |
|
(return-from c2funcall nil))) |
147 |
|
(unless loc |
148 |
|
(unless (listp args) (baboon)) |
149 |
|
(cond ((eq (car form) 'LOCATION) (setq loc (caddr form))) |
150 |
|
((and (eq (car form) 'VAR) |
151 |
|
(not (args-info-changed-vars (caaddr form) args))) |
152 |
|
(setq loc (cons 'VAR (caddr form)))) |
153 |
|
(t |
154 |
|
(setq loc (list 'vs (vs-push))) |
155 |
|
(let ((*value-to-go* loc)) (c2expr* (caddr funob)))))) |
156 |
|
(push-args args) |
157 |
|
(if *compiler-push-events* |
158 |
|
(wt-nl "super_funcall(" loc ");") |
159 |
|
(if *super-funcall* |
160 |
|
(funcall *super-funcall* loc) |
161 |
|
(wt-nl "super_funcall_no_event(" loc ");"))) |
162 |
|
(unwind-exit 'fun-val))) |
163 |
|
(otherwise (baboon)) |
164 |
|
)) |
165 |
|
|
166 |
|
|
167 |
|
(defun fcalln-inline (&rest args &aux (f (car args)) length) |
168 |
|
(wt #\() |
169 |
|
(unless (and (consp f) (eq (car f) 'var)) |
170 |
|
(setq f (list 'cvar (cs-push))) |
171 |
|
(wt-nl f " = " (car args) ",")) |
172 |
|
(wt-nl "(type_of(" f ") == t_sfun ?" |
173 |
|
; "(*(object (*)())((" f ")->sfn.sfn_self)):") |
174 |
|
"(*((" f ")->sfn.sfn_self)):") |
175 |
|
(when (< *space* 3) |
176 |
|
(setq length t) |
177 |
|
(wt-nl "(fcall.argd=" (length (cdr args)) ",type_of("f")==t_vfun) ?") |
178 |
|
; (wt-nl "(*(object (*)())((" f ")->sfn.sfn_self)):")) |
179 |
|
(wt-nl "(*((" f ")->sfn.sfn_self)):")) |
180 |
|
(wt-nl "(fcall.fun=(" f "),") |
181 |
|
(unless length |
182 |
|
(wt "fcall.argd=" (length (cdr args)) ",")) |
183 |
|
(wt "fcalln))(") |
184 |
|
(when (cdr args) (wt (cadr args)) |
185 |
|
(dolist (loc (cddr args)) (wt #\, loc))) |
186 |
|
(wt #\) #\) )) |
187 |
|
|
188 |
|
(defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr))) |
189 |
|
(declare (object lambda-list)) |
190 |
|
(cond ((or (cadr lambda-list) ;;; Has optional? |
191 |
|
(caddr lambda-list) ;;; Has rest? |
192 |
|
(cadddr lambda-list) ;;; Has key? |
193 |
|
(not (listp args)) ;;; Args already pushed? |
194 |
|
) |
195 |
|
(when (listp args) ;;; Args already pushed? |
196 |
|
(let ((*vs* *vs*) (base *vs*)) |
197 |
|
(push-args-lispcall args) |
198 |
|
(when (need-to-set-vs-pointers lambda-list) |
199 |
|
(wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") |
200 |
|
(base-used) |
201 |
|
))) |
202 |
|
(c2lambda-expr lambda-list (caddr (cddr lambda-expr))) |
203 |
|
) |
204 |
|
(t |
205 |
|
(let ((l-length (length (car lambda-list))) |
206 |
|
(a-length (length args))) |
207 |
|
(or (eql a-length l-length) |
208 |
|
(cmperr "Calling lambda with ~a args not ~a" a-length |
209 |
|
l-length))) |
210 |
|
|
211 |
|
(c2let (car lambda-list) args (caddr (cddr lambda-expr))))) |
212 |
|
) |
213 |
|
|
214 |
|
(defun check-fname-args (fname args) |
215 |
|
(let ((a (get fname 'arg-types t))) |
216 |
|
(and (eq t a) (get fname 'si::structure-access) |
217 |
|
(setq a '(t))) |
218 |
|
(cond ((and (listp a) |
219 |
|
(listp args) |
220 |
|
(not (member '* a))) |
221 |
|
(or (eql (length a) (length args)) |
222 |
|
(cmpwarn "Wrong number of args for ~s: ~a instead of ~a." |
223 |
|
fname |
224 |
|
(length args) (length a))))))) |
225 |
|
|
226 |
|
(defun save-avma (fd) |
227 |
|
(when (and (not *restore-avma*) |
228 |
|
(setq *restore-avma* |
229 |
|
(or |
230 |
|
(member 'integer (car fd)) |
231 |
|
(eq (cadr fd) 'integer) |
232 |
|
(flag-p (caddr fd) is)))) |
233 |
|
(wt-nl "{ save_avma;") |
234 |
|
(inc-inline-blocks) |
235 |
|
(or (consp *inline-blocks*) |
236 |
|
(setq *inline-blocks* (cons *inline-blocks* 'restore-avma))))) |
237 |
|
|
238 |
|
|
239 |
|
|
240 |
|
|
241 |
|
|
242 |
|
(defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*)) |
243 |
|
;this is now done in get-inline-info |
244 |
|
; (and *Fast-link-compiling* (fast-link-proclaimed-type-p fname args) |
245 |
|
; (add-fast-link fname t args)) |
246 |
|
(if (inline-possible fname) |
247 |
|
(cond |
248 |
|
;;; Tail-recursive case. |
249 |
|
((and (listp args) |
250 |
|
*do-tail-recursion* |
251 |
|
*tail-recursion-info* |
252 |
|
(eq (car *tail-recursion-info*) fname) |
253 |
|
(member *exit* |
254 |
|
'(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT |
255 |
|
RETURN-LONG-FLOAT RETURN-OBJECT)) |
256 |
|
(tail-recursion-possible) |
257 |
|
(= (length args) (length (cdr *tail-recursion-info*)))) |
258 |
|
(let* ((*value-to-go* 'trash) |
259 |
|
(*exit* (next-label)) |
260 |
|
(*unwind-exit* (cons *exit* *unwind-exit*))) |
261 |
|
(c2psetq (mapcar #'(lambda (v) (list v nil)) |
262 |
|
(cdr *tail-recursion-info*)) |
263 |
|
args) |
264 |
|
(wt-label *exit*)) |
265 |
|
(unwind-no-exit 'tail-recursion-mark) |
266 |
|
(wt-nl "goto TTL;") |
267 |
|
(cmpnote "Tail-recursive call of ~s was replaced by iteration." fname)) |
268 |
|
|
269 |
|
;;; Open-codable function call. |
270 |
|
((and (listp args) |
271 |
|
(null loc) |
272 |
|
(setq fd (get-inline-info fname args return-type))) |
273 |
|
(let ((*inline-blocks* 0) |
274 |
|
(*restore-avma* *restore-avma*)) |
275 |
|
(save-avma fd) |
276 |
|
(unwind-exit (get-inline-loc fd args) nil fname) |
277 |
|
(close-inline-blocks))) |
278 |
|
|
279 |
|
;;; Call to a function whose C language function name is known. |
280 |
|
((setq fd (or (get fname 'Lfun) (get fname 'Ufun))) |
281 |
|
(check-fname-args fname args) |
282 |
|
(push-args args) |
283 |
|
(wt-nl fd "();") |
284 |
|
(unwind-exit 'fun-val nil fname) |
285 |
|
) |
286 |
|
|
287 |
|
( t; *Fast-link-compiling* |
288 |
|
(cond ((and |
289 |
|
(listp args) |
290 |
|
(< (the fixnum (length args)) 10) |
291 |
|
(or |
292 |
|
*ifuncall* |
293 |
|
(get fname 'ifuncall)) |
294 |
|
(progn (if (eq *value-to-go* 'top) (format t "~%Called with top:~a" fname)) t) |
295 |
|
(not (eq 'top *value-to-go*)) |
296 |
|
(null loc) |
297 |
|
) |
298 |
|
(let ((*inline-blocks* 0)) |
299 |
|
(unwind-exit (get-inline-loc (inline-proc fname args) args) |
300 |
|
nil fname) |
301 |
|
(close-inline-blocks))) |
302 |
|
(t |
303 |
|
(push-args args) |
304 |
|
(let ((num (add-fast-link fname nil args))) |
305 |
|
(wt-nl "(void) (*Lnk" num ")(") |
306 |
|
(if (get fname 'proclaimed-closure) (wt "Lclptr" num)) |
307 |
|
(wt ");") |
308 |
|
(unwind-exit 'fun-val nil fname))))) |
309 |
|
|
310 |
|
|
311 |
|
;;; Call to a function defined in the same file. |
312 |
|
((setq fd (assoc fname *global-funs*)) |
313 |
|
(push-args args) |
314 |
|
(wt-nl "L" (cdr fd) "();") |
315 |
|
(unwind-exit 'fun-val nil fname) |
316 |
|
) |
317 |
|
((eql fname 'funcall-c) |
318 |
|
(wt-funcall-c args)) |
319 |
|
|
320 |
|
;;; Otherwise. |
321 |
|
(t (c2call-unknown-global fname args loc t))) |
322 |
|
(c2call-unknown-global fname args loc nil)) |
323 |
|
) |
324 |
|
|
325 |
|
|
326 |
|
|
327 |
|
(defun add-fast-link (fname type args) |
328 |
|
(let (link link-info (n (add-symbol fname)) vararg) |
329 |
|
(cond (type |
330 |
|
;;should do some args checking in that case too. |
331 |
|
(let* (link-string tem argtypes |
332 |
|
(leng (and (listp args) (length args)))) |
333 |
|
(setq argtypes |
334 |
|
(cond ((get fname 'proclaimed-function) |
335 |
|
(get fname 'proclaimed-arg-types)) |
336 |
|
((setq tem (get fname ' fixed-args)) |
337 |
|
(cond ((si:fixnump tem) |
338 |
|
(or (equal leng tem) |
339 |
|
(cmpwarn "~a: Fixed args not fixed!" |
340 |
|
fname))) |
341 |
|
(t (setf (get fname 'fixed-args) leng))) |
342 |
|
(make-list leng :initial-element t)))) |
343 |
|
(and leng |
344 |
|
(or (eql leng (length argtypes)) |
345 |
|
(MEMBER '* ARGTYPES) |
346 |
|
(cmpwarn "~a called with ~a args, expected ~a " |
347 |
|
fname leng |
348 |
|
(length argtypes)))) |
349 |
|
(unless |
350 |
|
(cddr (setq link-info (assoc fname *function-links*))) |
351 |
|
(setq link-string |
352 |
|
(with-output-to-string |
353 |
|
(st) |
354 |
|
(format st "(*(LnkLI~d))(" n) |
355 |
|
(do ((com) |
356 |
|
(v argtypes (cdr v)) |
357 |
|
(i 0 (+ 1 i))) |
358 |
|
((null v)) |
359 |
|
(cond ((eq (car v) '*) |
360 |
|
(setq vararg t) |
361 |
|
(princ "#*" st)) |
362 |
|
(t |
363 |
|
(if com (princ "," st) (setq com t)) |
364 |
|
(format st "#~a" i)))) |
365 |
|
(princ ")" st) |
366 |
|
) |
367 |
|
) |
368 |
|
; (print (list 'link-string link-string)) |
369 |
|
; (format t "~{~a~#[~:;,~]~}" '(1 2 3 4)) |
370 |
|
; 1,2,3,4 |
371 |
|
|
372 |
|
(if vararg (setq link |
373 |
|
#'(lambda ( &rest l) |
374 |
|
(wt "(VFUN_NARGS="(length l) ",") |
375 |
|
(wt-inline-loc link-string l) |
376 |
|
(wt ")")))) |
377 |
|
|
378 |
|
(push (list fname argtypes |
379 |
|
(or (get fname 'proclaimed-return-type) |
380 |
|
t) |
381 |
|
(flags side-effect-p allocates-new-storage) |
382 |
|
(or link link-string) 'link-call) |
383 |
|
*inline-functions*) |
384 |
|
(setq link-info (list fname (format nil "LI~d" n) |
385 |
|
(or (get fname 'proclaimed-return-type) |
386 |
|
t) |
387 |
|
argtypes))))) |
388 |
|
(t |
389 |
|
(check-fname-args fname args) |
390 |
|
(setq link-info (list fname n |
391 |
|
(if (get fname 'proclaimed-closure) 'proclaimed-closure) |
392 |
|
)))) |
393 |
|
(pushnew link-info *function-links* :test 'equal) |
394 |
|
n)) |
395 |
|
|
396 |
|
(defun declaration-type (type) |
397 |
|
(cond ((equal type "") "void") |
398 |
|
((equal type "long ") "object ") |
399 |
|
(t type))) |
400 |
|
|
401 |
|
;;make a function which will be called hopefully only once, |
402 |
|
;;and will establish the link. |
403 |
|
(defun wt-function-link (x) |
404 |
|
(let ((name (first x)) |
405 |
|
(num (second x)) |
406 |
|
(type (third x)) |
407 |
|
(args (fourth x))) |
408 |
|
(cond |
409 |
|
((null type) |
410 |
|
(wt-nl1 "static void LnkT" |
411 |
|
num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}" |
412 |
|
)) |
413 |
|
((eql type 'proclaimed-closure) |
414 |
|
(wt-nl1 "static void LnkT" num |
415 |
|
"(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}")) |
416 |
|
(t |
417 |
|
;;change later to include above. |
418 |
|
;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr"))))) |
419 |
|
(wt-nl1 "static " (declaration-type (rep-type type)) " LnkT" num ) |
420 |
|
(cond ((or args (not (eq t type))) |
421 |
|
(let ((vararg (member '* args))) |
422 |
|
(wt "(object first,...){" |
423 |
|
(declaration-type (rep-type type)) "V1;" |
424 |
|
"va_list ap;va_start(ap,first);V1=call_" |
425 |
|
(if vararg "v" "") "proc_new(VV[" |
426 |
|
(add-object name)"],(void **)(void *)&Lnk" num ) |
427 |
|
(or vararg (wt "," (proclaimed-argd args type))) |
428 |
|
(wt ",first,ap);va_end(ap);return V1;}" ))) |
429 |
|
(t (wt "(){return call_proc0(VV[" (add-object name) |
430 |
|
"],(void **)(void *)&Lnk" num ");}" )))) |
431 |
|
(t (error "unknown link type ~a" type))) |
432 |
|
(setq name (symbol-name name)) |
433 |
|
(if (find #\/ name) (setq name (remove #\/ name))) |
434 |
|
(wt " /* " name " */") |
435 |
|
)) |
436 |
|
|
437 |
|
|
438 |
|
|
439 |
|
;;For funcalling when the argument is guaranteed to be a compiled-function. |
440 |
|
;;For (funcall-c he 3 4), he being a compiled function. (not a symbol)! |
441 |
|
(defun wt-funcall-c (args) |
442 |
|
(let ((fun (car args)) |
443 |
|
(real-args (cdr args)) |
444 |
|
loc) |
445 |
|
(cond ((eql (car fun) 'var) |
446 |
|
(let ((fun-loc (cons (car fun) (third fun)))) |
447 |
|
(when *safe-compile* |
448 |
|
(wt-nl "(type_of(") |
449 |
|
(wt-loc fun-loc) |
450 |
|
(wt ")==t_cfun)||FEinvalid_function(") |
451 |
|
(wt-loc fun-loc)(wt ");")) |
452 |
|
(push-args real-args) |
453 |
|
(wt-nl "(") |
454 |
|
(wt-loc fun-loc))) |
455 |
|
(t |
456 |
|
(setq loc (list 'cvar (incf *next-cvar*))) |
457 |
|
(let ((*value-to-go* loc)) |
458 |
|
(wt-nl |
459 |
|
"{object V" (second loc) ";") |
460 |
|
(c2expr* (car args)) |
461 |
|
(push-args (cdr args)) |
462 |
|
(wt "(V" (second loc))))) |
463 |
|
(wt ")->cf.cf_self ();") |
464 |
|
(and loc (wt "}"))) |
465 |
|
(unwind-exit 'fun-val)) |
466 |
|
|
467 |
|
(defun inline-proc (fname args &aux (n (length args)) res |
468 |
|
(obj (add-object fname))) |
469 |
|
(format t "~%Using ifuncall: ~a" fname) |
470 |
|
(let ((result |
471 |
|
(case n |
472 |
|
;(0 (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj))) |
473 |
|
(1 (list '(t) t (flags ans set) (format nil "ifuncall1(VV[~d],(#0))" obj) |
474 |
|
'ifuncall)) |
475 |
|
(2 (list '(t t) t (flags ans set) |
476 |
|
(format nil "ifuncall2(VV[~d],(#0),(#1))" obj) |
477 |
|
'ifuncall)) |
478 |
|
(t |
479 |
|
(list (make-list n :initial-element t) |
480 |
|
t (flags ans set) |
481 |
|
(format nil "ifuncall(VV[~a],~a~{,#~a~})" |
482 |
|
obj n |
483 |
|
(dotimes (i n(nreverse res)) |
484 |
|
(push i res))) |
485 |
|
'ifuncall))))) |
486 |
|
(push (cons fname result ) *inline-functions*) |
487 |
|
result |
488 |
|
)) |
489 |
|
|
490 |
|
|
491 |
|
(si:putprop 'simple-call 'wt-simple-call 'wt-loc) |
492 |
|
|
493 |
|
(defun wt-simple-call (cfun base n &optional (vv-index nil)) |
494 |
|
(wt "simple_" cfun "(") |
495 |
|
(when vv-index (wt "VV[" vv-index "],")) |
496 |
|
(wt "base+" base "," n ")") |
497 |
|
(base-used)) |
498 |
|
|
499 |
|
;;; Functions that use SAVE-FUNOB should reset *vs*. |
500 |
|
(defun save-funob (funob) |
501 |
|
(case (car funob) |
502 |
|
((call-lambda call-quote-lambda call-local)) |
503 |
|
(call-global |
504 |
|
(unless (and (inline-possible (caddr funob)) |
505 |
|
(or (get (caddr funob) 'Lfun) |
506 |
|
(get (caddr funob) 'Ufun) |
507 |
|
(assoc (caddr funob) *global-funs*))) |
508 |
|
(let ((temp (list 'vs (vs-push)))) |
509 |
|
(if *safe-compile* |
510 |
|
(wt-nl |
511 |
|
temp |
512 |
|
"=symbol_function(VV[" (add-symbol (caddr funob)) "]);") |
513 |
|
(wt-nl temp |
514 |
|
"=VV[" (add-symbol (caddr funob)) "]->s.s_gfdef;")) |
515 |
|
temp))) |
516 |
|
(ordinary (let* ((temp (list 'vs (vs-push))) |
517 |
|
(*value-to-go* temp)) |
518 |
|
(c2expr* (caddr funob)) |
519 |
|
temp)) |
520 |
|
(otherwise (baboon)) |
521 |
|
)) |
522 |
|
|
523 |
|
(defun push-args (args) |
524 |
|
(cond ((null args) (wt-nl "vs_base=vs_top;")) |
525 |
|
((consp args) |
526 |
|
(let ((*vs* *vs*) (base *vs*)) |
527 |
|
(dolist** (arg args) |
528 |
|
(let ((*value-to-go* (list 'vs (vs-push)))) |
529 |
|
(c2expr* arg))) |
530 |
|
(wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") |
531 |
|
(base-used))))) |
532 |
|
|
533 |
|
(defun push-args-lispcall (args) |
534 |
|
(dolist** (arg args) |
535 |
|
(let ((*value-to-go* (list 'vs (vs-push)))) |
536 |
|
(c2expr* arg)))) |
537 |
|
|
538 |
|
(defun c2call-unknown-global (fname args loc inline-p) |
539 |
|
(cond (*compiler-push-events* |
540 |
|
;;; Want to set up the return catcher. |
541 |
|
(unless loc |
542 |
|
(setq loc (list 'vs (vs-push))) |
543 |
|
(wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);")) |
544 |
|
(push-args args) |
545 |
|
(wt-nl "funcall_with_catcher(VV[" (add-symbol fname) "]," loc ");") |
546 |
|
(unwind-exit 'fun-val nil fname)) |
547 |
|
(loc |
548 |
|
;;; The function was already pushed. |
549 |
|
(push-args args) |
550 |
|
(if inline-p |
551 |
|
(if *safe-compile* |
552 |
|
(wt-nl "funcall_no_event(" loc ");") |
553 |
|
(wt-nl "CMPfuncall(" loc ");")) |
554 |
|
(wt-nl "funcall(" loc ");")) |
555 |
|
(unwind-exit 'fun-val)) |
556 |
|
((args-cause-side-effect args) |
557 |
|
;;; Evaluation of the arguments may cause side-effect. |
558 |
|
;;; Arguments are not yet pushed. |
559 |
|
(let ((base *vs*)) |
560 |
|
(setq loc (list 'vs (vs-push))) |
561 |
|
(if *safe-compile* |
562 |
|
(wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);") |
563 |
|
(wt-nl loc "=(VV[" (add-symbol fname) "]->s.s_gfdef);")) |
564 |
|
(push-args-lispcall args) |
565 |
|
(cond ((or (eq *value-to-go* 'return) |
566 |
|
(eq *value-to-go* 'top)) |
567 |
|
(wt-nl "lispcall") |
568 |
|
(when inline-p (wt "_no_event")) |
569 |
|
(wt "(base+" base "," (length args) ");") |
570 |
|
(base-used) |
571 |
|
(unwind-exit 'fun-val)) |
572 |
|
(t (unwind-exit |
573 |
|
(list 'SIMPLE-CALL |
574 |
|
(if inline-p "lispcall_no_event" "lispcall") |
575 |
|
base (length args)))))) |
576 |
|
) |
577 |
|
(t |
578 |
|
;;; Evaluation of the arguments causes no side-effect. |
579 |
|
;;; Arguments are not yet pushed. |
580 |
|
(let ((base *vs*)) |
581 |
|
(push-args-lispcall args) |
582 |
|
(cond ((or (eq *value-to-go* 'return) |
583 |
|
(eq *value-to-go* 'top)) |
584 |
|
(wt-nl "symlispcall") |
585 |
|
(when inline-p (wt "_no_event")) |
586 |
|
(wt "(VV[" (add-symbol fname) "],base+" base "," |
587 |
|
(length args) ");") |
588 |
|
(base-used) |
589 |
|
(unwind-exit 'fun-val nil fname)) |
590 |
|
(t (unwind-exit |
591 |
|
(list 'SIMPLE-CALL |
592 |
|
(if inline-p "symlispcall_no_event" "symlispcall") |
593 |
|
base (length args) (add-symbol fname)) |
594 |
|
nil fname)))) |
595 |
|
))) |