from-cps.sml 14.1 KB
Newer Older
mb0's avatar
mb0 committed
1
2
3
4
5
6
7
8
9

structure FromCPS : sig
   val run:
      CPS.Spec.t ->
         Closure.Spec.t CompilationMonad.t
end = struct

   structure CM = CompilationMonad
   structure FV = FreeVars
mb0's avatar
mb0 committed
10
   structure FI = FunInfo
mb0's avatar
mb0 committed
11
   structure Map = SymMap
mb0's avatar
mb0 committed
12
   structure Set = FreeVars.Set
mb0's avatar
mb0 committed
13
   structure Clos = Closure.Stmt
mb0's avatar
mb0 committed
14

15
16
   val closure = Atom.atom "env"
   val label = Atom.atom "lab"
mb0's avatar
mb0 committed
17
   val fresh = Aux.fresh
mb0's avatar
mb0 committed
18
19
20

   local open CPS.Exp in

mb0's avatar
mb0 committed
21
   fun conv spec = let
mb0's avatar
mb0 committed
22
     
mb0's avatar
mb0 committed
23
      val bindings = ref Map.empty
24
      val escapingvariants = ref Map.empty
mb0's avatar
mb0 committed
25
26
27
28
29
30
31
32
33
34
35
36
37

      fun bindFun (f, closure, k, xs, body) =
         bindings :=
            Map.insert
               (!bindings,
                f,
                Closure.Fun.FUN
                  {f=f,
                   k=k,
                   closure=closure,
                   xs=xs,
                   body=body})

38
39
40
41
42
43
44
45
46
47
48
      fun bindFastFun (f, k, xs, body) =
         bindings :=
            Map.insert
               (!bindings,
                f,
                Closure.Fun.FASTFUN
                  {f=f,
                   k=k,
                   xs=xs,
                   body=body})

mb0's avatar
mb0 committed
49
50
51
52
53
54
55
56
57
58
59
      fun bindCont (k, closure, xs, body) =
         bindings :=
            Map.insert
               (!bindings,
                k,
                Closure.Fun.CONT
                  {k=k,
                   closure=closure,
                   xs=xs,
                   body=body})

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
      fun bindFastCont (k, xs, body) =
         bindings :=
            Map.insert
               (!bindings,
                k,
                Closure.Fun.FASTCONT
                  {k=k,
                   xs=xs,
                   body=body})

      fun bindEscaping f fesc =
         escapingvariants := Map.insert (!escapingvariants, f, fesc)

      val toStr = Layout.tostring o CPS.PP.var

      fun escapingVariantOf f = 
         case Map.find (!escapingvariants, f) of
            NONE => 
               raise Fail ("closureConversion.escapingVariantOf: " ^ toStr f)
          | SOME f' => f'

mb0's avatar
mb0 committed
81
      fun boundFn f = FI.member f
mb0's avatar
mb0 committed
82

mb0's avatar
mb0 committed
83
84
85
86
87
88
89
90
      fun mapi f xs = 
         let
            fun lp (x::xs, i, acc) = lp (xs, i + 1, f (x, i)::acc)
              | lp ([], _, acc) = rev acc
         in
            lp (xs, 0, [])
         end

91
92
93
94
95
96
97
98
99
100
101
102
      fun checkArity f =
         case FI.find (fn x => x) f of
            NONE => ()
          | SOME (FI.F (_,_,[x],_)) => ()
          | SOME (FI.C (_,[x],_)) => ()
          | _ =>
               let
                  val f = Layout.tostring (CPS.PP.var f)
               in
                  raise Fail ("closureConversion.arity: " ^ f)
               end

103
      (* Assuming the corresponding function `f` is not part of `xs` *)
mb0's avatar
mb0 committed
104
      fun unfoldEnv xs env {stmts, flow} =
105
         {stmts=mapi (fn (x, i) => Clos.LETREF (x, env, i+1)) xs@stmts,
mb0's avatar
mb0 committed
106
107
          flow=flow}

mb0's avatar
mb0 committed
108
109
      val escapes = boundFn
      val isBound = boundFn
mb0's avatar
mb0 committed
110

mb0's avatar
mb0 committed
111
112
113
114
115
116
117
118
      fun free sigma f = 
         List.filter
            (not o boundFn)
            ((Set.listItems (FV.get f)))
      fun freeUse sigma f =
         List.filter
            (not o boundFn)
            (Subst.applyAll sigma (Set.listItems (FV.get f)))
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
  
      fun convEscaping () =
         let
            fun mkEscapingVariant f =
               case f of
                  FI.F (f,k,xs,body) =>
                     if Census.count#esc f = 0 then () else
                     let
                        val fs = freeUse Subst.empty f
                        val f' = Subst.copyWithSuffix "esc" f
                        val k' = Subst.copy k
                        val fs' = Subst.copyAll fs
                        val xs' = Subst.copyAll xs
                        val env = fresh closure
                        val body =
                           unfoldEnv
                              fs'
                              env
                              {stmts=[],
                               flow=Clos.FASTAPP {f=f,k=k',xs=fs'@xs'}}
                     in
                        bindEscaping f f'
                       ;bindFun (f', env, k', xs', Clos.BLOCK body)
                     end
                | FI.C (k,xs,body) =>
                     if Census.count#esc k = 0 then () else
                     let
                        val fs = freeUse Subst.empty k
                        val k' = Subst.copyWithSuffix "esc" k
                        val fs' = Subst.copyAll fs
                        val xs' = Subst.copyAll xs
                        val env = fresh closure
                        val body =
                           unfoldEnv
                              fs'
                              env
                              {stmts=[],
                               flow=Clos.FASTCC {k=k,xs=fs'@xs'}}
                     in
                        bindEscaping k k'
                       ;bindCont (k', env, xs', Clos.BLOCK body)
                     end
         in
            FI.app mkEscapingVariant
         end

mb0's avatar
mb0 committed
165
166
      fun convTerm sigma cps = 
         case cps of
mb0's avatar
mb0 committed
167
            LETVAL (f, FN (k, xs, K), L) =>
mb0's avatar
mb0 committed
168
               let
mb0's avatar
mb0 committed
169
170
                  val () =
                     convFun sigma f K
171
172
                        (fn {fs, body} =>
                           bindFastFun (f, k, fs@xs, Clos.BLOCK body))
mb0's avatar
mb0 committed
173
174
                  val {stmts, flow} = convTerm sigma L
               in
mb0's avatar
mb0 committed
175
                  {stmts=stmts,
mb0's avatar
mb0 committed
176
177
                   flow=flow}
               end
mb0's avatar
mb0 committed
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
          | LETVAL (x, v, body) =>
               let
                  val {stmts, flow} = convTerm sigma body
               in
                  {flow=flow,
                   stmts=convCVal sigma x v@stmts}
               end
          | LETREC (ds, body) =>
               let
                  val _ = convRecs sigma ds
                  val body = convTerm sigma body
               in
                  body
               end
          | LETCONT (ds, body) =>
               let
                  val _ = convConts sigma ds
                  val body = convTerm sigma body
               in
                  body
               end
          | LETPRJ (y, f, x, body) =>
               let
                  val x = Subst.apply sigma x
                  val {stmts, flow} = convTerm sigma body
               in
                  {flow=flow,
                   stmts=Clos.LETPRJ (y, f, x)::stmts}
               end
mb0's avatar
mb0 committed
207
208
209
210
211
212
213
214
          | LETDECON (y, x, body) =>
               let
                  val x = Subst.apply sigma x
                  val {stmts, flow} = convTerm sigma body
               in
                  {flow=flow,
                   stmts=Clos.LETDECON (y, x)::stmts}
               end
mb0's avatar
mb0 committed
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
          | LETUPD (y, x, ds, body) =>
               let
                  val x = Subst.apply sigma x
                  val fs = map #1 ds
                  val xs = map #2 ds
                  val env =
                     useAll sigma xs
                        (fn xs =>
                           [Clos.LETUPD (y, x, ListPair.zip (fs, xs))])
                  val {stmts, flow} = convTerm sigma body
               in
                  {flow=flow,
                   stmts=env@stmts}
               end
          | APP (f, k, xs) =>
mb0's avatar
mb0 committed
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
               let
                  val f = Subst.apply sigma f
               in
                  if isBound f
                     then
                        let   
                           val fs = freeUse sigma f
                           val k' = ref k
                           val xs' = ref xs
                           val stmts = 
                              use sigma k (fn k =>
                                 useAll sigma xs (fn xs =>
                                    (k' := k; xs' := xs; [])))
                        in
                           {stmts=stmts,
                            flow=Clos.FASTAPP {f=f, k= !k', xs=fs @ !xs'}}
                        end               
                  else
                     let
mb0's avatar
mb0 committed
249
250
                        val k' = ref k
                        val xs' = ref xs
mb0's avatar
mb0 committed
251
252
                        val f' = Subst.copy f
                        val stmts =
mb0's avatar
mb0 committed
253
254
                           use sigma k (fn k =>
                              useAll sigma xs (fn xs =>
mb0's avatar
mb0 committed
255
256
257
258
259
260
261
262
                                 (k' := k
                                 ;xs' := xs
                                 ;[Clos.LETREF (f', f, 0)])))
                        in
                           {stmts=stmts,
                            flow=Clos.APP {f=f', closure=f, k= !k', xs= !xs'}}
                        end
               end
mb0's avatar
mb0 committed
263
          | CC (k, xs) =>
mb0's avatar
mb0 committed
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
               let
                  val k = Subst.apply sigma k
               in
                  if isBound k
                     then
                        let
                           val fs = freeUse sigma k
                           val xs' = ref xs
                           val stmts =
                              useAll sigma xs (fn xs => (xs' := xs;[]))
                        in
                           {stmts=stmts,
                            flow=Clos.FASTCC {k=k, xs=fs @ !xs'}}
                        end
                  else
mb0's avatar
mb0 committed
279
                     let
mb0's avatar
mb0 committed
280
                        val k' = Subst.copy k
mb0's avatar
mb0 committed
281
282
                        val xs' = ref xs
                        val stmts =
mb0's avatar
mb0 committed
283
284
285
                           useAll sigma xs (fn xs =>
                              (xs' := xs
                              ;[Clos.LETREF (k', k, 0)]))
mb0's avatar
mb0 committed
286
287
                     in
                        {stmts=stmts,
mb0's avatar
mb0 committed
288
                         flow=Clos.CC {k=k', closure=k, xs= !xs'}}
mb0's avatar
mb0 committed
289
                     end
mb0's avatar
mb0 committed
290
               end
mb0's avatar
mb0 committed
291
          | CASE (ty, x, ks) =>
mb0's avatar
mb0 committed
292
               {stmts=[],
mb0's avatar
mb0 committed
293
                flow=Clos.CASE (ty, Subst.apply sigma x, convCases sigma ks)}
294
295

      and convCases sigma ks = map (fn (tag, c) => (tag, convCase sigma c)) ks
mb0's avatar
mb0 committed
296
297
298
299
300
      and convCase sigma (k, xs) =
         Clos.BLOCK
            (convTerm
               sigma
               (CC (Subst.apply sigma k, Subst.applyAll sigma xs)))
mb0's avatar
mb0 committed
301
302
303
304

      and convConts sigma ds = app (convCont sigma) ds
      and convCont sigma (k, xs, body) =
         convFun sigma k body
305
306
            (fn {fs, body} =>
               bindFastCont (k, fs@xs, Clos.BLOCK body))
mb0's avatar
mb0 committed
307

mb0's avatar
mb0 committed
308
309
310
      and convRecs sigma ds = app (convRec sigma) ds
      and convRec sigma (f, k, xs, body) =
         convFun sigma f body
311
312
            (fn {fs, body} =>
               bindFastFun (f, k, fs@xs, Clos.BLOCK body))
mb0's avatar
mb0 committed
313
314
315

      and buildEnv sigma f =
         let
316
            val fs = freeUse sigma f
317
            val f' = fresh label
mb0's avatar
mb0 committed
318
            val env = fresh closure
319
320
321
            val stmts =
               [Clos.LETVAL (f', Clos.LAB f),
                Clos.LETENV (env, f'::fs)]
mb0's avatar
mb0 committed
322
         in
mb0's avatar
mb0 committed
323
            {label=f', env=env, body=stmts}
mb0's avatar
mb0 committed
324
325
326
327
328
329
330
331
332
         end

      and convFun sigma f body k =
         let
            val fs = free sigma f
            val ys = Subst.copyAll fs
            val sigma = Subst.extendAll sigma ys fs
            val body = convTerm sigma body
         in
333
            k {fs=ys, body=body}
mb0's avatar
mb0 committed
334
335
336
         end

      and convCVal sigma x v =
mb0's avatar
mb0 committed
337
         case v of
mb0's avatar
mb0 committed
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
            PRI (f, xs) =>
               useAll sigma xs
                  (fn xs =>
                     [Clos.LETVAL (x, Clos.PRI (f, xs))])
          | INJ (tag, y) =>
               use sigma y
                  (fn y =>
                     [Clos.LETVAL (x, Clos.INJ (tag, y))])
          | REC ds =>
               let
                  val fs = map #1 ds
                  val xs = map #2 ds
               in
                  useAll sigma xs
                     (fn xs =>
                        [Clos.LETVAL (x, Clos.REC (ListPair.zip (fs, xs)))])
               end
          | INT i => [Clos.LETVAL (x, Clos.INT i)]
          | FLT f => [Clos.LETVAL (x, Clos.FLT f)]
          | STR s => [Clos.LETVAL (x, Clos.STR s)]
          | VEC v => [Clos.LETVAL (x, Clos.VEC v)]
          | UNT => [Clos.LETVAL (x, Clos.UNT)]
360
          | FN _ => raise Fail "closureConversion.bug"
mb0's avatar
mb0 committed
361
362
363
364
365
366
367
368
369
370

      and useAll sigma xs k =
         let
            val xs = Subst.applyAll sigma xs
            fun lp (xs, lets, ys) =
               case xs of
                  x::xs =>
                     if escapes x
                        then
                           let
mb0's avatar
mb0 committed
371
                              (* val _ = checkArity x *)
372
                              val fs = freeUse sigma x
373
                              val x = escapingVariantOf x
374
                              val l = fresh label
mb0's avatar
mb0 committed
375
376
377
                              val closure = fresh closure
                           in
                              lp (xs,
378
379
380
                                  Clos.LETENV (closure, l::fs)::
                                  Clos.LETVAL (l, Clos.LAB x)::
                                  lets,
mb0's avatar
mb0 committed
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
                                  closure::ys)
                           end
                     else lp (xs, lets, x::ys)
                | [] => rev lets@k (rev ys)
         in
            lp (xs, [], [])
         end

      and use sigma x k =
         let
            val x = Subst.apply sigma x
         in
            if escapes x
               then
                  let
mb0's avatar
mb0 committed
396
                     (* val _ = checkArity x *)
397
                     val fs = freeUse sigma x
398
                     val x = escapingVariantOf x
399
                     val l = fresh label
mb0's avatar
mb0 committed
400
401
                     val closure = fresh closure
                  in
402
                     Clos.LETVAL (l, Clos.LAB x)::
mb0's avatar
mb0 committed
403
                     Clos.LETENV (closure, l::fs)::
404
                     k closure
mb0's avatar
mb0 committed
405
406
407
                  end
            else k x
         end
mb0's avatar
mb0 committed
408
409
               
   in
mb0's avatar
mb0 committed
410
411
      Spec.upd
         (fn cps =>
mb0's avatar
mb0 committed
412
            (FV.run cps
mb0's avatar
mb0 committed
413
            ;FI.run cps
414
            ;Census.run cps
mb0's avatar
mb0 committed
415
            ;CheckDefUse.run cps
mb0's avatar
mb0 committed
416
            (* ;FV.dump() *)
mb0's avatar
mb0 committed
417
            (* ;FI.dump() *)
418
            ;convEscaping()
mb0's avatar
mb0 committed
419
            ;ignore(convTerm Subst.empty cps)
mb0's avatar
mb0 committed
420
421
422
            ;Map.listItems (!bindings))) spec : Closure.Spec.t
   end

mb0's avatar
mb0 committed
423
424
425
426

   end (* end local *)

   fun dumpPre (os, spec) = Pretty.prettyTo (os, CPS.PP.spec spec)
427
428
429
430
431
432
   fun dumpPost (os, spec) =
      Pretty.prettyTo
         (os,
          Layout.align
            [Closure.PP.spec spec,
             Layout.seq [Layout.str "freevars=", FV.layout()]]) 
mb0's avatar
mb0 committed
433
434
435
436
437
438

   val conv =
      BasicControl.mkKeepPass
         {passName="flatClosureConversion",
          registry=ClosureControl.registry,
          pass=conv,
mb0's avatar
mb0 committed
439
          preExt="cps",
mb0's avatar
mb0 committed
440
441
442
443
444
445
          preOutput=dumpPre,
          postExt="clos",
          postOutput=dumpPost}

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