mlton/backend/implement-profiling.fun

   1 (* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 functor ImplementProfiling (S: IMPLEMENT_PROFILING_STRUCTS): IMPLEMENT_PROFILING =
   9 struct
  10
  11 open S
  12 open Rssa
  13
  14 structure CFunction =
  15    struct
  16       open CFunction
  17
  18       structure CType =
  19          struct
  20             open CType
  21             val gcState = cpointer
  22          end
  23
  24       local
  25          fun make {args, name, prototype} =
  26             T {args = args,
  27                convention = Convention.Cdecl,
  28                kind = Kind.Runtime {bytesNeeded = NONE,
  29                                     ensuresBytesFree = false,
  30                                     mayGC = false,
  31                                     maySwitchThreads = false,
  32                                     modifiesFrontier = false,
  33                                     readsStackTop = true,
  34                                     writesStackTop = false},
  35                prototype = (prototype, NONE),
  36                return = Type.unit,
  37                symbolScope = SymbolScope.Private,
  38                target = Target.Direct name}
  39       in
  40          val profileEnter = fn () =>
  41             make {args = Vector.new1 (Type.gcState ()),
  42                   name = "GC_profileEnter",
  43                   prototype = Vector.new1 CType.gcState}
  44          val profileInc = fn () =>
  45             make {args = Vector.new2 (Type.gcState (), Type.csize ()),
  46                   name = "GC_profileInc",
  47                   prototype = Vector.new2 (CType.gcState, CType.csize ())}
  48          val profileLeave = fn () =>
  49             make {args = Vector.new1 (Type.gcState ()),
  50                   name = "GC_profileLeave",
  51                   prototype = Vector.new1 CType.gcState}
  52       end
  53    end
  54
  55 type sourceSeq = int list
  56
  57 structure InfoNode =
  58    struct
  59       datatype t = T of {info: SourceInfo.t,
  60                          nameIndex: int,
  61                          sourcesIndex: int,
  62                          successors: t list ref}
  63
  64       local
  65          fun make f (T r) = f r
  66       in
  67          val info = make #info
  68          val sourcesIndex = make #sourcesIndex
  69       end
  70
  71       fun layout (T {info, ...}) =
  72          Layout.record [("info", SourceInfo.layout info)]
  73
  74       fun equals (n: t, n': t): bool = SourceInfo.equals (info n, info n')
  75
  76       fun call {from = T {successors, ...},
  77                 to as T {info = i', ...}} =
  78          if let
  79                open SourceInfo
  80             in
  81                equals (i', gc)
  82                orelse equals (i', main)
  83                orelse equals (i', unknown)
  84             end orelse List.exists (!successors, fn n => equals (n, to))
  85             then ()
  86          else List.push (successors, to)
  87
  88       val call =
  89          Trace.trace ("Profile.InfoNode.call",
  90                       fn {from, to} =>
  91                       Layout.record [("from", layout from),
  92                                      ("to", layout to)],
  93                       Unit.layout)
  94          call
  95    end
  96
  97 structure FuncInfo =
  98    struct
  99       datatype t = T of {callers: InfoNode.t list ref,
 100                          enters: InfoNode.t list ref,
 101                          seen: bool ref,
 102                          tailCalls: t list ref}
 103
 104       fun new () = T {callers = ref [],
 105                       enters = ref [],
 106                       seen = ref false,
 107                       tailCalls = ref []}
 108    end
 109
 110 structure Push =
 111    struct
 112       datatype t =
 113          Enter of InfoNode.t
 114        | Skip of SourceInfo.t
 115
 116       fun layout z =
 117          let
 118             open Layout
 119          in
 120             case z of
 121                Enter n => seq [str "Enter ", InfoNode.layout n]
 122              | Skip i => seq [str "Skip ", SourceInfo.layout i]
 123          end
 124
 125       fun toSources (ps: t list): int list =
 126          List.fold (rev ps, [], fn (p, ac) =>
 127                     case p of
 128                        Enter (InfoNode.T {sourcesIndex, ...}) =>
 129                           sourcesIndex :: ac
 130                      | Skip _ => ac)
 131    end
 132
 133 val traceEnter =
 134    Trace.trace2 ("Profile.enter",
 135                  List.layout Push.layout,
 136                  SourceInfo.layout,
 137                  Layout.tuple2 (List.layout Push.layout, Bool.layout))
 138
 139 fun doit program =
 140    if !Control.profile = Control.ProfileNone
 141       then (program, fn _ => NONE)
 142    else
 143    let
 144       val Program.T {functions, handlesSignals, main, objectTypes} = program
 145       val debug = false
 146       datatype z = datatype Control.profile
 147       val profile = !Control.profile
 148       val profileStack: bool = !Control.profileStack
 149       val needProfileLabels: bool =
 150          profile = ProfileTimeLabel orelse profile = ProfileLabel
 151       val needCodeCoverage: bool =
 152          needProfileLabels orelse (profile = ProfileTimeField)
 153       val frameProfileIndices: (Label.t * int) list ref = ref []
 154       val infoNodes: InfoNode.t list ref = ref []
 155       val nameCounter = Counter.new 0
 156       val names: string list ref = ref []
 157       local
 158          val sourceCounter = Counter.new 0
 159          val sep =
 160             if profile = ProfileCallStack
 161                then " "
 162             else "\t"
 163          val {get = nameIndex, ...} =
 164             Property.get (SourceInfo.plist,
 165                           Property.initFun
 166                           (fn si =>
 167                            (List.push (names, SourceInfo.toString' (si, sep))
 168                             ; Counter.next nameCounter)))
 169       in
 170          fun sourceInfoNode (si: SourceInfo.t) =
 171             let
 172                val infoNode =
 173                   InfoNode.T {info = si,
 174                               nameIndex = nameIndex si,
 175                               sourcesIndex = Counter.next sourceCounter,
 176                               successors = ref []}
 177                val _ = List.push (infoNodes, infoNode)
 178             in
 179                infoNode
 180             end
 181       end
 182       fun firstEnter (ps: Push.t list): InfoNode.t option =
 183          List.peekMap (ps, fn p =>
 184                        case p of
 185                           Push.Enter n => SOME n
 186                         | _ => NONE)
 187       (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
 188       val unknownInfoNode = sourceInfoNode SourceInfo.unknown
 189       (* gc must be 1 which == SOURCES_INDEX_GC from gc.h *)
 190       val gcInfoNode = sourceInfoNode SourceInfo.gc
 191       val mainInfoNode = sourceInfoNode SourceInfo.main
 192       fun wantedSource (si: SourceInfo.t): bool =
 193          if SourceInfo.isC si
 194             then List.length (!Control.profileC) > 0
 195             else (case SourceInfo.file si of
 196                      NONE => true
 197                    | SOME file =>
 198                         List.foldr
 199                         (!Control.profileInclExcl, true,
 200                          fn ((re, keep), b) =>
 201                          if Regexp.Compiled.matchesAll (re, file)
 202                             then keep
 203                             else b))
 204       val wantedSource =
 205          Trace.trace ("Profile.wantedSource", SourceInfo.layout, Bool.layout)
 206          wantedSource
 207       fun wantedCSource (si: SourceInfo.t): bool =
 208          wantedSource si
 209          andalso
 210          if SourceInfo.isC si
 211             then false
 212             else (case SourceInfo.file si of
 213                      NONE => false
 214                    | SOME file =>
 215                         List.foldr
 216                         (!Control.profileC, false,
 217                          fn (re, b) =>
 218                          if Regexp.Compiled.matchesAll (re, file)
 219                             then true
 220                             else b))
 221       val wantedCSource =
 222          Trace.trace ("Profile.wantedCSource", SourceInfo.layout, Bool.layout)
 223          wantedCSource
 224       fun keepSource (si: SourceInfo.t): bool =
 225          profile <> ProfileCount
 226          orelse wantedSource si
 227       val keepSource =
 228          Trace.trace ("Profile.keepSource", SourceInfo.layout, Bool.layout)
 229          keepSource
 230       (* With -profile count, we want to get zero counts for all functions,
 231        * whether or not they made it into the final executable.
 232        *)
 233       val () =
 234          case profile of
 235             ProfileCount =>
 236                List.foreach (SourceInfo.all (), fn si =>
 237                              if wantedSource si
 238                                 then ignore (sourceInfoNode si)
 239                              else ())
 240           | _ => ()
 241       val sourceInfoNode =
 242          fn si =>
 243          let
 244             open SourceInfo
 245          in
 246             if equals (si, unknown)
 247                then unknownInfoNode
 248             else if equals (si, gc)
 249                then gcInfoNode
 250             else if equals (si, main)
 251                then mainInfoNode
 252             else sourceInfoNode si
 253          end
 254       val sourceInfoNode =
 255          Trace.trace ("Profile.sourceInfoNode", SourceInfo.layout, InfoNode.layout)
 256          sourceInfoNode
 257       local
 258          val table: {hash: word,
 259                      index: int,
 260                      sourceSeq: int vector} HashSet.t =
 261             HashSet.new {hash = #hash}
 262          val c = Counter.new 0
 263          val sourceSeqs: int vector list ref = ref []
 264       in
 265          fun sourceSeqIndex (s: sourceSeq): int =
 266             let
 267                val s = Vector.fromListRev s
 268                val hash =
 269                   Vector.fold (s, 0w0, fn (i, w) =>
 270                                w * 0w31 + Word.fromInt i)
 271             in
 272                #index
 273                (HashSet.lookupOrInsert
 274                 (table, hash,
 275                  fn {sourceSeq = s', ...} => s = s',
 276                  fn () => let
 277                              val _ = List.push (sourceSeqs, s)
 278                           in
 279                              {hash = hash,
 280                               index = Counter.next c,
 281                               sourceSeq = s}
 282                           end))
 283             end
 284          fun makeSourceSeqs () = Vector.fromListRev (!sourceSeqs)
 285       end
 286       (* Ensure that [SourceInfo.unknown] is index 0. *)
 287       val _ = sourceSeqIndex [InfoNode.sourcesIndex unknownInfoNode]
 288       (* Ensure that [SourceInfo.gc] is index 1. *)
 289       val _ = sourceSeqIndex [InfoNode.sourcesIndex gcInfoNode]
 290       fun addFrameProfileIndex (label: Label.t,
 291                                 index: int): unit =
 292          List.push (frameProfileIndices, (label, index))
 293       fun addFrameProfilePushes (label: Label.t,
 294                                  pushes: Push.t list): unit =
 295          addFrameProfileIndex (label,
 296                                sourceSeqIndex (Push.toSources pushes))
 297       val {get = labelInfo: Label.t -> {block: Block.t,
 298                                         visited1: bool ref,
 299                                         visited2: bool ref},
 300            set = setLabelInfo, ...} =
 301          Property.getSetOnce
 302          (Label.plist, Property.initRaise ("info", Label.layout))
 303       val labels = ref []
 304       fun profileLabelFromIndex (sourceSeqsIndex: int): Statement.t =
 305          let
 306             val l = ProfileLabel.new ()
 307             val _ = List.push (labels, {label = l,
 308                                         sourceSeqsIndex = sourceSeqsIndex})
 309          in
 310             Statement.ProfileLabel l
 311          end
 312       fun setCurSourceSeqsIndexFromIndex (sourceSeqsIndex: int): Statement.t =
 313          let
 314             val curSourceSeqsIndex =
 315                Operand.Runtime Runtime.GCField.CurSourceSeqsIndex
 316          in
 317             Statement.Move
 318             {dst = curSourceSeqsIndex,
 319              src = Operand.word (WordX.fromIntInf
 320                                  (IntInf.fromInt sourceSeqsIndex,
 321                                   WordSize.word32))}
 322          end
 323       fun codeCoverageStatementFromIndex (sourceSeqsIndex: int): Statement.t =
 324          if needProfileLabels
 325             then profileLabelFromIndex sourceSeqsIndex
 326          else if profile = ProfileTimeField
 327             then setCurSourceSeqsIndexFromIndex sourceSeqsIndex
 328          else Error.bug "Profile.codeCoverageStatement"
 329       fun codeCoverageStatement (sourceSeq: int list): Statement.t =
 330          codeCoverageStatementFromIndex (sourceSeqIndex sourceSeq)
 331       local
 332          val {get: Func.t -> FuncInfo.t, ...} =
 333             Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
 334       in
 335          val funcInfo = get
 336          fun addFuncEdges () =
 337             (* Don't need to add edges for main because no one calls it. *)
 338             List.foreach
 339             (functions, fn f =>
 340              let
 341                 val allSeen: bool ref list ref = ref []
 342                 val func = Function.name f
 343                 val fi as FuncInfo.T {callers, ...} = get func
 344                 (* Add edges from all the callers to the enters in f and all
 345                  * functions that f tail calls.
 346                  *)
 347                 fun call (FuncInfo.T {enters, seen, tailCalls, ...}): unit =
 348                    if !seen
 349                       then ()
 350                    else
 351                       let
 352                          val _ = seen := true
 353                          val _ = List.push (allSeen, seen)
 354                          val _ =
 355                             List.foreach
 356                             (!callers, fn from =>
 357                              List.foreach
 358                              (!enters, fn to =>
 359                               InfoNode.call {from = from, to = to}))
 360                       in
 361                          List.foreach (!tailCalls, call)
 362                       end
 363                 val _ = call fi
 364                 val _ = List.foreach (!allSeen, fn r => r := false)
 365              in
 366                 ()
 367              end)
 368       end
 369       fun doFunction (f: Function.t): Function.t =
 370          let
 371             val {args, blocks, name, raises, returns, start} = Function.dest f
 372             val _ =
 373                if not debug
 374                   then ()
 375                else print (concat ["doFunction ", Func.toString name, "\n"])
 376             val FuncInfo.T {enters, tailCalls, ...} = funcInfo name
 377             fun enter (ps: Push.t list, si: SourceInfo.t): Push.t list * bool =
 378                let
 379                   val node = Promise.lazy (fn () => sourceInfoNode si)
 380                   fun yes () = (Push.Enter (node ()) :: ps, true)
 381                   fun no () = (Push.Skip si :: ps, false)
 382                in
 383                   if SourceInfo.equals (si, SourceInfo.unknown)
 384                      then no ()
 385                   else
 386                      case firstEnter ps of
 387                         NONE =>
 388                            if keepSource si
 389                               then (List.push (enters, node ())
 390                                     ; yes ())
 391                            else no ()
 392                       | SOME (node' as InfoNode.T {info = si', ...}) =>
 393                            (*
 394                             * si  : callee
 395                             * si' : caller
 396                             *)
 397                            if keepSource si
 398                               andalso
 399                               let
 400                                  open SourceInfo
 401                               in
 402                                  equals (si', unknown)
 403                                  orelse
 404                                  (wantedSource si
 405                                   andalso
 406                                   not (equals (si, gcArrayAllocate))
 407                                   andalso
 408                                   (not (isC si)
 409                                    orelse
 410                                    (wantedCSource si'
 411                                     andalso not (equals (si', main)))))
 412                               end
 413                               then (InfoNode.call {from = node', to = node ()}
 414                                     ; yes ())
 415                            else no ()
 416                end
 417             val enter = traceEnter enter
 418             val _ =
 419                Vector.foreach
 420                (blocks, fn block as Block.T {label, ...} =>
 421                 setLabelInfo (label, {block = block,
 422                                       visited1 = ref false,
 423                                       visited2 = ref false}))
 424             (* Find the first Enter statement and (conceptually) move it to the
 425              * front of the function.
 426              *)
 427             local
 428                exception Yes of Label.t * Statement.t
 429                fun goto l =
 430                   let
 431                      val {block, visited1, ...} = labelInfo l
 432                   in
 433                      if !visited1
 434                         then ()
 435                      else
 436                         let
 437                            val () = visited1 := true
 438                            val Block.T {statements, transfer, ...} = block
 439                            val () =
 440                               Vector.foreach
 441                               (statements, fn s =>
 442                                case s of
 443                                   Statement.Profile (ProfileExp.Enter _) =>
 444                                      raise Yes (l, s)
 445                                 | _ => ())
 446                            val () = Transfer.foreachLabel (transfer, goto)
 447                         in
 448                            ()
 449                         end
 450                   end
 451             in
 452                val first = (goto start; NONE) handle Yes z => SOME z
 453             end
 454             val blocks = ref []
 455             datatype z = datatype Statement.t
 456             datatype z = datatype ProfileExp.t
 457             fun backward {args,
 458                           kind,
 459                           label,
 460                           leaves,
 461                           sourceSeq: int list,
 462                           statements: Statement.t list,
 463                           transfer: Transfer.t}: unit =
 464                let
 465                   val (_, ncc, sourceSeq, statements) =
 466                      List.fold
 467                      (statements,
 468                       (leaves, true, sourceSeq, []),
 469                       fn (s, (leaves, ncc, sourceSeq, ss)) =>
 470                       case s of
 471                          Object _ => (leaves, true, sourceSeq, s :: ss)
 472                        | Profile ps =>
 473                             let
 474                                val (ncc, ss) =
 475                                   if needCodeCoverage
 476                                      then
 477                                         if ncc
 478                                            andalso not (List.isEmpty sourceSeq)
 479                                            then (false,
 480                                                  codeCoverageStatement sourceSeq :: ss)
 481                                         else (true, ss)
 482                                   else (false, ss)
 483                                val (leaves, sourceSeq) =
 484                                   case ps of
 485                                      Enter _ =>
 486                                         (case sourceSeq of
 487                                             [] => Error.bug
 488                                                   "Profile.backward: unmatched Enter"
 489                                           | _ :: sis => (leaves, sis))
 490                                    | Leave _ =>
 491                                         (case leaves of
 492                                             [] => Error.bug
 493                                                   "Profile.backward: missing Leave"
 494                                           | infoNode :: leaves =>
 495                                                (leaves,
 496                                                 InfoNode.sourcesIndex infoNode
 497                                                 :: sourceSeq))
 498                             in
 499                                (leaves, ncc, sourceSeq, ss)
 500                             end
 501                        | _ => (leaves, true, sourceSeq, s :: ss))
 502                   val statements =
 503                      if needCodeCoverage
 504                         andalso ncc
 505                         then codeCoverageStatement sourceSeq :: statements
 506                      else statements
 507                   val {args, kind, label} =
 508                      if profileStack andalso (case kind of
 509                                                  Kind.Cont _ => true
 510                                                | Kind.Handler => true
 511                                                | _ => false)
 512                         then
 513                            let
 514                               val func = CFunction.profileLeave ()
 515                               val newLabel = Label.newNoname ()
 516                               val _ =
 517                                  addFrameProfileIndex
 518                                  (newLabel, sourceSeqIndex sourceSeq)
 519                               val statements =
 520                                  if needCodeCoverage
 521                                     then (Vector.new1
 522                                           (codeCoverageStatement sourceSeq))
 523                                  else Vector.new0 ()
 524                               val _ =
 525                                  List.push
 526                                  (blocks,
 527                                   Block.T
 528                                   {args = args,
 529                                    kind = kind,
 530                                    label = label,
 531                                    statements = statements,
 532                                    transfer =
 533                                    Transfer.CCall
 534                                    {args = Vector.new1 Operand.GCState,
 535                                     func = func,
 536                                     return = SOME newLabel}})
 537                            in
 538                               {args = Vector.new0 (),
 539                                kind = Kind.CReturn {func = func},
 540                                label = newLabel}
 541                            end
 542                      else
 543                         {args = args,
 544                          kind = kind,
 545                          label = label}
 546                in
 547                   List.push (blocks,
 548                              Block.T {args = args,
 549                                       kind = kind,
 550                                       label = label,
 551                                       statements = Vector.fromList statements,
 552                                       transfer = transfer})
 553                end
 554             val backward =
 555                Trace.trace
 556                ("Profile.backward",
 557                 fn {leaves, statements, sourceSeq, ...} =>
 558                 let
 559                    open Layout
 560                 in
 561                    record [("leaves", List.layout InfoNode.layout leaves),
 562                            ("sourceSeq", List.layout Int.layout sourceSeq),
 563                            ("statements",
 564                             List.layout Statement.layout statements)]
 565                 end,
 566                 Unit.layout)
 567                backward
 568             fun profileEnter (pushes: Push.t list,
 569                               transfer: Transfer.t): Transfer.t =
 570                let
 571                   val func = CFunction.profileEnter ()
 572                   val newLabel = Label.newNoname ()
 573                   val index = sourceSeqIndex (Push.toSources pushes)
 574                   val _ = addFrameProfileIndex (newLabel, index)
 575                   val statements =
 576                      if needCodeCoverage
 577                         then Vector.new1 (codeCoverageStatementFromIndex index)
 578                      else Vector.new0 ()
 579                   val _ =
 580                      List.push
 581                      (blocks,
 582                       Block.T {args = Vector.new0 (),
 583                                kind = Kind.CReturn {func = func},
 584                                label = newLabel,
 585                                statements = statements,
 586                                transfer = transfer})
 587                in
 588                   Transfer.CCall {args = Vector.new1 Operand.GCState,
 589                                   func = func,
 590                                   return = SOME newLabel}
 591                end
 592             fun goto (l: Label.t, pushes: Push.t list): unit =
 593                let
 594                   val _ =
 595                      if not debug
 596                         then ()
 597                      else
 598                      let
 599                         open Layout
 600                      in
 601                         outputl (seq [str "goto (",
 602                                       Label.layout l,
 603                                       str ", ",
 604                                       List.layout Push.layout pushes,
 605                                       str ")"],
 606                                  Out.error)
 607                      end
 608                   val {block, visited2, ...} = labelInfo l
 609                in
 610                   if !visited2
 611                      then ()
 612                   else
 613                      let
 614                         val _ = visited2 := true
 615                         val Block.T {args, kind, label, statements, transfer,
 616                                      ...} = block
 617                         val statements =
 618                            case first of
 619                               NONE => statements
 620                             | SOME (firstLabel, firstEnter) =>
 621                                  if Label.equals (label, firstLabel)
 622                                     then
 623                                        Vector.removeFirst
 624                                        (statements, fn s =>
 625                                         case s of
 626                                            Profile (Enter _) => true
 627                                          | _ => false)
 628                                  else if Label.equals (label, start)
 629                                          then
 630                                             Vector.concat
 631                                             [Vector.new1 firstEnter,
 632                                              statements]
 633                                       else statements
 634                         val _ =
 635                            let
 636                               fun add pushes =
 637                                  addFrameProfilePushes (label, pushes)
 638                               datatype z = datatype Kind.t
 639                            in
 640                               case kind of
 641                                  Cont _ => add pushes
 642                                | CReturn {func, ...} =>
 643                                     let
 644                                        datatype z = datatype CFunction.Target.t
 645                                        val target = CFunction.target func
 646                                        fun doit si =
 647                                           add (#1 (enter (pushes, si)))
 648                                     in
 649                                        case target of
 650                                           Direct "GC_collect" => doit SourceInfo.gc
 651                                         | Direct "GC_arrayAllocate" =>
 652                                              doit SourceInfo.gcArrayAllocate
 653                                         | Direct "MLton_bug" => add pushes
 654                                         | Direct name => doit (SourceInfo.fromC name)
 655                                         | Indirect => doit (SourceInfo.fromC "<indirect>")
 656                                     end
 657                                | Handler => add pushes
 658                                | Jump => ()
 659                            end
 660                         fun maybeSplit {args,
 661                                         bytesAllocated: Bytes.t,
 662                                         kind,
 663                                         label,
 664                                         leaves,
 665                                         pushes: Push.t list,
 666                                         shouldSplit: bool,
 667                                         statements} =
 668                            if not shouldSplit
 669                               then {args = args,
 670                                     bytesAllocated = Bytes.zero,
 671                                     kind = kind,
 672                                     label = label,
 673                                     leaves = leaves,
 674                                     statements = statements}
 675                            else
 676                               let
 677                                  val newLabel = Label.newNoname ()
 678                                  val _ =
 679                                     addFrameProfilePushes (newLabel, pushes)
 680                                  val func = CFunction.profileInc ()
 681                                  val amount =
 682                                     case profile of
 683                                        ProfileAlloc => Bytes.toInt bytesAllocated
 684                                      | ProfileCount => 1
 685                                      | _ => Error.bug "Profile.maybeSplit: amount"
 686                                  val transfer =
 687                                     Transfer.CCall
 688                                     {args = (Vector.new2
 689                                              (Operand.GCState,
 690                                               Operand.word
 691                                               (WordX.fromIntInf
 692                                                (IntInf.fromInt amount,
 693                                                 WordSize.csize ())))),
 694                                      func = func,
 695                                      return = SOME newLabel}
 696                                  val sourceSeq = Push.toSources pushes
 697                                  val _ =
 698                                     backward {args = args,
 699                                               kind = kind,
 700                                               label = label,
 701                                               leaves = leaves,
 702                                               sourceSeq = sourceSeq,
 703                                               statements = statements,
 704                                               transfer = transfer}
 705                               in
 706                                  {args = Vector.new0 (),
 707                                   bytesAllocated = Bytes.zero,
 708                                   kind = Kind.CReturn {func = func},
 709                                   label = newLabel,
 710                                   leaves = [],
 711                                   statements = []}
 712                               end
 713                         val {args, bytesAllocated, kind, label, leaves, pushes,
 714                              statements} =
 715                            Vector.fold
 716                            (statements,
 717                             {args = args,
 718                              bytesAllocated = Bytes.zero,
 719                              kind = kind,
 720                              label = label,
 721                              leaves = [],
 722                              pushes = pushes,
 723                              statements = []},
 724                             fn (s, {args, bytesAllocated, kind, label,
 725                                     leaves,
 726                                     pushes: Push.t list,
 727                                     statements}) =>
 728                             (if not debug
 729                                 then ()
 730                              else
 731                                 let
 732                                    open Layout
 733                                 in
 734                                    outputl
 735                                    (seq [List.layout Push.layout pushes,
 736                                          str " ",
 737                                          Statement.layout s],
 738                                     Out.error)
 739                                 end
 740                              ;
 741                             case s of
 742                                Object {size, ...} =>
 743                                   {args = args,
 744                                    bytesAllocated = Bytes.+ (bytesAllocated, size),
 745                                    kind = kind,
 746                                    label = label,
 747                                    leaves = leaves,
 748                                    pushes = pushes,
 749                                    statements = s :: statements}
 750                              | Profile ps =>
 751                                   let
 752                                      val shouldSplit =
 753                                         profile = ProfileAlloc
 754                                         andalso Bytes.> (bytesAllocated,
 755                                                          Bytes.zero)
 756                                      val {args, bytesAllocated, kind, label,
 757                                           leaves, statements} =
 758                                         maybeSplit
 759                                         {args = args,
 760                                          bytesAllocated = bytesAllocated,
 761                                          kind = kind,
 762                                          label = label,
 763                                          leaves = leaves,
 764                                          pushes = pushes,
 765                                          shouldSplit = shouldSplit,
 766                                          statements = statements}
 767                                      datatype z = datatype ProfileExp.t
 768                                      val (pushes, keep, leaves) =
 769                                         case ps of
 770                                            Enter si =>
 771                                               let
 772                                                  val (pushes, keep) =
 773                                                     enter (pushes, si)
 774                                               in
 775                                                  (pushes, keep, leaves)
 776                                               end
 777                                          | Leave si =>
 778                                               (case pushes of
 779                                                   [] => Error.bug
 780                                                         "Profile.goto: unmatched Leave"
 781                                                 | p :: pushes =>
 782                                                      let
 783                                                         val (keep, si', leaves) =
 784                                                            case p of
 785                                                               Push.Enter
 786                                                               (infoNode as
 787                                                                InfoNode.T
 788                                                                {info, ...}) =>
 789                                                                  (true, info,
 790                                                                   infoNode :: leaves)
 791                                                             | Push.Skip si' =>
 792                                                                  (false, si',
 793                                                                   leaves)
 794                                                      in
 795                                                         if SourceInfo.equals (si, si')
 796                                                            then (pushes,
 797                                                                  keep,
 798                                                                  leaves)
 799                                                         else Error.bug
 800                                                              "Profile.goto: mismatched Leave"
 801                                                      end)
 802                                      val shouldSplit =
 803                                         profile = ProfileCount
 804                                         andalso (case ps of
 805                                                     Enter _ => keep
 806                                                   | _ => false)
 807                                      val {args, bytesAllocated, kind, label,
 808                                           leaves, statements} =
 809                                         maybeSplit
 810                                         {args = args,
 811                                          bytesAllocated = bytesAllocated,
 812                                          kind = kind,
 813                                          label = label,
 814                                          leaves = leaves,
 815                                          pushes = pushes,
 816                                          shouldSplit = shouldSplit,
 817                                          statements = statements}
 818                                      val statements =
 819                                         if keep
 820                                            then s :: statements
 821                                         else statements
 822                                   in
 823                                      {args = args,
 824                                       bytesAllocated = bytesAllocated,
 825                                       kind = kind,
 826                                       label = label,
 827                                       leaves = leaves,
 828                                       pushes = pushes,
 829                                       statements = statements}
 830                                   end
 831                              | _ =>
 832                                   {args = args,
 833                                    bytesAllocated = bytesAllocated,
 834                                    kind = kind,
 835                                    label = label,
 836                                    leaves = leaves,
 837                                    pushes = pushes,
 838                                    statements = s :: statements})
 839                             )
 840                         val shouldSplit =
 841                            profile = ProfileAlloc
 842                            andalso Bytes.> (bytesAllocated, Bytes.zero)
 843                         val {args, kind, label, leaves, statements, ...} =
 844                            maybeSplit {args = args,
 845                                        bytesAllocated = bytesAllocated,
 846                                        kind = kind,
 847                                        label = label,
 848                                        leaves = leaves,
 849                                        pushes = pushes,
 850                                        shouldSplit = shouldSplit,
 851                                        statements = statements}
 852                         val _ =
 853                            Transfer.foreachLabel
 854                            (transfer, fn l => goto (l, pushes))
 855                         val transfer =
 856                            case transfer of
 857                               Transfer.Call {func, return, ...} =>
 858                                  let
 859                                     val fi as FuncInfo.T {callers, ...} =
 860                                        funcInfo func
 861                                  in
 862                                     case return of
 863                                        Return.NonTail _ =>
 864                                           let
 865                                              val _ =
 866                                                 case firstEnter pushes of
 867                                                    NONE =>
 868                                                       List.push (tailCalls, fi)
 869                                                  | SOME n =>
 870                                                       List.push (callers, n)
 871                                           in
 872                                              if profileStack
 873                                                 then profileEnter (pushes,
 874                                                                    transfer)
 875                                              else transfer
 876                                           end
 877                                      | _ =>
 878                                           (List.push (tailCalls, fi)
 879                                            ; transfer)
 880                                  end
 881                             | _ => transfer
 882                      in
 883                         backward {args = args,
 884                                   kind = kind,
 885                                   label = label,
 886                                   leaves = leaves,
 887                                   sourceSeq = Push.toSources pushes,
 888                                   statements = statements,
 889                                   transfer = transfer}
 890                      end
 891                end
 892             val _ = goto (start, [])
 893             val blocks = Vector.fromList (!blocks)
 894          in
 895             Function.new {args = args,
 896                           blocks = blocks,
 897                           name = name,
 898                           raises = raises,
 899                           returns = returns,
 900                           start = start}
 901          end
 902       val program = Program.T {functions = List.revMap (functions, doFunction),
 903                                handlesSignals = handlesSignals,
 904                                main = doFunction main,
 905                                objectTypes = objectTypes}
 906       val _ = addFuncEdges ()
 907       val names = Vector.fromListRev (!names)
 908       val sources =
 909          Vector.map
 910          (Vector.fromListRev (!infoNodes),
 911           fn InfoNode.T {nameIndex, successors, ...} =>
 912           {nameIndex = nameIndex,
 913            successorsIndex = (sourceSeqIndex
 914                               (List.revMap (!successors,
 915                                             InfoNode.sourcesIndex)))})
 916       (* makeSourceSeqs () must happen after making sources, since that creates
 917        * new sourceSeqs.
 918        *)
 919       val sourceSeqs = makeSourceSeqs ()
 920       fun makeProfileInfo {frames} =
 921          let
 922             val {get, set, ...} =
 923                Property.getSetOnce
 924                (Label.plist,
 925                 Property.initRaise ("frameProfileIndex", Label.layout))
 926             val _ =
 927                List.foreach (!frameProfileIndices, fn (l, i) =>
 928                              set (l, i))
 929             val frameSources = Vector.map (frames, get)
 930          in
 931             SOME (Machine.ProfileInfo.T
 932                   {frameSources = frameSources,
 933                    labels = Vector.fromList (!labels),
 934                    names = names,
 935                    sourceSeqs = sourceSeqs,
 936                    sources = sources})
 937          end
 938    in
 939       (program, makeProfileInfo)
 940    end
 941
 942 end