Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2014-2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor CCodegen (S: C_CODEGEN_STRUCTS): C_CODEGEN = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | open Machine | |
16 | ||
17 | datatype z = datatype RealSize.t | |
18 | datatype z = datatype WordSize.prim | |
19 | ||
20 | local | |
21 | open Runtime | |
22 | in | |
23 | structure GCField = GCField | |
24 | end | |
25 | ||
26 | structure Kind = | |
27 | struct | |
28 | open Kind | |
29 | ||
30 | fun isEntry (k: t): bool = | |
31 | case k of | |
32 | Cont _ => true | |
33 | | CReturn {func, ...} => CFunction.mayGC func | |
34 | | Func => true | |
35 | | Handler _ => true | |
36 | | _ => false | |
37 | end | |
38 | ||
39 | val traceGotoLabel = Trace.trace ("CCodegen.gotoLabel", Label.layout, Unit.layout) | |
40 | ||
41 | structure C = | |
42 | struct | |
43 | val truee = "TRUE" | |
44 | val falsee = "FALSE" | |
45 | ||
46 | fun bool b = if b then truee else falsee | |
47 | ||
48 | fun args (ss: string list): string | |
49 | = concat ("(" :: List.separate (ss, ", ") @ [")"]) | |
50 | ||
51 | fun callNoSemi (f: string, xs: string list, print: string -> unit): unit | |
52 | = (print f | |
53 | ; print " (" | |
54 | ; (case xs | |
55 | of [] => () | |
56 | | x :: xs => (print x | |
57 | ; List.foreach (xs, | |
58 | fn x => (print ", "; print x)))) | |
59 | ; print ")") | |
60 | ||
61 | fun call (f, xs, print) = | |
62 | (callNoSemi (f, xs, print) | |
63 | ; print ";\n") | |
64 | ||
65 | fun int (i: int) = | |
66 | if i >= 0 | |
67 | then Int.toString i | |
68 | else concat ["-", Int.toString (~ i)] | |
69 | ||
70 | val bytes = int o Bytes.toInt | |
71 | ||
72 | fun string s = | |
73 | let val quote = "\"" | |
74 | in concat [quote, String.escapeC s, quote] | |
75 | end | |
76 | ||
77 | fun word (w: Word.t) = "0x" ^ Word.toString w | |
78 | ||
79 | fun push (size: Bytes.t, print) = | |
80 | call ("\tPush", [bytes size], print) | |
81 | end | |
82 | ||
83 | structure RealX = | |
84 | struct | |
85 | open RealX | |
86 | ||
87 | fun toC (r: t): string = | |
88 | let | |
89 | (* The main difference between SML reals and C floats/doubles is that | |
90 | * SML uses "~" while C uses "-". | |
91 | *) | |
92 | val s = | |
93 | String.translate (toString r, | |
94 | fn #"~" => "-" | c => String.fromChar c) | |
95 | (* Also, inf is spelled INFINITY and nan is NAN in C. *) | |
96 | val s = | |
97 | case s of | |
98 | "-inf" => "-INFINITY" | |
99 | | "inf" => "INFINITY" | |
100 | | "nan" => "NAN" | |
101 | | other => other | |
102 | in | |
103 | case size r of | |
104 | R32 => concat ["(Real32)", s] | |
105 | | R64 => s | |
106 | end | |
107 | end | |
108 | ||
109 | structure WordX = | |
110 | struct | |
111 | open WordX | |
112 | ||
113 | fun toC (w: t): string = | |
114 | let | |
115 | fun doit s = | |
116 | concat ["(Word", s, ")(", toString w, "ull)"] | |
117 | in | |
118 | case WordSize.prim (size w) of | |
119 | W8 => doit "8" | |
120 | | W16 => doit "16" | |
121 | | W32 => doit "32" | |
122 | | W64 => doit "64" | |
123 | end | |
124 | end | |
125 | ||
126 | structure WordXVector = | |
127 | struct | |
128 | local | |
129 | structure Z = WordX | |
130 | in | |
131 | open WordXVector | |
132 | structure WordX = Z | |
133 | end | |
134 | ||
135 | fun toC (v: t): string = | |
136 | let | |
137 | fun string () = | |
138 | concat ["(pointer)", | |
139 | C.string (String.implode (toListMap (v, WordX.toChar)))] | |
140 | fun vector s = | |
141 | concat ["(pointer)((Word", s, "[]){", | |
142 | String.concatWith (toListMap (v, WordX.toC), ","), | |
143 | "})"] | |
144 | in | |
145 | case WordSize.prim (elementSize v) of | |
146 | W8 => string () | |
147 | | W16 => vector "16" | |
148 | | W32 => vector "32" | |
149 | | W64 => vector "64" | |
150 | end | |
151 | end | |
152 | ||
153 | structure Operand = | |
154 | struct | |
155 | open Operand | |
156 | ||
157 | fun isMem (z: t): bool = | |
158 | case z of | |
159 | ArrayOffset _ => true | |
160 | | Cast (z, _) => isMem z | |
161 | | Contents _ => true | |
162 | | Offset _ => true | |
163 | | StackOffset _ => true | |
164 | | _ => false | |
165 | end | |
166 | ||
167 | fun implementsPrim (p: 'a Prim.t): bool = | |
168 | let | |
169 | datatype z = datatype Prim.Name.t | |
170 | in | |
171 | case Prim.name p of | |
172 | CPointer_add => true | |
173 | | CPointer_diff => true | |
174 | | CPointer_equal => true | |
175 | | CPointer_fromWord => true | |
176 | | CPointer_lt => true | |
177 | | CPointer_sub => true | |
178 | | CPointer_toWord => true | |
179 | | FFI_Symbol _ => true | |
180 | | Real_Math_acos _ => true | |
181 | | Real_Math_asin _ => true | |
182 | | Real_Math_atan _ => true | |
183 | | Real_Math_atan2 _ => true | |
184 | | Real_Math_cos _ => true | |
185 | | Real_Math_exp _ => true | |
186 | | Real_Math_ln _ => true | |
187 | | Real_Math_log10 _ => true | |
188 | | Real_Math_sin _ => true | |
189 | | Real_Math_sqrt _ => true | |
190 | | Real_Math_tan _ => true | |
191 | | Real_abs _ => true | |
192 | | Real_add _ => true | |
193 | | Real_castToWord _ => true | |
194 | | Real_div _ => true | |
195 | | Real_equal _ => true | |
196 | | Real_ldexp _ => true | |
197 | | Real_le _ => true | |
198 | | Real_lt _ => true | |
199 | | Real_mul _ => true | |
200 | | Real_muladd _ => true | |
201 | | Real_mulsub _ => true | |
202 | | Real_neg _ => true | |
203 | | Real_qequal _ => false | |
204 | | Real_rndToReal _ => true | |
205 | | Real_rndToWord _ => true | |
206 | | Real_round _ => true | |
207 | | Real_sub _ => true | |
208 | | Word_add _ => true | |
209 | | Word_addCheck _ => true | |
210 | | Word_andb _ => true | |
211 | | Word_castToReal _ => true | |
212 | | Word_equal _ => true | |
213 | | Word_extdToWord _ => true | |
214 | | Word_lshift _ => true | |
215 | | Word_lt _ => true | |
216 | | Word_mul _ => true | |
217 | | Word_mulCheck _ => true | |
218 | | Word_neg _ => true | |
219 | | Word_negCheck _ => true | |
220 | | Word_notb _ => true | |
221 | | Word_orb _ => true | |
222 | | Word_quot (_, {signed}) => not signed | |
223 | | Word_rem (_, {signed}) => not signed | |
224 | | Word_rndToReal _ => true | |
225 | | Word_rol _ => true | |
226 | | Word_ror _ => true | |
227 | | Word_rshift _ => true | |
228 | | Word_sub _ => true | |
229 | | Word_subCheck _ => true | |
230 | | Word_xorb _ => true | |
231 | | _ => false | |
232 | end | |
233 | ||
234 | fun creturn (t: Type.t): string = | |
235 | concat ["CReturn", CType.name (Type.toCType t)] | |
236 | ||
237 | fun outputIncludes (includes, print) = | |
238 | (List.foreach (includes, fn i => (print "#include <"; | |
239 | print i; | |
240 | print ">\n")) | |
241 | ; print "\n") | |
242 | ||
243 | fun declareProfileLabel (l, print) = | |
244 | C.call ("DeclareProfileLabel", [ProfileLabel.toString l], print) | |
245 | ||
246 | fun declareGlobals (prefix: string, print) = | |
247 | let | |
248 | (* gcState can't be static because stuff in mlton-lib.c refers to | |
249 | * it. | |
250 | *) | |
251 | val _ = print (concat [prefix, "struct GC_state gcState;\n"]) | |
252 | val _ = | |
253 | List.foreach | |
254 | (CType.all, fn t => | |
255 | let | |
256 | val s = CType.toString t | |
257 | in | |
258 | print (concat [prefix, s, " global", s, | |
259 | " [", C.int (Global.numberOfType t), "];\n"]) | |
260 | ; print (concat [prefix, s, " CReturn", CType.name t, ";\n"]) | |
261 | end) | |
262 | val _ = | |
263 | print (concat [prefix, "Pointer globalObjptrNonRoot [", | |
264 | C.int (Global.numberOfNonRoot ()), | |
265 | "];\n"]) | |
266 | in | |
267 | () | |
268 | end | |
269 | ||
270 | fun outputDeclarations | |
271 | {additionalMainArgs: string list, | |
272 | includes: string list, | |
273 | print: string -> unit, | |
274 | program = (Program.T | |
275 | {frameLayouts, frameOffsets, maxFrameSize, | |
276 | objectTypes, profileInfo, reals, vectors, ...}), | |
277 | rest: unit -> unit | |
278 | }: unit = | |
279 | let | |
280 | fun declareExports () = | |
281 | Ffi.declareExports {print = print} | |
282 | fun declareLoadSaveGlobals () = | |
283 | let | |
284 | val _ = | |
285 | (print "static int saveGlobals (FILE *f) {\n" | |
286 | ; (List.foreach | |
287 | (CType.all, fn t => | |
288 | print (concat ["\tSaveArray (global", | |
289 | CType.toString t, ", f);\n"]))) | |
290 | ; print "\treturn 0;\n}\n") | |
291 | val _ = | |
292 | (print "static int loadGlobals (FILE *f) {\n" | |
293 | ; (List.foreach | |
294 | (CType.all, fn t => | |
295 | print (concat ["\tLoadArray (global", | |
296 | CType.toString t, ", f);\n"]))) | |
297 | ; print "\treturn 0;\n}\n") | |
298 | in | |
299 | () | |
300 | end | |
301 | fun declareVectors () = | |
302 | (print "BeginVectorInits\n" | |
303 | ; (List.foreach | |
304 | (vectors, fn (g, v) => | |
305 | (C.callNoSemi ("VectorInitElem", | |
306 | [C.int (Bytes.toInt | |
307 | (WordSize.bytes | |
308 | (WordXVector.elementSize v))), | |
309 | C.int (Global.index g), | |
310 | C.int (WordXVector.length v), | |
311 | WordXVector.toC v], | |
312 | print) | |
313 | ; print "\n"))) | |
314 | ; print "EndVectorInits\n") | |
315 | fun declareReals () = | |
316 | (print "static void real_Init() {\n" | |
317 | ; List.foreach (reals, fn (g, r) => | |
318 | print (concat ["\tglobalReal", | |
319 | RealSize.toString (RealX.size r), | |
320 | "[", C.int (Global.index g), "] = ", | |
321 | RealX.toC r, ";\n"])) | |
322 | ; print "}\n") | |
323 | fun declareFrameOffsets () = | |
324 | Vector.foreachi | |
325 | (frameOffsets, fn (i, v) => | |
326 | (print (concat ["static uint16_t frameOffsets", C.int i, "[] = {"]) | |
327 | ; print (C.int (Vector.length v)) | |
328 | ; Vector.foreach (v, fn i => (print ","; print (C.bytes i))) | |
329 | ; print "};\n")) | |
330 | fun declareArray (ty: string, | |
331 | name: string, | |
332 | v: 'a vector, | |
333 | toString: int * 'a -> string) = | |
334 | (print (concat ["static ", ty, " ", name, "[] = {\n"]) | |
335 | ; Vector.foreachi (v, fn (i, x) => | |
336 | print (concat ["\t", toString (i, x), ",\n"])) | |
337 | ; print "};\n") | |
338 | fun declareFrameLayouts () = | |
339 | declareArray ("struct GC_frameLayout", "frameLayouts", frameLayouts, | |
340 | fn (_, {frameOffsetsIndex, isC, size}) => | |
341 | concat ["{", | |
342 | if isC then "C_FRAME" else "ML_FRAME", | |
343 | ", frameOffsets", C.int frameOffsetsIndex, | |
344 | ", ", C.bytes size, | |
345 | "}"]) | |
346 | fun declareAtMLtons () = | |
347 | declareArray ("char*", "atMLtons", !Control.atMLtons, C.string o #2) | |
348 | fun declareObjectTypes () = | |
349 | declareArray | |
350 | ("struct GC_objectType", "objectTypes", objectTypes, | |
351 | fn (_, ty) => | |
352 | let | |
353 | datatype z = datatype Runtime.RObjectType.t | |
354 | val (tag, hasIdentity, bytesNonObjptrs, numObjptrs) = | |
355 | case ObjectType.toRuntime ty of | |
356 | Array {hasIdentity, bytesNonObjptrs, numObjptrs} => | |
357 | ("ARRAY_TAG", hasIdentity, | |
358 | Bytes.toInt bytesNonObjptrs, numObjptrs) | |
359 | | Normal {hasIdentity, bytesNonObjptrs, numObjptrs} => | |
360 | ("NORMAL_TAG", hasIdentity, | |
361 | Bytes.toInt bytesNonObjptrs, numObjptrs) | |
362 | | Stack => | |
363 | ("STACK_TAG", false, 0, 0) | |
364 | | Weak {gone} => | |
365 | let | |
366 | val bytesObjptr = | |
367 | Bits.toBytes (Control.Target.Size.objptr ()) | |
368 | val bytesNonObjptrs = | |
369 | let | |
370 | val align = | |
371 | case !Control.align of | |
372 | Control.Align4 => Bytes.fromInt 4 | |
373 | | Control.Align8 => Bytes.fromInt 8 | |
374 | val bytesMetaData = | |
375 | Bits.toBytes (Control.Target.Size.normalMetaData ()) | |
376 | val bytesCPointer = | |
377 | Bits.toBytes (Control.Target.Size.cpointer ()) | |
378 | ||
379 | val bytesObject = | |
380 | Bytes.+ (bytesMetaData, | |
381 | Bytes.+ (bytesCPointer, | |
382 | bytesObjptr)) | |
383 | val bytesTotal = | |
384 | Bytes.align (bytesObject, {alignment = align}) | |
385 | val bytesPad = Bytes.- (bytesTotal, bytesObject) | |
386 | in | |
387 | Bytes.+ (bytesPad, bytesCPointer) | |
388 | end | |
389 | val (bytesNonObjptrs, bytesObjptr) = | |
390 | (Bytes.toInt bytesNonObjptrs, | |
391 | Bytes.toInt bytesObjptr) | |
392 | val (bytesNonObjptrs, numObjptrs) = | |
393 | if gone | |
394 | then (bytesNonObjptrs + bytesObjptr, 0) | |
395 | else (bytesNonObjptrs, 1) | |
396 | in | |
397 | ("WEAK_TAG", false, bytesNonObjptrs, numObjptrs) | |
398 | end | |
399 | in | |
400 | concat ["{ ", tag, ", ", | |
401 | C.bool hasIdentity, ", ", | |
402 | C.int bytesNonObjptrs, ", ", | |
403 | C.int numObjptrs, " }"] | |
404 | end) | |
405 | fun declareMLtonMain () = | |
406 | let | |
407 | val align = | |
408 | case !Control.align of | |
409 | Control.Align4 => 4 | |
410 | | Control.Align8 => 8 | |
411 | val magic = | |
412 | let | |
413 | val version = String.hash Version.version | |
414 | val random = Random.word () | |
415 | in | |
416 | Word.orb | |
417 | (Word.<< (version, Word.fromInt (Word.wordSize - 8)), | |
418 | Word.>> (random, Word.fromInt 8)) | |
419 | end | |
420 | val profile = | |
421 | case !Control.profile of | |
422 | Control.ProfileNone => "PROFILE_NONE" | |
423 | | Control.ProfileAlloc => "PROFILE_ALLOC" | |
424 | | Control.ProfileCallStack => "PROFILE_NONE" | |
425 | | Control.ProfileCount => "PROFILE_COUNT" | |
426 | | Control.ProfileDrop => "PROFILE_NONE" | |
427 | | Control.ProfileLabel => "PROFILE_NONE" | |
428 | | Control.ProfileTimeField => "PROFILE_TIME_FIELD" | |
429 | | Control.ProfileTimeLabel => "PROFILE_TIME_LABEL" | |
430 | in | |
431 | C.callNoSemi (case !Control.format of | |
432 | Control.Archive => "MLtonLibrary" | |
433 | | Control.Executable => "MLtonMain" | |
434 | | Control.LibArchive => "MLtonLibrary" | |
435 | | Control.Library => "MLtonLibrary", | |
436 | [C.int align, | |
437 | C.word magic, | |
438 | C.bytes maxFrameSize, | |
439 | C.bool (!Control.markCards), | |
440 | profile, | |
441 | C.bool (!Control.profileStack)] | |
442 | @ additionalMainArgs, | |
443 | print) | |
444 | ; print "\n" | |
445 | end | |
446 | fun declareMain () = | |
447 | if !Control.emitMain andalso !Control.format = Control.Executable | |
448 | then List.foreach | |
449 | (["int main (int argc, char* argv[]) {", | |
450 | "return (MLton_main (argc, argv));", | |
451 | "}"], fn s => (print s; print "\n")) | |
452 | else () | |
453 | fun declareProfileInfo () = | |
454 | let | |
455 | fun doit (ProfileInfo.T {frameSources, labels, names, sourceSeqs, | |
456 | sources}) = | |
457 | (Vector.foreach (labels, fn {label, ...} => | |
458 | declareProfileLabel (label, print)) | |
459 | ; (Vector.foreachi | |
460 | (sourceSeqs, fn (i, v) => | |
461 | (print (concat ["static uint32_t sourceSeq", | |
462 | Int.toString i, | |
463 | "[] = {"]) | |
464 | ; print (C.int (Vector.length v)) | |
465 | ; Vector.foreach (v, fn i => | |
466 | (print (concat [",", C.int i]))) | |
467 | ; print "};\n"))) | |
468 | ; declareArray ("uint32_t*", "sourceSeqs", sourceSeqs, fn (i, _) => | |
469 | concat ["sourceSeq", Int.toString i]) | |
470 | ; declareArray ("GC_sourceSeqIndex", "frameSources", frameSources, C.int o #2) | |
471 | ; (declareArray | |
472 | ("struct GC_sourceLabel", "sourceLabels", labels, | |
473 | fn (_, {label, sourceSeqsIndex}) => | |
474 | concat ["{(pointer)&", ProfileLabel.toString label, ", ", | |
475 | C.int sourceSeqsIndex, "}"])) | |
476 | ; declareArray ("char*", "sourceNames", names, C.string o #2) | |
477 | ; declareArray ("struct GC_source", "sources", sources, | |
478 | fn (_, {nameIndex, successorsIndex}) => | |
479 | concat ["{ ", Int.toString nameIndex, ", ", | |
480 | Int.toString successorsIndex, " }"])) | |
481 | in | |
482 | case profileInfo of | |
483 | NONE => doit ProfileInfo.empty | |
484 | | SOME z => doit z | |
485 | end | |
486 | in | |
487 | outputIncludes (includes, print) | |
488 | ; declareGlobals ("PRIVATE ", print) | |
489 | ; declareExports () | |
490 | ; declareLoadSaveGlobals () | |
491 | ; declareVectors () | |
492 | ; declareReals () | |
493 | ; declareFrameOffsets () | |
494 | ; declareFrameLayouts () | |
495 | ; declareObjectTypes () | |
496 | ; declareProfileInfo () | |
497 | ; declareAtMLtons () | |
498 | ; rest () | |
499 | ; declareMLtonMain () | |
500 | ; declareMain () | |
501 | end | |
502 | ||
503 | structure Type = | |
504 | struct | |
505 | open Type | |
506 | ||
507 | fun toC (t: t): string = | |
508 | CType.toString (Type.toCType t) | |
509 | end | |
510 | ||
511 | structure StackOffset = | |
512 | struct | |
513 | open StackOffset | |
514 | ||
515 | fun toString (T {offset, ty}): string = | |
516 | concat ["S", C.args [Type.toC ty, C.bytes offset]] | |
517 | end | |
518 | ||
519 | fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]] | |
520 | ||
521 | fun declareFFI (Chunk.T {blocks, ...}, {print: string -> unit}) = | |
522 | let | |
523 | val seen = String.memoize (fn _ => ref false) | |
524 | fun doit (name: string, declare: unit -> string): unit = | |
525 | let | |
526 | val r = seen name | |
527 | in | |
528 | if !r | |
529 | then () | |
530 | else (r := true; print (declare ())) | |
531 | end | |
532 | in | |
533 | Vector.foreach | |
534 | (blocks, fn Block.T {statements, transfer, ...} => | |
535 | let | |
536 | datatype z = datatype CFunction.SymbolScope.t | |
537 | val _ = | |
538 | Vector.foreach | |
539 | (statements, fn s => | |
540 | case s of | |
541 | Statement.PrimApp {prim, ...} => | |
542 | (case Prim.name prim of | |
543 | Prim.Name.FFI_Symbol {name, cty, symbolScope} => | |
544 | doit | |
545 | (name, fn () => | |
546 | concat [case symbolScope of | |
547 | External => "EXTERNAL " | |
548 | | Private => "PRIVATE " | |
549 | | Public => "PUBLIC ", | |
550 | "extern ", | |
551 | case cty of | |
552 | SOME x => CType.toString x | |
553 | | NONE => "void", | |
554 | " ", | |
555 | name, | |
556 | ";\n"]) | |
557 | | _ => ()) | |
558 | | _ => ()) | |
559 | val _ = | |
560 | case transfer of | |
561 | Transfer.CCall {func, ...} => | |
562 | let | |
563 | datatype z = datatype CFunction.Target.t | |
564 | val CFunction.T {target, ...} = func | |
565 | in | |
566 | case target of | |
567 | Direct "Thread_returnToC" => () | |
568 | | Direct name => | |
569 | doit (name, fn () => | |
570 | concat [CFunction.cPrototype func, ";\n"]) | |
571 | | Indirect => () | |
572 | end | |
573 | | _ => () | |
574 | in | |
575 | () | |
576 | end) | |
577 | end | |
578 | ||
579 | fun output {program as Machine.Program.T {chunks, | |
580 | frameLayouts, | |
581 | main = {chunkLabel, label}, ...}, | |
582 | outputC: unit -> {file: File.t, | |
583 | print: string -> unit, | |
584 | done: unit -> unit}} = | |
585 | let | |
586 | datatype status = None | One | Many | |
587 | val {get = labelInfo: Label.t -> {block: Block.t, | |
588 | chunkLabel: ChunkLabel.t, | |
589 | frameIndex: int option, | |
590 | status: status ref, | |
591 | layedOut: bool ref}, | |
592 | set = setLabelInfo, ...} = | |
593 | Property.getSetOnce | |
594 | (Label.plist, Property.initRaise ("CCodeGen.info", Label.layout)) | |
595 | val entryLabels: (Label.t * int) list ref = ref [] | |
596 | val indexCounter = Counter.new (Vector.length frameLayouts) | |
597 | val _ = | |
598 | List.foreach | |
599 | (chunks, fn Chunk.T {blocks, chunkLabel, ...} => | |
600 | Vector.foreach | |
601 | (blocks, fn b as Block.T {kind, label, ...} => | |
602 | let | |
603 | fun entry (index: int) = | |
604 | List.push (entryLabels, (label, index)) | |
605 | val frameIndex = | |
606 | case Kind.frameInfoOpt kind of | |
607 | NONE => (if Kind.isEntry kind | |
608 | then entry (Counter.next indexCounter) | |
609 | else () | |
610 | ; NONE) | |
611 | | SOME (FrameInfo.T {frameLayoutsIndex, ...}) => | |
612 | (entry frameLayoutsIndex | |
613 | ; SOME frameLayoutsIndex) | |
614 | in | |
615 | setLabelInfo (label, {block = b, | |
616 | chunkLabel = chunkLabel, | |
617 | frameIndex = frameIndex, | |
618 | layedOut = ref false, | |
619 | status = ref None}) | |
620 | end)) | |
621 | val a = Array.fromList (!entryLabels) | |
622 | val () = QuickSort.sortArray (a, fn ((_, i), (_, i')) => i <= i') | |
623 | val entryLabels = Vector.map (Vector.fromArray a, #1) | |
624 | val labelChunk = #chunkLabel o labelInfo | |
625 | val {get = chunkLabelIndex: ChunkLabel.t -> int, ...} = | |
626 | Property.getSet (ChunkLabel.plist, | |
627 | Property.initFun (let | |
628 | val c = Counter.new 0 | |
629 | in | |
630 | fn _ => Counter.next c | |
631 | end)) | |
632 | val chunkLabelToString = C.int o chunkLabelIndex | |
633 | fun declareChunk (Chunk.T {chunkLabel, ...}, print) = | |
634 | C.call ("DeclareChunk", | |
635 | [chunkLabelToString chunkLabel], | |
636 | print) | |
637 | val {get = labelIndex, set = setLabelIndex, ...} = | |
638 | Property.getSetOnce (Label.plist, | |
639 | Property.initRaise ("index", Label.layout)) | |
640 | val _ = | |
641 | Vector.foreachi (entryLabels, fn (i, l) => setLabelIndex (l, i)) | |
642 | fun labelToStringIndex (l: Label.t): string = | |
643 | let | |
644 | val s = C.int (labelIndex l) | |
645 | in | |
646 | if 0 = !Control.Native.commented | |
647 | then s | |
648 | else concat [s, " /* ", Label.toString l, " */"] | |
649 | end | |
650 | val handleMisaligned = | |
651 | let | |
652 | open Control | |
653 | in | |
654 | !align = Align4 | |
655 | andalso (case !Control.Target.arch of | |
656 | Target.HPPA => true | |
657 | | Target.Sparc => true | |
658 | | _ => false) | |
659 | end | |
660 | val handleMisaligned = | |
661 | fn ty => | |
662 | handleMisaligned | |
663 | andalso (Type.equals (ty, Type.real R64) | |
664 | orelse Type.equals (ty, Type.word WordSize.word64)) | |
665 | fun addr z = concat ["&(", z, ")"] | |
666 | fun fetch (z, ty) = | |
667 | concat [CType.toString (Type.toCType ty), | |
668 | "_fetch(", addr z, ")"] | |
669 | fun move' ({dst, src}, ty) = | |
670 | concat [CType.toString (Type.toCType ty), | |
671 | "_move(", addr dst, ", ", addr src, ");\n"] | |
672 | fun store ({dst, src}, ty) = | |
673 | concat [CType.toString (Type.toCType ty), | |
674 | "_store(", addr dst, ", ", src, ");\n"] | |
675 | fun move {dst: string, dstIsMem: bool, | |
676 | src: string, srcIsMem: bool, | |
677 | ty: Type.t}: string = | |
678 | if handleMisaligned ty then | |
679 | case (dstIsMem, srcIsMem) of | |
680 | (false, false) => concat [dst, " = ", src, ";\n"] | |
681 | | (false, true) => concat [dst, " = ", fetch (src, ty), ";\n"] | |
682 | | (true, false) => store ({dst = dst, src = src}, ty) | |
683 | | (true, true) => move' ({dst = dst, src = src}, ty) | |
684 | else | |
685 | concat [dst, " = ", src, ";\n"] | |
686 | local | |
687 | datatype z = datatype Operand.t | |
688 | fun toString (z: Operand.t): string = | |
689 | case z of | |
690 | ArrayOffset {base, index, offset, scale, ty} => | |
691 | concat ["X", C.args [Type.toC ty, | |
692 | toString base, | |
693 | toString index, | |
694 | Scale.toString scale, | |
695 | C.bytes offset]] | |
696 | | Cast (z, ty) => concat ["(", Type.toC ty, ")", toString z] | |
697 | | Contents {oper, ty} => contents (ty, toString oper) | |
698 | | Frontier => "Frontier" | |
699 | | GCState => "GCState" | |
700 | | Global g => | |
701 | if Global.isRoot g | |
702 | then concat ["G", | |
703 | C.args [Type.toC (Global.ty g), | |
704 | Int.toString (Global.index g)]] | |
705 | else concat ["GPNR", C.args [Int.toString (Global.index g)]] | |
706 | | Label l => labelToStringIndex l | |
707 | | Null => "NULL" | |
708 | | Offset {base, offset, ty} => | |
709 | concat ["O", C.args [Type.toC ty, | |
710 | toString base, | |
711 | C.bytes offset]] | |
712 | | Real r => RealX.toC r | |
713 | | Register r => | |
714 | concat [Type.name (Register.ty r), "_", | |
715 | Int.toString (Register.index r)] | |
716 | | StackOffset s => StackOffset.toString s | |
717 | | StackTop => "StackTop" | |
718 | | Word w => WordX.toC w | |
719 | in | |
720 | val operandToString = toString | |
721 | end | |
722 | fun fetchOperand (z: Operand.t): string = | |
723 | if handleMisaligned (Operand.ty z) andalso Operand.isMem z then | |
724 | fetch (operandToString z, Operand.ty z) | |
725 | else | |
726 | operandToString z | |
727 | fun outputStatement (s, print) = | |
728 | let | |
729 | datatype z = datatype Statement.t | |
730 | in | |
731 | case s of | |
732 | Noop => () | |
733 | | _ => | |
734 | (print "\t" | |
735 | ; (case s of | |
736 | Move {dst, src} => | |
737 | ||
738 | (move {dst = operandToString dst, | |
739 | dstIsMem = Operand.isMem dst, | |
740 | src = operandToString src, | |
741 | srcIsMem = Operand.isMem src, | |
742 | ty = Operand.ty dst}) | |
743 | | Noop => () | |
744 | | PrimApp {args, dst, prim} => | |
745 | let | |
746 | fun call (): string = | |
747 | concat | |
748 | [Prim.toString prim, | |
749 | " (", | |
750 | concat | |
751 | (List.separate | |
752 | (Vector.toListMap (args, fetchOperand), | |
753 | ", ")), | |
754 | ")"] | |
755 | fun app (): string = | |
756 | case Prim.name prim of | |
757 | Prim.Name.FFI_Symbol {name, ...} => | |
758 | concat | |
759 | ["((",CType.toString CType.CPointer, | |
760 | ")(&", name, "))"] | |
761 | | _ => call () | |
762 | in | |
763 | case dst of | |
764 | NONE => (print (app ()) | |
765 | ; print ";\n") | |
766 | | SOME dst => | |
767 | print (move {dst = operandToString dst, | |
768 | dstIsMem = Operand.isMem dst, | |
769 | src = app (), | |
770 | srcIsMem = false, | |
771 | ty = Operand.ty dst}) | |
772 | end | |
773 | | ProfileLabel l => | |
774 | C.call ("ProfileLabel", [ProfileLabel.toString l], | |
775 | print) | |
776 | )) | |
777 | end | |
778 | val amTimeProfiling = | |
779 | !Control.profile = Control.ProfileTimeField | |
780 | orelse !Control.profile = Control.ProfileTimeLabel | |
781 | fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, regMax, ...}) = | |
782 | let | |
783 | val {done, print, ...} = outputC () | |
784 | fun declareChunks () = | |
785 | let | |
786 | val {get, ...} = | |
787 | Property.get (ChunkLabel.plist, | |
788 | Property.initFun (fn _ => ref false)) | |
789 | val _ = | |
790 | Vector.foreach | |
791 | (blocks, fn Block.T {transfer, ...} => | |
792 | case transfer of | |
793 | Transfer.Call {label, ...} => | |
794 | get (labelChunk label) := true | |
795 | | _ => ()) | |
796 | val _ = | |
797 | List.foreach | |
798 | (chunks, fn c as Chunk.T {chunkLabel, ...} => | |
799 | if ! (get chunkLabel) | |
800 | then declareChunk (c, print) | |
801 | else ()) | |
802 | in | |
803 | () | |
804 | end | |
805 | fun declareProfileLabels () = | |
806 | Vector.foreach | |
807 | (blocks, fn Block.T {statements, ...} => | |
808 | Vector.foreach | |
809 | (statements, fn s => | |
810 | case s of | |
811 | Statement.ProfileLabel l => declareProfileLabel (l, print) | |
812 | | _ => ())) | |
813 | (* Count how many times each label is jumped to. *) | |
814 | fun jump l = | |
815 | let | |
816 | val {status, ...} = labelInfo l | |
817 | in | |
818 | case !status of | |
819 | None => status := One | |
820 | | One => status := Many | |
821 | | Many => () | |
822 | end | |
823 | fun force l = #status (labelInfo l) := Many | |
824 | val _ = | |
825 | Vector.foreach | |
826 | (blocks, fn Block.T {kind, label, transfer, ...} => | |
827 | let | |
828 | val _ = if Kind.isEntry kind then jump label else () | |
829 | datatype z = datatype Transfer.t | |
830 | in | |
831 | case transfer of | |
832 | Arith {overflow, success, ...} => | |
833 | (jump overflow; jump success) | |
834 | | CCall {func, return, ...} => | |
835 | if CFunction.maySwitchThreads func | |
836 | then () | |
837 | else Option.app (return, jump) | |
838 | | Call {label, ...} => jump label | |
839 | | Goto dst => jump dst | |
840 | | Raise => () | |
841 | | Return => () | |
842 | | Switch s => Switch.foreachLabel (s, jump) | |
843 | end) | |
844 | fun push (return: Label.t, size: Bytes.t) = | |
845 | (print "\t" | |
846 | ; print (move {dst = (StackOffset.toString | |
847 | (StackOffset.T | |
848 | {offset = Bytes.- (size, Runtime.labelSize ()), | |
849 | ty = Type.label return})), | |
850 | dstIsMem = true, | |
851 | src = operandToString (Operand.Label return), | |
852 | srcIsMem = false, | |
853 | ty = Type.label return}) | |
854 | ; C.push (size, print) | |
855 | ; if amTimeProfiling | |
856 | then print "\tFlushStackTop();\n" | |
857 | else ()) | |
858 | fun copyArgs (args: Operand.t vector): string list * (unit -> unit) = | |
859 | let | |
860 | fun usesStack z = | |
861 | case z of | |
862 | Operand.ArrayOffset {base, index, ...} => | |
863 | (usesStack base) orelse (usesStack index) | |
864 | | Operand.Cast (z, _) => | |
865 | (usesStack z) | |
866 | | Operand.Contents {oper, ...} => | |
867 | (usesStack oper) | |
868 | | Operand.Offset {base, ...} => | |
869 | (usesStack base) | |
870 | | Operand.StackOffset _ => true | |
871 | | _ => false | |
872 | in | |
873 | if Vector.exists (args, usesStack) | |
874 | then | |
875 | let | |
876 | val _ = print "\t{\n" | |
877 | val c = Counter.new 0 | |
878 | val args = | |
879 | Vector.toListMap | |
880 | (args, fn z => | |
881 | if usesStack z | |
882 | then | |
883 | let | |
884 | val ty = Operand.ty z | |
885 | val tmp = | |
886 | concat ["tmp", | |
887 | Int.toString (Counter.next c)] | |
888 | val _ = | |
889 | ||
890 | (concat | |
891 | ["\t", Type.toC ty, " ", tmp, " = ", | |
892 | fetchOperand z, ";\n"]) | |
893 | in | |
894 | tmp | |
895 | end | |
896 | else fetchOperand z) | |
897 | in | |
898 | (args, fn () => print "\t}\n") | |
899 | end | |
900 | else (Vector.toListMap (args, fetchOperand), | |
901 | fn () => ()) | |
902 | end | |
903 | val tracePrintLabelCode = | |
904 | Trace.trace | |
905 | ("CCodegen.printLabelCode", | |
906 | fn {block, layedOut, ...} => | |
907 | Layout.record [("block", Label.layout (Block.label block)), | |
908 | ("layedOut", Bool.layout (!layedOut))], | |
909 | Unit.layout) | |
910 | fun maybePrintLabel l = | |
911 | if ! (#layedOut (labelInfo l)) | |
912 | then () | |
913 | else gotoLabel l | |
914 | and gotoLabel arg = | |
915 | traceGotoLabel | |
916 | (fn l => | |
917 | let | |
918 | val info as {layedOut, ...} = labelInfo l | |
919 | in | |
920 | if !layedOut | |
921 | then print (concat ["\tgoto ", Label.toString l, ";\n"]) | |
922 | else printLabelCode info | |
923 | end) arg | |
924 | and printLabelCode arg = | |
925 | tracePrintLabelCode | |
926 | (fn {block = Block.T {kind, label = l, live, statements, | |
927 | transfer, ...}, | |
928 | layedOut, status, ...} => | |
929 | let | |
930 | val _ = layedOut := true | |
931 | val _ = | |
932 | case !status of | |
933 | Many => | |
934 | let | |
935 | val s = Label.toString l | |
936 | in | |
937 | print s | |
938 | ; print ":\n" | |
939 | end | |
940 | | _ => () | |
941 | fun pop (fi: FrameInfo.t) = | |
942 | (C.push (Bytes.~ (Program.frameSize (program, fi)), print) | |
943 | ; if amTimeProfiling | |
944 | then print "\tFlushStackTop();\n" | |
945 | else ()) | |
946 | val _ = | |
947 | case kind of | |
948 | Kind.Cont {frameInfo, ...} => pop frameInfo | |
949 | | Kind.CReturn {dst, frameInfo, ...} => | |
950 | (case frameInfo of | |
951 | NONE => () | |
952 | | SOME fi => pop fi | |
953 | ; (Option.app | |
954 | (dst, fn x => | |
955 | let | |
956 | val x = Live.toOperand x | |
957 | val ty = Operand.ty x | |
958 | in | |
959 | ||
960 | (concat | |
961 | ["\t", | |
962 | move {dst = operandToString x, | |
963 | dstIsMem = Operand.isMem x, | |
964 | src = creturn ty, | |
965 | srcIsMem = false, | |
966 | ty = ty}]) | |
967 | end))) | |
968 | | Kind.Func => () | |
969 | | Kind.Handler {frameInfo, ...} => pop frameInfo | |
970 | | Kind.Jump => () | |
971 | val _ = | |
972 | if 0 = !Control.Native.commented | |
973 | then () | |
974 | else print (let open Layout | |
975 | in toString | |
976 | (seq [str "\t/* live: ", | |
977 | Vector.layout Live.layout live, | |
978 | str " */\n"]) | |
979 | end) | |
980 | val _ = Vector.foreach (statements, fn s => | |
981 | outputStatement (s, print)) | |
982 | val _ = outputTransfer (transfer, l) | |
983 | in () | |
984 | end) arg | |
985 | and outputTransfer (t, source: Label.t) = | |
986 | let | |
987 | fun iff (test, a, b) = | |
988 | (force a | |
989 | ; C.call ("\tBNZ", [test, Label.toString a], print) | |
990 | ; gotoLabel b | |
991 | ; maybePrintLabel a) | |
992 | datatype z = datatype Transfer.t | |
993 | in | |
994 | case t of | |
995 | Arith {prim, args, dst, overflow, success, ...} => | |
996 | let | |
997 | val prim = | |
998 | let | |
999 | datatype z = datatype Prim.Name.t | |
1000 | fun const i = | |
1001 | case Vector.sub (args, i) of | |
1002 | Operand.Word _ => true | |
1003 | | _ => false | |
1004 | fun const0 () = const 0 | |
1005 | fun const1 () = const 1 | |
1006 | in | |
1007 | case Prim.name prim of | |
1008 | Word_addCheck _ => | |
1009 | concat [Prim.toString prim, | |
1010 | if const0 () | |
1011 | then "CX" | |
1012 | else if const1 () | |
1013 | then "XC" | |
1014 | else ""] | |
1015 | | Word_mulCheck _ => Prim.toString prim | |
1016 | | Word_negCheck _ => Prim.toString prim | |
1017 | | Word_subCheck _ => | |
1018 | concat [Prim.toString prim, | |
1019 | if const0 () | |
1020 | then "CX" | |
1021 | else if const1 () | |
1022 | then "XC" | |
1023 | else ""] | |
1024 | | _ => Error.bug "CCodegen.outputTransfer: Arith" | |
1025 | end | |
1026 | val _ = force overflow | |
1027 | in | |
1028 | print "\t" | |
1029 | ; C.call (prim, | |
1030 | operandToString dst | |
1031 | :: (Vector.toListMap (args, operandToString) | |
1032 | @ [Label.toString overflow]), | |
1033 | print) | |
1034 | ; gotoLabel success | |
1035 | ; maybePrintLabel overflow | |
1036 | end | |
1037 | | CCall {args, frameInfo, func, return} => | |
1038 | let | |
1039 | val CFunction.T {return = returnTy, | |
1040 | target, ...} = func | |
1041 | val (args, afterCall) = | |
1042 | case frameInfo of | |
1043 | NONE => | |
1044 | (Vector.toListMap (args, fetchOperand), | |
1045 | fn () => ()) | |
1046 | | SOME frameInfo => | |
1047 | let | |
1048 | val size = | |
1049 | Program.frameSize (program, frameInfo) | |
1050 | val res = copyArgs args | |
1051 | val _ = push (valOf return, size) | |
1052 | in | |
1053 | res | |
1054 | end | |
1055 | val _ = | |
1056 | if CFunction.modifiesFrontier func | |
1057 | then print "\tFlushFrontier();\n" | |
1058 | else () | |
1059 | val _ = | |
1060 | if CFunction.readsStackTop func | |
1061 | then print "\tFlushStackTop();\n" | |
1062 | else () | |
1063 | val _ = print "\t" | |
1064 | val _ = | |
1065 | if Type.isUnit returnTy | |
1066 | then () | |
1067 | else print (concat [creturn returnTy, " = "]) | |
1068 | datatype z = datatype CFunction.Target.t | |
1069 | val _ = | |
1070 | case target of | |
1071 | Direct name => C.call (name, args, print) | |
1072 | | Indirect => | |
1073 | let | |
1074 | val (fptr,args) = | |
1075 | case args of | |
1076 | (fptr::args) => (fptr, args) | |
1077 | | _ => Error.bug "CCodegen.outputTransfer: CCall,Indirect" | |
1078 | val name = | |
1079 | concat ["(*(", | |
1080 | CFunction.cPointerType func, | |
1081 | " ", fptr, "))"] | |
1082 | in | |
1083 | C.call (name, args, print) | |
1084 | end | |
1085 | val _ = afterCall () | |
1086 | val _ = | |
1087 | if CFunction.modifiesFrontier func | |
1088 | then print "\tCacheFrontier();\n" | |
1089 | else () | |
1090 | val _ = | |
1091 | if CFunction.writesStackTop func | |
1092 | then print "\tCacheStackTop();\n" | |
1093 | else () | |
1094 | val _ = | |
1095 | if CFunction.maySwitchThreads func | |
1096 | then print "\tReturn();\n" | |
1097 | else Option.app (return, gotoLabel) | |
1098 | in | |
1099 | () | |
1100 | end | |
1101 | | Call {label, return, ...} => | |
1102 | let | |
1103 | val dstChunk = labelChunk label | |
1104 | val _ = | |
1105 | case return of | |
1106 | NONE => () | |
1107 | | SOME {return, size, ...} => | |
1108 | push (return, size) | |
1109 | in | |
1110 | if ChunkLabel.equals (labelChunk source, dstChunk) | |
1111 | then gotoLabel label | |
1112 | else | |
1113 | C.call ("\tFarJump", | |
1114 | [chunkLabelToString dstChunk, | |
1115 | labelToStringIndex label], | |
1116 | print) | |
1117 | end | |
1118 | | Goto dst => gotoLabel dst | |
1119 | | Raise => C.call ("\tRaise", [], print) | |
1120 | | Return => C.call ("\tReturn", [], print) | |
1121 | | Switch switch => | |
1122 | let | |
1123 | fun bool (test: Operand.t, t, f) = | |
1124 | iff (operandToString test, t, f) | |
1125 | fun doit {cases: (string * Label.t) vector, | |
1126 | default: Label.t option, | |
1127 | test: Operand.t}: unit = | |
1128 | let | |
1129 | val test = operandToString test | |
1130 | fun switch (cases: (string * Label.t) vector, | |
1131 | default: Label.t): unit = | |
1132 | (print "switch (" | |
1133 | ; print test | |
1134 | ; print ") {\n" | |
1135 | ; (Vector.foreach | |
1136 | (cases, fn (n, l) => (print "case " | |
1137 | ; print n | |
1138 | ; print ":\n" | |
1139 | ; gotoLabel l))) | |
1140 | ; print "default:\n" | |
1141 | ; gotoLabel default | |
1142 | ; print "}\n") | |
1143 | in | |
1144 | case (Vector.length cases, default) of | |
1145 | (0, NONE) => | |
1146 | Error.bug "CCodegen.outputTransfers: Switch" | |
1147 | | (0, SOME l) => gotoLabel l | |
1148 | | (1, NONE) => | |
1149 | gotoLabel (#2 (Vector.sub (cases, 0))) | |
1150 | | (_, NONE) => | |
1151 | switch (Vector.dropPrefix (cases, 1), | |
1152 | #2 (Vector.sub (cases, 0))) | |
1153 | | (_, SOME l) => switch (cases, l) | |
1154 | end | |
1155 | val Switch.T {cases, default, test, ...} = switch | |
1156 | fun normal () = | |
1157 | doit {cases = Vector.map (cases, fn (c, l) => | |
1158 | (WordX.toC c, l)), | |
1159 | default = default, | |
1160 | test = test} | |
1161 | in | |
1162 | if 2 = Vector.length cases | |
1163 | andalso Option.isNone default | |
1164 | then | |
1165 | let | |
1166 | val (c0, l0) = Vector.sub (cases, 0) | |
1167 | val (c1, l1) = Vector.sub (cases, 1) | |
1168 | val i0 = WordX.toIntInf c0 | |
1169 | val i1 = WordX.toIntInf c1 | |
1170 | in | |
1171 | if i0 = 0 andalso i1 = 1 | |
1172 | then bool (test, l1, l0) | |
1173 | else if i0 = 1 andalso i1 = 0 | |
1174 | then bool (test, l0, l1) | |
1175 | else normal () | |
1176 | end | |
1177 | else normal () | |
1178 | end | |
1179 | end | |
1180 | fun declareRegisters () = | |
1181 | List.foreach | |
1182 | (CType.all, fn t => | |
1183 | let | |
1184 | val pre = concat ["\t", CType.toString t, " ", | |
1185 | CType.name t, "_"] | |
1186 | in | |
1187 | Int.for (0, 1 + regMax t, fn i => | |
1188 | print (concat [pre, C.int i, ";\n"])) | |
1189 | end) | |
1190 | fun outputOffsets () = | |
1191 | List.foreach | |
1192 | ([("ExnStackOffset", GCField.ExnStack), | |
1193 | ("FrontierOffset", GCField.Frontier), | |
1194 | ("StackBottomOffset", GCField.StackBottom), | |
1195 | ("StackTopOffset", GCField.StackTop)], | |
1196 | fn (name, f) => | |
1197 | print (concat ["#define ", name, " ", | |
1198 | Bytes.toString (GCField.offset f), "\n"])) | |
1199 | in | |
1200 | outputIncludes (["c-chunk.h"], print) | |
1201 | ; outputOffsets () | |
1202 | ; declareGlobals ("PRIVATE extern ", print) | |
1203 | ; declareFFI (chunk, {print = print}) | |
1204 | ; declareChunks () | |
1205 | ; declareProfileLabels () | |
1206 | ; C.callNoSemi ("Chunk", [chunkLabelToString chunkLabel], print) | |
1207 | ; print "\n" | |
1208 | ; declareRegisters () | |
1209 | ; C.callNoSemi ("ChunkSwitch", [chunkLabelToString chunkLabel], | |
1210 | print) | |
1211 | ; print "\n" | |
1212 | ; Vector.foreach (blocks, fn Block.T {kind, label, ...} => | |
1213 | if Kind.isEntry kind | |
1214 | then (print "case " | |
1215 | ; print (labelToStringIndex label) | |
1216 | ; print ":\n" | |
1217 | ; gotoLabel label) | |
1218 | else ()) | |
1219 | ; print "EndChunk\n" | |
1220 | ; done () | |
1221 | end | |
1222 | val additionalMainArgs = | |
1223 | [chunkLabelToString chunkLabel, | |
1224 | labelToStringIndex label] | |
1225 | val {print, done, ...} = outputC () | |
1226 | fun rest () = | |
1227 | (List.foreach (chunks, fn c => declareChunk (c, print)) | |
1228 | ; print "PRIVATE struct cont ( *nextChunks []) () = {" | |
1229 | ; Vector.foreach (entryLabels, fn l => | |
1230 | let | |
1231 | val {chunkLabel, ...} = labelInfo l | |
1232 | in | |
1233 | print "\t" | |
1234 | ; C.callNoSemi ("Chunkp", | |
1235 | [chunkLabelToString chunkLabel], | |
1236 | print) | |
1237 | ; print ",\n" | |
1238 | end) | |
1239 | ; print "};\n") | |
1240 | val _ = | |
1241 | outputDeclarations {additionalMainArgs = additionalMainArgs, | |
1242 | includes = ["c-main.h"], | |
1243 | program = program, | |
1244 | print = print, | |
1245 | rest = rest} | |
1246 | val _ = done () | |
1247 | val _ = List.foreach (chunks, outputChunk) | |
1248 | in | |
1249 | () | |
1250 | end | |
1251 | ||
1252 | end |