forked from justinethier/cyclone
-
Notifications
You must be signed in to change notification settings - Fork 0
/
cyclone.scm
1189 lines (1108 loc) · 47.2 KB
/
cyclone.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
;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains a front-end for the compiler itself.
;;;;
(import (scheme base)
(scheme case-lambda)
(scheme eval)
(scheme file)
(scheme lazy)
(scheme read)
(scheme time)
(scheme write)
(scheme cyclone ast)
(scheme cyclone common)
(scheme cyclone util)
(scheme cyclone cgen)
(scheme cyclone primitives)
(scheme cyclone transforms)
(scheme cyclone cps-optimizations)
(scheme cyclone libraries)
(srfi 18))
(define *fe:batch-compile* #t) ;; Batch compilation. TODO: default to false or true??
(define *optimization-level* 2) ;; Default level
(define *optimize:memoize-pure-functions* #f) ;; Memoize pure function
(define *optimize:beta-expand-threshold* #f) ;; BE threshold or #f to use default
(define *optimize:inline-unsafe* #f) ;; Inline primitives even if generated code may be unsafe
(define *cgen:track-call-history* #t)
(define *cgen:use-unsafe-prims* #f)
; Placeholder for future enhancement to show elapsed time by phase:
(define *start* (current-second))
;; FUTURE: make this a cmd line option
(define *report-elapsed* #f)
(define (report:elapsed label)
(when *report-elapsed*
(display "Elapsed is " (current-error-port))
(display (- (current-second) *start*) (current-error-port))
(display (string-append " at " label) (current-error-port))
(newline (current-error-port))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Batch compilation section
;; Do we need to recompile given library?
(define (recompile? lib-dep append-dirs prepend-dirs)
(let* ((sld-file (lib:import->filename lib-dep ".sld" append-dirs prepend-dirs))
(includes (lib:read-includes lib-dep append-dirs prepend-dirs))
(included-files
(map
(lambda (include)
(lib:import->path lib-dep append-dirs prepend-dirs include))
includes))
(base (basename sld-file))
(obj-file (string-append base ".o"))
(sys-dir (Cyc-installation-dir 'sld)) )
(and
(not (in-subdir? sys-dir sld-file)) ;; Never try to recompile installed libraries
(or
(not (file-exists? obj-file)) ;; No obj file, must rebuild
(any
(lambda (src-file)
(> (file-mtime src-file)
(file-mtime obj-file))) ;; obj file out of date
(cons sld-file included-files))))))
;; Is "path" under given subdirectory "dir"?
(define (in-subdir? dir path)
(and (>= (string-length path)
(string-length dir))
(equal? dir (substring path 0 (string-length dir)))))
(define-c file-mtime
"(void *data, int argc, closure _, object k, object filename)"
" make_double(box, 0.0);
Cyc_check_str(data, filename);
double_value(&box) = Cyc_file_last_modified_time(string_str(filename));
return_closcall1(data, k, &box); ")
(define-c calling-program
"(void *data, int argc, closure _, object k)"
" make_utf8_string(data, s, _cyc_argv[0]);
return_closcall1(data, k, &s); ")
;; END batch compilation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Code emission.
; c-compile-and-emit : (string -> A) exp -> void
(define (c-compile-and-emit input-program program:imports/code
lib-deps change-lib-deps! src-file append-dirs prepend-dirs)
(call/cc
(lambda (return)
(define globals '())
(define module-globals '()) ;; Globals defined by this module
(define program? #t) ;; Are we building a program or a library?
(define imports '())
(define inlines '())
(define imported-vars '())
(define lib-name '())
(define lib-exports '())
(define lib-renamed-exports '())
(define lib-pass-thru-exports '())
(define c-headers '())
(define rename-env (env:extend-environment '() '() '()))
(emit *c-file-header-comment*) ; Guarantee placement at top of C file
(report:elapsed "---------------- input program:")
(trace:info "---------------- input program:")
(trace:info input-program)
(cond
((library? (car input-program))
(let ((includes (lib:includes (car input-program))))
(set! program? #f)
(set! lib-name (lib:name (car input-program)))
(set! c-headers (lib:include-c-headers (car input-program)))
(when (> *optimization-level* 0)
(set! inlines (lib:inlines (car input-program))))
(set! lib-exports
(cons
(lib:name->symbol lib-name)
(lib:exports (car input-program))))
(set! lib-pass-thru-exports lib-exports)
(set! lib-renamed-exports
(lib:rename-exports (car input-program)))
(set! imports (lib:imports (car input-program)))
(set! input-program (lib:body (car input-program)))
;; Add any renamed exports to the begin section
(set! input-program
(append
(map
(lambda (r)
`(define ,(caddr r) ,(cadr r)))
lib-renamed-exports)
input-program))
;; Prepend any included files into the begin section
(if (not (null? includes))
(for-each
(lambda (include)
(set! input-program
(append (read-file ;(string-append
(lib:import->path lib-name append-dirs prepend-dirs include)
;include)
)
input-program)))
(reverse includes))))) ;; Append code in same order as the library's includes
(else
;; Handle imports, if present
(let ((reduction program:imports/code))
(set! imports (car reduction))
(set! input-program (cdr reduction)))
;; Handle inline list, if present`
(let ((lis (lib:inlines `(dummy dummy ,@input-program))))
(cond
((not (null? lis))
(when (> *optimization-level* 0)
(set! inlines lis))
(set! input-program
(filter
(lambda (expr)
(not (tagged-list? 'inline expr)))
input-program)))))
;; Handle any C headers
(let ((headers (lib:include-c-headers `(dummy dummy ,@input-program))))
(cond
((not (null? headers))
(set! c-headers headers)
(set! input-program
(filter
(lambda (expr)
(not (tagged-list? 'include-c-header expr)))
input-program)))))
))
(report:elapsed "inline candidates:")
(trace:info "inline candidates:")
(trace:info inlines)
;; Process library imports
(report:elapsed "imports:")
(trace:info "imports:")
(trace:info imports)
(set! imported-vars (lib:imports->idb imports append-dirs prepend-dirs (base-expander)))
(report:elapsed "resolved imports:")
(trace:info "resolved imports:")
(trace:info imported-vars)
(let ((meta (lib:resolve-meta imports append-dirs prepend-dirs)))
(set! *defined-macros* (append meta *defined-macros*))
(trace:info "resolved macros:")
(trace:info meta))
;; TODO: how to handle stdlib when compiling a library??
;; either need to keep track of what was actually used,
;; or just assume all imports were used and include them
;; in final compiled program
;(set! input-program (add-libs input-program))
;; Load macros for expansion phase
(let ((macros (filter
(lambda (v)
(Cyc-macro? (Cyc-get-cvar (cdr v))))
(Cyc-global-vars))))
(set! *defined-macros*
(append
macros
*defined-macros*)))
(macro:load-env! *defined-macros* (create-environment '() '()))
;; Expand macros
;; In each case, the input is expanded in a way that ensures
;; defines from any top-level begins are spliced correctly.
(set! input-program
(cond
(program?
(expand-lambda-body input-program (macro:get-env) rename-env))
(else
(let ((expanded (expand `(begin ,@input-program)
(macro:get-env)
rename-env)))
(cond
((and (pair? expanded)
(tagged-list? 'lambda (car expanded)))
(lambda->exp (car expanded)))
((tagged-list? 'define expanded)
(list expanded))
((boolean? expanded)
(list expanded))
(else
(error `(Unhandled expansion ,expanded))))))))
(report:elapsed "---------------- after macro expansion:")
(trace:info "---------------- after macro expansion:")
(trace:info input-program)
(set! input-program (macro:cleanup input-program rename-env))
(report:elapsed "---------------- after macro expansion cleanup:")
(trace:info "---------------- after macro expansion cleanup:")
(trace:info input-program)
;; If a program, check to see if any macros expanded into top-level imports
(when program?
(let ((program:imports/code (import-reduction input-program (base-expander))))
(when (not (null? (car program:imports/code)))
(trace:info "-------------- macro expanded into import expression(s):")
(set! imports (append imports (car program:imports/code)))
(trace:info "imports:")
(trace:info imports)
(set! imported-vars (lib:imports->idb imports append-dirs prepend-dirs (base-expander)))
(report:elapsed "resolved imports:")
(trace:info "resolved imports:")
(trace:info imported-vars)
(let ((meta (lib:resolve-meta imports append-dirs prepend-dirs)))
(set! *defined-macros* (append meta *defined-macros*))
(trace:info "resolved macros:")
(trace:info meta))
(set! input-program (cdr program:imports/code))
;(set! lib-deps (append lib-deps (lib:get-all-import-deps (car program:imports/code) append-dirs prepend-dirs)))
(let ((changed #f)
(new-lib-deps (lib:get-all-import-deps (car program:imports/code) append-dirs prepend-dirs #f)))
(for-each
(lambda (dep)
(when (not (member dep lib-deps))
(set! changed #t)
(set! lib-deps (cons dep lib-deps))))
new-lib-deps)
(when changed
;; Library dependencies can change if additional import
;; expressions were encountered during macro expansion.
;; If so, update the list of dependencies now
(set! ;; Use new deps
lib-deps
(change-lib-deps! lib-deps)))) ;; Caller updates and returns new deps
(trace:info lib-deps)
)))
;; END additional top-level imports
;; Debug output for our dependencies
(trace:info "---------------- Library dependencies")
(trace:info lib-deps)
(trace:info "---------------- Library files")
(trace:info (map
(lambda (lib-dep)
(lib:import->filename lib-dep ".sld" append-dirs prepend-dirs))
lib-deps))
;; Build dependent libraries, if instructed
(when *fe:batch-compile*
(for-each
(lambda (lib-dep)
(when (recompile? lib-dep append-dirs prepend-dirs)
(let ((result (system (string-append
(calling-program) " "
(dirs->args "-A" append-dirs) " "
(dirs->args "-I" prepend-dirs) " "
(lib:import->filename lib-dep ".sld" append-dirs prepend-dirs)))))
(when (> result 0)
(error "Unable to compile library" lib-dep)))))
lib-deps))
;; Validate syntax of basic forms
(validate-keyword-syntax input-program)
;; Separate global definitions from the rest of the top-level code
(set! input-program
(isolate-globals input-program program? lib-name rename-env))
;; Optimize-out unused global variables
;; For now, do not do this if eval is used.
;; TODO: do not have to be so aggressive, unless (eval (read)) or such
(if (not (has-global? input-program 'eval))
(set! input-program
(filter-unused-variables input-program lib-exports)))
(report:elapsed "---------------- after processing globals")
(trace:info "---------------- after processing globals")
(trace:info input-program)
;; Identify global variables
(set! module-globals (global-vars input-program))
(set! globals (append (lib:idb:ids imported-vars) module-globals))
;; Register inlinable Scheme functions
(for-each
(lambda (e)
(if (define-c-inline? e)
(prim:add-udf! (define->var e) (define-c->inline-var e))))
;(write `(DEBUG add inline ,(define->var e) ,(define-c->inline-var e)))))
input-program)
;; Inlines do not have to be non-CPS, they are really two separate things.
;; So keep track of all functions marked as inline because there are still
;; possibilities for optimization even if the function must call into its
;; continuation.
(opt:add-inlinable-functions inlines)
;; Trim down the export list to any exports that are just "pass throughs"
;; from imported libraries. That is, they are not actually defined in
;; the library being compiled
(set! lib-pass-thru-exports
(filter
(lambda (e)
(let ((module-global? (member e module-globals))
(imported-var? (assoc e imported-vars)))
(cond
((eq? e 'call/cc) #f) ;; Special case
((and (not module-global?)
(not imported-var?)
(not (prim? e)))
(error "Identifier is exported but not defined" e))
(else
;; Pass throughs are not defined in this module,
;; but by definition must be defined in an imported lib
(and (not module-global?) imported-var?)))))
lib-pass-thru-exports))
(report:elapsed "pass thru exports:")
(trace:info "pass thru exports:")
(trace:info lib-pass-thru-exports)
; Note alpha-conversion is overloaded to convert internal defines to
; set!'s below, since all remaining phases operate on set!, not define.
(set! globals (union globals '())) ;; Ensure list is sorted
(set! input-program
(map
(lambda (expr)
(alpha-convert expr globals return))
input-program))
(report:elapsed "---------------- after alpha conversion:")
(trace:info "---------------- after alpha conversion:")
(trace:info input-program)
;; EXPERIMENTAL CODE - Load functions in other modules that are
;; able to be inlined (in this context, from CPS).
;;
;; TODO: extend this initially by, for each import, invoking that module's inlinable_lambdas function
;; behind an exception handler (in case the compiler does not have that module loaded).
;;
;; Longer term, need to test if module is loaded (maybe do that in combo with exception handler above)
;; and if not loaded, eval/import it and try again.
;;
;; assumes (scheme base) is available to compiler AND at runtime in the compiled module/program
;; TODO: probably not good enough since inlines are not in export list
;;
;; TODO: later on, in cgen, only add inlinables that correspond to exported functions
(for-each
(lambda (import)
(with-handler
(lambda (err)
#f)
(let* ((lib-name-str (lib:name->string (lib:list->import-set import)))
(inlinable-lambdas-fnc
(string->symbol
(string-append "c_" lib-name-str "_inlinable_lambdas"))))
(cond
((imported? import)
(let ((lib-name (lib:import->library-name
(lib:list->import-set import)))
(vars/inlines
(filter
(lambda (v/i)
;; Try to avoid name conflicts by not loading inlines
;; that conflict with identifiers in this module.
;; More of a band-aid than a true solution, though.
(not (member (car v/i) module-globals)))
(eval `( ,inlinable-lambdas-fnc )))))
;(trace:info `(DEBUG ,import ,vars/inlines ,module-globals))
;; Register inlines as user-defined primitives
(for-each
(lambda (v/i)
(let ((var (car v/i)) (inline (cdr v/i)))
(prim:add-udf! var inline)))
vars/inlines)
;; Keep track of inline version of functions along with other imports
(set! imported-vars
(append
imported-vars
(map
(lambda (v/i)
(cons (cdr v/i) lib-name))
vars/inlines)))))
(else
;; TODO: try loading if not loaded (but need ex handler in case anything bad happens) #t ;(eval `(import ,import))
;;(%import import)
;; if this work is done, would need to consolidate inline reg code above
#f)))))
imports)
;; END
;; Convert some function calls to primitives, if possible
(set! input-program
(map
(lambda (expr)
(prim-convert expr))
input-program))
(report:elapsed "---------------- after func->primitive conversion:")
(trace:info "---------------- after func->primitive conversion:")
(trace:info input-program)
;; Identify native Scheme functions (from module being compiled) that can be inlined
;;
;; NOTE: There is a chicken-and-egg problem here that prevents this from
;; automatically working 100%. Basically we need to know whether the inline logic will
;; work for a given candidate. The problem is, the only way to do that is to run the
;; code through CPS and by then we would have to go back and repeat many phases if a
;; candidate fails the inline tests. At least for now, an alternative is to require
;; user code to specify (via inline) what functions the compiler should try inlining.
;; There is a small chance one of those inlines can pass these tests and still fail
;; the subsequent inline checks though, which causes an error in the C compiler.
(define inlinable-scheme-fncs '())
(let ((lib-init-fnc (lib:name->symbol lib-name))) ;; safe to ignore for programs
(for-each
(lambda (e)
(when (and (define? e)
(member (define->var e) inlines) ;; Primary check, did use request inline
(not (equal? (define->var e) lib-init-fnc))
(inlinable-top-level-lambda? e)) ;; Failsafe, reject if basic checks fail
(set! inlinable-scheme-fncs
(cons (define->var e) inlinable-scheme-fncs))
(set! module-globals
(cons (define-c->inline-var e) module-globals))
(prim:add-udf! (define->var e) (define-c->inline-var e))))
input-program)
(report:elapsed "---------------- results of inlinable-top-level-lambda analysis: ")
(trace:info "---------------- results of inlinable-top-level-lambda analysis: ")
(trace:info inlinable-scheme-fncs))
(let ((cps (map
(lambda (expr)
(cps-convert expr))
input-program)))
(cond
((and library? (equal? lib-name '(scheme base)))
(set! globals (append '(call/cc) globals))
(set! module-globals (append '(call/cc) module-globals))
(set! input-program
;(cons
; ;; Experimental version of call-with-values,
; ;; seems OK in compiler but not in eval.
; '(define call-with-values
; (lambda (k producer consumer)
; (let ((x (producer)))
; (if (and (pair? x) (equal? '(multiple values) (car x)))
; (apply consumer (cdr x))
; (consumer k x))))
; ; (producer
; ; (lambda (result)
; ; (consumer k result))))
; )
;; multiple args requires more than just this.
;; may want to look at:
;; http://stackoverflow.com/questions/16674214/how-to-implement-call-with-values-to-match-the-values-example-in-r5rs
;; (lambda vals
;; (apply k consumer vals)))))
(cons
;; call/cc must be written in CPS form, so it is added here
`(define call/cc
,(ast:make-lambda
'(k f)
(list
(list 'f 'k
(ast:make-lambda '(_ result)
(list '(k result)))))))
;(lambda (k f) (f k (lambda (_ result) (k result)))))
cps)));)
(else
;; No need for call/cc yet
(set! input-program cps))))
(report:elapsed "---------------- after CPS:")
(trace:info "---------------- after CPS:")
(trace:info (ast:ast->pp-sexp input-program))
(define (inject-import lis)
(let ((dep (lib:list->import-set lis)))
(when (not (member dep lib-deps))
(set! lib-deps (append lib-deps (list dep)))
(change-lib-deps! lib-deps)))
)
(define (inject-globals! lis)
;; FUTURE: these lines are specifically for memoization optizations.
;; if we need to make this more generic and have other globals
;; injected, then this code will need to be relocated, maybe into
;; an 'inject-memoization!' or such helper.
(when (not (member 'Cyc-memoize globals))
(set! globals (append globals '(Cyc-memoize)))
(set! imported-vars (cons (lib:list->import-set '(Cyc-memoize srfi 69)) imported-vars))
)
(inject-import '(scheme cyclone common))
(inject-import '(scheme base))
(inject-import '(scheme char))
(inject-import '(srfi 69))
;; END memoization-specific code
(set! module-globals (append module-globals lis))
(set! globals (append globals lis))
(set! globals (union globals '())) ;; Ensure list is sorted
)
(define (flag-set? flag)
(cond
((eq? flag 'memoize-pure-functions)
(and program? ;; Only for programs, because SRFI 69 becomes a new dep
*optimize:memoize-pure-functions*))
((eq? flag 'track-call-history)
*cgen:track-call-history*)
((eq? flag 'use-unsafe-prims)
*cgen:use-unsafe-prims*)
((eq? flag 'inline-unsafe)
*optimize:inline-unsafe*)
((eq? flag 'beta-expand-threshold)
*optimize:beta-expand-threshold*)
(else #f)))
(when (> *optimization-level* 0)
(set! input-program
(optimize-cps input-program inject-globals! flag-set?))
(report:elapsed "---------------- after cps optimizations (1):")
(trace:info "---------------- after cps optimizations (1):")
(trace:info (ast:ast->pp-sexp input-program))
(set! input-program
(optimize-cps input-program inject-globals! flag-set?))
(report:elapsed "---------------- after cps optimizations (2):")
(trace:info "---------------- after cps optimizations (2):")
(trace:info (ast:ast->pp-sexp input-program))
(set! input-program
(optimize-cps input-program inject-globals! flag-set?))
(report:elapsed "---------------- after cps optimizations (3):")
(trace:info "---------------- after cps optimizations (3):")
(trace:info (ast:ast->pp-sexp input-program))
)
(set! input-program (opt:local-var-reduction input-program))
(report:elapsed "---------------- after local variable reduction")
(trace:info "---------------- after local variable reduction")
(trace:info (ast:ast->pp-sexp input-program))
;; Clean up lambda numbering after code elimination
(set! input-program (opt:renumber-lambdas! input-program))
(report:elapsed "---------------- after renumber lambdas")
(trace:info "---------------- after renumber lambdas")
(trace:info (ast:ast->pp-sexp input-program))
(set! input-program
(map
(lambda (expr)
(clear-mutables)
(analyze-mutable-variables expr)
(wrap-mutables expr globals))
input-program))
(report:elapsed "---------------- after wrap-mutables:")
(trace:info "---------------- after wrap-mutables:")
(trace:info (ast:ast->pp-sexp input-program))
;; Perform this analysis here since we need it later so it doesn't
;; make sense to execute it multiple times during CPS optimization
(analyze:find-known-lambdas input-program)
(set! input-program
(map
(lambda (expr)
(cond
((define? expr)
;; Global
`(define ,(define->var expr)
,@(car (ast:lambda-body (closure-convert (define->exp expr) globals *optimization-level*)))))
((define-c? expr)
expr)
(else
(car (ast:lambda-body ;; Strip off superfluous lambda
(closure-convert expr globals *optimization-level*))))))
input-program))
(report:elapsed "---------------- after closure-convert:")
(trace:info "---------------- after closure-convert:")
(trace:info (ast:ast->pp-sexp input-program))
(report:elapsed "---------------- analysis db: ")
(trace:info "---------------- analysis db: ")
(trace:info (adb:get-db))
(when (not *do-code-gen*)
(trace:error "DEBUG, existing program")
(exit 0))
(trace:info "---------------- C headers: ")
(trace:info c-headers)
(trace:info "---------------- module globals: ")
(trace:info module-globals)
(report:elapsed "---------------- C code:")
(trace:info "---------------- C code:")
(mta:code-gen input-program
program?
lib-name
lib-pass-thru-exports
imported-vars
module-globals
c-headers
lib-deps
src-file
flag-set?)
(return '())))) ;; No codes to return
;; Read top-level imports from a program and return a cons of:
;; - imports
;; - remaining program
(define (import-reduction expr expander)
(let ((results
(foldl
(lambda (ex accum)
(define (process e)
(cond
((tagged-list? 'import e)
(cons (cons (cdr e) (car accum)) (cdr accum)))
(else
(cons (car accum) (cons e (cdr accum))))))
(cond
((tagged-list? 'cond-expand ex)
(let ((ex* (expander ex))) ;(expand ex (macro:get-env) rename-env)))
;(trace:info `(DEBUG ,ex* ,ex))
(if (tagged-list? 'import ex*)
(process ex*)
(process ex))))
(else
(process ex))))
(cons '() '())
expr)))
(cons
(apply append (reverse (car results)))
(reverse (cdr results)))))
;; Return a function to expand any built-in macros
;; NOTE: since this uses a global macro env, it will be overridden later on when
;; macros are loaded from dependent libraries.
(define (base-expander)
(let ((rename-env (env:extend-environment '() '() '()))
(macros (filter
(lambda (v)
(Cyc-macro? (Cyc-get-cvar (cdr v))))
(Cyc-global-vars))))
(macro:load-env! macros (create-environment '() '()))
(lambda (ex)
(expand ex (macro:get-env) rename-env))))
;; TODO: longer-term, will be used to find where cyclone's data is installed
(define (get-data-path)
".")
(define (get-lib filename)
(string-append (get-data-path) "/" filename))
(define (read-file filename)
(call-with-input-file filename
(lambda (port)
(read-all/source port filename))))
;; Parse given expression and return data from any instances
;; of c-compiler-options
(define (program-c-compiler-opts! in-prog)
(get-options! 'c-compiler-options in-prog))
(define (program-c-linker-opts! in-prog)
(get-options! 'c-linker-options in-prog))
(define (get-options! opt in-prog)
(foldl
(lambda (expr acc)
(cond
((tagged-list? opt expr)
;; Replace expression since it is only used in this initial
;; pass, and would cause problems downstream
(set-car! expr (string->symbol "quote"))
(cons (cadr expr) acc))
(else
acc)))
'()
in-prog))
;; Compile and emit:
(define (run-compiler args append-dirs prepend-dirs change-cc-opts!)
(let* ((in-file (car args))
(expander (base-expander))
(in-prog-raw (read-file in-file))
(program? (not (library? (car in-prog-raw))))
(in-prog
(cond
(program?
(Cyc-add-feature! 'program) ;; Load special feature
;; TODO: what about top-level cond-expands in the program?
in-prog-raw)
(else
;; Account for any cond-expand declarations in the library
(list (lib:cond-expand in-file (car in-prog-raw) expander)))))
;; expand in-prog, if a library, using lib:cond-expand.
;; TODO: will also need to do below in lib:get-all-import-deps, after reading each library
(program:imports/code (if program? (import-reduction in-prog expander) '()))
(lib-deps
(if (and program?
(not (null? (car program:imports/code))))
(lib:get-all-import-deps (car program:imports/code) append-dirs prepend-dirs expander)
'()))
;; Read C compiler options
(cc-opts
(cond
(program?
(let ((opts (program-c-compiler-opts! in-prog)))
(when (not (null? opts))
(change-cc-opts! opts))
(string-join ;; Check current program for options
opts
" ")))
(else
(string-join
(lib:c-compiler-options (car in-prog))
" "))))
;; Read all linker options from dependent libs
(c-linker-options
(let ((lib-options (lib:get-all-c-linker-options lib-deps append-dirs prepend-dirs expander)))
(if program?
(string-append ;; Also read from current program
(string-join (program-c-linker-opts! in-prog) " ")
" "
lib-options)
lib-options)))
(exec-file (basename in-file))
(src-file (string-append exec-file ".c"))
(meta-file (string-append exec-file ".meta"))
(get-comp-env
(lambda (sym str)
(if (> (string-length str) 0)
str
(Cyc-compilation-environment sym))))
(create-c-file
(lambda (program)
(with-output-to-file
src-file
(lambda ()
(c-compile-and-emit
program
program:imports/code
lib-deps
(lambda (new-lib-deps)
;; Deps changed so we need to
;; resolve dependency tree again
(set!
lib-deps
(lib:get-all-import-deps
new-lib-deps
append-dirs
prepend-dirs
expander))
;; Recompute linker options
(set! c-linker-options
(lib:get-all-c-linker-options
lib-deps
append-dirs
prepend-dirs
expander))
;; Return new deps
lib-deps)
in-file
append-dirs
prepend-dirs))))))
(create-c-file in-prog)
(cond
(program?
;; Use .meta file to store information for C compiler phase
(save-program-metadata meta-file lib-deps c-linker-options))
(else
;; Emit .meta file
(with-output-to-file
meta-file
(lambda ()
(display ";; This file was automatically generated by the Cyclone Scheme compiler")
(newline)
(write (macro:get-defined-macros))))))))
(define (save-program-metadata filename lib-deps c-linker-options)
(with-output-to-file
filename
(lambda ()
(display ";; This file was automatically generated by the Cyclone Scheme compiler")
(newline)
(write `(lib-deps . ,lib-deps))
(newline)
(write `(c-linker-options . ,c-linker-options)))))
(define (load-program-metadata filename)
(let ((data (call-with-input-file filename read-all)))
(delete-file filename)
data))
(define (get-meta meta symbol default)
(if (assoc symbol meta)
(cdr (assoc symbol meta))
default))
(define (run-external-compiler
args append-dirs prepend-dirs
cc? cc-prog cc-exec cc-lib cc-so
cc-opts cc-prog-linker-opts cc-prog-linker-objs)
(let* ((in-file (car args))
(expander (base-expander))
(in-prog-raw (read-file in-file))
(program? (not (library? (car in-prog-raw))))
(in-prog
(cond
(program?
(Cyc-add-feature! 'program) ;; Load special feature
;; TODO: what about top-level cond-expands in the program?
in-prog-raw)
(else
;; Account for any cond-expand declarations in the library
(list (lib:cond-expand in-file (car in-prog-raw) expander)))))
;; Only read C compiler options from module being compiled
(cc-opts*
(cond
(program?
(string-join ;; Check current program for options
(program-c-compiler-opts! in-prog)
" "))
(else
(string-join
(lib:c-compiler-options (car in-prog))
" "))))
(exec-file (basename in-file))
(src-file (string-append exec-file ".c"))
(meta-file (string-append exec-file ".meta"))
(get-comp-env
(lambda (sym str)
(if (> (string-length str) 0)
str
(Cyc-compilation-environment sym))))
)
;; Compile the generated C file
(cond
(program?
(letrec ((metadata (load-program-metadata meta-file))
(c-linker-options (get-meta metadata 'c-linker-options '()))
(lib-deps (get-meta metadata 'lib-deps '()))
(objs-str
(string-append
cc-prog-linker-objs
(apply
string-append
(map
(lambda (i)
(string-append " " (lib:import->filename i ".o" append-dirs prepend-dirs) " "))
lib-deps))))
(comp-prog-cmd
(string-append
(string-replace-all
(string-replace-all
(string-replace-all
;(Cyc-compilation-environment 'cc-prog)
(get-comp-env 'cc-prog cc-prog)
"~src-file~" src-file)
"~cc-extra~" cc-opts)
"~exec-file~" exec-file)
" "
cc-opts*))
(comp-objs-cmd
(string-append
(string-replace-all
(string-replace-all
(string-replace-all
(string-replace-all
;(Cyc-compilation-environment 'cc-exec)
(get-comp-env 'cc-exec cc-exec)
"~exec-file~" exec-file)
"~ld-extra~" cc-prog-linker-opts)
"~obj-files~" objs-str)
"~exec-file~" exec-file)
" "
c-linker-options
)))
;(write `(DEBUG all imports ,lib-deps objs ,objs-str))
;(write `(DEBUG ,(lib:get-all-import-deps (cdar in-prog))))
(cond
(cc?
(if (equal? 0 (system comp-prog-cmd))
(system comp-objs-cmd)))
(else
(display comp-prog-cmd)
(newline)
(display comp-objs-cmd)
(newline)))))
(else
;; Compile library
(let ((comp-lib-cmd
(string-append
(string-replace-all
(string-replace-all
(string-replace-all
(get-comp-env 'cc-lib cc-lib)
"~src-file~" src-file)
"~cc-extra~" cc-opts)
"~exec-file~" exec-file)
" "
cc-opts*))
(comp-so-cmd
(string-append
(string-replace-all
(string-replace-all
(get-comp-env 'cc-so cc-so)
"~src-file~" src-file)
"~exec-file~" exec-file)
" "
cc-opts
" "
cc-opts*))
)
(cond
(cc?
(system comp-lib-cmd)
(system comp-so-cmd)
)
(else
(display comp-lib-cmd)
(newline)
(display comp-so-cmd)
(newline))))))))
;; Collect values for the given command line arguments and option.
;; Will return a list of values for the option.
;; For example:
;; ("-a" "1" "2") ==> ("1")
;; ("-a" "1" "-a" "2") ==> ("1" "2")
(define (collect-opt-values args opt)
(cdr
(foldl
(lambda (arg accum)
(cond
((equal? arg opt)
(cons opt (cdr accum)))
((car accum) ;; we are at an opt value
(cons #f (cons arg (cdr accum))))
(else
(cons #f (cdr accum)))))
(list #f)
args)))
;; Convert a list of directories to a string of arguments.
;; EG: (dirs->args "-I" '("dir-1" "dir-2")) =>
;; " -I dir-1 -I dir-2 "
(define (dirs->args prefix dirs)
(apply
string-append
(map
(lambda (dir)
(string-append " " prefix " " dir " "))
dirs)))