from-core.sml 22.4 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
52
53
         val concatstring = get "+++"
         val showbitvec = get "showbitvec"
         val showint = get "showint"
mb0's avatar
mb0 committed
54
         val sub = get "-"
mb0's avatar
Foo.    
mb0 committed
55
56
57
         val sx = get "sx"
         val zx = get "zx"

mb0's avatar
mb0 committed
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
         val concatstring = 
            let
               val a = fresh "a"
               val b = fresh "b"
               val prim = get "%concatstring"
               val body = PRI (prim, [a, b])
            in
               (concatstring, [a,b], body)
            end

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

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

mb0's avatar
Foo.    
mb0 committed
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
         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
115

mb0's avatar
mb0 committed
116
117
118
119
120
121
122
123
124
125
126
127
         (* 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

128
         (* val and a b = %and(a,b) *)
mb0's avatar
mb0 committed
129
130
131
132
133
         val andd =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primAnd = get "%and"
134
135
               val body = PRI (primAnd, [a, b])
                     
mb0's avatar
mb0 committed
136
            in
137
               (andd, [a, b], body)
mb0's avatar
mb0 committed
138
139
            end

140
         (* val == a b = %equal(a,b) *)
mb0's avatar
mb0 committed
141
142
143
144
145
         val == =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primEqual = get "%equal"
146
               val body = PRI (primEqual, [a, b])
mb0's avatar
mb0 committed
147
            in
148
               (==, [a, b], body)
mb0's avatar
mb0 committed
149
150
            end

151
         (* val not a = %not(a) *)
mb0's avatar
mb0 committed
152
153
154
155
156
         val not =
            let
               val a = fresh "a"
               val x = fresh "x"
               val primNot = get "%not"
157
               val body = PRI (primNot, [a])
mb0's avatar
mb0 committed
158
            in
159
               (not, [a], body)
mb0's avatar
mb0 committed
160
161
            end

mb0's avatar
mb0 committed
162
         (* val ^ k a b = %concat(a,b) *)
mb0's avatar
mb0 committed
163
164
165
166
167
         val concat =
            let
               val a = fresh "a"
               val b = fresh "b"
               val primConcat = get "%concat"
168
               val body = PRI (primConcat, [a, b])
mb0's avatar
mb0 committed
169
            in
170
               (concat, [a, b], body)
mb0's avatar
mb0 committed
171
172
            end

173
         (* val raise a = return(%raise(a)) *)
mb0's avatar
mb0 committed
174
175
176
177
         val raisee =
            let
               val a = fresh "a"
               val primRaise = get "%raise"
mb0's avatar
mb0 committed
178
               val body = APP (ID return, [PRI (primRaise, [a])])
mb0's avatar
mb0 committed
179
            in
180
               (raisee, [a], body)
mb0's avatar
mb0 committed
181
182
            end

mb0's avatar
mb0 committed
183
         (* val slice tok offs sz = return (%slice(tok,offs,sz) *)
mb0's avatar
mb0 committed
184
185
186
187
188
189
         val slice =
            let
               val tok = fresh "tok"
               val offs = fresh "offs"
               val sz = fresh "sz"
               val primSlice = get "%slice"
mb0's avatar
mb0 committed
190
               val body = APP (ID return, [PRI (primSlice, [tok, offs, sz])])
mb0's avatar
mb0 committed
191
            in
mb0's avatar
mb0 committed
192
               (slice, [tok, offs, sz], body) 
mb0's avatar
mb0 committed
193
194
            end

mb0's avatar
Up.    
mb0 committed
195
196
         (* val consume8 s = %consume8(s) *)
         val consume8 =
mb0's avatar
mb0 committed
197
198
            let
               val s = fresh "s"
mb0's avatar
Up.    
mb0 committed
199
200
               val primconsume8 = get "%consume8"
               val body = PRI (primconsume8, [s])
mb0's avatar
mb0 committed
201
            in
mb0's avatar
Up.    
mb0 committed
202
               (consume8, [s], body)
mb0's avatar
mb0 committed
203
204
            end

mb0's avatar
Up.    
mb0 committed
205
206
         (* val unconsume8 s = %unconsume8(s) *)
         val unconsume8 =
mb0's avatar
mb0 committed
207
208
            let
               val s = fresh "s"
mb0's avatar
Up.    
mb0 committed
209
210
               val primUnconsume8 = get "%unconsume8"
               val body = PRI (primUnconsume8, [s])
mb0's avatar
mb0 committed
211
            in
mb0's avatar
Up.    
mb0 committed
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
               (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
253
254
            end
      in
mb0's avatar
mb0 committed
255
         [slice,
mb0's avatar
Up.    
mb0 committed
256
257
258
259
260
261
          consume8,
          unconsume8,
          consume16,
          unconsume16,
          consume32,
          unconsume32,
mb0's avatar
mb0 committed
262
263
264
          concatstring,
          showbitvec,
          showint,
mb0's avatar
mb0 committed
265
266
267
268
269
270
271
272
273
          andd,
          not,
          ==,
          concat,
          raisee,
          add,
          sx,
          zx,
          sub]
mb0's avatar
mb0 committed
274
275
276
277
      end

   end

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

mb0's avatar
mb0 committed
280
281
282
   fun isEnumLike c =
      case SymMap.lookup (!constructors, c) of
         (_, NONE) => true | _ => false
283

mb0's avatar
mb0 committed
284
   fun fresh variable = let
285
      val (tab, sym) =
mb0's avatar
mb0 committed
286
         VarInfo.fresh (!SymbolTables.varTable, variable)
287
288
289
290
291
292
293
294
   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
295
296
297
298
299
300
301
302
303
304
305
306
307
308
   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

309
310
311
312
   fun translate spec =
      Spec.upd
         (fn cs =>
            let
mb0's avatar
mb0 committed
313
314
315
               val main = fresh function
               val kont = fresh continuation
               val () = constructors := Spec.get#constructors spec
mb0's avatar
mb0 committed
316
317
318
319
320
321
322
323
324
               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
325
326
327
328
329
330
               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
331
332
               val cps =
                  trans0 
333
                     (LETREC (Builtin.mk()@cs, RECORD (exports spec)))
mb0's avatar
mb0 committed
334
                     (fn z => Exp.APP (main, kont, [z]))
335
            in
336
               cps
337
338
339
340
341
342
            end) spec

   and trans0 e kappa = 
      case e of
         LETVAL (v, e, body) =>
            let
mb0's avatar
mb0 committed
343
               val j = fresh continuation
344
345
               val body = trans0 body kappa
            in
346
               Exp.LETCONT ([(j, [v], body)], trans1 e j)
347
            end
mb0's avatar
mb0 committed
348
349
350
351
352
353
354
355
356
357
       | 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
358
               val ty = guessPatTy e ps
mb0's avatar
mb0 committed
359
               val j = fresh continuation
mb0's avatar
mb0 committed
360
361
362
363
               fun trans z ps cps ks =
                  case ps of
                     [] =>
                        let
mb0's avatar
mb0 committed
364
                           val x = fresh variable
mb0's avatar
mb0 committed
365
                        in
mb0's avatar
mb0 committed
366
367
368
369
370
371
372
373
374
                           case ks of
                              [([],body)] =>
                                 Exp.LETCONT
                                    ((j, [x], kappa x)::cps,
                                     Exp.CC body)

                            | _ =>
                                 Exp.LETCONT
                                    ((j, [x], kappa x)::cps,
mb0's avatar
mb0 committed
375
                                     Exp.CASE (ty, z, ks))
mb0's avatar
mb0 committed
376
377
378
                        end
                   | (p, e)::ps =>
                        let
mb0's avatar
mb0 committed
379
                           val k = fresh continuation
mb0's avatar
mb0 committed
380
381
382
383
384
                           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
385
                        in
mb0's avatar
mb0 committed
386
                           trans z ps ((k, [], bindTrans x)::cps) ks
mb0's avatar
mb0 committed
387
388
                        end
            in
389
               trans0 e (fn z => trans z ps [] [])
mb0's avatar
mb0 committed
390
            end
mb0's avatar
mb0 committed
391
       | APP (e1, es) =>
392
            let
mb0's avatar
mb0 committed
393
394
               val k = fresh continuation
               val x = fresh variable
mb0's avatar
mb0 committed
395
396
397
398
               fun trans es xs k =
                  case es of
                     e::es => trans0 e (fn x => trans es (x::xs) k)
                   | [] => k (rev xs)
399
            in
mb0's avatar
mb0 committed
400
401
402
               trans0 e1 (fn x1 =>
                  trans es [] (fn xs =>
                     Exp.LETCONT ([(k, [x], kappa x)], Exp.APP (x1, k, xs))))
403
            end
404
405
406
407
408
409
       | PRI (f, xs) =>
            let
               val x = fresh variable
            in
               Exp.LETVAL (x, Exp.PRI (f, xs), kappa x)
            end
410
411
       | FN (x, e) =>
            let
mb0's avatar
mb0 committed
412
413
               val f = fresh function
               val k = fresh continuation
414
            in
415
               Exp.LETVAL (f, Exp.FN (k, [x], trans1 e k), kappa f) 
416
417
418
419
420
421
422
            end
       | RECORD fs =>
            let
               fun trans fs fvs =
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
423
                           val x = fresh variable
424
425
426
427
428
429
430
431
432
                        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
433
434
       | UPDATE fs => 
            let
mb0's avatar
mb0 committed
435
436
437
               val f = fresh function
               val k = fresh continuation
               val z = fresh variable
mb0's avatar
mb0 committed
438
439
               val x = fresh variable
               fun trans fs fvs =
mb0's avatar
mb0 committed
440
441
                  case fs of
                     [] =>
mb0's avatar
mb0 committed
442
443
444
445
446
447
                        Exp.LETVAL
                           (f,
                            Exp.FN (k, [x],
                              Exp.LETUPD (z, x, fvs,
                                 Exp.CC (k, [z]))),
                            kappa f)
mb0's avatar
mb0 committed
448
449
                   | (f, e)::fs =>
                        trans0 e (fn z =>
mb0's avatar
mb0 committed
450
                           trans fs ((f, z)::fvs))
mb0's avatar
mb0 committed
451
            in
mb0's avatar
mb0 committed
452
               trans fs []
mb0's avatar
mb0 committed
453
            end
454
455
       | SELECT fld =>
            let
mb0's avatar
mb0 committed
456
457
458
459
               val f = fresh function
               val k = fresh continuation
               val x = fresh variable
               val z = fresh variable
460
            in
mb0's avatar
mb0 committed
461
462
463
464
               Exp.LETVAL
                  (f,
                   Exp.FN
                     (k,
mb0's avatar
mb0 committed
465
466
                      [x],
                      Exp.LETPRJ (z, fld, x, Exp.CC (k, [z]))),
467
468
469
                   kappa f)
            end
       | CON c =>
mb0's avatar
mb0 committed
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
            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
485
486
                  val j = fresh continuation
                  val z = fresh variable
mb0's avatar
mb0 committed
487
               in
mb0's avatar
mb0 committed
488
489
490
491
                  Exp.LETVAL
                     (f,
                      Exp.FN
                        (k,
mb0's avatar
mb0 committed
492
493
494
                         [x],
                         Exp.LETVAL (y, Exp.INJ (c, x), Exp.CC (k, [y]))),
                      kappa f) 
mb0's avatar
mb0 committed
495
               end
496
497
       | LIT l =>
            let
mb0's avatar
mb0 committed
498
               val x = fresh variable
499
500
501
502
503
            in
               Exp.LETVAL (x, transLit l, kappa x)
            end
       | ID v => kappa v
       | _ => raise CM.CompilationError
mb0's avatar
mb0 committed
504
  
mb0's avatar
mb0 committed
505
506
   and explodePat str =
      let
mb0's avatar
mb0 committed
507
508
509
510
         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
511
512
513
514
515
516
517
518
519
520
         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
521
522
523
         if CharVector.all (fn c => c = #".") str then [] else
         case str of
            "" => []
mb0's avatar
mb0 committed
524
525
526
527
528
529
          | _ =>
               case String.tokens (fn c => c = #"|") str of
                  strs =>
                     List.concat
                        (map (fn str =>
                           lp (S.full str, [])) strs)
mb0's avatar
mb0 committed
530
531
      end

mb0's avatar
mb0 committed
532
533
534
535
536
537
538
539
540
541
542
   and guessPatTy e ps =
      let
         open Core.Pat
      in
         case #1 (hd ps) of
            CON _ => Exp.CASETYCON
          | BIT _ => Exp.CASETYVEC
          | INT _ => Exp.CASETYINT
          | _ => Exp.CASETYINT (* FIXME *)
      end

mb0's avatar
mb0 committed
543
   and transPat p k ks =
544
      let (* TODO: apply arguments to the branches *)
mb0's avatar
mb0 committed
545
          (* TODO: check size of generated patterns and bail out if to large *)
mb0's avatar
mb0 committed
546
         open Core.Pat
mb0's avatar
mb0 committed
547

mb0's avatar
mb0 committed
548
549
         fun toIdx p =
            case p of
mb0's avatar
mb0 committed
550
               BIT str => explodePat str
551
             | INT i => [Word.fromLargeInt (IntInf.toLarge i)]
mb0's avatar
mb0 committed
552
553
554
555
556
557
558
559
560
             | 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
561
      in
mb0's avatar
mb0 committed
562
         (bndVars p, (toIdx p, (k, []))::ks)
mb0's avatar
mb0 committed
563
564
565
566
      end

   and trans0rec (n, args, e) =
      let
mb0's avatar
mb0 committed
567
         val k = fresh continuation
mb0's avatar
mb0 committed
568
      in
569
         case args of
mb0's avatar
mb0 committed
570
571
572
573
            [] =>
               let
                  val x = fresh variable
               in
mb0's avatar
mb0 committed
574
                  (* TODO: value vs (rec) fun *)
mb0's avatar
mb0 committed
575
                  (n, k, [x], trans1 (APP (e, [ID x])) k)
mb0's avatar
mb0 committed
576
               end
mb0's avatar
mb0 committed
577
          | args => (n, k, args, trans1 e k)
mb0's avatar
mb0 committed
578
579
      end

580
581
   and trans1 e kont =
      case e of
mb0's avatar
mb0 committed
582
583
         LETVAL (v, e, body) =>
            let
mb0's avatar
mb0 committed
584
               val j = fresh continuation
mb0's avatar
mb0 committed
585
586
               val body = trans1 body kont
            in
587
               Exp.LETCONT ([(j, [v], body)], trans1 e j)
mb0's avatar
mb0 committed
588
589
590
591
592
593
594
595
596
597
598
            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
mb0's avatar
mb0 committed
599
               val ty = guessPatTy e ps
mb0's avatar
mb0 committed
600
601
602
603
               fun trans z ps cps ks =
                  case ps of
                     (p, e)::ps =>
                        let
mb0's avatar
mb0 committed
604
                           val k = fresh continuation
mb0's avatar
mb0 committed
605
606
607
608
609
                           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
610
                        in
mb0's avatar
mb0 committed
611
                           trans z ps ((k, [], bindTrans x)::cps) ks
mb0's avatar
mb0 committed
612
                        end
mb0's avatar
mb0 committed
613
614
615
616
617
                   | [] =>
                        case ks of
                           [([],body)] =>
                              Exp.LETCONT (cps, Exp.CC body)
                         | _ =>
mb0's avatar
mb0 committed
618
                              Exp.LETCONT (cps, Exp.CASE (ty, z, ks))
mb0's avatar
mb0 committed
619
            in
620
               trans0 e (fn z => trans z ps [] [])
mb0's avatar
mb0 committed
621
            end
mb0's avatar
mb0 committed
622
623
624
625
626
627
628
629
630
631
632
       | 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
633
634
635
636
637
638
       | 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
639
640
       | FN (x, e) =>
            let
mb0's avatar
mb0 committed
641
642
               val f = fresh function
               val j = fresh continuation
mb0's avatar
mb0 committed
643
            in
644
               Exp.LETVAL (f, Exp.FN (j, [x], trans1 e j), Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
645
646
647
648
649
650
651
            end
       | RECORD fs =>
            let
               fun trans fs fvs =
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
652
                           val x = fresh variable
mb0's avatar
mb0 committed
653
                        in
mb0's avatar
mb0 committed
654
                           Exp.LETVAL (x, Exp.REC fvs, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
655
656
657
658
659
660
661
662
663
                        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
664
665
666
667
668
               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
669
670
671
                  case fs of
                     [] =>
                        let
mb0's avatar
mb0 committed
672
                           val x = fresh variable
mb0's avatar
mb0 committed
673
                        in
mb0's avatar
mb0 committed
674
                           Exp.LETUPD (x, y, fvs, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
675
676
677
                        end
                   | (f, e)::fs =>
                        trans0 e (fn z =>
mb0's avatar
mb0 committed
678
                           trans y fs ((f, z)::fvs))
mb0's avatar
mb0 committed
679
            in
mb0's avatar
mb0 committed
680
681
               Exp.LETVAL
                  (f,
mb0's avatar
mb0 committed
682
683
                   Exp.FN (k, [x], trans x fs []),
                   Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
684
685
686
            end
       | SELECT fld =>
            let
mb0's avatar
mb0 committed
687
688
689
690
               val f = fresh function
               val k = fresh continuation
               val x = fresh variable
               val z = fresh variable
mb0's avatar
mb0 committed
691
            in
mb0's avatar
mb0 committed
692
693
               Exp.LETVAL
                  (f,
mb0's avatar
mb0 committed
694
695
                   Exp.FN (k, [x], Exp.LETPRJ (z, fld, x, Exp.CC (k, [z]))),
                   Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
696
697
            end
       | CON c =>
mb0's avatar
mb0 committed
698
699
700
701
702
703
704
            if isEnumLike c
               then
                  let
                     val x = fresh variable
                     val y = fresh variable
                  in
                     Exp.LETVAL (y, Exp.UNT,
mb0's avatar
mb0 committed
705
                     Exp.LETVAL (x, Exp.INJ (c, y), Exp.CC (kont, [x])))
mb0's avatar
mb0 committed
706
707
708
709
710
711
712
713
714
715
716
717
                  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
718
                         [x],
mb0's avatar
mb0 committed
719
                         Exp.LETVAL
mb0's avatar
mb0 committed
720
721
                           (y, Exp.INJ (c, x), Exp.CC (k, [y]))),
                      Exp.CC (kont, [f]))
mb0's avatar
mb0 committed
722
               end
mb0's avatar
mb0 committed
723
724
       | LIT l =>
            let
mb0's avatar
mb0 committed
725
               val x = fresh variable
mb0's avatar
mb0 committed
726
            in
mb0's avatar
mb0 committed
727
               Exp.LETVAL (x, transLit l, Exp.CC (kont, [x]))
mb0's avatar
mb0 committed
728
            end
mb0's avatar
mb0 committed
729
       | ID x => Exp.CC (kont, [x])
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
       | _ => 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
746
         {passName="cpsConversion",
747
748
          registry=CPSControl.registry,
          pass=translate,
mb0's avatar
mb0 committed
749
          preExt="core",
750
          preOutput=dumpPre,
mb0's avatar
mb0 committed
751
          postExt="cps",
752
753
754
755
          postOutput=dumpPost}

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