from-core.sml 21.2 KB
Newer Older
1
2
3
4
5
6
7
8
9

structure FromCore : sig
   val run:
      Core.Spec.t ->
         CPS.Spec.t CompilationMonad.t
end = struct

   structure CM = CompilationMonad
   structure Exp = CPS.Exp
mb0's avatar
mb0 committed
10
   structure CCTab = CPS.CCTab
mb0's avatar
mb0 committed
11
   structure S = Substring
12
13

   val variable = Atom.atom "x"
mb0's avatar
mb0 committed
14
15
16
   val function = Atom.atom "f"
   val constructor = Atom.atom "cons"
   val continuation = CCTab.kont
17

mb0's avatar
mb0 committed
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
   structure Builtin = struct
      fun fresh v = let
         val (tab, sym) =
            VarInfo.fresh (!SymbolTables.varTable, Atom.atom v)
      in
         sym before SymbolTables.varTable := tab
      end

      fun field f = let
         val (tab, sym) =
            FieldInfo.fresh (!SymbolTables.fieldTable, f)
      in
         sym before SymbolTables.fieldTable := tab
      end
      
      fun get s = VarInfo.lookup (!SymbolTables.varTable, Atom.atom s)

      fun mk () = let
36
         open Core.Exp
mb0's avatar
mb0 committed
37
         val slice = get "slice"
mb0's avatar
Up.    
mb0 committed
38
39
40
41
42
43
         val consume8 = get "consume8"
         val unconsume8 = get "unconsume8"
         val consume16 = get "consume16"
         val unconsume16 = get "unconsume16"
         val consume32 = get "consume32"
         val unconsume32 = get "unconsume32"
mb0's avatar
mb0 committed
44
45
         val andd = get "and"
         val concat = get "^"
mb0's avatar
mb0 committed
46
47
         val == = get "=="
         val not = get "not"
mb0's avatar
mb0 committed
48
         val raisee = get "raise"
mb0's avatar
mb0 committed
49
         val return = get "return"
mb0's avatar
Foo.    
mb0 committed
50
         val add = get "+"
mb0's avatar
mb0 committed
51
         val sub = get "-"
mb0's avatar
Foo.    
mb0 committed
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
         val sx = get "sx"
         val zx = get "zx"

         val sx = 
            let
               val x = fresh "x"
               val primSx = get "%sx"
               val body = PRI (primSx, [x])
            in
               (sx, [x], body)
            end

         val zx = 
            let
               val x = fresh "x"
               val primZx = get "%zx"
               val body = PRI (primZx, [x])
            in
               (zx, [x], body)
            end

         (* val + a b = %add(a,b) *)
         val add =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primAdd = get "%add"
               val body = PRI (primAdd, [a, b])
                     
            in
               (add, [a, b], body)
            end
mb0's avatar
mb0 committed
84

mb0's avatar
mb0 committed
85
86
87
88
89
90
91
92
93
94
95
96
         (* val - a b = %sub(a,b) *)
         val sub =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primSub = get "%sub"
               val body = PRI (primSub, [a, b])
                     
            in
               (sub, [a, b], body)
            end

97
         (* val and a b = %and(a,b) *)
mb0's avatar
mb0 committed
98
99
100
101
102
         val andd =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primAnd = get "%and"
103
104
               val body = PRI (primAnd, [a, b])
                     
mb0's avatar
mb0 committed
105
            in
106
               (andd, [a, b], body)
mb0's avatar
mb0 committed
107
108
            end

109
         (* val == a b = %equal(a,b) *)
mb0's avatar
mb0 committed
110
111
112
113
114
         val == =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primEqual = get "%equal"
115
               val body = PRI (primEqual, [a, b])
mb0's avatar
mb0 committed
116
            in
117
               (==, [a, b], body)
mb0's avatar
mb0 committed
118
119
            end

120
         (* val not a = %not(a) *)
mb0's avatar
mb0 committed
121
122
123
124
125
         val not =
            let
               val a = fresh "a"
               val x = fresh "x"
               val primNot = get "%not"
126
               val body = PRI (primNot, [a])
mb0's avatar
mb0 committed
127
            in
128
               (not, [a], body)
mb0's avatar
mb0 committed
129
130
            end

mb0's avatar
mb0 committed
131
         (* val ^ k a b = %concat(a,b) *)
mb0's avatar
mb0 committed
132
133
134
135
136
         val concat =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primConcat = get "%concat"
137
               val body = PRI (primConcat, [a, b])
mb0's avatar
mb0 committed
138
            in
139
               (concat, [a, b], body)
mb0's avatar
mb0 committed
140
141
            end

142
         (* val raise a = return(%raise(a)) *)
mb0's avatar
mb0 committed
143
144
145
146
         val raisee =
            let
               val a = fresh "a"
               val primRaise = get "%raise"
mb0's avatar
mb0 committed
147
               val body = APP (ID return, [PRI (primRaise, [a])])
mb0's avatar
mb0 committed
148
            in
149
               (raisee, [a], body)
mb0's avatar
mb0 committed
150
151
            end

mb0's avatar
mb0 committed
152
         (* val slice tok offs sz = return (%slice(tok,offs,sz) *)
mb0's avatar
mb0 committed
153
154
155
156
157
158
         val slice =
            let
               val tok = fresh "tok"
               val offs = fresh "offs"
               val sz = fresh "sz"
               val primSlice = get "%slice"
mb0's avatar
mb0 committed
159
               val body = APP (ID return, [PRI (primSlice, [tok, offs, sz])])
mb0's avatar
mb0 committed
160
            in
mb0's avatar
mb0 committed
161
               (slice, [tok, offs, sz], body) 
mb0's avatar
mb0 committed
162
163
            end

mb0's avatar
Up.    
mb0 committed
164
165
         (* val consume8 s = %consume8(s) *)
         val consume8 =
mb0's avatar
mb0 committed
166
167
            let
               val s = fresh "s"
mb0's avatar
Up.    
mb0 committed
168
169
               val primconsume8 = get "%consume8"
               val body = PRI (primconsume8, [s])
mb0's avatar
mb0 committed
170
            in
mb0's avatar
Up.    
mb0 committed
171
               (consume8, [s], body)
mb0's avatar
mb0 committed
172
173
            end

mb0's avatar
Up.    
mb0 committed
174
175
         (* val unconsume8 s = %unconsume8(s) *)
         val unconsume8 =
mb0's avatar
mb0 committed
176
177
            let
               val s = fresh "s"
mb0's avatar
Up.    
mb0 committed
178
179
               val primUnconsume8 = get "%unconsume8"
               val body = PRI (primUnconsume8, [s])
mb0's avatar
mb0 committed
180
            in
mb0's avatar
Up.    
mb0 committed
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
               (unconsume8, [s], body)
            end

         (* val consume16 s = %consume16(s) *)
         val consume16 =
            let
               val s = fresh "s"
               val primconsume16 = get "%consume16"
               val body = PRI (primconsume16, [s])
            in
               (consume16, [s], body)
            end

         (* val unconsume16 s = %unconsume16(s) *)
         val unconsume16 =
            let
               val s = fresh "s"
               val primUnconsume16 = get "%unconsume16"
               val body = PRI (primUnconsume16, [s])
            in
               (unconsume16, [s], body)
            end

         (* val consume32 s = %consume32(s) *)
         val consume32 =
            let
               val s = fresh "s"
               val primconsume32 = get "%consume32"
               val body = PRI (primconsume32, [s])
            in
               (consume32, [s], body)
            end

         (* val unconsume32 s = %unconsume32(s) *)
         val unconsume32 =
            let
               val s = fresh "s"
               val primUnconsume32 = get "%unconsume32"
               val body = PRI (primUnconsume32, [s])
            in
               (unconsume32, [s], body)
mb0's avatar
mb0 committed
222
223
            end
      in
mb0's avatar
mb0 committed
224
         [slice,
mb0's avatar
Up.    
mb0 committed
225
226
227
228
229
230
          consume8,
          unconsume8,
          consume16,
          unconsume16,
          consume32,
          unconsume32,
mb0's avatar
mb0 committed
231
232
233
234
235
236
237
238
239
          andd,
          not,
          ==,
          concat,
          raisee,
          add,
          sx,
          zx,
          sub]
mb0's avatar
mb0 committed
240
241
242
243
      end

   end

mb0's avatar
mb0 committed
244
   val constructors: (Spec.sym * Spec.ty option) SymMap.map ref = ref SymMap.empty
mb0's avatar
mb0 committed
245

mb0's avatar
mb0 committed
246
247
248
   fun isEnumLike c =
      case SymMap.lookup (!constructors, c) of
         (_, NONE) => true | _ => false
249

mb0's avatar
mb0 committed
250
   fun fresh variable = let
251
      val (tab, sym) =
mb0's avatar
mb0 committed
252
         VarInfo.fresh (!SymbolTables.varTable, variable)
253
254
255
256
257
258
259
260
   in
      sym before SymbolTables.varTable := tab
   end

   fun bind map v t = SymMap.insert (map, v, t) 

   local open Core.Exp in

mb0's avatar
mb0 committed
261
262
263
264
265
266
267
268
269
270
271
272
273
274
   fun field f = let
      val tab = SymbolTables.fieldTable
      val n = VarInfo.getAtom (!SymbolTables.varTable, f)
   in
      case FieldInfo.find (!tab, n) of
         SOME s => s
       | NONE =>
            let
               val (tab, sym) = FieldInfo.fresh (!tab, n)
            in
               sym before SymbolTables.fieldTable := tab
            end
   end

275
276
277
278
   fun translate spec =
      Spec.upd
         (fn cs =>
            let
mb0's avatar
mb0 committed
279
280
281
               val main = fresh function
               val kont = fresh continuation
               val () = constructors := Spec.get#constructors spec
mb0's avatar
mb0 committed
282
283
284
285
286
287
288
289
290
               fun exports cs =
                  rev (foldl
                     (fn ((f, _, _), acc) => 
                        let
                           val fld = field f
                        in
                           (fld, ID f)::acc
                        end)
                     [] cs)
mb0's avatar
mb0 committed
291
292
293
294
295
296
               fun exports spec =
                  let 
                     val es = Spec.get#exports spec
                  in
                     map (fn e => (field e, ID e)) es
                  end
mb0's avatar
mb0 committed
297
298
               val cps =
                  trans0 
299
                     (LETREC (Builtin.mk()@cs, RECORD (exports spec)))
mb0's avatar
mb0 committed
300
                     (fn z => Exp.APP (main, kont, [z]))
301
            in
302
               cps
303
304
305
306
307
308
            end) spec

   and trans0 e kappa = 
      case e of
         LETVAL (v, e, body) =>
            let
mb0's avatar
mb0 committed
309
               val j = fresh continuation
310
311
               val body = trans0 body kappa
            in
312
               Exp.LETCONT ([(j, [v], body)], trans1 e j)
313
            end
mb0's avatar
mb0 committed
314
315
316
317
318
319
320
321
322
323
       | LETREC (ds, body) => Exp.LETREC (map trans0rec ds, trans0 body kappa)
       | IF (iff, thenn, elsee) =>
            trans0
               (CASE
                  (iff,
                   [(Core.Pat.BIT "1", thenn),
                    (Core.Pat.BIT "0", elsee)]))
               kappa
       | CASE (e, ps) =>
            let
mb0's avatar
mb0 committed
324
               val j = fresh continuation
mb0's avatar
mb0 committed
325
326
327
328
               fun trans z ps cps ks =
                  case ps of
                     [] =>
                        let
mb0's avatar
mb0 committed
329
                           val x = fresh variable
mb0's avatar
mb0 committed
330
                        in
mb0's avatar
mb0 committed
331
332
333
334
335
336
337
338
339
340
                           case ks of
                              [([],body)] =>
                                 Exp.LETCONT
                                    ((j, [x], kappa x)::cps,
                                     Exp.CC body)

                            | _ =>
                                 Exp.LETCONT
                                    ((j, [x], kappa x)::cps,
                                     Exp.CASE (z, ks))
mb0's avatar
mb0 committed
341
342
343
                        end
                   | (p, e)::ps =>
                        let
mb0's avatar
mb0 committed
344
                           val k = fresh continuation
mb0's avatar
mb0 committed
345
346
347
348
349
                           val (x, ks) = transPat p k ks
                           fun bindTrans x =
                              case x of
                                 SOME x => Exp.LETDECON (x, z, trans1 e j)
                               | _ => trans1 e j
mb0's avatar
mb0 committed
350
                        in
mb0's avatar
mb0 committed
351
                           trans z ps ((k, [], bindTrans x)::cps) ks
mb0's avatar
mb0 committed
352
353
                        end
            in
354
               trans0 e (fn z => trans z ps [] [])
mb0's avatar
mb0 committed
355
            end
mb0's avatar
mb0 committed
356
       | APP (e1, es) =>
357
            let
mb0's avatar
mb0 committed
358
359
               val k = fresh continuation
               val x = fresh variable
mb0's avatar
mb0 committed
360
361
362
363
               fun trans es xs k =
                  case es of
                     e::es => trans0 e (fn x => trans es (x::xs) k)
                   | [] => k (rev xs)
364
            in
mb0's avatar
mb0 committed
365
366
367
               trans0 e1 (fn x1 =>
                  trans es [] (fn xs =>
                     Exp.LETCONT ([(k, [x], kappa x)], Exp.APP (x1, k, xs))))
368
            end
369
370
371
372
373
374
       | PRI (f, xs) =>
            let
               val x = fresh variable
            in
               Exp.LETVAL (x, Exp.PRI (f, xs), kappa x)
            end
375
376
       | FN (x, e) =>
            let
mb0's avatar
mb0 committed
377
378
               val f = fresh function
               val k = fresh continuation
379
            in
380
               Exp.LETVAL (f, Exp.FN (k, [x], trans1 e k), kappa f) 
381
382
383
384
385
386
387
            end
       | RECORD fs =>
            let
               fun trans fs fvs =
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
388
                           val x = fresh variable
389
390
391
392
393
394
395
396
397
                        in
                           Exp.LETVAL (x, Exp.REC fvs, kappa x)
                        end
                   | (f, e)::fs =>
                        trans0 e (fn z =>
                           trans fs ((f, z)::fvs))
            in
               trans fs []
            end
mb0's avatar
mb0 committed
398
399
       | UPDATE fs => 
            let
mb0's avatar
mb0 committed
400
401
402
               val f = fresh function
               val k = fresh continuation
               val z = fresh variable
mb0's avatar
mb0 committed
403
404
               val x = fresh variable
               fun trans fs fvs =
mb0's avatar
mb0 committed
405
406
                  case fs of
                     [] =>
mb0's avatar
mb0 committed
407
408
409
410
411
412
                        Exp.LETVAL
                           (f,
                            Exp.FN (k, [x],
                              Exp.LETUPD (z, x, fvs,
                                 Exp.CC (k, [z]))),
                            kappa f)
mb0's avatar
mb0 committed
413
414
                   | (f, e)::fs =>
                        trans0 e (fn z =>
mb0's avatar
mb0 committed
415
                           trans fs ((f, z)::fvs))
mb0's avatar
mb0 committed
416
            in
mb0's avatar
mb0 committed
417
               trans fs []
mb0's avatar
mb0 committed
418
            end
419
420
       | SELECT fld =>
            let
mb0's avatar
mb0 committed
421
422
423
424
               val f = fresh function
               val k = fresh continuation
               val x = fresh variable
               val z = fresh variable
425
            in
mb0's avatar
mb0 committed
426
427
428
429
               Exp.LETVAL
                  (f,
                   Exp.FN
                     (k,
mb0's avatar
mb0 committed
430
431
                      [x],
                      Exp.LETPRJ (z, fld, x, Exp.CC (k, [z]))),
432
433
434
                   kappa f)
            end
       | CON c =>
mb0's avatar
mb0 committed
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
            if isEnumLike c
               then
                  let
                     val x = fresh variable
                     val y = fresh variable
                  in
                     Exp.LETVAL (y, Exp.UNT,
                     Exp.LETVAL (x, Exp.INJ (c, y), kappa x))
                  end
            else
               let
                  val f = fresh constructor
                  val k = fresh continuation
                  val x = fresh variable
                  val y = fresh variable
mb0's avatar
mb0 committed
450
451
                  val j = fresh continuation
                  val z = fresh variable
mb0's avatar
mb0 committed
452
               in
mb0's avatar
mb0 committed
453
454
455
456
                  Exp.LETVAL
                     (f,
                      Exp.FN
                        (k,
mb0's avatar
mb0 committed
457
458
459
                         [x],
                         Exp.LETVAL (y, Exp.INJ (c, x), Exp.CC (k, [y]))),
                      kappa f) 
mb0's avatar
mb0 committed
460
               end
461
462
       | LIT l =>
            let
mb0's avatar
mb0 committed
463
               val x = fresh variable
464
465
466
467
468
            in
               Exp.LETVAL (x, transLit l, kappa x)
            end
       | ID v => kappa v
       | _ => raise CM.CompilationError
mb0's avatar
mb0 committed
469
  
mb0's avatar
mb0 committed
470
471
   and explodePat str =
      let
mb0's avatar
mb0 committed
472
473
474
475
         fun toWord str =
            case StringCvt.scanString (Word.scan StringCvt.BIN) str of
               SOME w => w
             | NONE => raise Fail ("Invalid bit-pattern: " ^ str)
mb0's avatar
mb0 committed
476
477
478
479
480
481
482
483
484
485
         val cvt = toWord o String.implode
         fun lp (s, acc) =
            case S.getc s of
               SOME (#".",s) => lp(s,#"0"::acc)@lp(s,#"1"::acc)
             | SOME (n,s) =>
                  if not (Char.isDigit n)
                     then raise Fail ("Invalid bit-pattern: " ^ str)
                  else lp(s,n::acc)
             | NONE => [cvt (rev acc)]
      in
mb0's avatar
mb0 committed
486
487
488
         if CharVector.all (fn c => c = #".") str then [] else
         case str of
            "" => []
mb0's avatar
mb0 committed
489
490
491
492
493
494
          | _ =>
               case String.tokens (fn c => c = #"|") str of
                  strs =>
                     List.concat
                        (map (fn str =>
                           lp (S.full str, [])) strs)
mb0's avatar
mb0 committed
495
496
      end

mb0's avatar
mb0 committed
497
   and transPat p k ks =
498
      let (* TODO: apply arguments to the branches *)
mb0's avatar
mb0 committed
499
          (* TODO: check size of generated patterns and bail out if to large *)
mb0's avatar
mb0 committed
500
         open Core.Pat
mb0's avatar
mb0 committed
501

mb0's avatar
mb0 committed
502
503
         fun toIdx p =
            case p of
mb0's avatar
mb0 committed
504
               BIT str => explodePat str
505
             | INT i => [Word.fromLargeInt (IntInf.toLarge i)]
mb0's avatar
mb0 committed
506
507
508
509
510
511
512
513
514
             | CON (tag, _) => [Word.fromInt (SymbolTable.toInt tag)]
             | ID _ => []
             | WILD => []

         fun bndVars p =
            case p of
               CON (_,SOME x) => SOME x
             | ID x => SOME x
             | _ => NONE
mb0's avatar
mb0 committed
515
      in
mb0's avatar
mb0 committed
516
         (bndVars p, (toIdx p, (k, []))::ks)
mb0's avatar
mb0 committed
517
518
519
520
      end

   and trans0rec (n, args, e) =
      let
mb0's avatar
mb0 committed
521
         val k = fresh continuation
mb0's avatar
mb0 committed
522
      in
523
         case args of
mb0's avatar
mb0 committed
524
525
526
527
            [] =>
               let
                  val x = fresh variable
               in
mb0's avatar
mb0 committed
528
                  (* TODO: value vs (rec) fun *)
mb0's avatar
mb0 committed
529
                  (n, k, [x], trans1 (APP (e, [ID x])) k)
mb0's avatar
mb0 committed
530
               end
mb0's avatar
mb0 committed
531
          | args => (n, k, args, trans1 e k)
mb0's avatar
mb0 committed
532
533
      end

534
535
   and trans1 e kont =
      case e of
mb0's avatar
mb0 committed
536
537
         LETVAL (v, e, body) =>
            let
mb0's avatar
mb0 committed
538
               val j = fresh continuation
mb0's avatar
mb0 committed
539
540
               val body = trans1 body kont
            in
541
               Exp.LETCONT ([(j, [v], body)], trans1 e j)
mb0's avatar
mb0 committed
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
            end
       | LETREC (ds, body) => Exp.LETREC (map trans0rec ds, trans1 body kont)
       | IF (iff, thenn, elsee) =>
            trans1
               (CASE
                  (iff,
                   [(Core.Pat.BIT "1", thenn),
                    (Core.Pat.BIT "0", elsee)]))
               kont
       | CASE (e, ps) =>
            let
               fun trans z ps cps ks =
                  case ps of
                     (p, e)::ps =>
                        let
mb0's avatar
mb0 committed
557
                           val k = fresh continuation
mb0's avatar
mb0 committed
558
559
560
561
562
                           val (x, ks) = transPat p k ks
                           fun bindTrans x =
                              case x of
                                 SOME x => Exp.LETDECON (x, z, trans1 e kont)
                               | _ => trans1 e kont
mb0's avatar
mb0 committed
563
                        in
mb0's avatar
mb0 committed
564
                           trans z ps ((k, [], bindTrans x)::cps) ks
mb0's avatar
mb0 committed
565
                        end
mb0's avatar
mb0 committed
566
567
568
569
570
571
                   | [] =>
                        case ks of
                           [([],body)] =>
                              Exp.LETCONT (cps, Exp.CC body)
                         | _ =>
                              Exp.LETCONT (cps, Exp.CASE (z, ks))
mb0's avatar
mb0 committed
572
            in
573
               trans0 e (fn z => trans z ps [] [])
mb0's avatar
mb0 committed
574
            end
mb0's avatar
mb0 committed
575
576
577
578
579
580
581
582
583
584
585
       | APP (e1, es) =>
            let
               fun trans es xs k =
                  case es of
                     e::es => trans0 e (fn x => trans es (x::xs) k)
                   | [] => k (rev xs)
            in
               trans0 e1 (fn x1 =>
                  trans es [] (fn xs =>
                     Exp.APP (x1, kont, xs)))
            end
586
587
588
589
590
591
       | PRI (f, xs) =>
            let
               val x = fresh variable
            in
               Exp.LETVAL (x, Exp.PRI (f, xs), Exp.CC (kont, [x]))
            end
mb0's avatar
mb0 committed
592
593
       | FN (x, e) =>
            let
mb0's avatar
mb0 committed
594
595
               val f = fresh function
               val j = fresh continuation
mb0's avatar
mb0 committed
596
            in
597
               Exp.LETVAL (f, Exp.FN (j, [x], trans1 e j), Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
598
599
600
601
602
603
604
            end
       | RECORD fs =>
            let
               fun trans fs fvs =
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
605
                           val x = fresh variable
mb0's avatar
mb0 committed
606
                        in
mb0's avatar
mb0 committed
607
                           Exp.LETVAL (x, Exp.REC fvs, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
608
609
610
611
612
613
614
615
616
                        end
                   | (f, e)::fs =>
                        trans0 e (fn z =>
                           trans fs ((f, z)::fvs))
            in
               trans fs []
            end
       | UPDATE fs => 
            let
mb0's avatar
mb0 committed
617
618
619
620
621
               val f = fresh function
               val k = fresh continuation
               val x = fresh variable
               val z = fresh variable
               fun trans y fs fvs =
mb0's avatar
mb0 committed
622
623
624
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
625
                           val x = fresh variable
mb0's avatar
mb0 committed
626
                        in
mb0's avatar
mb0 committed
627
                           Exp.LETUPD (x, y, fvs, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
628
629
630
                        end
                   | (f, e)::fs =>
                        trans0 e (fn z =>
mb0's avatar
mb0 committed
631
                           trans y fs ((f, z)::fvs))
mb0's avatar
mb0 committed
632
            in
mb0's avatar
mb0 committed
633
634
               Exp.LETVAL
                  (f,
mb0's avatar
mb0 committed
635
636
                   Exp.FN (k, [x], trans x fs []),
                   Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
637
638
639
            end
       | SELECT fld =>
            let
mb0's avatar
mb0 committed
640
641
642
643
               val f = fresh function
               val k = fresh continuation
               val x = fresh variable
               val z = fresh variable
mb0's avatar
mb0 committed
644
            in
mb0's avatar
mb0 committed
645
646
               Exp.LETVAL
                  (f,
mb0's avatar
mb0 committed
647
648
                   Exp.FN (k, [x], Exp.LETPRJ (z, fld, x, Exp.CC (k, [z]))),
                   Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
649
650
            end
       | CON c =>
mb0's avatar
mb0 committed
651
652
653
654
655
656
657
            if isEnumLike c
               then
                  let
                     val x = fresh variable
                     val y = fresh variable
                  in
                     Exp.LETVAL (y, Exp.UNT,
mb0's avatar
mb0 committed
658
                     Exp.LETVAL (x, Exp.INJ (c, y), Exp.CC (kont, [x])))
mb0's avatar
mb0 committed
659
660
661
662
663
664
665
666
667
668
669
670
                  end
            else
               let
                  val f = fresh constructor
                  val k = fresh continuation
                  val x = fresh variable
                  val y = fresh variable
               in
                  Exp.LETVAL
                     (f,
                      Exp.FN
                        (k,
mb0's avatar
mb0 committed
671
                         [x],
mb0's avatar
mb0 committed
672
                         Exp.LETVAL
mb0's avatar
mb0 committed
673
674
                           (y, Exp.INJ (c, x), Exp.CC (k, [y]))),
                      Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
675
               end
mb0's avatar
mb0 committed
676
677
       | LIT l =>
            let
mb0's avatar
mb0 committed
678
               val x = fresh variable
mb0's avatar
mb0 committed
679
            in
mb0's avatar
mb0 committed
680
               Exp.LETVAL (x, transLit l, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
681
            end
mb0's avatar
mb0 committed
682
       | ID x => Exp.CC (kont, [x])
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
       | _ => raise CM.CompilationError

   and transLit l =
      case l of
         Core.Lit.INTlit i => Exp.INT i
       | Core.Lit.FLTlit f => Exp.FLT f
       | Core.Lit.VEClit v => Exp.VEC v 
       | Core.Lit.STRlit s => Exp.STR s

   end (* end local *)

   fun dumpPre (os, spec) = Pretty.prettyTo (os, Core.PP.spec spec)
   fun dumpPost (os, spec) = Pretty.prettyTo (os, CPS.PP.spec spec)

   val translate =
      BasicControl.mkKeepPass
mb0's avatar
mb0 committed
699
         {passName="cpsConversion",
700
701
          registry=CPSControl.registry,
          pass=translate,
mb0's avatar
mb0 committed
702
          preExt="core",
703
          preOutput=dumpPre,
mb0's avatar
mb0 committed
704
          postExt="cps",
705
706
707
708
          postOutput=dumpPost}

   fun run spec = CM.return (translate spec)
end