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
|
;;; This is the top-level phase structure of the compiler.
;;; Compilation phase support
(define *phase* '#f)
(define *abort-phase* '#f) ; abort when this phase completes
(define *abort-compilation*
(lambda ()
(error "No error continuation defined here!")))
(define *module-asts* '()) ; a global only for debugging purposes
;;; Later add the printing and timing stuff here
(define-local-syntax (phase-body phase-name body printer)
`(dynamic-let ((*phase* ',phase-name))
(when (memq ',phase-name (dynamic *printers*))
(format '#t "~%Phase ~a:~%" ',phase-name)
(force-output))
(let* ((phase-start-time (get-run-time))
(result ,body)
(current-time (get-run-time)))
(when (eq? (dynamic *abort-phase*) ',phase-name)
(abort-compilation))
,@(if (eq? printer '#f)
'()
`((when (memq ',phase-name (dynamic *printers*))
(funcall ,printer result)
(force-output))))
(when (memq 'phase-time *printers*)
(let ((elapsed-time (- current-time phase-start-time)))
(format '#t "~&~A complete: ~A seconds~%"
',phase-name elapsed-time)
(force-output)))
result)))
;;; Returns 2 values: module ast's and lisp code.
(define (compile-haskell-files files)
(dynamic-let ((*abort-phase* '#f))
(let ((all-mods (haskell-parse-files files))
(interface-mods '())
(regular-mods '()))
(dolist (m all-mods)
(if (eq? (module-type m) 'interface)
(push m interface-mods)
(push m regular-mods)))
(dynamic-let ((*unit* (module-name (car all-mods))))
(values
all-mods
`(begin
,(if interface-mods
(compile-interface-modules (nreverse interface-mods))
'#f)
,(if regular-mods
(compile-modules (nreverse regular-mods))
'#f))
)))))
(define (compile-modules mods)
(dynamic-let ((*context* '#f)
(*recoverable-error-handler* '#f)
(*abort-phase* '#f)
(*unique-name-counter* 1)
(*suffix-table* (make-table)))
(haskell-import-export mods '#f)
(haskell-process-type-declarations mods)
(haskell-scope mods)
(let ((big-let (haskell-dependency-analysis mods)))
(cond ((not (void? big-let))
(haskell-type-check big-let mods)
(setf big-let (haskell-cfn big-let))
(setf big-let (haskell-dependency-reanalysis big-let))
(setf big-let (haskell-ast-to-flic big-let))
(setf big-let (haskell-optimize big-let))
(setf big-let (haskell-strictness big-let))
(haskell-codegen big-let mods))
(else
''#f)
))))
(define (modules->lisp-code modules)
(dynamic-let ((*unit* (module-name (car modules))))
(compile-modules modules)))
(predefine (notify-error)) ; in command-interface/command-utils.scm
(define (abort-compilation)
(notify-error)
(funcall (dynamic *abort-compilation*)))
(define (halt-compilation)
(setf (dynamic *abort-phase*) (dynamic *phase*)))
;;; Here are the actual phase bodies
(predefine (parse-files files))
(define (haskell-parse-files filenames)
(phase-body parse
(let ((mods (parse-files filenames)))
mods)
#f))
(predefine (import-export modules)) ; in import-export/import-export.scm
(predefine (import-export/interface modules))
(define (haskell-import-export modules interface?)
(phase-body import
(if interface?
(import-export/interface modules)
(import-export modules))
#f))
(predefine (process-type-declarations modules))
; in tdecl/type-declaration-analysis.scm
(define (haskell-process-type-declarations modules)
(phase-body type-decl
(begin
(process-type-declarations modules))
#f))
(predefine (scope-modules x)) ; in prec/scope.scm
(predefine (print-full-module x . maybe-stream)) ; in the printers
(define (haskell-scope modules)
(phase-body scope
(scope-modules modules)
(lambda (result)
(declare (ignore result))
(dolist (m modules) (print-full-module m)))
))
(predefine (do-dependency-analysis x)) ; in depend/dependency-analysis.scm
(define (haskell-dependency-analysis modules)
(phase-body depend
(do-dependency-analysis modules)
(function pprint*)))
(predefine (do-haskell-type-check big-let mods))
(define (haskell-type-check big-let modules)
(phase-body type
(do-haskell-type-check big-let modules)
#f))
(predefine (cfn-ast x)) ; in cfn/main.scm
(define (haskell-cfn big-let)
(phase-body cfn
(cfn-ast big-let)
(function pprint*)))
(predefine (analyze-dependency-top x)) ; in depend/dependency-analysis.scm
(define (haskell-dependency-reanalysis big-let)
(phase-body depend2
(begin
(analyze-dependency-top big-let)
big-let)
(function pprint*)))
(predefine (ast-to-flic x)) ; in flic/ast-to-flic.scm
(define (haskell-ast-to-flic big-let)
(phase-body flic
(ast-to-flic big-let)
(function pprint*)))
(predefine (optimize-top x)) ; in backend/optimize.scm
(define (haskell-optimize big-let)
(phase-body optimize
(optimize-top big-let)
(function pprint*)))
(predefine (strictness-analysis-top x)) ; in backend/strictness.scm
(predefine (strictness-analysis-printer x))
(define (haskell-strictness big-let)
(phase-body strictness
(strictness-analysis-top big-let)
(function strictness-analysis-printer)))
(predefine (codegen-top x)) ; in backend/codegen.scm
(predefine (codegen-exported-types x)) ; "
(predefine (codegen-prim-entries x)) ; ditto
(define (haskell-codegen big-let mods)
(phase-body codegen
`(begin
,(codegen-exported-types mods)
,(codegen-top big-let))
#f))
;;; This is for interface modules.
(predefine (haskell-codegen/interface mods))
(define (compile-interface-modules mods)
(dynamic-let ((*context* '#f)
(*recoverable-error-handler* '#f)
(*abort-phase* '#f))
(haskell-import-export mods '#t)
(haskell-process-type-declarations mods)
(haskell-scope mods)
(haskell-codegen/interface mods)))
|
