3
(eval-when (compile load eval)
5
(defmacro opt (key opt)
6
`(nth ,(position key '(args return flag template )) ,opt))
8
(eval-when (eval compile load)
10
(defun flags-pos (flag &aux (i 0))
13
(cond ((member flag v :test 'eq)
14
(return-from flags-pos i)))
16
(error "unknown opt flag"))
20
'((allocates-new-storage ans) ; might invoke gbc
21
(side-effect-p set) ; no effect on arguments
22
(constantp) ; always returns same result,
24
(result-type-from-args rfa) ; if passed args of matching
25
;type result is of result type
26
(is);; extends the `integer stack'.
27
(mv);; in a declaration, function may return MV.
28
(safe);; can be used at safety 3
30
(touch-mv);;Invoking this may alter the MV locations.
31
(not-1-val) ;; obsoluete
32
(proclaim) ; do a proclaim.
35
(defmacro flags (&rest lis &aux (i 0))
37
(setq i (logior i (ash 1 (flags-pos v)))))
41
(defun print-flag (n &optional safe)
43
(dotimes (i (length *flags*))
44
(if (logbitp i n) (format t " ~(~s~)"(car (last (nth i *flags*))) )))
45
(if safe (princ " safe"))
50
;; Convert old AKCL opts.
52
(defun print-opt (sym prop &aux tem )
53
(unless (get 'compiler::boolean 'comp-type)
54
(setf (get 'compiler::boolean 'comp-type) 'boolean)
55
(setf (get :dynamic-extent 'comp-type) 'dynamic-extent)
56
(setf (get 'compiler::fixnum-float 'comp-type) 'fix-or-sf-or-df))
57
(cond ((setq tem (get sym prop))
58
(format t "~%(defopt ~s" sym)
59
(let ((*print-case* :downcase))
60
(dolist (v (reverse tem))
61
(format t "~% (~s ~s " (mapcar 'comp-type (car v))
62
(comp-type (second v)))
63
(print-flag (third v) (eq prop 'compiler::inline-always))
65
(if (stringp (fourth v))
66
(substitute #\$ #\# (fourth v))
70
(defun convert-old (&rest props &aux syms)
71
(sloop for pack in '(lisp si compiler)
73
(sloop for v in-package pack
74
when (sloop for w in props when (get v w) return t)
76
(setq syms (sort syms #'(lambda (x y) (string-lessp (symbol-name x)
79
do (sloop for w in props
82
;(with-open-file (*standard-output* "/tmp/opts1.lsp" :direction :output) (convert-old 'compiler::inline-always 'compiler::inline-unsafe))
83
;(load "/tmp/opts.lsp")
84
;(with-open-file (*standard-output* "/tmp/opts.lsp" :direction :output) (convert-old 'bcomp-opt))
88
(defmacro defopt (fname &rest l)
89
;; adds additional opts to the front.
90
;; last added is most significant.
91
`(defopt1 ',fname ',l))
92
(defun defopt1 (fname l)
94
(let ((fl (opt flag v)))
95
(cond ((flag-p fl proclaim)
96
(proclaim1 `(ftype (function ,(opt args v) ,(opt return v)) ,fname)))))
97
(push v (get fname 'bcomp-opt))))
99
(defmacro flag-p (n flag)
100
`(logbitp ,(flags-pos flag) ,n))
102
(setf (get 'aref 'coerce-arg-types) '(t fixnum fixnum fixnum fixnum))
103
(setf (get 'si::aset1 'coerce-arg-types) '(t fixnum ))
107
(defun get-inline-template (fname fdecl arg-types ret-type type-wanted
110
(mask (if (> *safety* 0) ;*unsafe*
113
(declare (fixnum mask opt-flag))
114
(or (symbolp fname) (wfs-error))
115
(setq lis (get fname 'bcomp-opt))
116
(or lis (return-from get-inline-template nil))
117
(cond ((eq type-wanted 'mv)
120
(and fdecl (not (flag-p (second fdecl) mv)))
121
;function proclaimed to return 1 arg
122
(setq mask (logior mask #. (flags mv)
124
(when (setq tem (get fname 'coerce-arg-types))
125
(sloop for v on arg-types
127
unless (eq w t) do (setf (car v) (type-and (car v) w))))
128
(if (member type-wanted *immediate-types*)
129
(setq ret-type type-wanted))
130
(sloop for opt in lis
132
(setq opt-ret (opt return opt))
133
(setq opt-flag (opt flag opt))
134
;; check return return matches
138
(eql mask (logand opt-flag mask))
141
(comp-subtypep ret-type opt-ret)))
144
for w on (opt args opt)
146
(cond ((eq (car w) '*)
147
(return-from get-inline-template opt))
148
((or (comp-subtypep (car v) (car w)) (return nil))))
150
(cond ((eq (car w) '*)
151
(return-from get-inline-template opt))
152
((and (null v) (null w))
153
(return-from get-inline-template opt))))))
156
(defun result-from-args (sym argl &aux arg-types)
157
(let ((tem (get sym 'bcomp-opt)))
159
(sloop for opt in tem
160
when (flag-p (opt flag opt) rfa)
161
do (or arg-types (setq arg-types (mapcar 'result-type argl)))
164
for w on (opt args opt)
166
(cond ((eq (car w) '*)
167
(return-from result-from-args (opt return opt)))
168
((or (subtypep (car v) (car w)) (return nil))))
170
(cond ((eq (car w) '*)
171
(return-from result-from-args (opt return opt))
173
((and (null v) (null w))
174
(return-from result-from-args (opt return opt))
176
(cond ((get sym 'arithmetic-contagion)
177
(or arg-types (setq arg-types (mapcar 'result-type argl)))
179
(or (member 'double-float arg-types )
180
(member 'short-float arg-types)))
181
(if (and tem (sloop for v in arg-types
182
always (or (subtypep v 'fixnum)
183
(subtypep v 'double-float)
184
(subtypep v 'short-float))))
185
(return-from result-from-args (car tem)))
188
(dolist (v '(* + - 1- 1+ /)) (setf (get v 'arithmetic-contagion) t))
190
;; symbol_value ;; the result depends on WHEN the form is evaluated.
191
;; list ;; Different invocations give different results with same
192
;; args, but order of eval is not important. Double EVAL is.
193
;; (add x y) ;; May be multiple eval'd. WHEN is not important.
194
;; (aref x i) ;; May be multiple eval'd. WHEN is important.
195
;; (set x 3) ;; May be multiple eval'd. Changes something in x. WHEN important.
197
;; by 'not side-effect' in the property of an inline, means that it may be
198
;; multiple eval'd as long as there were no intervening operation which does
199
;; not have the no-side-effect property, and the results would be same EXCEPT,
200
;; that we might get a different storage location.
202
;; by allocates-new-storage we mean that storage is allocated.
204
;; A function which has no-side-effect and 'not allocates-new-storage'
205
;; must return eq results if multiple-eval'd with no intervening
206
;; no-side-effect function.
208
;; Call a function foo and goo `unordered' if
209
;; (setq a (goo x y))
210
;; (setq b (foo x y))
211
;; Then no common lisp function could tell whether a or b was computed first.
212
;; The set of 'not side-effect' functions are unordered.
214
;; This is the case for LIST, CONS, MAKE-ARRAY, APPEND, AREF, ..
216
(defun inline-args (args arg-types &aux type-wanted)
217
;; returns (cons arglist referred-vars)
218
;; where REFERRED-VARS is a list of vars which will be eval'd
219
;; during the inline writeout of the forms in ARGLIST. The
220
;; list of these variables is necessary so that INLINE-CALL
221
;; may produce this list.
223
;; we check thru each ARG, and any one which we find which does not
224
;; meet the following criteria, is pre eval'd as a temp.
225
;; 1: Are them selves inline calls to functions with 'not side-effect-p' flag
226
;; 2: Refer to vars which are setq'd by subsequent inline-calls (since
227
;; it will be to late to eliminate them then. Those setq's will actually
228
;; be written out in the preevalling. )
229
;; 3: lexical or special vars unless the last arg.
231
;; eg (foo x (progn (setq x 3) 7)) would require saving initial value of x in a
232
;; temp, because it is changed by a subsequent arg.
233
;; In (foo (progn (setq x 3) 7) x (+ x y)) the second x and the (+ x y)
234
;; could stay and be inlined.
235
;; All user functions are presumed to have 'side-effect-p'
237
(sloop for v on args with referred = (cons nil nil)
239
(or (equal arg-types '(*)) (pop arg-types)))
240
collect (inline-arg (car v) type-wanted (cdr v) referred) into all
241
finally (setf (car referred) all)
244
(defun function-constant-p (x)
245
;; a function which returns something which will be the SAME for a given
246
;; set of arguments, where SAME means that there would not be a way in common lisp
247
;; of distinguishing between two results of an invocation OTHER than using eq.
248
(member x '(+ * list cons)))
250
(defun remaining-args-constant (rest &aux cd)
257
(unless (and (function-constant-p (call-data-fname cd))
258
(remaining-args-constant (call-data-arglist cd)))
263
(defun is-var-changed (var subsequent-args &aux cd)
264
(sloop for v in subsequent-args
266
(cond ((or (atom v) (eq (car v) 'var) (eq (car v) 'dv)) nil)
267
((not (plain-var-p var))
271
(function-constant-p (call-data-fname cd))
272
(not (is-var-changed var (call-data-arglist cd))))
274
((typep (second v) 'desk)
275
(return (memq var (desk-changed-vars (second v)))))
278
(defun inline-arg(a type-wanted rest referred &aux referred-vars result n tem)
279
;; a value which can be written inline as an arg, and
280
;; sets referred-vars
282
(when (eq type-wanted 'fix-or-sf-or-df)
283
(let ((x (car (member (result-type a) '(fixnum short-float double-float)))))
284
(and x (setq type-wanted x))))
286
(when (eq type-wanted 'double_ptr)
287
(let ((v (get-temp 'double-float))
288
(tem (inline-arg a 'double-float rest referred)))
289
(wr-set-inline-loc v tem)
290
(return-from inline-arg (list 'address v))))
293
(or (typep a 'var) (wfs-error))
295
(cond ((or (null rest)
296
(remaining-args-constant rest)
298
(not (is-var-changed a rest))))
299
(push a (cdr referred)))
300
(t (setq result (get-temp (var-implementation-type a)))
301
(wr-nl result "=" a ";")))
302
(or (eq (var-implementation-type a) type-wanted)
303
(setq result (list 'inline-loc type-wanted result))))
304
((eq (car a) 'var) ;a temp var
306
(or (eq (third a) type-wanted)
307
(setq result (list 'inline-loc type-wanted result))))
309
(setq result (add-data a))
310
(or (eq t type-wanted)
311
(setq result (list 'inline-loc type-wanted result))))
313
(setq result (inline-arg (third a) type-wanted rest referred)))
315
(setq result (inline-call a type-wanted ))
317
(setf referred-vars (car result)
318
(car result) 'inline-call)
319
(let ((templ (cddr result))
321
(setq n (opt flag templ))
322
(cond ( ;; need a temp:
323
(or (not (or (flag-p n constantp)
324
(and (not (flag-p n set))
325
(not (flag-p n ans)))))
326
(and (typep (setq tem1 (fourth templ)) 'link)
327
(or (argd-flag-p (link-argd tem1) requires-nargs)
328
(argd-flag-p (link-argd tem1) requires-fun-passed))))
329
(setq tem (get-temp type-wanted)))
331
(sloop for referred-var in referred-vars
332
when (is-var-changed referred-var rest)
333
do (setq tem (get-temp (opt return templ)))
336
(setq referred-vars nil)
337
(wr-set-inline-loc tem result)
339
(unless (eq (opt return templ) type-wanted)
341
(list 'inline-loc type-wanted result)))
343
(setf (cdr referred) (nconc referred-vars (cdr referred))))
345
(t (setq result (get-temp type-wanted))
346
(when *do-pending-open*
347
(setq *do-pending-open* nil)(open-block))
348
(valex (list 'var result) (next-exit) (expr-b2 a))
353
(defun constant-inline-fixnum(x &aux y)
354
(or (and (consp x) (eq (car x) 'inline-loc)
355
(eq (second x) 'fixnum)
356
(and (consp (setq y (third x)))
358
(typep (third y) 'fixnum)))
362
(setf (get 'boole 'bo2) 'bo2-boole)
364
(defun bo2-boole(a type-wanted arg-types)
365
(when (and (equal arg-types '(fixnum fixnum fixnum))
366
(dv-p (car (call-data-arglist (third a)))))
367
(do-inline-call 'boole3 a 'fixnum)))
369
(defun wr-inline-boole3 (iargs)
370
(wr-inline-call1 (cdr iargs)
371
(ecase (constant-inline-fixnum (car iargs))
372
(#.boole-ior "(($0) | ($1))" )
373
(#.boole-xor "(($0) ^ ($1))" )
374
(#.boole-and "(($0) & ($1))" )
375
(#.boole-eqv "(~(($0) ^ ($1)))" )
376
(#.boole-nand "(~(($0) & ($1)))" )
377
(#.boole-nor "(~(($0) | ($1)))" )
378
(#.boole-andc1 "((~($0)) & ($1))" )
379
(#.boole-andc2 "(($0) & (~($1)))" )
380
(#.boole-orc1 "((~($0)) | ($1))" )
381
(#.boole-orc2 "(($0) | (~($1)))" )
383
(#.boole-set "(-1)" )
384
(#.boole-1 "(($0))" )
385
(#.boole-2 "(($1))" )
386
(#.boole-c1 "(~($0))" )
387
(#.boole-c2 "(~($1))" ))))
390
(defun do-inline-call (fname a type-wanted)
391
(inline-call (list 'call (second a) (make-call-data
393
(call-data-arglist (third a)) nil nil))
396
(defun coerce-to-binary (sym dsk argl &aux first)
398
`(call ,dsk ,(make-call-data sym (list (car argl)(second argl)) nil nil)))
400
(coerce-to-binary sym dsk (cons first (cddr argl))))
403
(defun bo2-coerce-to-binary (a type-wanted arg-types) arg-types
404
(let* ((form-type (desk-result-type (second a)))
406
(arglist (call-data-arglist (third a))))
407
(cond ((and (cddr arglist)
408
(or (not (eq type-wanted t))
409
(not (eq form-type t))))
410
(if (eq type-wanted 'mv) (setq type-wanted t))
411
(inline-call (coerce-to-binary (call-data-fname call-dat)
412
(make-desk (type-and type-wanted
418
(dolist (v '(+ * - /)) (setf (get v 'bo2) 'bo2-coerce-to-binary))
420
(setf (get 'aref 'bo2) 'bo2-aref)
422
(defun bo2-aref (a type-wanted arg-types &aux (cd (third a)) argl type size) arg-types
423
(setq argl (call-data-arglist cd))
424
(setq type (result-type (car argl)))
427
(eql 3 (length argl))
429
(eq (car type) 'array)
431
(consp (setq size (third type)))
432
(typep (second size) 'fixnum))
433
(if (eq type-wanted 'mv) (setq type-wanted t))
434
(inline-call (list 'call (second a)
438
(list (get-object (second size))))
443
(defun inline-call (a type-wanted &aux call-dat in-args template tem
444
(*exit* (next-exit)))
445
;; The arg A is a (call ..) as returned from b1-walk.
446
;; If TYPE-WANTED is NIL then we may need Mult Values.
447
;; This function returns a list:
448
;; (referred-vars inlined-args result-type flags fname-or-string)
449
;; The REFERRED-VARS and RESULT-TYPE and FLAGS are necessary for
450
;; recursive calls, while the FNAME-OR-STRING and INLINED-ARGS
451
;; are used to actually write out the result.
452
(setq call-dat (third a))
454
(let* ((fname (call-data-fname call-dat))
456
(arglist (call-data-arglist call-dat))
457
(arg-types (mapcar 'result-type arglist))
458
(form-type (desk-result-type (second a))))
461
(cond ((and (setq tem (get fname 'bo2))
462
(setq tem (funcall tem a type-wanted arg-types)))
463
(return-from inline-call tem)))
467
(cond ((call-data-local-fun call-dat)
469
(setq template (get-template-fdata
471
(call-data-local-fun call-dat))))))
474
(setq fdecl (function-declaration fname))
475
(let ((ret (if fdecl (ret-from-argd (fdecl argd fdecl)))))
477
(cond ((eq ret 'double_ptr)
478
(setq form-type (type-and 'double-float form-type)))
479
((or (eq ret t)(eq ret '*)))
480
(t (setq form-type (type-and ret form-type)))))))
481
(get-inline-template fname fdecl
482
arg-types form-type type-wanted))))
483
((setq template (add-link-template fname fdecl
484
arg-types type-wanted))))
485
;; now we have template.
487
(sloop for v in (car template) with al = arglist
489
(cond ((eq v '*) (return t))
490
((null al) (comp-error "Too few args passed to ~a " fname))
492
(cond ((flag-p (opt flag template)is )
493
(sloop for v on *control-stack*
494
when (or (eq (car v) 'avma-bind)
495
(eq (car v) 'avma-bind-needed))
496
do (setf (car v) 'avma-bind-needed)
498
finally (wfs-error))))
500
(setq in-args (inline-args arglist (opt args template)))
501
(list* (cdr in-args) ; the referred-vars
502
(car in-args) ; the arglist
505
(defun add-link-template (fname fdecl arg-types type-wanted &aux tem link ans
506
(leng (length arg-types)))
507
(declare (fixnum leng))
508
(setq tem (assoc fname *file-inline-templates*))
510
(setq link (fourth tem))
511
(cond ((typep link 'link)
512
(cond ((< leng (argd-minargs (link-argd link)))
513
(setf (argd-minargs (link-argd link)) leng))
514
((> leng (argd-maxargs (link-argd link)))
515
(setf (argd-maxargs (link-argd link)) leng))
517
(if (eq type-wanted 'mv) (setf (argd-flag-p (link-argd link) sets-mv) t))))
518
(return-from add-link-template (cdr tem)))
521
(flags #.(flags set ans mv))
524
(declare (fixnum argd))
526
(setq argd (car fdecl))
527
(setq argl (argl-from-argd argd))
528
(setq ret (ret-from-argd argd))
529
(setq flags (second fdecl)))
530
(t (setf (argd-minargs argd) (length arg-types))
531
(setf (argd-maxargs argd) (length arg-types))
532
(setf (argd-flag-p argd requires-nargs) t)
533
(setf (argd-flag-p argd sets-mv) t)))
534
(setq link (make-link fname fdecl))
535
(setf (link-argd link) argd)
536
;; we need the data object now, so make sure it gets in the vector
538
(add-data (get-object fname))
539
(push (setq ans (list fname argl ret flags link)) *file-inline-templates*)
542
(defun get-template-fdata (fd &aux fstring tem)
543
;; make a template for a local fdata
544
(or (typep fd 'fdata) (wfs-error))
545
(cond ((setq tem (fdata-local-template fd))
546
(return-from get-template-fdata tem)))
547
(let* ((vararg (vararg-p fd))
548
(fdecl (fdata-function-declaration fd))
552
(increment-function-decl
555
(sloop for v in (ll &required ll) collect (value-type v))
556
(if (ll &optional ll)
558
(sloop for v in (ll &optional ll) collect
559
(value-type (car v)))))
560
(if (or (ll &rest ll) (ll &key ll)) '(*) nil))
561
;; todo arrange that pickup ret type
562
;; from fdata some day10q
566
(setq fstring (format nil "L~a($@0)" (fdata-ind fd)))
567
(if vararg (setq fstring (format nil "(VFUN_NARGS = $#,~a)" fstring)))
568
; (wr-h (rep-type t) " L" (fdata-ind fd) "();")
569
;; it is only fitting that a closure's template `format string' should in
570
;; fact be a closure. Takes a closure to know a closure.
571
(cond ((fdata-closure-vars fd)
574
(setf fstring #'(lambda (iargs)
576
(or (fdata-closure-self fdc)
577
(fdata-to-obj fdc)) ",")
578
(wr-inline-call1 iargs string)
581
(list (argl-from-argd (fdecl argd fdecl)) (ret-from-argd (fdecl argd fdecl))
582
(fdecl flag fdecl) fstring)))
583
(setf (fdata-local-template fd) ans)
588
(defun replace-inline-by-temp (x)
589
(let* ((type (result-type x))
590
(tem (get-temp type)))
591
(wr-set-inline-loc tem x)
added
removed
comp/inline.lsp
