Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[cabec2]: src / compiler / ir1-translators.lisp Maximize Restore History

Download this file

ir1-translators.lisp    991 lines (913 with data), 39.9 kB

  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
;;;; the usual place for DEF-IR1-TRANSLATOR forms (and their
;;;; close personal friends)
;;;; 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")
;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
"Progn Form*
Evaluates each Form in order, returning the values of the last form. With no
forms, returns NIL."
(ir1-convert-progn-body start cont forms))
(def-ir1-translator if ((test then &optional else) start cont)
#!+sb-doc
"If Predicate Then [Else]
If Predicate evaluates to non-null, evaluate Then and returns its values,
otherwise evaluate Else and return its values. Else defaults to NIL."
(let* ((pred (make-continuation))
(then-cont (make-continuation))
(then-block (continuation-starts-block then-cont))
(else-cont (make-continuation))
(else-block (continuation-starts-block else-cont))
(dummy-cont (make-continuation))
(node (make-if :test pred
:consequent then-block
:alternative else-block)))
;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
;; order of the following two forms is important
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
(link-node-to-previous-continuation node pred)
(use-continuation node dummy-cont)
(let ((start-block (continuation-block pred)))
(setf (block-last start-block) node)
(continuation-starts-block cont)
(link-blocks start-block then-block)
(link-blocks start-block else-block))
(ir1-convert then-cont cont then)
(ir1-convert else-cont cont else)))
;;;; BLOCK and TAGBODY
;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to
;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT
;;;; node.
;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
;;; body in the modified environment. We make CONT start a block now,
;;; since if it was done later, the block would be in the wrong
;;; environment.
(def-ir1-translator block ((name &rest forms) start cont)
#!+sb-doc
"Block Name Form*
Evaluate the Forms as a PROGN. Within the lexical scope of the body,
(RETURN-FROM Name Value-Form) can be used to exit the form, returning the
result of Value-Form."
(unless (symbolp name)
(compiler-error "The block name ~S is not a symbol." name))
(continuation-starts-block cont)
(let* ((dummy (make-continuation))
(entry (make-entry))
(cleanup (make-cleanup :kind :block
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(let* ((env-entry (list entry cont))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
(push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
(def-ir1-translator return-from ((name &optional value) start cont)
#!+sb-doc
"Return-From Block-Name Value-Form
Evaluate the Value-Form, returning its values from the lexically enclosing
BLOCK Block-Name. This is constrained to be used only within the dynamic
extent of the BLOCK."
;; CMU CL comment:
;; We make CONT start a block just so that it will have a block
;; assigned. People assume that when they pass a continuation into
;; IR1-CONVERT as CONT, it will have a block when it is done.
;; KLUDGE: Note that this block is basically fictitious. In the code
;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
;; it's the block which answers the question "which block is
;; the (SETQ X 3) in?" when the right answer is that (SETQ X 3) is
;; dead code and so doesn't really have a block at all. The existence
;; of this block, and that way that it doesn't explicitly say
;; "I'm actually nowhere at all" makes some logic (e.g.
;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
;; to get rid of it, perhaps using a special placeholder value
;; to indicate the orphanedness of the code.
(continuation-starts-block cont)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
(value-cont (make-continuation))
(entry (first found))
(exit (make-exit :entry entry
:value value-cont)))
(push exit (entry-exits entry))
(setf (continuation-dest value-cont) exit)
(ir1-convert start value-cont value)
(link-node-to-previous-continuation exit value-cont)
(let ((home-lambda (continuation-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
;;; tagbody into segments of non-tag statements, and explicitly
;;; represent the drop-through with a GO. The first segment has a
;;; dummy NIL tag, since it represents code before the first tag. The
;;; last segment (which may also be the first segment) ends in NIL
;;; rather than a GO.
(defun parse-tagbody (body)
(declare (list body))
(collect ((segments))
(let ((current (cons nil body)))
(loop
(let ((tag-pos (position-if (complement #'listp) current :start 1)))
(unless tag-pos
(segments `(,@current nil))
(return))
(let ((tag (elt current tag-pos)))
(when (assoc tag (segments))
(compiler-error
"The tag ~S appears more than once in the tagbody."
tag))
(unless (or (symbolp tag) (integerp tag))
(compiler-error "~S is not a legal tagbody statement." tag))
(segments `(,@(subseq current 0 tag-pos) (go ,tag))))
(setq current (nthcdr tag-pos current)))))
(segments)))
;;; Set up the cleanup, emitting the entry node. Then make a block for
;;; each tag, building up the tag list for LEXENV-TAGS as we go.
;;; Finally, convert each segment with the precomputed Start and Cont
;;; values.
(def-ir1-translator tagbody ((&rest statements) start cont)
#!+sb-doc
"Tagbody {Tag | Statement}*
Define tags for used with GO. The Statements are evaluated in order
(skipping Tags) and NIL is returned. If a statement contains a GO to a
defined Tag within the lexical scope of the form, then control is transferred
to the next statement following that tag. A Tag must an integer or a
symbol. A statement must be a list. Other objects are illegal within the
body."
(continuation-starts-block cont)
(let* ((dummy (make-continuation))
(entry (make-entry))
(segments (parse-tagbody statements))
(cleanup (make-cleanup :kind :tagbody
:mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
(collect ((tags)
(starts)
(conts))
(starts dummy)
(dolist (segment (rest segments))
(let* ((tag-cont (make-continuation))
(tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
(tags tag)
(push (cdr tag) (continuation-lexenv-uses tag-cont))))
(conts cont)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
(mapc (lambda (segment start cont)
(ir1-convert-progn-body start cont (rest segment)))
segments (starts) (conts))))))
;;; Emit an EXIT node without any value.
(def-ir1-translator go ((tag) start cont)
#!+sb-doc
"Go Tag
Transfer control to the named Tag in the lexically enclosing TAGBODY. This
is constrained to be used only within the dynamic extent of the TAGBODY."
(continuation-starts-block cont)
(let* ((found (or (lexenv-find tag tags :test #'eql)
(compiler-error "attempt to GO to nonexistent tag: ~S"
tag)))
(entry (first found))
(exit (make-exit :entry entry)))
(push exit (entry-exits entry))
(link-node-to-previous-continuation exit start)
(let ((home-lambda (continuation-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
(use-continuation exit (second found))))
;;;; translators for compiler-magic special forms
;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in top
;;; level forms are picked off and handled by PROCESS-TOPLEVEL-FORM,
;;; so that they're never seen at this level.)
;;;
;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
;;; of non-top-level EVAL-WHENs is very simple:
;;; EVAL-WHEN forms cause compile-time evaluation only at top level.
;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
;;; are ignored for non-top-level forms. For non-top-level forms, an
;;; eval-when specifying the :EXECUTE situation is treated as an
;;; implicit PROGN including the forms in the body of the EVAL-WHEN
;;; form; otherwise, the forms in the body are ignored.
(def-ir1-translator eval-when ((situations &rest forms) start cont)
#!+sb-doc
"EVAL-WHEN (Situation*) Form*
Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
(ir1-convert-progn-body start cont (and e forms)))
(values))
;;; common logic for MACROLET and SYMBOL-MACROLET
;;;
;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
;;; in-lexenv representation, stuff the results into *LEXENV*, and
;;; call FUN (with no arguments).
(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
definitionize-keyword
definitions
fun)
(declare (type function definitionize-fun fun))
(declare (type (member :vars :funs) definitionize-keyword))
(declare (type list definitions))
(unless (= (length definitions)
(length (remove-duplicates definitions :key #'first)))
(compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
(funcall fun definitionize-keyword processed-definitions)))
;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
;;; call FUN (with no arguments).
;;;
;;; This is split off from the IR1 convert method so that it can be
;;; shared by the special-case top level MACROLET processing code, and
;;; further split so that the special-case MACROLET processing code in
;;; EVAL can likewise make use of it.
(defmacro macrolet-definitionize-fun (context lexenv)
(flet ((make-error-form (control &rest args)
(ecase context
(:compile `(compiler-error ,control ,@args))
(:eval `(error 'simple-program-error
:format-control ,control
:format-arguments (list ,@args))))))
`(lambda (definition)
(unless (list-of-length-at-least-p definition 2)
,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
,(make-error-form "The local macro name ~S is not a symbol." 'name))
(unless (listp arglist)
,(make-error-form "The local macro argument list ~S is not a list." 'arglist))
(let ((whole (gensym "WHOLE"))
(environment (gensym "ENVIRONMENT")))
(multiple-value-bind (body local-decls)
(parse-defmacro arglist whole body name 'macrolet
:environment environment)
`(,name macro .
,(compile-in-lexenv
nil
`(lambda (,whole ,environment)
,@local-decls
(block ,name ,body))
,lexenv))))))))
(defun funcall-in-macrolet-lexenv (definitions fun)
(%funcall-in-foomacrolet-lexenv
(macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))
:funs
definitions
fun))
(def-ir1-translator macrolet ((definitions &rest body) start cont)
#!+sb-doc
"MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
Evaluate the Body-Forms in an environment with the specified local macros
defined. Name is the local macro name, Lambda-List is the DEFMACRO style
destructuring lambda list, and the Forms evaluate to the expansion.."
(funcall-in-macrolet-lexenv
definitions
(lambda (&key funs)
(declare (ignore funs))
(ir1-translate-locally body start cont))))
(defmacro symbol-macrolet-definitionize-fun (context)
(flet ((make-error-form (control &rest args)
(ecase context
(:compile `(compiler-error ,control ,@args))
(:eval `(error 'simple-program-error
:format-control ,control
:format-arguments (list ,@args))))))
`(lambda (definition)
(unless (proper-list-of-length-p definition 2)
,(make-error-form "malformed symbol/expansion pair: ~S" 'definition))
(destructuring-bind (name expansion) definition
(unless (symbolp name)
,(make-error-form
"The local symbol macro name ~S is not a symbol."
'name))
(let ((kind (info :variable :kind name)))
(when (member kind '(:special :constant))
,(make-error-form
"Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
'kind 'name)))
`(,name . (MACRO . ,expansion))))))1
(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
(%funcall-in-foomacrolet-lexenv
(symbol-macrolet-definitionize-fun :compile)
:vars
definitions
fun))
(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
#!+sb-doc
"SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
Define the Names as symbol macros with the given Expansions. Within the
body, references to a Name will effectively be replaced with the Expansion."
(funcall-in-symbol-macrolet-lexenv
macrobindings
(lambda (&key vars)
(ir1-translate-locally body start cont :vars vars))))
;;;; %PRIMITIVE
;;;;
;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
;;;; into a funny function.
;;; Carefully evaluate a list of forms, returning a list of the results.
(defun eval-info-args (args)
(declare (list args))
(handler-case (mapcar #'eval args)
(error (condition)
(compiler-error "Lisp error during evaluation of info args:~%~A"
condition))))
;;; Convert to the %%PRIMITIVE funny function. The first argument is
;;; the template, the second is a list of the results of any
;;; codegen-info args, and the remaining arguments are the runtime
;;; arguments.
;;;
;;; We do various error checking now so that we don't bomb out with
;;; a fatal error during IR2 conversion.
;;;
;;; KLUDGE: It's confusing having multiple names floating around for
;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
;;; VOP or %VOP.. -- WHN 2001-06-11
;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
(def-ir1-translator %primitive ((name &rest args) start cont)
(declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
(bug "undefined primitive ~A" name)))
(required (length (template-arg-types template)))
(info (template-info-arg-count template))
(min (+ required info))
(nargs (length args)))
(if (template-more-args-type template)
(when (< nargs min)
(bug "Primitive ~A was called with ~R argument~:P, ~
but wants at least ~R."
name
nargs
min))
(unless (= nargs min)
(bug "Primitive ~A was called with ~R argument~:P, ~
but wants exactly ~R."
name
nargs
min)))
(when (eq (template-result-types template) :conditional)
(bug "%PRIMITIVE was used with a conditional template."))
(when (template-more-results-type template)
(bug "%PRIMITIVE was used with an unknown values template."))
(ir1-convert start
cont
`(%%primitive ',template
',(eval-info-args
(subseq args required min))
,@(subseq args 0 required)
,@(subseq args min)))))
;;;; QUOTE
(def-ir1-translator quote ((thing) start cont)
#!+sb-doc
"QUOTE Value
Return Value without evaluating it."
(reference-constant start cont thing))
;;;; FUNCTION and NAMED-LAMBDA
(def-ir1-translator function ((thing) start cont)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
be a lambda expression."
(if (consp thing)
(case (car thing)
((lambda named-lambda instance-lambda lambda-with-lexenv)
(reference-leaf start
cont
(ir1-convert-lambdalike
thing
:debug-name (debug-namify "#'~S" thing)
:allow-debug-catch-tag t)))
((setf sb!pcl::class-predicate sb!pcl::slot-accessor)
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
(t
(compiler-error "~S is not a legal function name." thing)))
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var))))
;;;; FUNCALL
;;; FUNCALL is implemented on %FUNCALL, which can only call functions
;;; (not symbols). %FUNCALL is used directly in some places where the
;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
(deftransform funcall ((function &rest args) * *)
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
(%funcall ,(if (csubtypep (continuation-type function)
(specifier-type 'function))
'function
'(%coerce-callable-to-fun function))
,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start cont)
(let ((fun-cont (make-continuation)))
(ir1-convert start fun-cont `(the function ,function))
(ir1-convert-combination-args fun-cont cont args)))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
(define-source-transform funcall (function &rest args)
(if (and (consp function) (eq (car function) 'function))
`(%funcall ,function ,@args)
(values nil t)))
(deftransform %coerce-callable-to-fun ((thing) (function) *
:important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
;;;; LET and LET*
;;;;
;;;; (LET and LET* can't be implemented as macros due to the fact that
;;;; any pervasive declarations also affect the evaluation of the
;;;; arguments.)
;;; Given a list of binding specifiers in the style of LET, return:
;;; 1. The list of var structures for the variables bound.
;;; 2. The initial value form for each variable.
;;;
;;; The variable names are checked for legality and globally special
;;; variables are marked as such. Context is the name of the form, for
;;; error reporting purposes.
(declaim (ftype (function (list symbol) (values list list))
extract-let-vars))
(defun extract-let-vars (bindings context)
(collect ((vars)
(vals)
(names))
(flet ((get-var (name)
(varify-lambda-arg name
(if (eq context 'let*)
nil
(names)))))
(dolist (spec bindings)
(cond ((atom spec)
(let ((var (get-var spec)))
(vars var)
(names spec)
(vals nil)))
(t
(unless (proper-list-of-length-p spec 1 2)
(compiler-error "The ~S binding spec ~S is malformed."
context
spec))
(let* ((name (first spec))
(var (get-var name)))
(vars var)
(names name)
(vals (second spec)))))))
(values (vars) (vals))))
(def-ir1-translator let ((bindings &body body)
start cont)
#!+sb-doc
"LET ({(Var [Value]) | Var}*) Declaration* Form*
During evaluation of the Forms, bind the Vars to the result of evaluating the
Value forms. The variables are bound in parallel after all of the Values are
evaluated."
(multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let)
(let ((fun-cont (make-continuation)))
(let* ((*lexenv* (process-decls decls vars nil cont))
(fun (ir1-convert-lambda-body
forms vars
:debug-name (debug-namify "LET ~S" bindings))))
(reference-leaf start fun-cont fun))
(ir1-convert-combination-args fun-cont cont values)))))
(def-ir1-translator let* ((bindings &body body)
start cont)
#!+sb-doc
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
form to reference any of the previous Vars."
(multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
(let ((*lexenv* (process-decls decls vars nil cont)))
(ir1-convert-aux-bindings start cont forms vars values)))))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
;;;
;;; Note that all these things need to preserve toplevel-formness,
;;; but we don't need to worry about that within an IR1 translator,
;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
;;; forms before we hit the IR1 transform level.
(defun ir1-translate-locally (body start cont &key vars funs)
(declare (type list body) (type continuation start cont))
(multiple-value-bind (forms decls) (parse-body body nil)
(let ((*lexenv* (process-decls decls vars funs cont)))
(ir1-convert-aux-bindings start cont forms nil nil))))
(def-ir1-translator locally ((&body body) start cont)
#!+sb-doc
"LOCALLY Declaration* Form*
Sequentially evaluate the Forms in a lexical environment where the
the Declarations have effect. If LOCALLY is a top level form, then
the Forms are also processed as top level forms."
(ir1-translate-locally body start cont))
;;;; FLET and LABELS
;;; Given a list of local function specifications in the style of
;;; FLET, return lists of the function names and of the lambdas which
;;; are their definitions.
;;;
;;; The function names are checked for legality. CONTEXT is the name
;;; of the form, for error reporting.
(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars))
(defun extract-flet-vars (definitions context)
(collect ((names)
(defs))
(dolist (def definitions)
(when (or (atom def) (< (length def) 2))
(compiler-error "The ~S definition spec ~S is malformed." context def))
(let ((name (first def)))
(check-fun-name name)
(names name)
(multiple-value-bind (forms decls) (parse-body (cddr def))
(defs `(lambda ,(second def)
,@decls
(block ,(fun-name-block-name name)
. ,forms))))))
(values (names) (defs))))
(def-ir1-translator flet ((definitions &body body)
start cont)
#!+sb-doc
"FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
Evaluate the Body-Forms with some local function definitions. The bindings
do not enclose the definitions; any use of Name in the Forms will refer to
the lexically apparent function definition in the enclosing environment."
(multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'flet)
(let* ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
:debug-name (debug-namify
"FLET ~S" n)
:allow-debug-catch-tag t))
names defs))
(*lexenv* (make-lexenv
:default (process-decls decls nil fvars cont)
:funs (pairlis names fvars))))
(ir1-convert-progn-body start cont forms)))))
(def-ir1-translator labels ((definitions &body body) start cont)
#!+sb-doc
"LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
Evaluate the Body-Forms with some local function definitions. The bindings
enclose the new definitions, so the defined functions can call themselves or
each other."
(multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'labels)
(let* (;; dummy LABELS functions, to be used as placeholders
;; during construction of real LABELS functions
(placeholder-funs (mapcar (lambda (name)
(make-functional
:%source-name name
:%debug-name (debug-namify
"LABELS placeholder ~S"
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(placeholder-fenv (mapcar #'cons names placeholder-funs))
;; the real LABELS functions, compiled in a LEXENV which
;; includes the dummy LABELS functions
(real-funs
(let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
:debug-name (debug-namify
"LABELS ~S" name)
:allow-debug-catch-tag t))
names defs))))
;; Modify all the references to the dummy function leaves so
;; that they point to the real function leaves.
(loop for real-fun in real-funs and
placeholder-cons in placeholder-fenv do
(substitute-leaf real-fun (cdr placeholder-cons))
(setf (cdr placeholder-cons) real-fun))
;; Voila.
(let ((*lexenv* (make-lexenv
:default (process-decls decls nil real-funs cont)
;; Use a proper FENV here (not the
;; placeholder used earlier) so that if the
;; lexical environment is used for inline
;; expansion we'll get the right functions.
:funs (pairlis names real-funs))))
(ir1-convert-progn-body start cont forms))))))
;;;; the THE special operator, and friends
;;; A logic shared among THE and TRULY-THE.
(defun the-in-policy (type value policy start cont)
(let ((type (coerce-to-values
(if (ctype-p type) type
(compiler-values-specifier-type type)))))
(cond ((or (eq type *wild-type*)
(and (leaf-p value)
(values-subtypep (leaf-type value) type))
(and (sb!xc:constantp value)
(ctypep (constant-form-value value)
(single-value-type type))))
(ir1-convert start cont value))
(t (let ((value-cont (make-continuation)))
(ir1-convert start value-cont value)
(let ((cast (make-cast value-cont type policy)))
(link-node-to-previous-continuation cast value-cont)
(setf (continuation-dest value-cont) cast)
(use-continuation cast cont)))))))
;;; Assert that FORM evaluates to the specified type (which may be a
;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
;;;
;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
;;; this didn't seem to expand into an assertion, at least for ALIEN
;;; values. Check that SBCL doesn't have this problem.
(def-ir1-translator the ((type value) start cont)
(the-in-policy type value (lexenv-policy *lexenv*) start cont))
;;; This is like the THE special form, except that it believes
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
(def-ir1-translator truly-the ((type value) start cont)
#!+sb-doc
""
(declare (inline member))
#-nil
(let ((type (compiler-values-specifier-type type))
(old (find-uses cont)))
(ir1-convert start cont value)
(do-uses (use cont)
(unless (member use old :test #'eq)
(derive-node-type use type))))
#+nil
(the-in-policy type value '((type-check . 0)) start cont))
;;;; SETQ
;;; If there is a definition in LEXENV-VARS, just set that, otherwise
;;; look at the global information. If the name is for a constant,
;;; then error out.
(def-ir1-translator setq ((&whole source &rest things) start cont)
(let ((len (length things)))
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(if (= len 2)
(let* ((name (first things))
(leaf (or (lexenv-find name vars)
(find-free-var name))))
(etypecase leaf
(leaf
(when (constant-p leaf)
(compiler-error "~S is a constant and thus can't be set." name))
(when (lambda-var-p leaf)
(let ((home-lambda (continuation-home-lambda-or-null start)))
(when home-lambda
(pushnew leaf (lambda-calls-or-closes home-lambda))))
(when (lambda-var-ignorep leaf)
;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
;; requires that this be a STYLE-WARNING, not a full warning.
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
(setq-var start cont leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
(ir1-convert start cont
`(%set-heap-alien ',leaf ,(second things))))))
(collect ((sets))
(do ((thing things (cddr thing)))
((endp thing)
(ir1-convert-progn-body start cont (sets)))
(sets `(setq ,(first thing) ,(second thing))))))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
(let ((dest (make-continuation))
(type (or (lexenv-find var type-restrictions)
(leaf-type var))))
(ir1-convert start dest `(the ,type ,value))
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
(push res (basic-var-sets var))
(link-node-to-previous-continuation res dest)
(use-continuation res cont))))
;;;; CATCH, THROW and UNWIND-PROTECT
;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
;;; since as as far as IR1 is concerned, it has no interesting
;;; properties other than receiving multiple-values.
(def-ir1-translator throw ((tag result) start cont)
#!+sb-doc
"Throw Tag Form
Do a non-local exit, return the values of Form from the CATCH whose tag
evaluates to the same thing as Tag."
(ir1-convert start cont
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
;;; the current cleanup within the body. KIND is the kind of cleanup
;;; to make, and MESS-UP is a form that does the mess-up action. We
;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
;;; and introduce the cleanup into the lexical environment. We
;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
;;; cleanup, since this inner cleanup is the interesting one.
(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
(let ((dummy (make-continuation))
(dummy2 (make-continuation)))
(ir1-convert start dummy mess-up)
(let* ((mess-node (continuation-use dummy))
(cleanup (make-cleanup :kind kind
:mess-up mess-node))
(old-cup (lexenv-cleanup *lexenv*))
(*lexenv* (make-lexenv :cleanup cleanup)))
(setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
(ir1-convert dummy dummy2 '(%cleanup-point))
(ir1-convert-progn-body dummy2 cont body))))
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
;;; function, set its kind to :ESCAPE, and then reference it. The
;;; :ESCAPE kind indicates that this function's purpose is to
;;; represent a non-local control transfer, and that it might not
;;; actually have to be compiled.
;;;
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-fun ((tag) start cont)
(let ((fun (ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
:debug-name (debug-namify "escape function for ~S" tag))))
(setf (functional-kind fun) :escape)
(reference-leaf start cont fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
(def-ir1-translator %cleanup-fun ((name) start cont)
(let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
(reference-leaf start cont fun)))
;;; We represent the possibility of the control transfer by making an
;;; "escape function" that does a lexical exit, and instantiate the
;;; cleanup using %WITHIN-CLEANUP.
(def-ir1-translator catch ((tag &body body) start cont)
#!+sb-doc
"Catch Tag Form*
Evaluates Tag and instantiates it as a catcher while the body forms are
evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
scope of the body, then control will be transferred to the end of the body
and the thrown values will be returned."
(ir1-convert
start cont
(let ((exit-block (gensym "EXIT-BLOCK-")))
`(block ,exit-block
(%within-cleanup
:catch
(%catch (%escape-fun ,exit-block) ,tag)
,@body)))))
;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
;;; cleanup forms into a local function so that they can be referenced
;;; both in the case where we are unwound and in any local exits. We
;;; use %CLEANUP-FUN on this to indicate that reference by
;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
;;; an XEP.
(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
#!+sb-doc
"Unwind-Protect Protected Cleanup*
Evaluate the form Protected, returning its values. The cleanup forms are
evaluated whenever the dynamic scope of the Protected form is exited (either
due to normal completion or a non-local exit such as THROW)."
(ir1-convert
start cont
(let ((cleanup-fun (gensym "CLEANUP-FUN-"))
(drop-thru-tag (gensym "DROP-THRU-TAG-"))
(exit-tag (gensym "EXIT-TAG-"))
(next (gensym "NEXT"))
(start (gensym "START"))
(count (gensym "COUNT")))
`(flet ((,cleanup-fun () ,@cleanup nil))
;; FIXME: If we ever get DYNAMIC-EXTENT working, then
;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
;; and something can be done to make %ESCAPE-FUN have
;; dynamic extent too.
(block ,drop-thru-tag
(multiple-value-bind (,next ,start ,count)
(block ,exit-tag
(%within-cleanup
:unwind-protect
(%unwind-protect (%escape-fun ,exit-tag)
(%cleanup-fun ,cleanup-fun))
(return-from ,drop-thru-tag ,protected)))
(,cleanup-fun)
(%continue-unwind ,next ,start ,count)))))))
;;;; multiple-value stuff
;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
;;; MV-COMBINATION.
;;;
;;; If there are no arguments, then we convert to a normal
;;; combination, ensuring that a MV-COMBINATION always has at least
;;; one argument. This can be regarded as an optimization, but it is
;;; more important for simplifying compilation of MV-COMBINATIONS.
(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
#!+sb-doc
"MULTIPLE-VALUE-CALL Function Values-Form*
Call Function, passing all the values of each Values-Form as arguments,
values from the first Values-Form making up the first argument, etc."
(let* ((fun-cont (make-continuation))
(node (if args
(make-mv-combination fun-cont)
(make-combination fun-cont))))
(ir1-convert start fun-cont
(if (and (consp fun) (eq (car fun) 'function))
fun
`(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(let ((this-cont (make-continuation node)))
(ir1-convert this-start this-cont arg)
(setq this-start this-cont)
(arg-conts this-cont)))
(link-node-to-previous-continuation node this-start)
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
;;; the result code use result continuation (CONT), but transfer
;;; control to the evaluation of the body. In other words, the result
;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
;;; the result.
;;;
;;; In order to get the control flow right, we convert the result with
;;; a dummy result continuation, then convert all the uses of the
;;; dummy to be uses of CONT. If a use is an EXIT, then we also
;;; substitute CONT for the dummy in the corresponding ENTRY node so
;;; that they are consistent. Note that this doesn't amount to
;;; changing the exit target, since the control destination of an exit
;;; is determined by the block successor; we are just indicating the
;;; continuation that the result is delivered to.
;;;
;;; We then convert the body, using another dummy continuation in its
;;; own block as the result. After we are done converting the body, we
;;; move all predecessors of the dummy end block to CONT's block.
;;;
;;; Note that we both exploit and maintain the invariant that the CONT
;;; to an IR1 convert method either has no block or starts the block
;;; that control should transfer to after completion for the form.
;;; Nested MV-PROG1's work because during conversion of the result
;;; form, we use dummy continuation whose block is the true control
;;; destination.
(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
#!+sb-doc
"MULTIPLE-VALUE-PROG1 Values-Form Form*
Evaluate Values-Form and then the Forms, but return all the values of
Values-Form."
(continuation-starts-block cont)
(let* ((dummy-result (make-continuation))
(dummy-start (make-continuation))
(cont-block (continuation-block cont)))
(continuation-starts-block dummy-start)
(ir1-convert start dummy-start result)
(substitute-continuation-uses cont dummy-start)
(continuation-starts-block dummy-result)
(ir1-convert-progn-body dummy-start dummy-result forms)
(let ((end-block (continuation-block dummy-result)))
(dolist (pred (block-pred end-block))
(unlink-blocks pred end-block)
(link-blocks pred cont-block))
(aver (not (continuation-dest dummy-result)))
(delete-continuation dummy-result)
(remove-from-dfo end-block))))
;;;; interface to defining macros
;;; Old CMUCL comment:
;;;
;;; Return a new source path with any stuff intervening between the
;;; current path and the first form beginning with NAME stripped
;;; off. This is used to hide the guts of DEFmumble macros to
;;; prevent annoying error messages.
;;;
;;; Now that we have implementations of DEFmumble macros in terms of
;;; EVAL-WHEN, this function is no longer used. However, it might be
;;; worth figuring out why it was used, and maybe doing analogous
;;; munging to the functions created in the expanders for the macros.
(defun revert-source-path (name)
(do ((path *current-path* (cdr path)))
((null path) *current-path*)
(let ((first (first path)))
(when (or (eq first name)
(eq first 'original-source-start))
(return path)))))