-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathcompiler.scm
2272 lines (2002 loc) · 86.9 KB
/
compiler.scm
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
;;; Ur-Scheme: A GPL self-hosting compiler for a subset of R5RS to fast x86 asm
;; Copyright (C) 2008 Kragen Javier Sitaker (2008-01-03 through 24)
;; (although I made a few more modifications in the following weeks)
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;; From the Scheme 9 From Empty Space page:
;; Why in earth write another half-baked implementation of Scheme?
;; It is better than getting drunk at a bar.
;; And anyway, I never metacircular compiler I didn't like. (Neil Van-Dyke)
;; I had been working on this for a couple of days now when I ran across
;http://www.iro.umontreal.ca/%7Eboucherd/mslug/meetings/20041020/minutes-en.html
;; which says:
;; How to write a simple Scheme to C compiler, in Scheme. In only
;; 90 minutes! And although not supporting the whole Scheme
;; standard, the compiler supports fully optimized proper tail
;; calls, continuations, and (of course) full closures.
;; I was feeling pretty inferior until I started watching the video of
;; the talk, in which Marc Feeley, the speaker, begins by explaining:
;; So, uh, let me clarify the, uh, the title of the presentation!
;; The 90 minutes is not the time to write the compiler, but to
;; explain it.
;; I think this is nearly the smallest subset of R5RS Scheme that it's
;; practical to write a Scheme compiler in, and I've tried to keep
;; this implementation of it as simple as I can stand. I kind of feel
;; that someone more adept would be having more success at keeping it
;; simple, but hey, it's my first compiler.
;;; Implementation planned:
;; ("D" means "done")
;; D car, cdr, cons
;; D null?
;; D booleans
;; D eq?, pair?, null?, symbol?, integer?, boolean?, string?, procedure?, char?
;; D if
;; D lambda (with fixed numbers of arguments or with a single argument
;; that gets bound to the argument list (lambda <var> <body>)
;; D begin
;; D global variables
;; D lexically-scoped local variables
;; D nested scopes and closures
;; D set! for global and local variables
;; D top-level define of a variable (not a function)
;; - read, for proper and improper lists, symbols, strings, integers,
;; #t and #f, and ' (written, just not provided to other programs yet)
;; D consequently symbols need to store their strings, and we need
;; string->symbol; other parts of the compiler use symbol->string
;; D eof-object?
;; - garbage collection
;; D strings, with string-set!, string-ref, string literals,
;; string-length, and make-string with one argument, and string=?
;; D which unfortunately requires characters; char=? and character
;; literals
;; D very basic arithmetic: two-argument +, -, quotient, remainder,
;; and = for integers, and decimal numeric constants
;; D < for integers
;; D recursive procedure calls
;; D display, for strings, and newline
;; D error
;; D several other standard procedures: list, length, assq, caar,
;; cdar, cadr, caddr, not, string-append, for-each (in a limited
;; fashion), map (in a limited fashion), memq, memv, eqv?,
;; string->list
;; D several standard macros: cond (without =>), case, or, let
;; (without tagged looping)
;; D tail-call optimization
;; All of this would be a little simpler if strings were just lists
;; of small integers.
;; Remaining to implement:
;; - make read accessible to programs compiled with the compiler
;; somehow
;; - garbage collection
;; - maybe output buffering; compiled with itself, it takes 1.3 user
;; seconds to compile itself to assembly, but
;; another 0.6 system seconds because it makes
;; almost 50 000 system calls, all but 91 of which are
;; writes to stdout. So it would compile itself 50% faster with
;; output buffering. But segfaults would be harder to diagnose.
;; - fixing (error ...) to print stuff out nicely.
;; There were a bunch of parts of standard Scheme that I implemented
;; at the top of the compiler, which was a little bit silly --- any
;; program to be compiled by this compiler would either have to forgo
;; using those same facilities, or reimplement them itself.
;; Now I have moved them into a prelude called "standard-library" that
;; gets compiled before the user's program, which considerably expands
;; the subset of Scheme supported without adding any complexity to the
;; overall system. However, it does inflate output executables a bit.
;;; Not implemented:
;; - call/cc, dynamic-wind
;; - user-definable macros
;; - quasiquote
;; - most of arithmetic
;; - vectors
;; - some of the language syntax ` , ,@
;; - do
;; - let*, letrec
;; - delay, force
;; - internal definitions
;; - most of the library procedures for handling lists, characters
;; - eval, apply
;; - multiple-value returns
;; - scheme-report-environment, null-environment
;;; Design notes:
;; The strategy taken herein is to use the x86 as a stack machine
;; (within each function, anyway). %eax contains the top of stack;
;; %esp points at a stack in memory containing the rest of the stack
;; items. This eliminates any need to allocate registers; for
;; ordinary expressions, we just need to convert the Lisp code to RPN
;; and glue together the instruction sequences that comprise them.
;; We also use the ordinary x86 stack as a call stack. See the
;; section ";;; Procedure calls" for details. This would pose
;; problems for call/cc if I were going to implement it, but I'm not,
;; so I don't care. You might think it would cause problems for
;; closures of indefinite extent, but the "Implementation of Lua 5.0"
;; paper explains a fairly straightforward way of implementing
;; closures, called "upvalues", that still lets us stack-allocate
;; almost all of the time.
;; Pointers are tagged in the low bits in more or less the usual way:
;; - low bits binary 00: an actual pointer, to an object with an
;; embedded magic number; examine the magic number to see what it
;; is.
;; - low bits binary 01: a signed integer, stored in the upper 30 bits.
;; - low bits binary 10: one of a small number of unique objects. The
;; first 256 are the chars; following these we have the empty list,
;; #t, #f, and the EOF object, in that order. This means that eq?
;; works to compare chars in this implementation, but that isn't
;; guaranteed by R5RS, so we can't depend on that property inside
;; the compiler, since we want to be able to run it on other R5RS
;; Schemes.
;; - low bits binary 11: unused.
;; So, type-testing consists of testing the type-tag, then possibly
;; testing the magic number. In the usual case, we'll jump to an
;; error routine if the type test fails, which will exit the program.
;; I'll add more graceful exits later.
;;; Basic Lisp Stuff
;; Things that I can't find in R5RS, and so I'm not including in
;; standard-library down below.
(define (double val) (+ val val))
(define (quadruple val) (double (double val)))
;; These functions' names come from Common Lisp or Forth.
(define (1+ x) (+ x 1)) ; duplicated in stdlib
(define (1- x) (- x 1)) ; duplicated in stdlib
(define (reduce fn lst init)
(if (null? lst) init (fn (car lst) (reduce fn (cdr lst) init))))
(define (filter fn lst) ; this must exist in r5rs but I can't find it
(if (null? lst) '()
(let ((first (car lst)) (rest (filter fn (cdr lst))))
(if (fn first) (cons first rest) rest))))
(define (char->string char) ; duplicated in stdlib
(let ((buf (make-string 1))) (string-set! buf 0 char) buf))
(define (assert x why) (if (not x) (error "surprise! error" why) '()))
;; Boy, it sure causes a lot of hassle that Scheme has different types
;; for strings and chars.
;; copies "len" chars from "src" starting at "srcidx" to "dest"
;; starting at "destidx"
;; XXX needs a !
(define (string-blit! src srcidx len dest destidx) ; duplicated in stdlib
(if (= len 0) #f
(begin (string-set! dest destidx (string-ref src srcidx))
(string-blit! src (1+ srcidx) (1- len) dest (1+ destidx)))))
;;; Basic Assembly Language Emission
;; emit: output a line of assembly by concatenating the strings in an
;; arbitrarily nested list structure
(define assembly-diversions #f)
(define diverted-assembly '())
(define (asm-display stuff)
(if assembly-diversions (set! diverted-assembly (cons stuff diverted-assembly))
(display stuff)))
(define (push-assembly-diversion)
(assert (not assembly-diversions) "already diverted")
(set! assembly-diversions #t))
(define (pop-diverted-assembly)
(let ((result (asm-flatten (reverse diverted-assembly))))
(set! assembly-diversions #f)
(set! diverted-assembly '())
result))
(define (emit . stuff) (asm-display (asm-flatten (cons stuff "\n"))))
(define (asm-flatten stuff)
(let ((buf (make-string (asm-flatten-size stuff))))
(asm-flatten-inner buf 0 stuff)
buf))
(define (asm-flatten-size stuff)
(cond ((null? stuff) 0)
((pair? stuff) (+ (asm-flatten-size (car stuff))
(asm-flatten-size (cdr stuff))))
((string? stuff) (string-length stuff))
(else (error "flatten-size" stuff))))
(define (asm-flatten-inner buf idx stuff)
(cond ((null? stuff)
idx)
((pair? stuff)
(asm-flatten-inner buf
(asm-flatten-inner buf idx (car stuff))
(cdr stuff)))
((string? stuff)
(string-blit! stuff 0 (string-length stuff) buf idx)
(+ idx (string-length stuff)))
(else
(error "flattening" stuff))))
;; Memoize a one-argument assembly-generating routine.
(define (memo1-asm proc)
(let ((results '()))
(lambda (arg)
(let ((cached (assq arg results)))
(if cached (begin (asm-display (cadr cached)) (caddr cached))
(begin
(push-assembly-diversion)
(let ((result (proc arg)))
(let ((output (pop-diverted-assembly)))
(set! results (cons (list arg output result) results))
(asm-display output)
result))))))))
;; Memoize a zero-argument assembly-generating routine.
(define (memo0-asm proc)
(lambda ()
(let ((output #f) (result #f))
(cond (output (asm-display output) result)
(else (push-assembly-diversion)
(let ((nresult (proc)))
(set! output (pop-diverted-assembly))
(set! result nresult)
(asm-display output)
result))))))
;; Emit an indented instruction
(define (insn . insn) (emit (cons " " insn)))
(define (comment . comment) (insn "# " comment))
;; Emit a two-argument instruction
(define (twoarg mnemonic) (lambda (src dest) (insn mnemonic " " src ", " dest)))
;; For example:
(define mov (twoarg "movl")) (define movb (twoarg "movb"))
(define movzbl (twoarg "movzbl"))
(define test (twoarg "test")) (define cmp (twoarg "cmpl"))
(define lea (twoarg "lea"))
(define add (twoarg "add")) (define sub (twoarg "sub"))
(define xchg (twoarg "xchg"))
(define asm-and (twoarg "and"))
;; Emit a one-argument instruction
(define (onearg mnemonic) (lambda (rand) (insn mnemonic " " rand)))
(define asm-push (onearg "push")) (define asm-pop (onearg "pop"))
(define jmp (onearg "jmp")) (define jnz (onearg "jnz"))
(define je (onearg "je")) (define jz je)
(define jnb (onearg "jnb")) (define jl (onearg "jl"))
(define js (onearg "js"))
(define call (onearg "call")) (define int (onearg "int"))
(define inc (onearg "inc")) (define dec (onearg "dec"))
(define idiv (onearg "idiv"))
;; These have two-arg forms too, but I'm not using them.
(define sal (onearg "sal")) (define sar (onearg "sar"))
;; Currently only using three zero-argument instructions:
(define (ret) (insn "ret"))
(define (rep-stosb) (insn "rep stosb"))
(define (repe-cmpsb) (insn "repe cmpsb"))
;; Registers:
(define eax "%eax") (define ebx "%ebx")
(define ecx "%ecx") (define edx "%edx")
(define ebp "%ebp") (define esp "%esp")
(define esi "%esi") (define edi "%edi")
(define al "%al")
;; x86 addressing modes:
(define (const x) (list "$" x))
(define (indirect x) (list "(" x ")"))
(define (offset x offset) (list (number->string offset) (indirect x)))
(define (absolute x) (list "*" x))
;; Use this one inside of "indirect" or "offset".
(define (index-register base index size)
(list base "," index "," (number->string size)))
(define (syscall) (int (const "0x80")))
;; Other stuff for basic asm emission.
(define (section name) (insn ".section " name))
(define (rodata) (section ".rodata"))
(define (text) (insn ".text"))
(define (label label) (emit label ":"))
;; define a .globl label
(define (global-label lbl) (insn ".globl " lbl) (label lbl))
;; new-label: Allocate a new label (e.g. for a constant) and return it.
(define old-label-prefixes '())
(define constcounter 0)
(define label-prefix "k")
;; We set the label prefix (and reset the counter) periodically for
;; two reasons. First, the assembly code is much more readable when
;; it says movl (_cdr_2), %eax; call ensure_procedure, rather than
;; movl (k_321), %eax; call ensure_procedure. Second, resetting the
;; counter occasionally means that a compiler change that allocates
;; one more or one less label will have a fairly local effect on the
;; assembly output, rather than changing hundreds or thousands of
;; labels, and all the references to them. This makes the diff output
;; a lot more readable!
;; However, occasionally we'll get the label-prefix set to the same
;; thing twice, at different times. This can occur because of
;; quasi-name-collisions in the user program, duplicate defines of the
;; same variable, or just somebody naming a variable "k". In this
;; case, we simply decline to set the label-prefix.
(define (set-label-prefix new-prefix)
(let ((new-label-prefix
(asm-flatten
(cons "_"
(escape (symbol->string new-prefix) 0
'("+" "-" "=" "?" ">" "<" "!" "*" "/"
":" "@" "^" "~" "$" "%" "&")
'("Plus" "_" "Eq" "P" "Gt" "Lt" "Bang" "Star" "Slash"
"Co" "At" "Caret" "Tilde" "Dollar" "Pct" "And"))))))
(let ((prefix-symbol (string->symbol new-label-prefix)))
(if (not (memq prefix-symbol old-label-prefixes))
(begin
(set! label-prefix new-label-prefix)
(set! old-label-prefixes (cons prefix-symbol old-label-prefixes))
(set! constcounter 0))))))
(define (new-label)
(set! constcounter (1+ constcounter))
(list label-prefix "_" (number->string constcounter)))
;; stuff to output a Lisp string safely for assembly language
(define (escape-char char dangerous escapes) ; duplicated in stdlib
(cond ((null? dangerous) (char->string char))
((char=? char (string-ref (car dangerous) 0))
(car escapes))
(else (escape-char char (cdr dangerous) (cdr escapes)))))
(define (escape string idx dangerous escapes) ; duplicated in stdlib
(if (= idx (string-length string)) '()
(cons (escape-char (string-ref string idx) dangerous escapes)
(escape string (1+ idx) dangerous escapes))))
;; Escape the three necessary characters. duplicated in stdlib
(define (backslash string) (escape string 0 '("\\" "\n" "\"")
'("\\\\" "\\n" "\\\"")))
;; Represent a string appropriately for the output assembly language file.
(define (asm-represent-string string) (list "\"" (backslash string) "\""))
(define (ascii string) (insn ".ascii " (asm-represent-string string)))
;; emit a prologue for a datum to be assembled into .rodata
(define (rodatum labelname)
(rodata)
(comment "align pointers so they end in binary 00")
(insn ".align 4")
(label labelname))
(define (compile-word contents) (insn ".long " contents))
;;; Stack Machine Primitives
;; As explained earlier, there's an "abstract stack" that includes
;; %eax as well as the x86 stack.
(define tos eax) ; top-of-stack register
(define nos (indirect esp)) ; "next on stack", what's underneath TOS
;; push-const: Emit code to push a constant onto the abstract stack
(define (push-const val) (asm-push tos) (mov (const val) tos))
;; pop: Emit code to discard top of stack.
(define (pop) (asm-pop tos))
;; dup: Emit code to copy top of stack.
(define (dup) (asm-push tos))
;; swap: Emit code to exchange top of stack with what's under it.
(define (swap) (xchg tos nos))
;;; Some convenience stuff for the structure of the program.
(define stuff-to-put-in-the-header (lambda () #f))
(define (concatenate-thunks a b) (lambda () (a) (b)))
(define (add-to-header proc)
(set! stuff-to-put-in-the-header
(concatenate-thunks stuff-to-put-in-the-header proc)))
;; Add code to the header to define an error message.
(define (define-error-routine labelname message)
(add-to-header (lambda ()
(let ((errlabel
(constant-string (string-append "error: "
(string-append message "\n")))))
(label labelname)
(mov (const errlabel) tos)
(jmp "report_error")))))
;; Emit the code for the normal error-reporting routine
(add-to-header (lambda ()
(label "report_error")
(extract-string)
(comment "fd 2: stderr")
(mov (const "2") ebx)
(write_2)
(mov (const "1") ebx) ; exit code of program
(mov (const "1") eax) ; __NR_exit
(syscall))) ; make system call to exit
(define (compile-tag-check-procedure desired-tag)
(get-procedure-arg 0)
(asm-and (const "3") tos)
(cmp (const desired-tag) tos)
(je "return_true")
(jmp "return_false"))
;;; Procedure values and procedure calls.
;; Procedure values are at least 12 bytes:
;; - 4 bytes: procedure magic number 0xca11ab1e
;; - 4 bytes: pointer to procedure machine code
;; - 4 bytes: number of closed-over variables --- zero for top-level
;; procedures. This is not needed by the code inside the closure.
;; Pointers to any closed-over variables follow.
;;
;; The number of arguments is passed in %edx; on the machine stack is
;; the return address, with the arguments underneath it; the address
;; of the procedure value that was being called is in %eax. Callee
;; saves %ebp and pops their own arguments off the stack. The
;; prologue points %ebp at the arguments. Return value goes in %eax.
(define procedure-magic "0xca11ab1e")
;; Emit code for a procedure application, after the code to push the
;; arguments has already been emitted. Note that this contains a
;; forward reference to ensure-procedure.
(define compile-apply
(memo1-asm (lambda (nargs)
(ensure-procedure)
(mov (offset tos 4) ebx) ; address of actual procedure
(mov (const (number->string nargs)) edx)
(call (absolute ebx)))))
(define compile-tail-apply
(memo1-asm (lambda (nargs)
(comment "Tail call; nargs = " (number->string nargs))
(comment "Note %esp points at the last thing pushed,")
(comment "not the next thing to push. So for 1 arg, we want %ebx=%esp")
(lea (offset esp (quadruple (1- nargs))) ebx)
(pop-stack-frame edx)
(copy-args ebx nargs 0)
(asm-push edx)
(ensure-procedure)
(mov (offset tos 4) ebx)
(mov (const (number->string nargs)) edx)
(jmp (absolute ebx)))))
(define (copy-args basereg nargs i)
(if (not (= nargs i))
(begin (asm-push (offset basereg (- 0 (quadruple i))))
(copy-args basereg nargs (1+ i)))))
;; package up variadic arguments into a list. %ebp is fully set up,
;; so we can index off of it to find each argument, and %edx is the
;; total number of arguments. Only trouble is that we have to push
;; %edx and our loop counter and whatever if we want to save them
;; across a call to cons.
(add-to-header
(lambda ()
(label "package_up_variadic_args")
(comment "we have %ebp pointing at args, %edx with count")
(comment "saved %ebp in %eax. zero-iterations case: return nil")
(push-const nil-value)
(label "variadic_loop")
(dec edx)
(comment "fucking dec doesn't update carry flag, so jump if negative")
(js "variadic_loop_end")
(comment "calling cons clobbers registers, so push %edx")
(asm-push edx)
(comment "now push args for cons")
(asm-push eax)
(asm-push (offset (index-register ebp edx 4) 4))
(comment "give cons its argument count")
(mov (const "2") edx)
(call "cons")
(comment "now the args are popped and we have new list in %eax")
(asm-pop edx)
(jmp "variadic_loop")
(label "variadic_loop_end")
(comment "now we pretend procedure was called with the list as first arg")
(mov eax (indirect ebp))
(comment "restore %eax to value on entry to package_up_variadic_args")
(pop)
(ret)))
(define (compile-variadic-prologue)
(comment "make space for variadic argument list")
(asm-pop ebx)
(asm-push ebx)
(asm-push ebx)
(comment "push desired %esp on return")
(lea (offset (index-register esp edx 4) 8) ebx)
(asm-push ebx)
(asm-push ebp) ; save old %ebp
(lea (offset esp 12) ebp) ; 12 bytes to skip saved %ebp, %ebx, %eip
(call "package_up_variadic_args"))
(define compile-procedure-prologue
(memo1-asm (lambda (nargs)
(if (null? nargs) (compile-variadic-prologue)
(begin
(comment "compute desired %esp on return in %ebx and push it")
(lea (offset (index-register esp edx 4) 4) ebx)
(asm-push ebx)
(asm-push ebp) ; save old %ebp
(lea (offset esp 12) ebp) ; 12 bytes to skip saved %ebp, %ebx, %eip
(cmp (const (number->string nargs)) edx)
(jnz "argument_count_wrong"))))))
(define compile-procedure-epilogue
(memo0-asm (lambda ()
(comment "procedure epilogue")
(comment "get return address")
(pop-stack-frame edx)
(jmp (absolute edx)))))
(define (pop-stack-frame return-address-register)
(mov (offset ebp -4) return-address-register)
(mov (offset ebp -8) esp)
(mov (offset ebp -12) ebp))
(define-error-routine "argument_count_wrong" "wrong number of arguments")
;; Compiles a procedure into the text segment at a given label.
(define (compile-procedure bodylabel nargs body)
(text)
(label bodylabel)
(compile-procedure-prologue nargs)
(body)
(compile-procedure-epilogue)) ; maybe we should just centralize
; that and jump to it? :)
;; Define a built-in procedure so we can refer to it by label and
;; push-const that label and expect to get a procedure value.
(define (compile-procedure-labeled labelname nargs body)
(let ((bodylabel (new-label)))
(rodatum labelname)
(compile-word procedure-magic)
(compile-word bodylabel)
(compile-word "0") ; closed over zero artifacts
(compile-procedure bodylabel nargs body)))
;; Add code to define a global procedure known by a certain global
;; variable name to the header
(define (define-global-procedure symbolname nargs body)
(add-to-header
(lambda ()
(set-label-prefix symbolname)
(let ((procedure-value-label (new-label)))
(define-global-variable symbolname procedure-value-label)
(compile-procedure-labeled procedure-value-label nargs body)))))
;; Emit code to jump to e.g. an error handler if the magic doesn't
;; match. Used for procedure?, ensure_procedure, and similar things
;; for other data types.
(define (if-not-right-magic-jump magic destlabel)
(comment "test whether %eax has magic: " magic)
(comment "first, ensure that it's a pointer, not something unboxed")
(test (const "3") tos) ; test low two bits
(jnz destlabel)
(comment "now, test its magic number")
(cmp (const magic) (indirect tos))
(jnz destlabel))
;; Generic "ensure-whatever" routine based on magic numbers.
;; The emitted assembly routine exits with an error if the magic
;; number is wrong.
(define (call-ensure-magic-routine magic routine-label errmsg)
(let ((errlabel (new-label)))
(define-error-routine errlabel errmsg)
(add-to-header (lambda ()
(label routine-label)
(if-not-right-magic-jump magic errlabel)
(ret))))
(lambda () (call routine-label)))
(add-to-header
(lambda ()
(label "return_true")
(mov (const true-value) tos)
(compile-procedure-epilogue)
(label "return_false")
(mov (const false-value) tos)
(compile-procedure-epilogue)))
(define (define-magic-check-primitive name magic)
(define-global-procedure name 1
(lambda ()
(get-procedure-arg 0)
(if-not-right-magic-jump magic "return_false")
(jmp "return_true"))))
(define-magic-check-primitive 'procedure? procedure-magic)
(define ensure-procedure
(call-ensure-magic-routine procedure-magic
"ensure_procedure"
"not a procedure"))
;; Emit code to fetch the Nth argument of the innermost procedure.
(define get-procedure-arg
(memo1-asm (lambda (n)
(asm-push tos)
(mov (offset ebp (quadruple n)) tos))))
;; Emit code to mutate that same Nth argument.
(define (set-procedure-arg n)
(mov tos (offset ebp (quadruple n))))
;;; Closures and closure handling.
;; If a particular variable is captured by some nested
;; lambda-expression, we heap-allocate that variable. But that
;; requires knowing which variables are so captured.
;; With respect to a particular lambda-expression, any particular
;; variable can be in one of five categories:
;; - not mentioned;
;; - a stack argument --- one that isn't captured by any inner
;; lambdas;
;; - a heap argument --- one that is captured by inner lambdas;
;; - an "artifact" --- inherited from some enclosing lexical scope;
;; - a global variable.
;; First, some basic set arithmetic.
(define (set-subtract a b) (filter (lambda (x) (not (memq x b))) a))
(define (set-equal a b) (eq? (set-subtract a b) (set-subtract b a)))
(define (add-if-not-present obj set) (if (memq obj set) set (cons obj set)))
(define (set-union a b) (reduce add-if-not-present a b))
(define (set-intersect a b) (filter (lambda (x) (memq x b)) a))
(define (set-union-all sets) (reduce set-union sets '()))
(assert (set-equal '() '()) "empty set equality")
(assert (set-equal '(a) '(a)) "set equality with one item")
(assert (not (set-equal '(a) '(b))) "set inequality with one item")
(assert (not (set-equal '() '(a))) "set inequality () (a)")
(assert (not (set-equal '(a) '())) "set inequality (a) ()")
(assert (set-equal '(a a) '(a)) "set equality (a a) (a)")
(assert (set-equal '(a b) '(b a)) "set equality sequence varies")
(assert (= (length (add-if-not-present 'a '())) 1) "add to empty set")
(assert (= (length (add-if-not-present 'a '(a))) 1) "redundant add")
(assert (= (length (add-if-not-present 'a '(b))) 2) "nonredundant add")
(define sample-abcd (set-union '(a b c) '(b c d)))
(assert (= (length sample-abcd) 4) "set union")
(assert (memq 'a sample-abcd) "member from set 1")
(assert (memq 'd sample-abcd) "member from set 2")
(assert (not (memq '() sample-abcd)) "nil not in set")
(define (assert-set-equal a b) (assert (set-equal a b) (list 'set-equal a b)))
(assert-set-equal (set-intersect '(a b c) '(b c d)) '(b c))
;; Returns vars captured by some lambda inside expr, i.e. vars that
;; occurs free inside a lambda inside expr.
(define (captured-vars expr) (set-union-all (map free-vars (lambdas expr))))
(define (lambdas expr)
(cond ((not (pair? expr)) '()) ; non-lists and empty lists
;; We don't want the deeper-nested lambdas, just the top-level
;; ones.
((eq? (car expr) 'lambda) (list expr))
(else (reduce append (map lambdas expr) '()))))
(define (all-captured-vars expr) (set-union-all (map captured-vars expr)))
;; Returns a list of the vars that are bound by a particular lambda arg list.
(define (vars-bound args) (if (symbol? args) (list args) args))
;; Returns vars that occur free inside a lambda-abstraction with given
;; args and body.
(define (free-vars-lambda args body)
(set-subtract (all-free-vars body) (vars-bound args)))
;; Returns vars that occur free inside of expr.
(define (free-vars expr)
(cond ((symbol? expr) (list expr))
((not (pair? expr)) '())
(else (case (car expr)
((lambda) (free-vars-lambda (cadr expr) (cddr expr)))
((%begin %ifeq)
(all-free-vars (cdr expr)))
((quote) '())
((set!) (add-if-not-present (cadr expr)
(free-vars (caddr expr))))
(else (all-free-vars expr))))))
;; Returns vars that occur free inside of any of exprs.
(define (all-free-vars exprs) (set-union-all (map free-vars exprs)))
;; Returns the free vars of a lambda found somewhere in its lexical
;; environment. This needs access to the lexical environment to
;; distinguish artifacts from globals.
(define (artifacts vars body env) (filter (lambda (x) (assq x env))
(free-vars-lambda vars body)))
;; Compiles code to store the requested heap arguments; returns an
;; environment containing them as well as the original contents of the
;; environment.
(define (compile-heap-args heap-args heap-slots-used env)
(comment "discarding useless value in %eax")
(pop)
(compile-heap-args-2 heap-args heap-slots-used env))
(define (compile-heap-args-2 heap-args heap-slots-used env)
(if (null? heap-args) env
(let ((var (car heap-args)))
(begin
(comment "move arg from stack to heap: " (symbol->string var))
(compile-var var env)
(move-var-to-heap-arg)
;; Now we have the heap arg pointer on the stack, hopefully
;; in the right place.
(compile-heap-args-2 (cdr heap-args) (1+ heap-slots-used)
(cons (list var 'heap-pointer
heap-slots-used) env))))))
(define (push-artifacts artifacts) (push-artifacts-2 artifacts 0))
(define (push-artifacts-2 artifacts slotnum)
(if (null? artifacts) '()
(let ((var (car artifacts)))
(comment "fetch artifact from closure: " (number->string slotnum)
" " (symbol->string var))
;; 12 skips the magic number, code pointer, and artifact count.
(asm-push (offset eax (+ 12 (quadruple slotnum))))
(cons (list var 'heap-pointer slotnum)
(push-artifacts-2 (cdr artifacts) (1+ slotnum))))))
(define (push-closure label artifacts env)
(emit-malloc-n (+ 12 (quadruple (length artifacts))))
(mov tos ebx)
(mov (const procedure-magic) (indirect ebx))
(mov (const label) (offset ebx 4))
(mov (const (number->string (length artifacts))) (offset ebx 8))
(store-closure-artifacts ebx 12 artifacts env))
(define (store-closure-artifacts reg off artifacts env)
(if (not (null? artifacts))
(begin (get-heap-var (assq (car artifacts) env))
(mov tos (offset reg off))
(pop)
(store-closure-artifacts reg (+ off 4) (cdr artifacts) env))))
;; Heap variable objects are 8 bytes: a magic number and their current value.
(define heap-var-magic "0x1ce11ed")
(define (move-var-to-heap-arg)
(comment "moving top of stack to newly allocated heap var")
(emit-malloc-n 8)
(mov (const heap-var-magic) (indirect tos))
(asm-pop (offset tos 4)))
;; Some basic unit tests for closure handling.
(define sample-closure-expression
'(lambda (a b)
(lambda (c d)
(lambda (e f) (foo e f c a)))))
(assert-set-equal (free-vars sample-closure-expression) '(foo))
(assert-set-equal (captured-vars sample-closure-expression) '(foo))
(define sample-inner-lambda-1 (caddr sample-closure-expression))
(assert-set-equal (free-vars sample-inner-lambda-1) '(a foo))
(assert-set-equal (captured-vars sample-inner-lambda-1) '(a foo))
(define sample-inner-lambda-2 (caddr sample-inner-lambda-1))
(assert-set-equal (free-vars sample-inner-lambda-2) '(a c foo))
(assert-set-equal (captured-vars sample-inner-lambda-2) '(a c foo))
(assert-set-equal (artifacts '(e f) (caddr sample-inner-lambda-2)
'((c whatever) (d whatever)
(a whatever) (b whatever)))
'(a c))
;; Some tests for the other cases.
(define sample-quoted-expr '(foo bar '(a b c)))
(assert-set-equal (free-vars sample-quoted-expr) '(foo bar))
(assert-set-equal (captured-vars sample-quoted-expr) '())
(define sample-if-expr '(%ifeq a b c d))
(assert-set-equal (free-vars sample-if-expr) '(a b c d))
(assert-set-equal (captured-vars sample-if-expr) '())
(define sample-begin-expr '(%begin a b c))
(assert-set-equal (free-vars sample-begin-expr) '(a b c))
(assert-set-equal (captured-vars sample-begin-expr) '())
;; In particular, multiple expressions in a lambda body here.
(assert-set-equal (captured-vars
'(%begin (%ifeq x #f (lambda (y) (z a) (y c)) d) e))
'(z a c))
(assert-set-equal (captured-vars '(lambda x (x y z))) '(y z))
(define (heap-args varlist body)
(set-intersect varlist (all-captured-vars body)))
(assert-set-equal '(a) (heap-args (cadr sample-closure-expression)
(cddr sample-closure-expression)))
(assert-set-equal '(c) (heap-args (cadr sample-inner-lambda-1)
(cddr sample-inner-lambda-1)))
(assert-set-equal '() (heap-args (cadr sample-inner-lambda-2)
(cddr sample-inner-lambda-2)))
(assert-set-equal '(message)
(heap-args '(message)
'((lambda (message2)
(display message)
(display message2)
(newline)))))
(assert-set-equal '(a b) (free-vars '(set! a b)))
(assert-set-equal '() (captured-vars '(set! a b)))
;;; Memory management.
(add-to-header
(lambda ()
(insn ".bss")
(label "the_arena")
(insn ".space 128*1048576") ; no GC yet!
(compile-global-variable "arena_pointer" "the_arena")))
;; Emit code to bump a pointer in a register up, if necessary, to be
;; divisible by 4.
(define (align4 reg)
(add (const "3") reg)
(asm-and (const "~3") reg))
(define emit-malloc
(memo0-asm (lambda ()
(comment "code to allocate memory; untagged number of bytes in %eax")
(align4 eax)
(mov (indirect "arena_pointer") ebx)
(add eax (indirect "arena_pointer"))
(mov ebx eax)
(comment "now %eax points to newly allocated memory"))))
(define emit-malloc-n
(memo1-asm (lambda (n)
(assert-equal (remainder n 4) 0)
(let ((ns (number->string n)))
(comment "allocate bytes: " ns)
(asm-push tos)
(mov (indirect "arena_pointer") tos)
(add (const ns) (indirect "arena_pointer"))
(comment "now %eax points to newly allocated memory")))))
;; XXX still need to implement deallocation and a GC (see README.gc)
(add-to-header (lambda () (compile-global-variable "stack_bottom" "0")))
;;; Strings (on the target)
;; A string consists of the following, contiguous in memory:
;; - 4 bytes of a string magic number 0xbabb1e
;; - 4 bytes of string length "N";
;; - N bytes of string data.
(define string-magic "0xbabb1e")
(define-magic-check-primitive 'string? string-magic)
;; ensure-string: emit code to ensure that %eax is a string
(define ensure-string
(call-ensure-magic-routine string-magic "ensure_string" "not a string"))
(define (constant-string-2 contents labelname)
(rodatum labelname)
(compile-word string-magic)
(compile-word (number->string (string-length contents)))
(ascii contents)
(text)
labelname)
;; constant-string: Emit code to represent a constant string.
(define (constant-string contents) (constant-string-2 contents (new-label)))
;; Emit code to pull the string pointer and count out of a string
;; being pointed to and push them on the abstract stack
(define (extract-string)
(ensure-string)
(lea (offset tos 8) ebx) ; string pointer
(asm-push ebx)
(mov (offset tos 4) tos)) ; string length
(define-global-procedure 'make-string 1
(lambda () (get-procedure-arg 0)
(ensure-integer)
(comment "we need 8 bytes more than the string length")
(scheme-to-native-integer tos)
(add (const "8") tos)
(emit-malloc)
(mov (const string-magic) (indirect tos))
(mov tos ebx)
(comment "push address to return, get string length and store it")
(get-procedure-arg 0)
(scheme-to-native-integer tos)
(mov tos (offset ebx 4))
(comment "fill string with Xes")
(lea (offset ebx 8) edi)
(mov tos ecx)
(mov (const "'X") eax)
(rep-stosb)
(comment "now pop and return the address")
(pop)))
;; pops both index and bound
(define (check-array-bounds)
(comment "verify that tagged %eax is in [0, untagged NOS)")
(ensure-integer)
;; Intel manual 253667 explains, "[The SUB instruction]
;; evaluates the result for both signed and unsigned integer
;; operands and sets the OF and CF flags to indicate an overflow
;; in the signed or unsigned result, respectively. The SF flag
;; indicates the sign of the signed result."
(scheme-to-native-integer eax)
;; We can do this with a single unsigned comparison; negative
;; array indices will look like very large positive numbers and
;; therefore be out of bounds.
(comment "set flags by (unsigned array index - array max)")
(cmp nos tos)
(comment "now we expect unsigned overflow, i.e. borrow/carry.")
(jnb "index_out_of_bounds")
(comment "now discard both the index and the bound")
(pop) (pop))
(define-error-routine "index_out_of_bounds" "array index out of bounds")
(define-global-procedure 'string-set! 3
(lambda ()
(comment "string-set! primitive procedure")
(get-procedure-arg 0)
(extract-string)
(get-procedure-arg 1)
(check-array-bounds)
(get-procedure-arg 1)
(scheme-to-native-integer tos)
(mov tos edi)
(comment "now retrieve the address of string bytes from the stack")
(pop)
(mov tos ebx)
(get-procedure-arg 2)
(ensure-character)
(scheme-to-native-character tos)
(movb al (indirect (index-register ebx edi 1)))
(comment "discard the character and base address")
(pop) (pop)
(comment "but we need a return value...")
(get-procedure-arg 0)))
(define-global-procedure 'string-ref 2
(lambda ()
(comment "string-ref primitive procedure")
(get-procedure-arg 0)
(extract-string)
(get-procedure-arg 1)
(check-array-bounds)
(get-procedure-arg 1)
(scheme-to-native-integer tos)
(comment "get base address of string data from stack")
(asm-pop ebx)
(movzbl (indirect (index-register tos ebx 1)) tos)
(native-to-scheme-character tos)))
;; I was going to write an assembly version of string-blit! here, but