1
;;; CMPINLINE Open coding optimizer.
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
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)
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.
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.
22
(in-package 'compiler)
24
;;; Pass 1 generates the internal form
25
;;; ( id info-object . rest )
26
;;; for each form encountered.
28
;;; Change changed-vars and referrred-vars slots in info structure to arrays
29
;;; for dramatic compilation speed improvements when the number of variables
30
;;; are large, as occurs at present in running the random-int-form tester.
34
(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y))
35
(defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y)))
37
(defstruct (info (:copier old-copy-info))
38
(type t) ;;; Type of the form.
39
(sp-change nil) ;;; Whether execution of the form may change
40
;;; the value of a special variable *VS*.
41
(volatile nil) ;;; whether there is a possible setjmp
42
(changed-array (mia 10 0)) ;;; List of var-objects changed by the form.
43
(referred-array (mia 10 0))) ;;; List of var-objects referred in the form.
45
(defun copy-array (array)
46
(declare ((vector t) array))
47
(let ((new-array (mia (the fixnum (array-total-size array)) (length array))))
48
(declare ((vector t) new-array))
49
(do ((i 0 (1+ i))) ((>= i (length array)) new-array)
51
(setf (aref new-array i) (aref array i)))))
53
(defun copy-info (info)
54
(let ((new-info (old-copy-info info)))
55
(setf (info-referred-array new-info)
56
(copy-array (info-referred-array info)))
57
(setf (info-changed-array new-info)
58
(copy-array (info-changed-array info)))
61
(defun bsearchleq (x a i j le)
62
(declare (object x le) ((vector t) a) (fixnum i j))
64
(return-from bsearchleq (if (or le (and (< i (length a)) (eq x (aref a i)))) i (length a))))
65
(let* ((k (the fixnum (+ i (the fixnum (ash (the fixnum (- j i) ) -1)))))
67
(declare (fixnum k) (object y))
68
(cond ((si::objlt x y)
69
(bsearchleq x a i k le))
71
(t (bsearchleq x a (1+ k) j le)))))
73
(defun push-array (x ar s lin)
74
(declare (object x lin) ((vector t) ar) (fixnum s) (ignore lin))
76
; (do ((k s (1+ k))) ((or (eql k (length ar)) (si::objlt x (aref ar k)) (eq x (aref ar k))) k)
77
; (declare (fixnum k)))
78
; (bsearchleq x ar s (length ar)))))
79
(let ((j (bsearchleq x ar s (length ar) t)))
81
(when (and (< j (length ar)) (eq (aref ar j) x))
82
(return-from push-array -1))
83
(let ((ar (if (eql (length ar) (the fixnum (array-total-size ar)))
84
(adjust-array ar (the fixnum (* 2 (length ar))))
86
(declare ((vector t) ar))
87
(do ((i (length ar) (1- i))) ((<= i j))
89
(setf (aref ar i) (aref ar (the fixnum (1- i)))))
91
(setf (fill-pointer ar) (the fixnum (1+ (length ar))))
95
(defmacro do-array ((v oar) &rest body)
96
(let ((count (gensym)) (ar (gensym)))
98
(declare ((vector t) ,ar))
99
(do ((,count 0 (1+ ,count))) ((eql ,count (length ,ar)))
100
(declare (fixnum ,count))
101
(let ((,v (aref ,ar ,count)))
104
(defmacro in-array (v ar)
105
`(< (bsearchleq ,v ,ar 0 (length ,ar) nil) (length ,ar)))
108
(defmacro do-referred ((v info) &rest body)
109
`(do-array (,v (info-referred-array ,info)) ,@body))
110
(defmacro do-changed ((v info) &rest body)
111
`(do-array (,v (info-changed-array ,info)) ,@body))
112
(defmacro is-referred (var info)
113
`(in-array ,var (info-referred-array ,info)))
114
(defmacro is-changed (var info)
115
`(in-array ,var (info-changed-array ,info)))
116
(defmacro push-referred (var info)
117
`(push-array ,var (info-referred-array ,info) 0 nil))
118
(defmacro push-changed (var info)
119
`(push-array ,var (info-changed-array ,info) 0 nil))
120
(defmacro push-referred-with-start (var info s lin)
121
`(push-array ,var (info-referred-array ,info) ,s ,lin))
122
(defmacro push-changed-with-start (var info s lin)
123
`(push-array ,var (info-changed-array ,info) ,s ,lin))
124
(defmacro changed-length (info)
125
`(length (info-changed-array ,info)))
126
(defmacro referred-length (info)
127
`(length (info-referred-array ,info)))
130
(defvar *info* (make-info))
133
(declare (fixnum x y))
135
(return-from mlin nil))
137
(do ((tl y (ash tl -1)) (k -1 (1+ k))) ((eql tl 0) k)
138
(declare (fixnum k tl)))))
139
(declare (fixnum ly))
140
(let ((lyr (the fixnum (truncate y (the fixnum (1- ly))))))
141
(declare (fixnum lyr))
142
(> x (the fixnum (1+ lyr))))))
144
(defun add-info (to-info from-info)
145
;; Allow nil from-info without error CM 20031030
147
(return-from add-info to-info))
149
(lin)); (mlin (changed-length from-info) (changed-length to-info))))
150
(declare (fixnum s) (object lin))
151
(do-changed (v from-info)
152
(let ((res (push-changed-with-start v to-info s lin)))
153
(declare (fixnum res))
155
(setq s (the fixnum (1+ res)))))))
157
(lin)); (mlin (referred-length from-info) (referred-length to-info))))
158
(declare (fixnum s) (object lin))
159
(do-referred (v from-info)
160
(let ((res (push-referred-with-start v to-info s lin)))
161
(declare (fixnum res))
163
(setq s (the fixnum (1+ res)))))))
164
(when (info-sp-change from-info)
165
(setf (info-sp-change to-info) t))
166
;; Return to-info, CM 20031030
169
(defun args-info-changed-vars (var forms)
171
((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
172
(dolist** (form forms)
173
(when (is-changed var (cadr form))
174
(return-from args-info-changed-vars t))))
176
(t (dolist** (form forms nil)
177
(when (or (is-changed var (cadr form))
178
(info-sp-change (cadr form)))
179
(return-from args-info-changed-vars t)))))
182
;; Variable references in arguments can also be via replaced variables
183
;; (see gcl_cmplet.lsp) It appears that this is not necessary when
184
;; checking for changed variables, as matches would appear to require
185
;; that the variable not be replaced. It might be better to provide a
186
;; new slot in the var structure to point to the variable by which one
187
;; is replaced -- one would need to consider chains in such a case.
188
;; Here we match on the C variable reference, which should be complete.
191
(defun var-rep-loc (x)
193
(eq (var-kind x) 'replaced)
194
(consp (var-loc x)) ;; may not be necessary, but vars can also be replaced to 'locations
195
;; see gcl_cmplet.lsp
198
(defun is-rep-referred (var info)
199
(let ((rx (var-rep-loc var)))
200
(do-referred (v info)
201
(let ((ry (var-rep-loc v)))
202
(when (or (eql-not-nil (var-loc var) ry)
203
(eql-not-nil (var-loc v) rx)
205
(return-from is-rep-referred t))))))
207
(defun args-info-referred-vars (var forms)
209
((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
210
(dolist** (form forms nil)
211
(when (or (is-referred var (cadr form))
212
(is-rep-referred var (cadr form)))
213
(return-from args-info-referred-vars t))))
214
(t (dolist** (form forms nil)
215
(when (or (is-referred var (cadr form))
216
(is-rep-referred var (cadr form))
217
(info-sp-change (cadr form)))
218
(return-from args-info-referred-vars t))))
221
;;; Valid property names for open coded functions are:
223
;;; INLINE-SAFE safe-compile only
224
;;; INLINE-UNSAFE non-safe-compile only
226
;;; Each property is a list of 'inline-info's, where each inline-info is:
227
;;; ( types { type | boolean } side-effect new-object { string | function } ).
229
;;; For each open-codable function, open coding will occur only if there exits
230
;;; an appropriate property with the argument types equal to 'types' and with
231
;;; the return-type equal to 'type'. The third element
232
;;; is T if and only if side effects may occur by the call of the function.
233
;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side
234
;;; effects must be included in the compiled code.
235
;;; The forth element is T if and only if the result value is a new Lisp
236
;;; object, i.e., it must be explicitly protected against GBC.
238
(defvar *inline-functions* nil)
239
(defvar *inline-blocks* 0)
240
;;; *inline-functions* holds:
241
;;; (...( function-name . inline-info )...)
243
;;; *inline-blocks* holds the number of temporary cvars used to save
244
;;; intermediate results during evaluation of inlined function calls.
245
;;; This variable is used to close up blocks introduced to declare static
248
(defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer))
250
(defun inc-inline-blocks()
251
(cond ((consp *inline-blocks*)
252
(incf (car *inline-blocks*)))
253
(t (incf *inline-blocks*))))
255
(defun inline-args (forms types &optional fun &aux (locs nil) ii)
256
(do ((forms forms (cdr forms))
257
(types types (cdr types)))
258
((endp forms) (reverse locs))
259
(declare (object forms types))
260
(let ((form (car forms))
262
(declare (object form type))
264
(LOCATION (push (coerce-loc (caddr form) type) locs))
266
(cond ((args-info-changed-vars (caaddr form) (cdr forms))
267
(cond ((and (member (var-kind (caaddr form))
269
(eq type (var-kind (caaddr form))))
270
(let ((cvar (next-cvar)))
271
(wt-nl "{" (rep-type type) "V" cvar "= V"
272
(var-loc (caaddr form)) ";")
273
(push (list 'cvar cvar 'inline-args) locs)
274
(inc-inline-blocks)))
276
(let ((temp (wt-c-push)))
278
(wt-var (caaddr form) (cadr (caddr form)))
280
(push (coerce-loc temp type) locs)))))
281
((and (member (var-kind (caaddr form))
282
'(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER))
283
(not (eq type (var-kind (caaddr form)))))
284
(let ((temp (cs-push type)))
285
(wt-nl "V" temp " = "
286
(coerce-loc (cons 'var (caddr form)) type) ";")
287
(push (list 'cvar temp) locs)))
288
(t (push (coerce-loc (cons 'VAR (caddr form)) type)
291
(if (let ((fname (caddr form)))
292
(and (inline-possible fname)
293
(setq ii (get-inline-info
295
(info-type (cadr form))))
296
(progn (save-avma ii) t)))
297
(let ((loc (get-inline-loc ii (cadddr form))))
299
((or (and (flag-p (caddr ii) ans)(not *c-gc*))
301
(and (member (cadr ii)
302
'(FIXNUM LONG-FLOAT SHORT-FLOAT))
303
(not (eq type (cadr ii)))))
304
(let ((temp (cs-push type)))
305
(wt-nl "V" temp " = " (coerce-loc loc type) ";")
306
(push (list 'cvar temp) locs))
308
((or (need-to-protect (cdr forms) (cdr types))
309
;;if either new form or side effect,
310
;;we don't want double evaluation
311
(and (flag-p (caddr ii) allocates-new-storage)
313
;; Any fun such as list,list* which
314
;; does not cause side effects or
315
;; do double eval (ie not "@..")
319
fun '(list-inline list*-inline)))))
320
(flag-p (caddr ii) is)
321
(and (flag-p (caddr ii) set) ; side-effectp
322
(not (null (cdr forms)))))
326
(setq cvar (cs-push))
327
(wt-nl "V" cvar "= ")
329
(t (setq cvar (next-cvar))
330
(wt-nl "{" (rep-type type) "V" cvar "= ")
332
(fixnum (wt-fixnum-loc loc))
333
(integer (wt-integer-loc loc 'inline-args))
334
(character (wt-character-loc loc))
335
(long-float (wt-long-float-loc loc))
336
(short-float (wt-short-float-loc loc))
337
(otherwise (wt-loc loc)))
338
(inc-inline-blocks)))
340
(push (list 'cvar cvar 'inline-args) locs)
342
(t (push (coerce-loc loc type) locs))))
343
(let ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push)))))
344
(let ((*value-to-go* temp)) (c2expr* form))
345
(push (coerce-loc temp type) locs))))
347
(push (coerce-loc-structure-ref (cdr form) type)
350
(let ((vref (caddr form))
351
(form1 (cadddr form)))
352
(let ((*value-to-go* (cons 'var vref))) (c2expr* form1))
353
(cond ((eq (car form1) 'LOCATION)
354
(push (coerce-loc (caddr form1) type) locs))
356
(setq forms (list* form
357
(list 'VAR (cadr form) vref)
359
;; want (setq types (list* type type (cdr types)))
360
;; but type is first of types
361
(setq types (list* type types))))))
366
(list 'cvar (cs-push)))
367
(t (push (cons type (next-cvar)) *c-vars*)
375
:loc (cdar *c-vars*))
378
(t (list 'vs (vs-push))))))
379
(let ((*value-to-go* temp))
381
(push (coerce-loc temp type) locs))))))))
383
(defun coerce-loc (loc type)
385
(fixnum (list 'FIXNUM-LOC loc))
386
(integer (list 'integer-loc loc ))
387
(character (list 'CHARACTER-LOC loc))
388
(long-float (list 'LONG-FLOAT-LOC loc))
389
(short-float (list 'SHORT-FLOAT-LOC loc))
392
(defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)
393
;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.
394
(setq locs (inline-args args (car ii) fun))
395
(when (and (stringp fun) (char= (char (the string fun) 0) #\@))
396
(let ((i 1) (saves nil))
398
(do ((char (char (the string fun) i)
399
(char (the string fun) i)))
400
((char= char #\;) (incf i))
401
(declare (character char))
402
(push (the fixnum (- (char-code char) #.(char-code #\0))) saves)
404
(do ((l locs (cdr l))
407
((endp l) (setq locs (reverse locs1)))
408
(declare (fixnum n) (object l))
410
(let* ((loc1 (car l)) (loc loc1) (coersion nil))
411
(declare (object loc loc1))
412
(when (and (consp loc1)
414
'(FIXNUM-LOC integer-loc CHARACTER-LOC
415
LONG-FLOAT-LOC SHORT-FLOAT-LOC)))
416
(setq coersion (car loc1))
417
(setq loc (cadr loc1)) ; remove coersion
423
'(INLINE INLINE-COND))
424
(and (member (car loc)
426
INLINE-FIXNUM inline-integer
427
INLINE-CHARACTER INLINE-LONG-FLOAT
429
(or (flag-p (cadr loc) allocates-new-storage)
430
(flag-p (cadr loc) side-effect-p))
434
(let ((cvar (next-cvar)))
435
(push (list 'CVAR cvar) locs1)
437
((nil) (wt "object V" cvar "= ") (wt-loc loc1))
438
(FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc))
439
(integer-loc (wt "GEN V" cvar "= ") (wt-integer-loc loc
442
(wt "unsigned char V" cvar "= ") (wt-character-loc loc))
444
(wt "double V" cvar "= ") (wt-long-float-loc loc))
446
(wt "float V" cvar "= ") (wt-short-float-loc loc))
450
(t (push loc1 locs1))))
451
(push (car l) locs1)))))
452
(list (inline-type (cadr ii))
457
(defvar *inline-types*
458
'((boolean . INLINE-COND)
459
(fixnum . INLINE-FIXNUM)
460
(character . INLINE-CHARACTER)
461
(long-float . INLINE-LONG-FLOAT)
462
(short-float . INLINE-SHORT-FLOAT)
463
(integer . INLINE-INTEGER)
466
(defun inline-type (type)
467
(or (cdr (assoc type *inline-types*)) 'inline))
469
(defun get-inline-info (fname args return-type &aux x ii)
470
(and (fast-link-proclaimed-type-p fname args)
471
(add-fast-link fname return-type args))
472
(setq args (mapcar #'(lambda (form) (info-type (cadr form))) args))
473
(when (if *safe-compile*
474
(setq x (get fname 'inline-safe))
475
(setq x (get fname 'inline-unsafe)))
477
(when (setq ii (inline-type-matches y args return-type))
478
(return-from get-inline-info ii))))
479
(when (setq x (get fname 'inline-always))
481
(when (setq ii (inline-type-matches y args return-type))
482
(return-from get-inline-info ii))))
483
(dolist* (x *inline-functions*)
484
(when (and (eq (car x) fname)
485
(setq ii (inline-type-matches (cdr x) args return-type)))
486
(return-from get-inline-info ii)))
487
;; ( n . string , function ) or string , function
489
(when (and (setq x (get fname 'vfun))
490
(if (and (consp x) (typep (car x) 'fixnum))
491
(prog1 (>= (length args) (car x)) (setq x (cdr x)))
493
(return-from get-inline-info
494
(list (make-list (length args) :initial-element t)
495
t (flags allocates-new-storage side-effect-p)
497
(wt "(VFUN_NARGS="(length l) ",")
503
(defun inline-type-matches (inline-info arg-types return-type
505
(if (not (typep (third inline-info) 'fixnum))
506
(fix-opt inline-info))
507
(if (member 'integer (car inline-info))
508
(return-from inline-type-matches nil))
509
(if (and (let ((types (car inline-info)))
510
(declare (object types))
511
(dolist** (arg-type arg-types (or (equal types '(*))
513
(when (endp types) (return nil))
514
(cond ((equal types '(*))
515
(setq types '(t *))))
516
(cond ((eq (car types) 'fixnum-float)
517
(cond ((type>= 'fixnum arg-type)
519
((type>= 'long-float arg-type)
520
(push 'long-float rts))
521
((type>= 'short-float arg-type)
522
(push 'short-float rts))
524
((type>= (car types) arg-type)
525
(push (car types) rts))
528
(type>= (cadr inline-info) return-type))
529
(cons (reverse rts) (cdr inline-info))
533
(defun need-to-protect (forms types &aux ii)
534
(do ((forms forms (cdr forms))
535
(types types (cdr types)))
537
(declare (object forms types))
538
(let ((form (car forms)))
539
(declare (object form))
543
(when (or (args-info-changed-vars (caaddr form) (cdr forms))
544
(and (member (var-kind (caaddr form))
545
'(FIXNUM LONG-FLOAT SHORT-FLOAT))
547
(var-kind (caaddr form))))))
550
(let ((fname (caddr form)))
551
(declare (object fname))
553
(or (not (inline-possible fname))
554
(null (setq ii (get-inline-info
556
(info-type (cadr form)))))
557
(flag-p (caddr ii) allocates-new-storage)
558
(flag-p (caddr ii) set)
559
(flag-p (caddr ii) is)
560
(and (member (cadr ii)
561
'(fixnum long-float short-float))
562
(not (eq (car types) (cadr ii))))
563
(need-to-protect (cadddr form) (car ii)))
566
(when (need-to-protect (list (caddr form)) '(t))
572
(cond (*c-gc* (inc-inline-blocks)
573
(let ((tem (next-cvar)))
574
(wt "{" *volatile* "object V" tem ";")
576
(t (list 'VS (vs-push)))))
578
(defun close-inline-blocks ( &aux (bl *inline-blocks*))
580
(if (eql (cdr bl) 'restore-avma) (wt "restore_avma;"))
582
(dotimes** (i bl) (wt "}")))
584
(si:putprop 'inline 'wt-inline 'wt-loc)
585
(si:putprop 'inline-cond 'wt-inline-cond 'wt-loc)
586
(si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc)
587
(si:putprop 'inline-integer 'wt-inline-integer 'wt-loc)
588
(si:putprop 'inline-character 'wt-inline-character 'wt-loc)
589
(si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc)
590
(si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc)
592
(defun wt-inline-loc (fun locs &aux (i 0) (max -1))
593
(declare (fixnum i max))
595
(when (char= (char (the string fun) 0) #\@)
598
((char= (char (the string fun) i) #\;) (incf i))
600
(do ((size (length (the string fun))))
602
(declare (fixnum size ))
603
(let ((char (char (the string fun) i)))
604
(declare (character char))
605
(cond ((char= char #\#)
606
(let ((ch (char (the string fun)
607
(the fixnum (1+ i))))
611
(< (1+ max) (length locs)))
613
(do ((v (nthcdr (1+ max) locs) (cdr v)))
616
(if (cdr v) (wt ","))))
617
((digit-char-p ch 10)
618
(setq n (- (char-code ch)
621
(> (length fun) (+ i 2))
622
(progn (setq ch (char (the string fun)
629
(cond ((>= n max) (setq max n)))
630
(wt-loc (nth n locs)))))
633
(princ char *compiler-output1*)
636
(t (apply fun locs))))
638
(defun wt-inline (side-effectp fun locs)
639
(declare (ignore side-effectp))
640
(wt-inline-loc fun locs))
642
(defun wt-inline-cond (side-effectp fun locs)
643
(declare (ignore side-effectp))
644
(wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)"))
646
(defun wt-inline-fixnum (side-effectp fun locs)
647
(declare (ignore side-effectp))
648
(when (zerop *space*) (wt "CMP"))
649
(wt "make_fixnum((long)") (wt-inline-loc fun locs) (wt ")"))
651
(defun wt-inline-integer (side-effectp fun locs)
652
(declare (ignore side-effectp))
653
(wt "make_integer(") (wt-inline-loc fun locs) (wt ")"))
655
(defun wt-inline-character (side-effectp fun locs)
656
(declare (ignore side-effectp))
657
(wt "code_char(") (wt-inline-loc fun locs) (wt ")"))
659
(defun wt-inline-long-float (side-effectp fun locs)
660
(declare (ignore side-effectp))
661
(wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")"))
663
(defun wt-inline-short-float (side-effectp fun locs)
664
(declare (ignore side-effectp))
665
(wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")"))
667
(defun args-cause-side-effect (forms &aux ii)
668
(dolist** (form forms nil)
670
((LOCATION VAR structure-ref))
672
(let ((fname (caddr form)))
673
(declare (object fname))
674
(unless (and (inline-possible fname)
675
(setq ii (get-inline-info
677
(info-type (cadr form))))
679
(not (flag-p (caddr ii) side-effect-p)))
682
(otherwise (return t)))))
684
;;; Borrowed from CMPOPT.LSP
686
(defun list-inline (&rest x &aux tem (n (length x)))
688
(and (consp *value-to-go*)
689
(eq (car *value-to-go*) 'var)
690
(eq (var-type (second *value-to-go*)) :dynamic-extent)))
691
(wt "(ALLOCA_CONS(" n "),ON_STACK_LIST(" n))
692
(t (wt "list(" (length x))))
693
(dolist (loc x) (wt #\, loc))
699
(defun list*-inline (&rest x)
702
(2 (wt "make_cons(" (car x) "," (cadr x) ")"))
704
(wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\)))))
706
;;; Borrowed from LFUN_LIST.LSP
708
(defun defsysfun (fname cname-string arg-types return-type
709
never-change-special-var-p predicate)
710
;;; The value NIL for each parameter except for fname means "not known".
711
(when cname-string (si:putprop fname cname-string 'Lfun))
713
(si:putprop fname (mapcar #'(lambda (x)
714
(if (eq x '*) '* (type-filter x)))
715
arg-types) 'arg-types))
718
(let ((rt (function-return-type (if (atom return-type)
721
(or (consp rt) (setq rt (list rt)))
722
(si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt))
724
(when never-change-special-var-p (si:putprop fname t 'no-sp-change))
725
(when predicate (si:putprop fname t 'predicate))
added
removed
cmpnew/gcl_cmpinline.lsp
