cps-opt.sml 56.6 KB
Newer Older
mb0's avatar
mb0 committed
1

mb0's avatar
mb0 committed
2
3
4
structure Aux = struct
   val function = Atom.atom "f"
   val continuation = Atom.atom "k"
mb0's avatar
mb0 committed
5
   val variable = Atom.atom "x"
mb0's avatar
mb0 committed
6

7
8
   val variables = SymbolTables.varTable

mb0's avatar
mb0 committed
9
10
   fun fresh variable = let
      val (tab, sym) =
11
         VarInfo.fresh (!variables, variable)
mb0's avatar
mb0 committed
12
13
14
   in
      sym before SymbolTables.varTable := tab
   end
15
16

   fun atomOf x = VarInfo.getAtom (!variables, x)
17
   fun get s = VarInfo.lookup (!variables, Atom.atom s)
mb0's avatar
Foo.    
mb0 committed
18
   fun find s = VarInfo.find (!variables, Atom.atom s)
mb0's avatar
mb0 committed
19
   fun toString sym = Layout.tostring (CPS.PP.var sym)
mb0's avatar
mb0 committed
20
21
22
   fun failWithSymbol msg sym =
      msg ^ ": " ^ Layout.tostring (CPS.PP.var sym)
      
mb0's avatar
mb0 committed
23
24
end

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
structure CheckDefUse = struct
   structure Set = SymSet
   open CPS.Exp
   infix ++
   type t = Set.set

   val census = ref Set.empty : t ref

   fun def x =
      if Set.member (!census, x)
         then raise Fail
               (Aux.failWithSymbol "checkDefUse.duplicateDefiniton" x)
      else census := Set.add (!census, x)

   fun use x = ()

   fun visitTerm n cps =
      case cps of
         LETVAL (x, v, t) => (def x; visitCVal n v; visitTerm n t)
       | LETREC (ds, t) => (app (visitDecl n) ds; visitTerm n t)
       | LETPRJ (x, _, y, t) => (def x; use y; visitTerm n t)
mb0's avatar
mb0 committed
46
       | LETDECON (x, y, t) => (def x; use y; visitTerm n t)
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
       | LETUPD (x, y, fs, t) =>
            (def x
            ;use y
            ;app (visitField n) fs
            ;visitTerm n t)
       | LETCONT (ds, t) => (app (visitCont n) ds; visitTerm n t)
       | APP (x, k, ys) =>
            (use x
            ;use k
            ;app use ys)
       | CC (k, xs) => (use k; app use xs)
       | CASE (x, ks) => (use x; app (visitMatch n) ks)

   and visitMatch n (_, (k, xs)) = (use k; app use xs)

   and visitField n (_, v) = use v

   and visitDecl n (f, k, xs, t) =
      (def f
      ;def k
      ;app def xs
      ;visitTerm n t)

   and visitCont n (k, xs, t) =
      (def k
      ;app def xs
      ;visitTerm n t)

   and visitCVal n cval = 
      case cval of
         FN (k, xs, t) => (def k; app def xs; visitTerm n t)
       | PRI (f, xs) => (use f; app use xs)
       | INJ (_, x) => use x
       | REC fs => app (visitField n) fs
       | _ => () 
         
   fun run t =
      let
         val _ = census := Set.empty
      in
         visitTerm 1 t
        ;census := Set.empty
      end
mb0's avatar
mb0 committed
90
91
92
   val run = fn t =>
      run t
         handle (Fail s) => print ("Fail [" ^ s ^ "]\n")
93
94
end

mb0's avatar
mb0 committed
95
96
structure Census = struct
   open CPS.Exp
mb0's avatar
mb0 committed
97
98
   infix ++
   type t = {esc:int,app:int} SymMap.map 
mb0's avatar
mb0 committed
99

100
101
   val census = ref SymMap.empty : t ref

mb0's avatar
mb0 committed
102
   fun count s x =
103
      case SymMap.find (!census, x) of
mb0's avatar
mb0 committed
104
105
         NONE => s {esc= ~1,app= ~1}
       | SOME i => s i
mb0's avatar
mb0 committed
106

mb0's avatar
mb0 committed
107
   fun count0 s x =
mb0's avatar
mb0 committed
108
      case SymMap.find (!census, x) of
mb0's avatar
mb0 committed
109
110
111
112
113
114
115
116
117
         NONE => s {esc=0,app=0}
       | SOME i => s i

   fun countAll x =
      let
         val {esc,app} = count (fn i=>i) x
      in
         esc+app
      end
mb0's avatar
mb0 committed
118

119
120
121
122
   fun copy {src, dst} = 
      case SymMap.find (!census, src) of
         SOME i => census := SymMap.insert (!census, dst, i)
       | _ => ()
mb0's avatar
mb0 committed
123

124
   fun def x =
125
      case SymMap.find (!census, x) of
mb0's avatar
mb0 committed
126
         NONE => census := SymMap.insert (!census, x, {esc=0,app=0})
127
       | _ => ()
mb0's avatar
mb0 committed
128

mb0's avatar
mb0 committed
129
   fun update f x =
mb0's avatar
mb0 committed
130
      case SymMap.find (!census, x) of
mb0's avatar
mb0 committed
131
132
133
134
135
         NONE => census := SymMap.insert (!census, x, f {esc=0,app=0})
       | SOME m => census := SymMap.insert (!census, x, f m)

   fun E n {esc,app} = {esc=esc+n,app=app}
   fun A n {esc,app} = {esc=esc,app=app+n}
136
   fun {esc=n,app=m} ++ {esc=_,app=q} = {esc=n,app=m+q-1}
mb0's avatar
mb0 committed
137
138
139
140
141
142

   fun remove x =
      if SymMap.inDomain (!census, x)
         then #1 (SymMap.remove (!census, x))
      else !census

143
   fun extendApp x y =
mb0's avatar
mb0 committed
144
145
146
147
148
      case SymMap.find (!census, y) of
         NONE => census := remove x
       | SOME n =>
            census :=
               (case SymMap.find (!census, x) of
mb0's avatar
mb0 committed
149
150
151
                  NONE => !census
                | SOME m => SymMap.insert (!census, x, m++n))

152
   fun extendAppAll sigma xs ys =
mb0's avatar
mb0 committed
153
      app (fn (x, y) => extendApp x y)
mb0's avatar
mb0 committed
154
          (ListPair.zip (xs, ys))
mb0's avatar
mb0 committed
155

156
157
158
   val remove = fn x => census := remove x
   fun removeAll xs = app remove xs

159
160
   fun visitTerm n cps =
      case cps of
161
         LETVAL (x, v, t) => (def x; visitCVal n v; visitTerm n t)
162
       | LETREC (ds, t) => (app (visitDecl n) ds; visitTerm n t)
mb0's avatar
mb0 committed
163
164
       | LETPRJ (x, _, y, t) => (def x; (* TODO: does `y` really escape here? *) update (E n) y; visitTerm n t)
       | LETDECON (x, y, t) => (def x; (* TODO: does `y` really escape here? *)update (E n) y; visitTerm n t)
165
       | LETUPD (x, y, fs, t) =>
166
            (def x
mb0's avatar
mb0 committed
167
            ;update (E n) y
168
169
            ;app (visitField n) fs
            ;visitTerm n t)
mb0's avatar
mb0 committed
170
       | LETCONT (ds, t) => (app (visitCont n) ds; visitTerm n t)
171
       | APP (x, k, ys) =>
mb0's avatar
mb0 committed
172
173
174
175
176
            (update (A n) x
            ;update (E n) k
            ;app (update (E n)) ys)
       | CC (k, xs) => (update (A n) k; app (update (E n)) xs)
       | CASE (x, ks) => (update (E n) x; app (visitMatch n) ks)
177

mb0's avatar
mb0 committed
178
   and visitMatch n (_, (k, xs)) = (update (A n) k; app (update (E n)) xs)
179

mb0's avatar
mb0 committed
180
   and visitField n (_, v) = update (E n) v
181
182

   and visitDecl n (f, k, xs, t) =
183
184
185
      (def f
      ;def k
      ;app def xs
186
187
      ;visitTerm n t)

mb0's avatar
mb0 committed
188
   and visitCont n (k, xs, t) =
189
190
      (def k
      ;app def xs
191
192
193
194
      ;visitTerm n t)

   and visitCVal n cval = 
      case cval of
195
         FN (k, xs, t) => (def k; app def xs; visitTerm n t)
mb0's avatar
mb0 committed
196
197
       | PRI (f, xs) => (update (A n) f; app (update (E n)) xs)
       | INJ (_, x) => update (E n) x
198
199
200
       | REC fs => app (visitField n) fs
       | _ => () 
         
mb0's avatar
mb0 committed
201
202
   fun layout () =
      Pretty.symmap
mb0's avatar
mb0 committed
203
204
205
         {key=CPS.PP.var,
          item=fn {esc,app} =>
            Layout.record [("esc",Pretty.I esc),("app",Pretty.I app)]}
mb0's avatar
mb0 committed
206
207
         (!census)

208
209
210
211
212
213
   fun run t =
      let
         val _ = census := SymMap.empty
      in
         visitTerm 1 t
      end
mb0's avatar
mb0 committed
214
215
end

mb0's avatar
mb0 committed
216
(* Currently `FreeVars` is br0k3n considering mutually recursive functions *)
mb0's avatar
mb0 committed
217
218
structure FreeVars = struct
   structure Map = SymMap
mb0's avatar
mb0 committed
219
   structure Set = SymListSet
mb0's avatar
mb0 committed
220
   type t = Set.set Map.map
mb0's avatar
mb0 committed
221

mb0's avatar
mb0 committed
222
   val freevars = ref Map.empty : t ref
mb0's avatar
mb0 committed
223
   fun reset () = freevars := Map.empty
mb0's avatar
mb0 committed
224
225
226
227
228
229
230
231
232
   fun set f xs =
      if Set.isEmpty xs
         then ()
      else freevars := Map.insert (!freevars, f, xs)
   fun get f =
      case Map.find (!freevars, f) of
         NONE => Set.empty
       | SOME xs => xs

233
234
235
236
237
238
239
   fun merge a b = Set.union (a, b)
   fun def env x = Set.delete (env, x) handle NotFound => env
   fun use env x = merge (Set.add (env, x)) (get x)
   fun useAll env xs = foldl (fn (x, env) => use env x) env xs
   fun defAll env xs = foldl (fn (x, env) => def env x) env xs
   fun defAllWith f env xs = foldl (fn (x, env) => def env (f x)) env xs

mb0's avatar
mb0 committed
240
241
242
243
244
245
   fun run cps = let
      open CPS.Exp
      fun visitTerm (env, cps) = 
         case cps of
            LETVAL (x, v as (FN _), body) =>
               let
mb0's avatar
mb0 committed
246
247
                  val env' = visitCVal (env, v)
                  val _ = set x env'
mb0's avatar
mb0 committed
248
249
250
                  val env = visitTerm (env, body)
                  val env = def env x
               in
mb0's avatar
mb0 committed
251
                  env
mb0's avatar
mb0 committed
252
253
254
255
256
257
258
259
260
261
262
263
               end
          | LETVAL (x, v, body) =>
               let
                  val env = visitTerm (env, body)
                  val env = visitCVal (env, v)
                  val env = def env x
               in
                  env
               end
          | LETREC (ds, body) =>
               let
                  (* PERF *)
264
                  fun merge' () =
mb0's avatar
mb0 committed
265
266
267
268
                     app
                        (fn (f, k, xs, body) =>
                           let
                              val env = visitTerm (env, body)
mb0's avatar
mb0 committed
269
                              (* val env = def env f *)
mb0's avatar
mb0 committed
270
271
272
273
274
275
                              val env = def env k
                              val env = defAll env xs
                              val env = defAllWith #1 env ds 
                           in
                              set f env
                           end) ds
276
277
                  val _ = merge'()
                  val _ = merge'()
mb0's avatar
mb0 committed
278
279
280
281
282
283
284
285
286
287
288
289
                  val env = visitTerm (env, body)
                  val env =
                     foldl
                        (fn ((f, _, _, _), env) =>
                           merge (get f) env) env ds
                  val env = defAllWith #1 env ds
               in
                  env
               end
          | LETCONT (ds, body) =>
               let
                  (* PERF *)
290
                  fun merge' () =
mb0's avatar
mb0 committed
291
292
293
294
                     app
                        (fn (k, xs, body) =>
                           let
                              val env = visitTerm (env, body)
mb0's avatar
mb0 committed
295
                              (* val env = def env k *)
mb0's avatar
mb0 committed
296
                              val env = defAll env xs
mb0's avatar
mb0 committed
297
                              val env = defAllWith #1 env ds 
mb0's avatar
mb0 committed
298
299
300
                           in
                              set k env
                           end) ds
301
302
                  val _ = merge'()
                  val _ = merge'()
mb0's avatar
mb0 committed
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
                  val env = visitTerm (env, body)
                  val env =
                     foldl
                        (fn ((k, _, _), env) =>
                           merge (get k) env) env ds
                  val env = defAllWith #1 env ds
               in
                  env
               end
          | LETPRJ (y, _, x, body) =>
               let
                  val env = visitTerm (env, body)
                  val env = use env x
                  val env = def env y
               in
                  env
               end
mb0's avatar
mb0 committed
320
321
322
323
324
325
326
327
          | LETDECON (y, x, body) =>
               let
                  val env = visitTerm (env, body)
                  val env = use env x
                  val env = def env y
               in
                  env
               end
mb0's avatar
mb0 committed
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
          | LETUPD (y, x, fs, body) =>
               let
                  val env = visitTerm (env, body)
                  val env = use env x
                  val env = useAll env (map #2 fs)
                  val env = def env y
               in
                  env
               end
          | APP (f, k, xs) =>
               let
                  val env = use env f
                  val env = use env k
                  val env = useAll env xs
               in
                  env
               end
          | CC (k, xs) =>
               let
                  val env = use env k
                  val env = useAll env xs
               in
                  env
               end
          | CASE (x, ks) =>
               let
                  val env = use env x
355
356
357
358
359
360
361
362
363
                  val env =
                     foldl
                        (fn ((_,(k,xs)), env) =>
                           let
                              val env = use env k
                              val env = useAll env xs
                           in
                              env
                           end) env ks
mb0's avatar
mb0 committed
364
365
366
               in
                  env
               end
mb0's avatar
mb0 committed
367

mb0's avatar
mb0 committed
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
      and visitCVal (env, cval) =
         case cval of
            FN (k, xs, body) =>
               let
                  val env = visitTerm (env, body)
                  val env = def env k
                  val env = defAll env xs
               in
                  env
               end
          | PRI (_, xs) => useAll env xs
          | INJ (_, x) => use env x
          | REC fs => useAll env (map #2 fs)
          | _ => env
   in
mb0's avatar
mb0 committed
383
      (reset();visitTerm (Set.empty, cps))
mb0's avatar
mb0 committed
384
   end
385
386
387
388
  
   fun layout () =
      Pretty.symmap
         {key=CPS.PP.var,
mb0's avatar
mb0 committed
389
          item=Pretty.symlistset CPS.PP.var} (!freevars)
390
391
      
   fun dump () = Pretty.prettyTo(TextIO.stdOut, layout())
mb0's avatar
mb0 committed
392
393
394
395
396
397
398
399
400
401
end

structure Subst = struct
   type t = Core.sym SymMap.map

   val empty = SymMap.empty
   fun apply sigma x =
      case SymMap.find (sigma, x) of
         NONE => x
       | SOME y => y
402
   fun applyAll sigma xs = map (apply sigma) xs
mb0's avatar
mb0 committed
403
404
   fun extend sigma x y =
      SymMap.insert (sigma, y, x)
405
   fun extendAll sigma xs ys =
mb0's avatar
mb0 committed
406
407
408
409
      foldl
         (fn ((y, x), sigma) =>
            extend sigma y x)
         sigma (ListPair.zip (xs, ys))
410
411
412
413
414
415
416
417
418

   fun copy x =
      let
         val name = Aux.atomOf x
         val x' = Aux.fresh name
      in
         x'
      end

419
420
421
422
423
424
425
426
427
   fun copyWithSuffix s x =
      let
         val name = Aux.atomOf x
         val name = Atom.toString name
         val x' = Aux.fresh (Atom.atom (name ^ "#" ^ s))
      in
         x'
      end

428
429
   fun copyAll xs = map copy xs

mb0's avatar
mb0 committed
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
   fun renameAll sigma xs =
      let
         val ys = copyAll xs
         val sigma = extendAll sigma ys xs
      in
         (sigma, ys)
      end

   fun renameOne sigma x =
      let
         val y = copy x
         val sigma = extend sigma y x
      in
         (sigma, y)
      end

446
   local open CPS.Exp in
mb0's avatar
mb0 committed
447
448
449
  
   fun renameTerm cps = rename empty cps
   and rename sigma cps =
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
      case cps of
         LETVAL (x, v, t) =>
            let
               val x' = copy x
               val sigma = extend sigma x' x
            in
               LETVAL (x', renameCVal sigma v, rename sigma t)
            end
       | LETREC (ds, t) =>
            let
               val (sigma, ds) = renameRecs sigma ds
            in
               LETREC (ds, rename sigma t) 
            end 
       | LETPRJ (x, f, y, t) =>
            let
               val x' = copy x
               val y' = apply sigma y
               val sigma = extend sigma x' x
            in
               LETPRJ (x', f, y', rename sigma t)
            end
mb0's avatar
mb0 committed
472
473
474
475
476
477
478
479
       | LETDECON (x, y, t) =>
            let
               val x' = copy x
               val y' = apply sigma y
               val sigma = extend sigma x' x
            in
               LETDECON (x', y', rename sigma t)
            end
480
481
482
483
       | LETUPD (x, y, fs, t) =>
            let
               val x' = copy x
               val y' = apply sigma y
mb0's avatar
mb0 committed
484
               val fs'= map (fn (f, x) => (f, apply sigma x)) fs
485
486
487
488
               val sigma = extend sigma x' x
            in
               LETUPD (x', y', fs', rename sigma t)
            end
489
       | LETCONT (ds, t) =>
490
491
492
            let
               val (sigma, ds) = renameConts sigma ds
            in
493
               LETCONT (ds, rename sigma t)
494
495
496
497
498
499
500
            end
       | APP (f, k, xs) =>
            APP
               (apply sigma f,
                apply sigma k,
                applyAll sigma xs)
       | CC (k, xs) => CC (apply sigma k, applyAll sigma xs)
501
502
503
504
505
506
       | CASE (x, ks) =>
            CASE
               (apply sigma x,
                map
                  (fn (tags, (k, xs)) =>
                     (tags, (apply sigma k, applyAll sigma xs))) ks)
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565

   and renameRecs sigma ds =
      let
         val sigma = foldl renameRec sigma ds
      in
         (sigma,
          map
            (fn (f, k, xs, t) =>
               (apply sigma f,
                apply sigma k,
                applyAll sigma xs,
                rename sigma t)) ds)
      end
   
   and renameRec ((f, k, xs, _), sigma) =
      let
         val f' = copy f
         val k' = copy k
         val xs' = copyAll xs
         val sigma = extend sigma f' f
         val sigma = extend sigma k' k
         val sigma = extendAll sigma xs' xs
      in
         sigma
      end
  
   and renameConts sigma ds = 
      let
         val sigma = foldl renameCont sigma ds
      in
         (sigma,
          map
            (fn (k, xs, t) =>
               (apply sigma k,
                applyAll sigma xs,
                rename sigma t)) ds)
      end

   and renameCont ((k, xs, t), sigma) =
      let
         val k' = copy k
         val xs' = copyAll xs
         val sigma = extend sigma k' k
         val sigma = extendAll sigma xs' xs
      in
         sigma
      end

   and renameCVal sigma v =
      case v of
         FN (k, xs, t) =>
            let
               val k' = copy k
               val xs' = copyAll xs
               val sigma = extend sigma k' k
               val sigma = extendAll sigma xs' xs
            in
               FN (k', xs', rename sigma t)
            end
mb0's avatar
mb0 committed
566
       | PRI (f, xs) => PRI (apply sigma f, applyAll sigma xs)
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
       | INJ (c, x) => INJ (c, apply sigma x)
       | REC fs => REC (map (fn (f, x) => (f, apply sigma x)) fs)
       | otherwise => otherwise

   end (* local *)

(*
   val rename = fn sigma => fn cps =>
      let
         val cps' = rename sigma cps
      in
         (print"\nin:\n";
          Pretty.prettyTo(TextIO.stdOut, CPS.PP.term cps);
          print"\nout:\n";
          Pretty.prettyTo(TextIO.stdOut, CPS.PP.term cps');
          cps')
      end
      *)
mb0's avatar
mb0 committed
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
end

structure Rec = struct
   structure Map = SymMap
   structure Set = SymSet
   open CPS.Exp
   type t = SymSet.set

   val clicks = Stats.newCounter "cps.rec.clicks"
   fun click () = Stats.tick clicks
   val recs = ref Set.empty

   fun use (env, recs) x = (Set.add (env, x), recs)
   fun uses (env, recs) xs =
      (foldl (fn (x, env) => Set.add (env, x)) env xs, recs)
   fun recuse (env, recs) f = (env, Set.add (recs, f))
   fun unuse (env, recs) x = (Set.delete (env, x) handle NotFound => env, recs)
   fun unuses (env, recs) xs =
      (foldl
         (fn (x, env) =>
            Set.delete (env, x) handle NotFound => env) env xs, recs)
   val empty = (Set.empty, Set.empty)
   fun merge ((env1, recs1), (env2, recs2)) =
      (Set.union (env1, env2), Set.union (recs1, recs2))
   fun isRec f = Set.member (!recs, f)
   
   fun run cps = let
      fun visitTerm (cps, env) = 
         case cps of
             APP (f, k, xs) =>
               let 
                  val env = use env f
                  val env = use env k
                  val env = uses env xs
               in
                  env
               end
           | CC (j, xs) =>
               let
                  val env = use env j
                  val env = uses env xs
               in
                  env
               end
           | LETPRJ (y, _, x, t) => unuse (use (visitTerm (t, env)) x) y
mb0's avatar
mb0 committed
630
           | LETDECON (y, x, t) => unuse (use (visitTerm (t, env)) x) y
mb0's avatar
mb0 committed
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
           | LETUPD (y, x, fs, t) =>
               let
                  val env = visitTerm (t, env)
                  val env = use env x
                  val env = uses env (map #2 fs)
               in
                  unuse env y
               end
           | LETREC (ds, t) =>
               let
                  val env = visitRecs (ds, env)
                  val env = visitTerm (t, env)
               in
                  env
               end
646
           | LETCONT (ds, t) =>
mb0's avatar
mb0 committed
647
648
649
650
651
652
653
               let
                  val env = visitConts (ds, env)
                  val env = visitTerm (t, env)
               in
                  env
               end
           | LETVAL (x, v, t) => unuse (visitCVal (v, visitTerm (t, env))) x 
654
655
656
657
658
659
660
           | CASE (x, ks) =>
               let
                  val env = use env x
                  val env = visitCases (ks, env)
               in
                  env
               end
mb0's avatar
mb0 committed
661
662

      and visitCases (ks, env) = 
663
664
665
666
667
668
669
670
         foldl
            (fn ((_,(k,xs)), env) =>
               let
                  val env = use env k
                  val env = uses env xs
               in
                  env
               end) env ks
mb0's avatar
mb0 committed
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

      and printUses uses =
         let
            open Layout Pretty
            fun sym s = str (VarInfo.getString (!SymbolTables.varTable, s))
            fun set (s, _) =
               list (List.map sym (Set.listItems s))
            fun binding (f, s) = seq [sym f, str " = ", set s] 
         in
            prettyTo (TextIO.stdOut,
               seq [list (map binding (Map.listItemsi uses)), str "\n"])
         end

      and visitRecs (ds, env) =
         let
            val uses =
               foldl
                  (fn ((f, k, xs, t), uses) =>
                     let
                        val env = visitTerm (t, unuse env f)
                        val env = unuse env k
                        val env = unuses env xs
                     in
                        Map.insert (uses, f, env)
                     end) Map.empty ds

            val transitiveUses =
               Map.mapi
                  (fn (f, (site, _)) =>
                     Set.foldl
                        (fn (g, closure) =>
                           case Map.find (uses, g) of
                              NONE => closure
                            | SOME (uses, _) => Set.union (closure, uses))
                         site site) uses
            
            fun isRec f =
               case Map.find (transitiveUses, f) of
                  SOME uses => Set.member (uses, f)
                | _ => false

            val env =
               Map.foldli
                  (fn (f, uses, env) =>
                     let
                        val env = merge (uses, env)
                     in
                        if isRec f
                           then recuse env f
                        else env
                     end) empty uses 
         in
            env
         end

      and visitConts (ds, env) =
         let
            val uses =
               foldl
                  (fn ((k, xs, t), uses) =>
                     let
                        val env = visitTerm (t, unuse env k)
                        val env = unuses env xs
                     in
                        Map.insert (uses, k, env)
                     end) Map.empty ds

            val transitiveUses =
               Map.mapi
                  (fn (f, (site, _)) =>
                     Set.foldl
                        (fn (g, closure) =>
                           case Map.find (uses, g) of
                              NONE => closure
                            | SOME (uses, _) => Set.union (closure, uses))
                         site site) uses

            val env =
               Map.foldli
                  (fn (f, uses, env) =>
                     let
                        val env = merge (uses, env)
                     in
                        if isRec f
                           then recuse env f
                        else env
                     end) empty uses 
         in
            env
         end

      and visitCVal (cv, env) =
         case cv of
            INJ (_, x) => use env x
          | REC fs => uses env (map #2 fs)
mb0's avatar
mb0 committed
766
          | PRI (f, xs) => uses env (f::xs)
mb0's avatar
mb0 committed
767
768
769
770
771
772
773
774
775
776
          | FN (k, xs, t) =>
             let
                val env = visitTerm (t, env)
                val env = unuse env k
                val env = unuses env xs
             in
                env
             end
          | _ => env
   in
mb0's avatar
mb0 committed
777
      recs := #2 (visitTerm (cps, empty))
mb0's avatar
mb0 committed
778
   end
mb0's avatar
Track.    
mb0 committed
779
   fun layout() = Pretty.symset CPS.PP.var (!recs) 
mb0's avatar
mb0 committed
780
781
end

mb0's avatar
mb0 committed
782
structure FunInfo = struct
783
   structure Map = SymTab
mb0's avatar
mb0 committed
784
785
786
787
788
   open CPS CPS.Exp
   datatype t =
      F of Var.v * Var.c * Var.v list * term
    | C of Var.c * Var.v list * term

789
790
791
792
793
794
   val env = Map.new() : t Map.hash_table
   fun reset () = Map.clear env
   fun bindFun (f, (k, xs, K)) = Map.insert env (f, F (f, k, xs, K))
   fun bindCont (k, (xs, K)) = Map.insert env (k, C (k, xs, K))
   fun lookup s f = s (Map.lookup env f)
   fun find s f = Option.map s (Map.find env f)
mb0's avatar
mb0 committed
795
796
797
798
799
   fun getFun (F x) = x
     | getFun _ = raise Match
   fun getCont (C x) = x
     | getCont _ = raise Match

800
   fun member k = Map.inDomain env k
mb0's avatar
mb0 committed
801

mb0's avatar
mb0 committed
802
803
804
805
   val lookupFun = lookup getFun
   val lookupCont = lookup getCont
   val findFun = find getFun
   val findCont = find getCont
mb0's avatar
mb0 committed
806

mb0's avatar
mb0 committed
807
808
809
810
811
812
   fun visitTerm t =
      case t of
         LETVAL (f, FN (k, xs, K), L) =>
            (visitTerm K
            ;bindFun (f, (k, xs, K))
            ;visitTerm L)
mb0's avatar
mb0 committed
813
       | LETVAL (x, v, L) => visitTerm L
mb0's avatar
mb0 committed
814
       | LETPRJ (_, _, _, body) => visitTerm body
mb0's avatar
mb0 committed
815
       | LETDECON (_, _, body) => visitTerm body
mb0's avatar
mb0 committed
816
817
818
819
820
821
822
823
824
825
826
827
       | LETUPD (_, _, _, body) => visitTerm body
       | LETCONT (cs, body) =>
            (app (fn (k, xs, K) =>
               (visitTerm K
               ;bindCont (k, (xs, K)))) cs
            ;visitTerm body)
       | LETREC (ds, body) =>
            (app (fn (f, k, xs, K) =>
               (visitTerm K
               ;bindFun (f, (k, xs, K)))) ds
            ;visitTerm body)
       | _ => ()
828

829
   fun run t = (reset();visitTerm t)
mb0's avatar
mb0 committed
830

831
   fun app f = Map.app f env
mb0's avatar
mb0 committed
832

mb0's avatar
mb0 committed
833
834
835
   fun dump () =
      Pretty.prettyTo
         (TextIO.stdOut,
836
          Pretty.symtab
mb0's avatar
mb0 committed
837
            {key=CPS.PP.var,
838
             item=fn _ => Pretty.empty} env)
mb0's avatar
mb0 committed
839
end
mb0's avatar
mb0 committed
840

mb0's avatar
mb0 committed
841
842
structure Cost = struct
   open CPS CPS.Exp
mb0's avatar
mb0 committed
843
844
845
846
   structure FI = FunInfo
   structure Set = SymSet
   
   val env = ref Set.empty
847
   val allwaysInline = ref Set.empty
mb0's avatar
mb0 committed
848
   val neverInline = ref Set.empty
849
850
   fun reset () =
      (env:=Set.empty
mb0's avatar
mb0 committed
851
852
853
854
855
856
857
858
859
860
861
      ;allwaysInline:=Set.fromList (map Aux.get
         [">>",
          "return",
          ">>=",
          "consume",
          "unconsume",
          "slice",
          "update",
          "raise",
          "query",
          "and",
862
863
          "==",
          "not",
mb0's avatar
mb0 committed
864
          "^",
865
866
          "arity0",
          "unop",
mb0's avatar
mb0 committed
867
868
869
          "binop",
          "ternop",
          "quaternop"])
mb0's avatar
Foo.    
mb0 committed
870
871
872
873
874
875
       ;neverInline:=
         Set.union
            (!neverInline,
             Set.fromList
               (List.mapPartial (fn x=>x) 
               (List.map Aux.find []))))
876
877

   val allwaysInline = fn f => Set.member (!allwaysInline, f)
878
879
   fun dontInline f = neverInline := Set.add (!neverInline, f)
   val neverInline = fn f => Set.member (!neverInline, f)
mb0's avatar
mb0 committed
880
881

   fun isInliningCandidate t =
mb0's avatar
mb0 committed
882
      let
883
884
885
886
887
888
889
890
891
892
893
         fun CASES f {cases,conts,recs,apps,ccs} = 
            {cases=f cases,conts=conts,recs=recs,apps=apps,ccs=ccs}
         fun CONTS f {cases,conts,recs,apps,ccs} = 
            {cases=cases,conts=f conts,recs=recs,apps=apps,ccs=ccs}
         fun RECS f {cases,conts,recs,apps,ccs} = 
            {cases=cases,conts=conts,recs=f recs,apps=apps,ccs=ccs}
         fun APPS f {cases,conts,recs,apps,ccs} = 
            {cases=cases,conts=conts,recs=recs,apps=f apps,ccs=ccs}
         fun CCS f {cases,conts,recs,apps,ccs} = 
            {cases=cases,conts=conts,recs=recs,apps=apps,ccs=f ccs}
         fun inc t f n = f (fn m => n+m) t
mb0's avatar
mb0 committed
894
895
         fun lp (t, n) =
            case t of
mb0's avatar
mb0 committed
896
               LETVAL (_, FN (k, xs, K), L) => lp (K, lp (L, n))
mb0's avatar
mb0 committed
897
             | LETVAL (_, PRI _, body) => lp (body, n)
mb0's avatar
mb0 committed
898
899
             | LETVAL (_, _, body) => lp (body, n)
             | LETPRJ (_, _, _, body) => lp (body, n)
mb0's avatar
mb0 committed
900
             | LETDECON (_, _, body) => lp (body, n)
mb0's avatar
mb0 committed
901
902
903
904
             | LETUPD (_, _, _, body) => lp (body, n)
             | LETCONT (cs, body) =>
               foldl
                  (fn ((_, _, body), n) =>
905
                     lp (body, n)) (lp (body, inc n CONTS (length cs))) cs
mb0's avatar
mb0 committed
906
907
908
             | LETREC (ds, body) =>
               foldl
                  (fn ((_, _, _, body), n) =>
909
910
911
912
913
914
                     lp (body, n)) (lp (body, inc n RECS (length ds))) ds
             | CASE (_, cs) => inc n CASES (length cs)
             | APP _ => inc n APPS 1
             | CC _ => inc n CCS 1
         val ZERO = {cases=0,conts=0,recs=0,apps=0,ccs=0}
         val {cases,recs,...} = lp (t, ZERO)
mb0's avatar
mb0 committed
915
      in
mb0's avatar
mb0 committed
916
         cases <= 2 andalso recs = 0
mb0's avatar
mb0 committed
917
      end
mb0's avatar
mb0 committed
918
919
920
921
922
923
924
925
926
927
   fun mark () =
      FI.app
         (fn FI.F (f, k, xs, body) =>
               if isInliningCandidate body
                  then env := Set.add (!env, f)
               else ()
           | FI.C (k, xs, body) =>
               if isInliningCandidate body
                  then env := Set.add (!env, k)
               else ())
928
   fun inlineCandidate f = not (neverInline f) andalso Set.member (!env, f)
mb0's avatar
mb0 committed
929
   fun run () = (reset();mark()) 
mb0's avatar
mb0 committed
930
931
end

932
933
934
935
structure BetaPair :> sig
   val name: string
   val run: CPS.Exp.t -> CPS.Exp.t * int
end = struct
mb0's avatar
mb0 committed
936
937
938
939
940
941
942
   open CPS.Exp
   structure CM = CompilationMonad
   structure Map = SymMap
   structure Set = SymSet

   val clicks = ref 0
   fun click () = clicks := !clicks + 1
mb0's avatar
mb0 committed
943
   fun reset () = clicks := 0
mb0's avatar
mb0 committed
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998

   val eq = SymbolTable.eq_symid
   
   fun updateEnv env x fs = 
      let
         fun insertField ((f, x), env) = Map.insert (env, f, x)
         fun insertAll env fs = foldl insertField env fs
      in
         case Map.find (env, x) of
            NONE => insertAll Map.empty fs
          | SOME fss => insertAll fss fs
      end

   fun simplify env sigma t =
      case t of
         LETVAL (y, REC fs, L) =>
            let
               val y = Subst.apply sigma y
               val fs = map (fn (f, x) => (f, Subst.apply sigma x)) fs
               val env' =
                  Map.insert
                     (env,
                      y,
                      foldl
                        (fn ((f, x), fs) =>
                           Map.insert (fs, f, x)) Map.empty fs)
            in
               LETVAL (y, REC fs, simplify env' sigma L)
            end
       | LETVAL (x, v, L) =>
            LETVAL
               (x,
                simplifyVal env sigma v,
                simplify env sigma L)
       | LETREC (ds, t) =>
            LETREC
               (map (simplifyRec env sigma) ds,
                simplify env sigma t)
       | LETPRJ (y, f, x, K) =>
            let
               val x = Subst.apply sigma x
               val env' = Map.insert (env, x, updateEnv env x [(f, y)])
            in
               case Map.find (env, x) of
                  NONE => LETPRJ (y, f, x, simplify env' sigma K)
                | SOME fs =>
                     (case Map.find (fs, f) of
                        NONE => LETPRJ (y, f, x, simplify env' sigma K)
                      | SOME x =>
                           let
                              val sigma = Subst.extend sigma x y
                           in
                              click(); simplify env sigma K
                           end)
            end
mb0's avatar
mb0 committed
999
1000
       | LETDECON (x, y, L) =>
            LETDECON