/
ir1tran-lambda.lisp
1097 lines (1025 loc) · 42.9 KB
/
ir1tran-lambda.lisp
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; This file contains code which does the translation of lambda
;;;; forms from Lisp code to the first intermediate representation
;;;; (IR1).
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!C")
;;;; LAMBDA hackery
;;;; Note: Take a look at the compiler-overview.tex section on "Hairy
;;;; function representation" before you seriously mess with this
;;;; stuff.
;;; Verify that the NAME is a legal name for a variable and return a
;;; VAR structure for it, filling in info if it is globally special.
;;; If it is losing, we punt with a COMPILER-ERROR. NAMES-SO-FAR is a
;;; list of names which have previously been bound. If the NAME is in
;;; this list, then we error out.
(declaim (ftype (sfunction (t list) lambda-var) varify-lambda-arg))
(defun varify-lambda-arg (name names-so-far)
(declare (inline member))
(unless (symbolp name)
(compiler-error "The lambda variable ~S is not a symbol." name))
(when (member name names-so-far :test #'eq)
(compiler-error "The variable ~S occurs more than once in the lambda list."
name))
(let ((kind (info :variable :kind name)))
(when (or (keywordp name) (eq kind :constant))
(compiler-error "The name of the lambda variable ~S is already in use to name a constant."
name))
(cond ((eq kind :special)
(let ((specvar (find-free-var name)))
(make-lambda-var :%source-name name
:type (leaf-type specvar)
:where-from (leaf-where-from specvar)
:specvar specvar)))
(t
(make-lambda-var :%source-name name)))))
;;; Make the default keyword for a &KEY arg, checking that the keyword
;;; isn't already used by one of the VARS.
(declaim (ftype (sfunction (symbol list t) symbol) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
(keywordicate symbol)
symbol)))
(dolist (var vars)
(let ((info (lambda-var-arg-info var)))
(when (and info
(eq (arg-info-kind info) :keyword)
(eq (arg-info-key info) key))
(compiler-error
"The keyword ~S appears more than once in the lambda list."
key))))
key))
;;; Parse a lambda list into a list of VAR structures, stripping off
;;; any &AUX bindings. Each arg name is checked for legality, and
;;; duplicate names are checked for. If an arg is globally special,
;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY,
;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure
;;; which contains the extra information. If we hit something losing,
;;; we bug out with COMPILER-ERROR. These values are returned:
;;; 1. a list of the var structures for each top level argument;
;;; 2. a flag indicating whether &KEY was specified;
;;; 3. a flag indicating whether other &KEY args are allowed;
;;; 4. a list of the &AUX variables; and
;;; 5. a list of the &AUX values.
(declaim (ftype (sfunction (list) (values list boolean boolean list list))
make-lambda-vars))
(defun make-lambda-vars (list)
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
morep more-context more-count)
(parse-lambda-list list)
(declare (ignore auxp)) ; since we just iterate over AUX regardless
(collect ((vars)
(names-so-far)
(aux-vars)
(aux-vals))
(flet (;; PARSE-DEFAULT deals with defaults and supplied-p args
;; for optionals and keywords args.
(parse-default (spec info)
(when (consp (cdr spec))
(setf (arg-info-default info) (second spec))
(when (consp (cddr spec))
(let* ((supplied-p (third spec))
(supplied-var (varify-lambda-arg supplied-p
(names-so-far))))
(setf (arg-info-supplied-p info) supplied-var)
(names-so-far supplied-p)
(when (> (length (the list spec)) 3)
(compiler-error
"The list ~S is too long to be an arg specifier."
spec)))))))
(dolist (name required)
(let ((var (varify-lambda-arg name (names-so-far))))
(vars var)
(names-so-far name)))
(dolist (spec optional)
(if (atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :optional))
(vars var)
(names-so-far spec))
(let* ((name (first spec))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info :kind :optional)))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(parse-default spec info))))
(when restp
(let ((var (varify-lambda-arg rest (names-so-far))))
(setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
(vars var)
(names-so-far rest)))
(when morep
(let ((var (varify-lambda-arg more-context (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :more-context))
(vars var)
(names-so-far more-context))
(let ((var (varify-lambda-arg more-count (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :more-count))
(vars var)
(names-so-far more-count)))
(dolist (spec keys)
(cond
((atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :keyword
:key (make-keyword-for-arg spec
(vars)
t)))
(vars var)
(names-so-far spec)))
((atom (first spec))
(let* ((name (first spec))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
:key (make-keyword-for-arg name (vars) t))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(parse-default spec info)))
(t
(let ((head (first spec)))
(unless (proper-list-of-length-p head 2)
(error "malformed &KEY argument specifier: ~S" spec))
(let* ((name (second head))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
:key (make-keyword-for-arg (first head)
(vars)
nil))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(parse-default spec info))))))
(dolist (spec aux)
(cond ((atom spec)
(let ((var (varify-lambda-arg spec nil)))
(aux-vars var)
(aux-vals nil)
(names-so-far spec)))
(t
(unless (proper-list-of-length-p spec 1 2)
(compiler-error "malformed &AUX binding specifier: ~S"
spec))
(let* ((name (first spec))
(var (varify-lambda-arg name nil)))
(aux-vars var)
(aux-vals (second spec))
(names-so-far name)))))
(values (vars) keyp allowp (aux-vars) (aux-vals))))))
;;; This is similar to IR1-CONVERT-PROGN-BODY except that we
;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before
;;; converting the body. If there are no bindings, just convert the
;;; body, otherwise do one binding and recurse on the rest.
;;;
;;; FIXME: This could and probably should be converted to use
;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings,
;;; so I'm not motivated. Patches will be accepted...
(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals)
(declare (type continuation start cont) (list body aux-vars aux-vals))
(if (null aux-vars)
(ir1-convert-progn-body start cont body)
(let ((fun-cont (make-continuation))
(fun (ir1-convert-lambda-body body
(list (first aux-vars))
:aux-vars (rest aux-vars)
:aux-vals (rest aux-vals)
:debug-name (debug-namify
"&AUX bindings ~S"
aux-vars))))
(reference-leaf start fun-cont fun)
(ir1-convert-combination-args fun-cont cont
(list (first aux-vals)))))
(values))
;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
;;; the SPECVAR for each SVAR to the value of the variable is wrapped
;;; around the body. If there are no special bindings, we just convert
;;; the body, otherwise we do one special binding and recurse on the
;;; rest.
;;;
;;; We make a cleanup and introduce it into the lexical environment.
;;; If there are multiple special bindings, the cleanup for the blocks
;;; will end up being the innermost one. We force CONT to start a
;;; block outside of this cleanup, causing cleanup code to be emitted
;;; when the scope is exited.
(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
(declare (type continuation start cont)
(list body aux-vars aux-vals svars))
(cond
((null svars)
(ir1-convert-aux-bindings start cont body aux-vars aux-vals))
(t
(continuation-starts-block cont)
(let ((cleanup (make-cleanup :kind :special-bind))
(var (first svars))
(next-cont (make-continuation))
(nnext-cont (make-continuation)))
(ir1-convert start next-cont
`(%special-bind ',(lambda-var-specvar var) ,var))
(setf (cleanup-mess-up cleanup) (continuation-use next-cont))
(let ((*lexenv* (make-lexenv :cleanup cleanup)))
(ir1-convert next-cont nnext-cont '(%cleanup-point))
(ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
(rest svars))))))
(values))
;;; Create a lambda node out of some code, returning the result. The
;;; bindings are specified by the list of VAR structures VARS. We deal
;;; with adding the names to the LEXENV-VARS for the conversion. The
;;; result is added to the NEW-FUNCTIONALS in the *CURRENT-COMPONENT*
;;; and linked to the component head and tail.
;;;
;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits
;;; the special binding code.
;;;
;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
;;; dealing with &nonsense.
;;;
;;; AUX-VARS is a list of VAR structures for variables that are to be
;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
;;; to get the initial value for the corresponding AUX-VAR.
(defun ir1-convert-lambda-body (body
vars
&key
aux-vars
aux-vals
result
(source-name '.anonymous.)
debug-name
(note-lexical-bindings t))
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
;; We're about to try to put new blocks into *CURRENT-COMPONENT*.
(aver-live-component *current-component*)
(let* ((bind (make-bind))
(lambda (make-lambda :vars vars
:bind bind
:%source-name source-name
:%debug-name debug-name))
(result (or result (make-continuation))))
;; just to check: This function should fail internal assertions if
;; we didn't set up a valid debug name above.
;;
;; (In SBCL we try to make everything have a debug name, since we
;; lack the omniscient perspective the original implementors used
;; to decide which things didn't need one.)
(functional-debug-name lambda)
(setf (lambda-home lambda) lambda)
(collect ((svars)
(new-venv nil cons))
(dolist (var vars)
;; As far as I can see, LAMBDA-VAR-HOME should never have
;; been set before. Let's make sure. -- WHN 2001-09-29
(aver (null (lambda-var-home var)))
(setf (lambda-var-home var) lambda)
(let ((specvar (lambda-var-specvar var)))
(cond (specvar
(svars var)
(new-venv (cons (leaf-source-name specvar) specvar)))
(t
(when note-lexical-bindings
(note-lexical-binding (leaf-source-name var)))
(new-venv (cons (leaf-source-name var) var))))))
(let ((*lexenv* (make-lexenv :vars (new-venv)
:lambda lambda
:cleanup nil)))
(setf (bind-lambda bind) lambda)
(setf (node-lexenv bind) *lexenv*)
(let ((block (continuation-starts-block result)))
(let ((return (make-return :result result :lambda lambda))
(tail-set (make-tail-set :funs (list lambda)))
(dummy (make-continuation)))
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
(flush-continuation-externally-checkable-type result)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(link-blocks block (component-tail *current-component*)))
(with-component-last-block (*current-component*
(continuation-block result))
(let ((cont1 (make-continuation))
(cont2 (make-continuation)))
(continuation-starts-block cont1)
(link-node-to-previous-continuation bind cont1)
(use-continuation bind cont2)
(ir1-convert-special-bindings cont2 result body
aux-vars aux-vals (svars))))))
(link-blocks (component-head *current-component*) (node-block bind))
(push lambda (component-new-functionals *current-component*))
lambda))
;;; Entry point CLAMBDAs have a special kind
(defun register-entry-point (entry dispatcher)
(declare (type clambda entry)
(type optional-dispatch dispatcher))
(setf (functional-kind entry) :optional)
(setf (leaf-ever-used entry) t)
(setf (lambda-optional-dispatch entry)
dispatcher)
entry)
;;; Create the actual entry-point function for an optional entry
;;; point. The lambda binds copies of each of the VARS, then calls FUN
;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer
;;; to the VARS by name. The VALS are passed in the reverse order.
;;;
;;; If any of the copies of the vars are referenced more than once,
;;; then we mark the corresponding var as EVER-USED to inhibit
;;; "defined but not read" warnings for arguments that are only used
;;; by default forms.
(defun convert-optional-entry (fun vars vals defaults)
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
(arg-vars (mapcar (lambda (var)
(make-lambda-var
:%source-name (leaf-source-name var)
:type (leaf-type var)
:where-from (leaf-where-from var)
:specvar (lambda-var-specvar var)))
fvars))
(fun (collect ((default-bindings)
(default-vals))
(dolist (default defaults)
(if (constantp default)
(default-vals default)
(let ((var (gensym)))
(default-bindings `(,var ,default))
(default-vals var))))
(ir1-convert-lambda-body `((let (,@(default-bindings))
(%funcall ,fun
,@(reverse vals)
,@(default-vals))))
arg-vars
:debug-name
(debug-namify "&OPTIONAL processor ~D"
(random 100))
:note-lexical-bindings nil))))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
(setf (leaf-ever-used var) t)))
fvars arg-vars)
fun))
;;; This function deals with supplied-p vars in optional arguments. If
;;; the there is no supplied-p arg, then we just call
;;; IR1-CONVERT-HAIRY-ARGS on the remaining arguments, and generate a
;;; optional entry that calls the result. If there is a supplied-p
;;; var, then we add it into the default vars and throw a T into the
;;; entry values. The resulting entry point function is returned.
(defun generate-optional-default-entry (res default-vars default-vals
entry-vars entry-vals
vars supplied-p-p body
aux-vars aux-vals cont
source-name debug-name
force)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals)
(type (or continuation null) cont))
(let* ((arg (first vars))
(arg-name (leaf-source-name arg))
(info (lambda-var-arg-info arg))
(default (arg-info-default info))
(supplied-p (arg-info-supplied-p info))
(force (or force
(not (sb!xc:constantp (arg-info-default info)))))
(ep (if supplied-p
(ir1-convert-hairy-args
res
(list* supplied-p arg default-vars)
(list* (leaf-source-name supplied-p) arg-name default-vals)
(cons arg entry-vars)
(list* t arg-name entry-vals)
(rest vars) t body aux-vars aux-vals cont
source-name debug-name
force)
(ir1-convert-hairy-args
res
(cons arg default-vars)
(cons arg-name default-vals)
(cons arg entry-vars)
(cons arg-name entry-vals)
(rest vars) supplied-p-p body aux-vars aux-vals cont
source-name debug-name
force))))
;; We want to delay converting the entry, but there exist
;; problems: hidden references should not be established to
;; lambdas of kind NIL should not have (otherwise the compiler
;; might let-convert or delete them) and to variables.
(if (or force
supplied-p-p ; this entry will be of kind NIL
(and (lambda-p ep) (eq (lambda-kind ep) nil)))
(convert-optional-entry ep
default-vars default-vals
(if supplied-p
(list default nil)
(list default)))
(delay
(register-entry-point
(convert-optional-entry (force ep)
default-vars default-vals
(if supplied-p
(list default nil)
(list default)))
res)))))
;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars.
;;;
;;; The most interesting thing that we do is parse keywords. We create
;;; a bunch of temporary variables to hold the result of the parse,
;;; and then loop over the supplied arguments, setting the appropriate
;;; temps for the supplied keyword. Note that it is significant that
;;; we iterate over the keywords in reverse order --- this implements
;;; the CL requirement that (when a keyword appears more than once)
;;; the first value is used.
;;;
;;; If there is no supplied-p var, then we initialize the temp to the
;;; default and just pass the temp into the main entry. Since
;;; non-constant &KEY args are forcibly given a supplied-p var, we
;;; know that the default is constant, and thus safe to evaluate out
;;; of order.
;;;
;;; If there is a supplied-p var, then we create temps for both the
;;; value and the supplied-p, and pass them into the main entry,
;;; letting it worry about defaulting.
;;;
;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
;;; until we have scanned all the keywords.
(defun convert-more-entry (res entry-vars entry-vals rest morep keys)
(declare (type optional-dispatch res) (list entry-vars entry-vals keys))
(collect ((arg-vars)
(arg-vals (reverse entry-vals))
(temps)
(body))
(dolist (var (reverse entry-vars))
(arg-vars (make-lambda-var :%source-name (leaf-source-name var)
:type (leaf-type var)
:where-from (leaf-where-from var))))
(let* ((n-context (gensym "N-CONTEXT-"))
(context-temp (make-lambda-var :%source-name n-context))
(n-count (gensym "N-COUNT-"))
(count-temp (make-lambda-var :%source-name n-count
:type (specifier-type 'index))))
(arg-vars context-temp count-temp)
(when rest
(arg-vals `(%listify-rest-args ,n-context ,n-count)))
(when morep
(arg-vals n-context)
(arg-vals n-count))
(when (optional-dispatch-keyp res)
(let ((n-index (gensym "N-INDEX-"))
(n-key (gensym "N-KEY-"))
(n-value-temp (gensym "N-VALUE-TEMP-"))
(n-allowp (gensym "N-ALLOWP-"))
(n-losep (gensym "N-LOSEP-"))
(allowp (or (optional-dispatch-allowp res)
(policy *lexenv* (zerop safety))))
(found-allow-p nil))
(temps `(,n-index (1- ,n-count)) n-key n-value-temp)
(body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
(collect ((tests))
(dolist (key keys)
(let* ((info (lambda-var-arg-info key))
(default (arg-info-default info))
(keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
(n-value (gensym "N-VALUE-"))
(clause (cond (supplied-p
(let ((n-supplied (gensym "N-SUPPLIED-")))
(temps n-supplied)
(arg-vals n-value n-supplied)
`((eq ,n-key ',keyword)
(setq ,n-supplied t)
(setq ,n-value ,n-value-temp))))
(t
(arg-vals n-value)
`((eq ,n-key ',keyword)
(setq ,n-value ,n-value-temp))))))
(when (and (not allowp) (eq keyword :allow-other-keys))
(setq found-allow-p t)
(setq clause
(append clause `((setq ,n-allowp ,n-value-temp)))))
(temps `(,n-value ,default))
(tests clause)))
(unless allowp
(temps n-allowp n-losep)
(unless found-allow-p
(tests `((eq ,n-key :allow-other-keys)
(setq ,n-allowp ,n-value-temp))))
(tests `(t
(setq ,n-losep ,n-key))))
(body
`(when (oddp ,n-count)
(%odd-key-args-error)))
(body
`(locally
(declare (optimize (safety 0)))
(loop
(when (minusp ,n-index) (return))
(setf ,n-value-temp (%more-arg ,n-context ,n-index))
(decf ,n-index)
(setq ,n-key (%more-arg ,n-context ,n-index))
(decf ,n-index)
(cond ,@(tests)))))
(unless allowp
(body `(when (and ,n-losep (not ,n-allowp))
(%unknown-key-arg-error ,n-losep)))))))
(let ((ep (ir1-convert-lambda-body
`((let ,(temps)
,@(body)
(%funcall ,(optional-dispatch-main-entry res)
,@(arg-vals))))
(arg-vars)
:debug-name (debug-namify "~S processing" '&more)
:note-lexical-bindings nil)))
(setf (optional-dispatch-more-entry res)
(register-entry-point ep res)))))
(values))
;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST
;;; or &KEY arg. The arguments are similar to that function, but we
;;; split off any &REST arg and pass it in separately. REST is the
;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of
;;; the &KEY argument vars.
;;;
;;; When there are &KEY arguments, we introduce temporary gensym
;;; variables to hold the values while keyword defaulting is in
;;; progress to get the required sequential binding semantics.
;;;
;;; This gets interesting mainly when there are &KEY arguments with
;;; supplied-p vars or non-constant defaults. In either case, pass in
;;; a supplied-p var. If the default is non-constant, we introduce an
;;; IF in the main entry that tests the supplied-p var and decides
;;; whether to evaluate the default or not. In this case, the real
;;; incoming value is NIL, so we must union NULL with the declared
;;; type when computing the type for the main entry's argument.
(defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
rest more-context more-count keys supplied-p-p
body aux-vars aux-vals cont
source-name debug-name)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals keys body
aux-vars aux-vals)
(type (or continuation null) cont))
(collect ((main-vars (reverse default-vars))
(main-vals default-vals cons)
(bind-vars)
(bind-vals))
(when rest
(main-vars rest)
(main-vals '()))
(when more-context
(main-vars more-context)
(main-vals nil)
(main-vars more-count)
(main-vals 0))
(dolist (key keys)
(let* ((info (lambda-var-arg-info key))
(default (arg-info-default info))
(hairy-default (not (sb!xc:constantp default)))
(supplied-p (arg-info-supplied-p info))
(n-val (make-symbol (format nil
"~A-DEFAULTING-TEMP"
(leaf-source-name key))))
(key-type (leaf-type key))
(val-temp (make-lambda-var
:%source-name n-val
:type (if hairy-default
(type-union key-type (specifier-type 'null))
key-type))))
(main-vars val-temp)
(bind-vars key)
(cond ((or hairy-default supplied-p)
(let* ((n-supplied (gensym "N-SUPPLIED-"))
(supplied-temp (make-lambda-var
:%source-name n-supplied)))
(unless supplied-p
(setf (arg-info-supplied-p info) supplied-temp))
(when hairy-default
(setf (arg-info-default info) nil))
(main-vars supplied-temp)
(cond (hairy-default
(main-vals nil nil)
(bind-vals `(if ,n-supplied ,n-val ,default)))
(t
(main-vals default nil)
(bind-vals n-val)))
(when supplied-p
(bind-vars supplied-p)
(bind-vals n-supplied))))
(t
(main-vals (arg-info-default info))
(bind-vals n-val)))))
(let* ((main-entry (ir1-convert-lambda-body
body (main-vars)
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
:result cont
:debug-name (debug-namify "varargs entry for ~A"
(as-debug-name source-name
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) ())))
(setf (optional-dispatch-main-entry res)
(register-entry-point main-entry res))
(convert-more-entry res entry-vars entry-vals rest more-context keys)
(push (register-entry-point
(if supplied-p-p
(convert-optional-entry last-entry entry-vars entry-vals ())
last-entry)
res)
(optional-dispatch-entry-points res))
last-entry)))
;;; This function generates the entry point functions for the
;;; OPTIONAL-DISPATCH RES. We accomplish this by recursion on the list
;;; of arguments, analyzing the arglist on the way down and generating
;;; entry points on the way up.
;;;
;;; DEFAULT-VARS is a reversed list of all the argument vars processed
;;; so far, including supplied-p vars. DEFAULT-VALS is a list of the
;;; names of the DEFAULT-VARS.
;;;
;;; ENTRY-VARS is a reversed list of processed argument vars,
;;; excluding supplied-p vars. ENTRY-VALS is a list things that can be
;;; evaluated to get the values for all the vars from the ENTRY-VARS.
;;; It has the var name for each required or optional arg, and has T
;;; for each supplied-p arg.
;;;
;;; VARS is a list of the LAMBDA-VAR structures for arguments that
;;; haven't been processed yet. SUPPLIED-P-P is true if a supplied-p
;;; argument has already been processed; only in this case are the
;;; DEFAULT-XXX and ENTRY-XXX different.
;;;
;;; The result at each point is a lambda which should be called by the
;;; above level to default the remaining arguments and evaluate the
;;; body. We cause the body to be evaluated by converting it and
;;; returning it as the result when the recursion bottoms out.
;;;
;;; Each level in the recursion also adds its entry point function to
;;; the result OPTIONAL-DISPATCH. For most arguments, the defaulting
;;; function and the entry point function will be the same, but when
;;; SUPPLIED-P args are present they may be different.
;;;
;;; When we run into a &REST or &KEY arg, we punt out to
;;; IR1-CONVERT-MORE, which finishes for us in this case.
(defun ir1-convert-hairy-args (res default-vars default-vals
entry-vars entry-vals
vars supplied-p-p body aux-vars
aux-vals cont
source-name debug-name
force)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals)
(type (or continuation null) cont))
(cond ((not vars)
(if (optional-dispatch-keyp res)
;; Handle &KEY with no keys...
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil nil nil vars supplied-p-p body aux-vars
aux-vals cont source-name debug-name)
(let ((fun (ir1-convert-lambda-body
body (reverse default-vars)
:aux-vars aux-vars
:aux-vals aux-vals
:result cont
:debug-name (debug-namify
"hairy arg processor for ~A"
(as-debug-name source-name
debug-name)))))
(setf (optional-dispatch-main-entry res) fun)
(register-entry-point fun res)
(push (if supplied-p-p
(register-entry-point
(convert-optional-entry fun entry-vars entry-vals ())
res)
fun)
(optional-dispatch-entry-points res))
fun)))
((not (lambda-var-arg-info (first vars)))
(let* ((arg (first vars))
(nvars (cons arg default-vars))
(nvals (cons (leaf-source-name arg) default-vals)))
(ir1-convert-hairy-args res nvars nvals nvars nvals
(rest vars) nil body aux-vars aux-vals
cont
source-name debug-name
nil)))
(t
(let* ((arg (first vars))
(info (lambda-var-arg-info arg))
(kind (arg-info-kind info)))
(ecase kind
(:optional
(let ((ep (generate-optional-default-entry
res default-vars default-vals
entry-vars entry-vals vars supplied-p-p body
aux-vars aux-vals cont
source-name debug-name
force)))
;; See GENERATE-OPTIONAL-DEFAULT-ENTRY.
(push (if (lambda-p ep)
(register-entry-point
(if supplied-p-p
(convert-optional-entry ep entry-vars entry-vals ())
ep)
res)
(progn (aver (not supplied-p-p))
ep))
(optional-dispatch-entry-points res))
ep))
(:rest
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
arg nil nil (rest vars) supplied-p-p body
aux-vars aux-vals cont
source-name debug-name))
(:more-context
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil arg (second vars) (cddr vars) supplied-p-p
body aux-vars aux-vals cont
source-name debug-name))
(:keyword
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil nil nil vars supplied-p-p body aux-vars
aux-vals cont source-name debug-name)))))))
;;; This function deals with the case where we have to make an
;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and
;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
;;; figure out the MIN-ARGS and MAX-ARGS.
(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont
&key
(source-name '.anonymous.)
(debug-name (debug-namify
"OPTIONAL-DISPATCH ~S"
vars)))
(declare (list body vars aux-vars aux-vals) (type continuation cont))
(let ((res (make-optional-dispatch :arglist vars
:allowp allowp
:keyp keyp
:%source-name source-name
:%debug-name debug-name
:plist `(:ir1-environment
(,*lexenv*
,*current-path*))))
(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
(aver-live-component *current-component*)
(push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
cont source-name debug-name nil)
(setf (optional-dispatch-min-args res) min)
(setf (optional-dispatch-max-args res)
(+ (1- (length (optional-dispatch-entry-points res))) min))
res))
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
debug-name
allow-debug-catch-tag)
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
(type-of form)
form))
(unless (eq (car form) 'lambda)
(compiler-error "~S was expected but ~S was found:~% ~S"
'lambda
(car form)
form))
(unless (and (consp (cdr form)) (listp (cadr form)))
(compiler-error
"The lambda expression has a missing or non-list lambda list:~% ~S"
form))
(let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
(multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
(make-lambda-vars (cadr form))
(multiple-value-bind (forms decls) (parse-body (cddr form))
(let* ((result-cont (make-continuation))
(*lexenv* (process-decls decls
(append aux-vars vars)
nil result-cont))
(forms (if (and *allow-debug-catch-tag*
(policy *lexenv* (= insert-debug-catch 3)))
`((catch (make-symbol "SB-DEBUG-CATCH-TAG")
,@forms))
forms))
(res (if (or (find-if #'lambda-var-arg-info vars) keyp)
(ir1-convert-hairy-lambda forms vars keyp
allow-other-keys
aux-vars aux-vals result-cont
:source-name source-name
:debug-name debug-name)
(ir1-convert-lambda-body forms vars
:aux-vars aux-vars
:aux-vals aux-vals
:result result-cont
:source-name source-name
:debug-name debug-name))))
(setf (functional-inline-expansion res) form)
(setf (functional-arg-documentation res) (cadr form))
res)))))
;;; helper for LAMBDA-like things, to massage them into a form
;;; suitable for IR1-CONVERT-LAMBDA.
;;;
;;; KLUDGE: We cons up a &REST list here, maybe for no particularly
;;; good reason. It's probably lost in the noise of all the other
;;; consing, but it's still inelegant. And we force our called
;;; functions to do full runtime keyword parsing, ugh. -- CSR,
;;; 2003-01-25
(defun ir1-convert-lambdalike (thing &rest args
&key (source-name '.anonymous.)
debug-name allow-debug-catch-tag)
(declare (ignorable source-name debug-name allow-debug-catch-tag))
(ecase (car thing)
((lambda) (apply #'ir1-convert-lambda thing args))
((instance-lambda)
(let ((res (apply #'ir1-convert-lambda
`(lambda ,@(cdr thing)) args)))
(setf (getf (functional-plist res) :fin-function) t)
res))
((named-lambda)
(let ((name (cadr thing)))
(if (legal-fun-name-p name)
(let ((defined-fun-res (get-defined-fun name))
(res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
:source-name name
:debug-name nil
args)))
(assert-global-function-definition-type name res)
(setf (defined-fun-functional defined-fun-res)
res)
(unless (eq (defined-fun-inlinep defined-fun-res) :notinline)
(substitute-leaf res defined-fun-res))
res)
(apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
:debug-name name args))))
((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args))))
;;;; defining global functions
;;; Convert FUN as a lambda in the null environment, but use the
;;; current compilation policy. Note that FUN may be a
;;; LAMBDA-WITH-LEXENV, so we may have to augment the environment to
;;; reflect the state at the definition site.
(defun ir1-convert-inline-lambda (fun &key
(source-name '.anonymous.)
debug-name
allow-debug-catch-tag)
(destructuring-bind (decls macros symbol-macros &rest body)
(if (eq (car fun) 'lambda-with-lexenv)
(cdr fun)
`(() () () . ,(cdr fun)))
(let ((*lexenv* (make-lexenv
:default (process-decls decls nil nil
(make-continuation)
(make-null-lexenv))
:vars (copy-list symbol-macros)
:funs (mapcar (lambda (x)
`(,(car x) .
(macro . ,(coerce (cdr x) 'function))))
macros)
:policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body)
:source-name source-name
:debug-name debug-name
:allow-debug-catch-tag nil))))
;;; Get a DEFINED-FUN object for a function we are about to define. If
;;; the function has been forward referenced, then substitute for the
;;; previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
(let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
(note-name-defined name :function)
(cond ((not (defined-fun-p found))
(aver (not (info :function :inlinep name)))
(let* ((where-from (leaf-where-from found))
(res (make-defined-fun
:%source-name name
:where-from (if (eq where-from :declared)
:declared :defined)
:type (leaf-type found))))
(substitute-leaf res found)
(setf (gethash name *free-funs*) res)))
;; If *FREE-FUNS* has a previously converted definition
;; for this name, then blow it away and try again.
((defined-fun-functional found)
(remhash name *free-funs*)
(get-defined-fun name))
(t found))))
;;; Check a new global function definition for consistency with
;;; previous declaration or definition, and assert argument/result
;;; types if appropriate. This assertion is suppressed by the
;;; EXPLICIT-CHECK attribute, which is specified on functions that
;;; check their argument types as a consequence of type dispatching.
;;; This avoids redundant checks such as NUMBERP on the args to +, etc.
(defun assert-new-definition (var fun)
(let ((type (leaf-type var))
(for-real (eq (leaf-where-from var) :declared))
(info (info :function :info (leaf-source-name var))))
(assert-definition-type
fun type
;; KLUDGE: Common Lisp is such a dynamic language that in general
;; all we can do here in general is issue a STYLE-WARNING. It
;; would be nice to issue a full WARNING in the special case of
;; of type mismatches within a compilation unit (as in section
;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't
;; keep track of whether the mismatched data came from the same
;; compilation unit, so we can't do that. -- WHN 2001-02-11
:lossage-fun #'compiler-style-warn