summaryrefslogtreecommitdiff
path: root/emit.fun
blob: ada021705612919c446139e8471fad56632143fc (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
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
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
115
116
117
118
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
165
166
167
168
169
170
171
172
173
174
175
176
177
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
207
208
209
210
211
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
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
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
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
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
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
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
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
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
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
functor Emit(I: IL) = struct
  structure I = I

  structure P = I.P
  structure D = P.D
  structure PP = P.P

  val ip = I

  val file = ref NONE

  datatype reg =
    Rax | Rbx | Rcx | Rdx | Rsi | Rdi | Rbp | Rsp | R8 |
    R9 | R10 | R11 | R12 | R13 | R14 | R15

  datatype vConst = VConst of word | VAddrConst of int * word
  datatype vrType =
    VtConst of vConst | VtReg of reg | VtStack of int | VtUnk

  datatype affinity = AfHard of reg | AfSoft of int list | AfUnk

  val regs = [
    (Rax, 0),
    (Rdx, 1),
    (Rsp, 2),
    (Rbp, 3),

    (Rcx, 4),
    (Rsi, 5),
    (Rdi, 6),
    (R8, 7),
    (R9, 8),
    (R10, 9),
    (R11, 10),

    (Rbx, 11),
    (R12, 12),
    (R13, 13),
    (R14, 14),
    (R15, 15)
  ]

  val firstUsedReg = 4
  val usedRegNum = 12

  fun reg2idx reg =
    case List.find (fn (r, _) => r = reg) regs of
      NONE => raise Unreachable
    | SOME (_, idx) => idx

  fun idx2reg idx =
    case List.find (fn (_, i) => i = idx) regs of
      NONE => raise Unreachable
    | SOME (r, _) => r

  local
    fun output s =
    let
      val outstream = valOf $ !file
    in
      TextIO.output (outstream, s)
    end

    val ctx = ((false, makePrintfBase output),
      fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
  in
    fun fprint g = Fold.fold ctx g
  end

  fun fprintt g = fprint `"\t" g

  fun fprinttn g =
    fprintt (fn (a, _) => g (a, fn (_, out) => (Printf out `"\n" %)))

  fun handleBSS objsZI =
  let
    val () = fprint `"section .bss\n" %

    fun handleObj (id, _, t, _, _) =
    let
      val align = P.alignOfType t
      val size = P.sizeOfType t
    in
      fprinttn `"align\t" W align %;
      fprint PP.? id `":\tresb " W size `"\n" %
    end
  in
    List.app handleObj objsZI
  end

  fun dd size w =
  let
    val cmd =
      case size of
        0w1 => "db"
      | 0w2 => "dw"
      | 0w4 => "dd"
      | 0w8 => "dq"
      | _ => raise Unreachable
  in
    fprint `cmd `" " W w %
  end

  fun emitAggrLayout id =
  let
    val (_, size, layout) = D.get P.iniLayouts id

    val () = fprint `"\n" %

    fun getPadding offset t [] = size - (offset + P.sizeOfType t)
      | getPadding offset t ({ offset = offset', ... } :: _) =
        offset' - (offset + P.sizeOfType t)

    fun emitScalars ({ offset, t, value } :: tail) =
    let
      val () = fprint `"\t" %
      val () = dd (P.sizeOfType t) value
      val padding = getPadding offset t tail
    in
      if padding > 0w0 then
        fprint `"\n\tresb " W padding `"\n" %
      else
        fprint `"\n" %;
      emitScalars tail
    end
      | emitScalars [] = ()
  in
    emitScalars layout
  end

  fun handleData objs =
  let
    val () = fprint `"section .data\n" %

    fun emitLayout (id, _, t, ini, _) =
    let
      val align = P.alignOfType t
      val () = fprinttn `"align\t" W align %
      val () = fprint PP.? id `":" %
    in
      case ini of
        P.CiniLayout id => emitAggrLayout id
      | P.CiniExpr _ => raise Unreachable
    end
  in
    List.app emitLayout objs
  end

  fun handleStrlits strlits =
  let
    fun f id = fprint `".S" I id `":\tdb " `(PP.?? id) `", 0\n" %
  in
    fprint `"\n" %;
    List.app f strlits
  end

  fun handleLocalIniLayouts () =
  let
    fun f (_, (true, _, _)) = ()
      | f (n, (false, _, _)) = (
        fprint `"\talign 16\n" %;
        fprint `".I" I n `":" %;
        emitAggrLayout n
      )
  in
    D.appi f P.iniLayouts
  end

  fun extendEnd (iStart, iEnd) ops labels =
  let
    fun loop idx iEnd =
      if idx = D.length ops then
        iEnd
      else
        let
          val (ins, _) = D.get ops idx
        in
          case ins of
            SOME (I.IrJmp lid) | SOME (I.IrJz (_, lid)) |
            SOME (I.IrJnz (_, lid)) =>
            let
              val ldest = valOf $ D.get labels lid

              val iEnd =
                if ldest > iStart andalso ldest < iEnd then
                  idx
                else
                  iEnd
            in
              loop (idx + 1) iEnd
            end
          | _ => loop (idx + 1) iEnd
        end
  in
    loop iEnd iEnd
  end

  fun computeIntLocal (s, e) firstDef ops labels =
  let
    val e = extendEnd (s, e) ops labels

    val (_, li) = D.get ops firstDef
  in
    case li of
      SOME (startL, endL) =>
      let
        val (startLoop, endLoop) =
          (valOf $ D.get labels startL, valOf $ D.get labels endL)

        val s = if s < startLoop then s else startLoop
        val e = if e > endLoop then e else endLoop
      in
        (s, e)
      end
    | _ => (s, e)
  end

  fun getBasicInt [] _ = raise Unreachable
    | getBasicInt defs [] = (List.last defs, hd defs + 1)
    | getBasicInt defs use =
    let
      val (firstDef, lastDef) = (List.last defs, hd defs)
      val (firstUse, lastUse) = (List.last use, hd use)

      val first = if firstDef < firstUse then firstDef else firstUse - 1
      val last = if lastDef < lastUse then lastUse else lastDef + 1
    in
      (first, last)
    end

  fun computeInt (I.Fi { vregs, ops, localBound, labels, ... }) var =
  let
    val { defs, use, ... } = D.get vregs var
    val (iStart, iEnd) = getBasicInt defs use

    val (iStart, iEnd) =
      if var < localBound then
        computeIntLocal (iStart, iEnd) (List.last defs) ops labels
      else
        (iStart, iEnd)
  in
    (var, iStart, iEnd)
  end

  fun computeInts F vars = List.map (computeInt F) vars

  fun printInts ints =
  let
    val () = printfn `"\nsorted intervals:\n" %
    fun p (id, s, e) = printfn `"id: %" I id `" {" I s `", " I e `"}" %
  in
    List.app p ints
  end

  fun updAff arr idx aff =
  let
    val (_, vt) = Array.sub (arr, idx)
  in
    Array.update (arr, idx, (aff, vt))
  end

  datatype insAff = IaNone | IaHard of (int * reg) list
                  | IaSoft of int * int list

  fun parNum2reg pr =
    case pr of
      0 => Rdi
    | 1 => Rsi
    | 2 => Rdx
    | 3 => Rcx
    | 5 => R8
    | 6 => R9
    | _ => raise Unreachable

  fun getInsAff (SOME ins) =
  let
    fun tr (rd, rs1, rs2) = IaSoft (rd, [rs1, rs2])

    fun setAff (rd, I.SaVReg rs) = IaSoft (rd, [rs])
      | setAff _ = IaNone

    fun fcallAff args =
    let
      fun collect idx (arg :: args) acc =
        collect (idx + 1) args ((arg, parNum2reg idx) :: acc)
        | collect _ [] acc = rev acc
    in
      IaHard $ collect 0 args []
    end
  in
    case ins of
      I.IrSet p => setAff p
    | I.IrAdd t => tr t
    | I.IrSub t => tr t
    | I.IrMul t => tr t
    | I.IrIMul t => tr t
    | I.IrDiv t => tr t
    | I.IrIDiv t => tr t
    | I.IrMod t => tr t
    | I.IrIMod t => tr t
    | I.IrShl t => tr t
    | I.IrShr t => tr t
    | I.IrSar t => tr t
    | I.IrAnd t => tr t
    | I.IrOr t => tr t
    | I.IrXor t => tr t
    | I.IrEq t => tr t
    | I.IrNeq t => tr t
    | I.IrCmpul t => tr t
    | I.IrCmpug t => tr t
    | I.IrCmpule t => tr t
    | I.IrCmpuge t => tr t
    | I.IrCmpsl t => tr t
    | I.IrCmpsg t => tr t
    | I.IrCmpsle t => tr t
    | I.IrCmpsge t => tr t

    | I.IrExtZero _ | I.IrExtSign _
    | I.IrLoad _ | I.IrStore _ | I.IrJmp _
    | I.IrJz _ | I.IrJnz _ | I.IrNopLabel _
    | I.IrNop _ | I.IrRet _ | I.IrAlloc _
    | I.IrCopy _ => IaNone
    | I.IrFcall (_, _, args) => fcallAff args
  end
   | getInsAff NONE = IaNone

  fun updateSoftAff rinfo rd rss =
  let
    fun sort [r] = [r]
      | sort [rs1, rs2] = if rs1 < rs2 then [rs1, rs2] else [rs2, rs1]
      | sort _ = raise Unreachable

    fun isNotConst rv =
    let
      val (_, vt) = Array.sub (rinfo, rv)
    in
      case vt of
        VtConst _ => false
      | _ => true
    end

    val (aff, vt) = Array.sub (rinfo, rd)
    val rss = List.filter isNotConst $ sort rss

    fun insertSorted ins [] = ins
      | insertSorted [] acc = acc
      | insertSorted (x :: xs) (y :: ys) =
        if x < y then
          x :: insertSorted xs (y :: ys)
        else
          y :: insertSorted (x :: xs) ys

    val aff =
      case aff of
        AfUnk => AfSoft rss
      | AfSoft affs => AfSoft $ insertSorted rss affs
      | AfHard _ => aff
  in
    Array.update (rinfo, rd, (aff, vt))
  end

  fun updateHardAff rinfo hards =
  let
    fun f (rd, reg) =
    let
      val (aff, vt) = Array.sub (rinfo, rd)

      val aff =
        case aff of
          AfUnk | AfSoft _ => AfHard reg
        | AfHard _ => raise Unreachable
    in
      Array.update (rinfo, rd, (aff, vt))
    end
  in
    List.app f hards
  end

  fun compAffinity rinfo ops paramNum =
  let
    fun compParams idx =
      if idx = paramNum then
        ()
      else
        let
          val reg = parNum2reg idx
        in
          updAff rinfo idx (AfHard reg);
          compParams (idx + 1)
        end
    val () = compParams 0

    fun loop idx =
      if idx = D.length ops then
        ()
      else
        let
          val (ins, _) = D.get ops idx
        in
          case getInsAff ins of
            IaNone => ()
          | IaSoft (rd, rss) => updateSoftAff rinfo rd rss
          | IaHard hards => updateHardAff rinfo hards;
          loop (idx + 1)
        end
  in
    loop 0
  end

  fun prepareRegInfo paramNum ops vregs =
  let
    val rinfo = Array.array (D.length vregs, (AfUnk, VtUnk))

    fun transfer idx acc =
      if idx = D.length vregs then
        rev acc
      else
      let
        val (vt, cand) =
          case #t $ D.get vregs idx of
            I.RtRem => (VtUnk, NONE)
          | I.RtConst w => (VtConst (VConst w), NONE)
          | I.RtAddrConst (id, w) => (VtConst (VAddrConst (id, w)), NONE)
          | I.RtReg => (VtUnk, SOME idx)
      in
        Array.update (rinfo, idx, (AfUnk, vt));
        transfer (idx + 1) (if isSome cand then valOf cand :: acc else acc)
      end

    val toAlloc = transfer 0 []
  in
    compAffinity rinfo ops paramNum;
    (toAlloc, rinfo)
  end

  fun preg reg out =
  let
    val s =
      case reg of
        Rax => "rax"
      | Rbx => "rbx"
      | Rcx => "rcx"
      | Rdx => "rdx"
      | Rsi => "rsi"
      | Rdi => "rdi"
      | Rbp => "rbp"
      | Rsp => "rsp"
      | R8 => "r8"
      | R9 => "r9"
      | R10 => "r10"
      | R11 => "r11"
      | R12 => "r12"
      | R13 => "r13"
      | R14 => "r14"
      | R15 => "r15"
  in
    Printf out `s %
  end

  val Preg = fn z => bind A1 preg z

  fun affPrint rinfo =
  let
    fun pv idx out = Printf out `"%" I idx %

    fun p (idx, (aff, _)) =
    let
      val () = printf `"%" I idx %
    in
      case aff of
       AfUnk => printfn `" = unk" %
     | AfHard reg => printfn `" <- " Preg reg %
     | AfSoft rss => printfn `" <- " Plist pv rss (", ", true, 1) %
    end
  in
    Array.appi p rinfo
  end

  fun sort _ [] = []
    | sort _ [x] = [x]
    | sort le l =
    let
      fun divide [] accp = accp
        | divide [x] (acc1, acc2) = (x :: acc1, acc2)
        | divide (x :: y :: tail) (acc1, acc2) =
          divide tail (x :: acc1, y :: acc2)
      val (part1, part2) = divide l ([], [])
      val part1 = sort le part1
      val part2 = sort le part2

      fun merge [] [] acc = acc
        | merge [] ys acc = rev $ List.revAppend (ys, acc)
        | merge xs [] acc = rev $ List.revAppend (xs, acc)
        | merge (x :: xs) (y :: ys) acc =
            if le (x, y) then
              merge xs (y :: ys) (x :: acc)
            else
              merge (x :: xs) ys (y :: acc)
    in
      merge part1 part2 []
    end

  fun updateI i = fn z =>
  let
    fun from rinfo active pool intervals stackCand =
      { rinfo, active, pool, intervals, stackCand }
    fun to f { rinfo, active, pool, intervals, stackCand } =
      f rinfo active pool intervals stackCand
  in
    FRU.makeUpdate5 (from, from, to) i
  end z

  fun returnToPool pool reg =
  let
    val idx = reg2idx reg - firstUsedReg
  in
    Array.update (pool, idx, NONE)
  end

  fun expireOne { rinfo, active, pool, ... } (_, start, _) =
    case !active of
      [] => false
    | (j, startp, endp) :: acts =>
      if endp > start then
        false
      else
        let
          val (_, vt) = Array.sub (rinfo, j)
          val reg = case vt of VtReg reg => reg | _ => raise Unreachable

          val () = printfn `"III!!! interval %"
              ip j `"(" ip startp `", " ip endp `") "
              `"with " Preg reg `" has expired" %
        in
          returnToPool pool reg;
          active := acts;
          true
        end

  fun expireOld (I as { active, ... }) int =
    let
      fun loop I =
        case expireOne I int of
          false => ()
        | true => loop I
    in
      case !active of
        [] => ()
      | _ => loop I
    end

  fun addToActive int [] = [int]
    | addToActive (I as (_, _, e1)) (act :: acts) =
    if e1 < #3 act then
      (I :: act :: acts)
    else
      act :: addToActive I acts

  fun updReg arr idx reg =
  let
    val (aff, _) = Array.sub (arr, idx)
  in
    Array.update (arr, idx, (aff, reg))
  end

  fun assignFirstReg poff { rinfo, pool, ... } vr =
  let
    fun loop idx =
      if idx = Array.length pool then
        raise Unreachable
      else
        let
          val user = Array.sub (pool, idx)
        in
          case user of
            SOME _ => loop (idx + 1)
          | NONE =>
            let
              val () = Array.update (pool, idx, SOME vr);
              val reg = idx2reg (firstUsedReg + idx)

              val () = printfn R poff
                `"assigned (first) reg " Preg reg `" to %" ip vr %
            in
              updReg rinfo vr (VtReg reg)
            end
        end
  in
    loop 0
  end

  fun freeRegList pool =
  let
    fun loop idx acc =
      if idx = Array.length pool then
        rev acc
      else
        case Array.sub (pool, idx) of
          NONE => loop (idx + 1) (idx2reg (idx + firstUsedReg) :: acc)
        | SOME _ => loop (idx + 1) acc
  in
    loop 0 []
  end

  fun getAffRegList rinfo affs =
  let
    fun loop [] acc = rev acc
      | loop (vr :: vrs) acc =
      let
        val (_, vt) = Array.sub (rinfo, vr)
      in
        case vt of
          VtReg r => loop vrs (r :: acc)
        | _ => loop vrs acc
      end
  in
    loop affs []
  end

  fun findCommonRegs l1 l2 =
  let
    val l1 = sort (fn (r1, r2) => reg2idx r1 <= reg2idx r2) l1
    val l2 = sort (fn (r1, r2) => reg2idx r1 <= reg2idx r2) l2

    fun intersection [] _ = []
      | intersection _ [] = []
      | intersection (x :: xs) (y :: ys) =
        case Int.compare (reg2idx x, reg2idx y) of
          LESS => intersection xs (y :: ys)
        | EQUAL => x :: intersection xs ys
        | GREATER => intersection (x :: xs) ys
  in
    intersection l1 l2
  end

  fun assignSoftReg poff affs (I as { rinfo,  pool, ... }) vr =
  let
    val () = printfn R poff
      `"trying to assign register (by affinity) to %" ip vr %

    val regs = freeRegList pool
    val affRegs = getAffRegList rinfo affs
    val common = findCommonRegs regs affRegs

    val () = printfn R (poff + 1)
      `"free registers: " Plist preg regs (", ", true, 0) %
    val () = printfn R (poff + 1)
      `"affinity registers: " Plist preg affRegs (", ", true, 0) %
  in
    case common of
      [] =>
      let
        val () = printfn R (poff + 1) `"affinity was not satisfied" %
      in
        assignFirstReg (poff + 2) I vr
      end
    | (reg :: _) =>
      let
      in
        updReg rinfo vr (VtReg reg);
        Array.update (pool, reg2idx reg - firstUsedReg, SOME vr);
        printfn R (poff + 1)
          `"assigned (by affinity) reg " Preg reg `" to %" ip vr %;
        printfn R (poff + 1)
          `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) %
      end
  end

  fun putToStack poff { rinfo, stackCand, ... } vr =
  let
    val () = printfn R poff
      `"puting %" ip vr `" to stack: " ip (!stackCand) %
  in
    updReg rinfo vr (VtStack (!stackCand));
    stackCand := !stackCand - 8
  end

  fun assignHardReg poff (I as { rinfo,  pool, ... }) vr reg =
  let
    val () = printfn R poff
      `"trying to assign hard reg " A1 preg reg `" to %" ip vr %

    val regIdx = reg2idx reg - firstUsedReg
    val user = Array.sub (pool, regIdx)

    fun setOurReg () =
    let
      val () = printfn R (poff + 1) `"reg assigned" %
    in
      Array.update (pool, regIdx, SOME vr);
      updReg rinfo vr (VtReg reg)
    end
  in
    case user of
      NONE => setOurReg ()
    | SOME u =>
      let
        val () = printfn R (poff + 1) `"reg is taken by %" ip u %
        val (aff, _) = Array.sub (rinfo, u)
      in
        case aff of
          AfHard _ => raise Unreachable
        | AfSoft affs => assignSoftReg poff affs I u
        | AfUnk => assignFirstReg poff I u
        ;
        setOurReg ()
      end
  end

  fun assignReg (I as { rinfo, ... }) (vr, _, _) =
  let
    val (aff, _) = Array.sub (rinfo, vr)
  in
    case aff of
      AfUnk => assignFirstReg 0 I vr
    | AfSoft affs => assignSoftReg 0 affs I vr
    | AfHard reg => assignHardReg 0 I vr reg
  end

  fun getPool () = Array.array (usedRegNum, NONE)

  fun changeInActive active newInt oldVr =
  let
    val a = !active
    val a = List.filter (fn (v, _, _) => v <> oldVr) a
  in
    active := addToActive newInt a
  end

  fun expropriateReg (I as { rinfo, pool, active, ... }) int reg =
  let
    val vr = #1 int

    val regIdx = reg2idx reg - firstUsedReg
    val u = valOf $ Array.sub (pool, regIdx)

    val (uAff, _) = Array.sub (rinfo, u)
    val () =
      case uAff of
        AfHard _ => raise Unreachable
      | _ => ()

    val () = putToStack 1 I u
    val () = Array.update (pool, regIdx, SOME vr)
    val () = updReg rinfo vr (VtReg reg)
  in
    changeInActive active int u
  end

  fun userIdx pool vr =
  let
    fun loop idx =
      if idx = Array.length pool then
        raise Unreachable
      else
        case Array.sub (pool, idx) of
          SOME u =>
            if u = vr then
              idx
            else
              loop (idx + 1)
        | NONE => loop (idx + 1)
  in
    loop 0
  end

  fun spillAtInterval (I as { rinfo, active, pool, ... }) int =
  let
    val spill = List.last (!active)

    val vr = #1 int
    val (ourAff, _) = Array.sub (rinfo, vr)

    fun isNotHard vr =
      case #1 $ Array.sub (rinfo, vr) of
        AfHard _ => false
      | _ => true

    val () = printfn `"SpilAtInt" %
    val () = printfn R 0
      `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) %
  in
    case ourAff of
      AfHard reg => expropriateReg I int reg
    | _ =>
      if #3 spill > #3 int andalso isNotHard (#1 spill) then
        let
          val idx = userIdx pool (#1 spill)
          val () = printfn `"spilling!!!" %
        in
          Array.update (pool, idx, SOME vr);
          updReg rinfo vr (VtReg $ idx2reg (idx + firstUsedReg));
          putToStack 1 I (#1 spill);
          changeInActive active int (#1 spill)
        end
      else
        putToStack 0 I vr
  end

  fun linearscan rinfo ints =
  let
    fun incStart ((_, start1, _), (_, start2, _)) = start1 <= start2
    val ints = sort incStart ints

    val () = printInts ints

    fun loop _ [] = ()
      | loop (I as { active, ... }) (int :: ints) =
      let
        val () = printfn `"\n\ninspectiing interval "
            ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")" %

        val () = expireOld I int

        val () =
          if length (!active) = usedRegNum then
            spillAtInterval I int
          else
            let
              val () = assignReg I int
            in
              active := addToActive int (!active)
            end
      in
        loop I ints
      end
  in
    loop { active = ref [], pool = getPool (), rinfo,
      stackCand = ref (~8) } ints
  end

  fun printAllocVar rinfo v =
  let
    val () = printf `"%" I v `": " %
    val (_, vt) = Array.sub (rinfo, v)
  in
    case vt of
      VtStack off => printfn `"stack " I off %
    | VtReg reg => printfn `"reg " A1 preg reg %
    | VtConst _ | VtUnk => raise Unreachable
  end

  fun printAlloced rinfo toAlloc =
  let
    val () = printfn `"\nallocated:\n" %
  in
    List.app (printAllocVar rinfo) toAlloc
  end

  fun getUsedRegs rinfo =
  let
    val regs = Array.array (usedRegNum, false)

    fun loop idx =
      if idx = Array.length rinfo then
        ()
      else
        let
          val (_, vt) = Array.sub (rinfo, idx)
        in
          case vt of
            VtReg reg => Array.update (regs, reg2idx reg - firstUsedReg, true)
          | _ => ();
          loop (idx + 1)
        end
    val () = loop 0

    fun collect idx acc =
      if idx = usedRegNum then
        acc
      else
        if Array.sub (regs, idx) then
          collect (idx + 1) (idx2reg (idx + firstUsedReg) :: acc)
        else
          collect (idx + 1) acc
  in
    collect 0 []
  end

  fun regAlloc (F as I.Fi { vregs, ops, paramNum, ... }) =
  let
    val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs
    val () = printfn `"for alloc: " Plist i toAlloc (", ", true, 0) %

    val () = affPrint regInfo

    val intervals = computeInts F toAlloc

    val () = linearscan regInfo intervals
    val () = printAlloced regInfo toAlloc

    val usedRegs = getUsedRegs regInfo
    val () = printfn
      `"used registers: " Plist preg usedRegs (", ", true, 0) %
  in
    raise Unimplemented
  end

  fun emitFunc (F as I.Fi { vregs, ... }) =
  let
    val () = regAlloc F vregs
  in
    raise Unimplemented
  end

  fun openFile fname = file := SOME (TextIO.openOut fname)

  fun emit fname
    (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... }) =
  let
    val () = openFile fname

    val () = List.app (fn gs => fprint `"global " PP.? gs `"\n" %) globSyms
    val () = List.app (fn es => fprint `"extern " PP.? es `"\n" %) extSyms

    val () = handleBSS objsZI
    val () = handleData objs
    val () = handleStrlits strlits
    val () = handleLocalIniLayouts ()

    val () = List.app emitFunc funcInfos
  in
    ()
  end
end