mlton/control/control.sml

   1 (* Copyright (C) 2009,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 structure Control: CONTROL =
  11 struct
  12
  13 open ControlFlags
  14
  15 structure Verbosity =
  16    struct
  17       datatype t = datatype verbosity
  18
  19       val op <= =
  20          fn (Silent, _) => true
  21           | (Top, Silent) => false
  22           | (Top, _) => true
  23           | (Pass, Pass) => true
  24           | (_, Detail) => true
  25           | _ => false
  26    end
  27
  28 datatype style = No | Assembly | C | Dot | LLVM | ML
  29
  30 val preSuf =
  31    fn No => ("", "")
  32     | Assembly => ("/* ", " */")
  33     | C => ("/* ", " */")
  34     | Dot => ("// ", "")
  35     | LLVM => ("; ", "")
  36     | ML => ("(* ", " *)")
  37
  38 fun outputHeader (style: style, output: Layout.t -> unit) =
  39    let
  40       val (pre, suf) = preSuf style
  41       val lines =
  42          Version.banner
  43          :: concat ["  created this file on ", Date.toString (Date.now ()), "."]
  44          :: "Do not edit this file."
  45          :: "Flag settings: "
  46          :: (List.map (all (), fn {name, value} =>
  47                        concat ["   ", name, ": ", value]))
  48    in List.foreach (lines, fn l => output (Layout.str (concat [pre, l, suf])))
  49    end
  50
  51 fun outputHeader' (style, out: Out.t) =
  52    outputHeader (style, fn l =>
  53                  (Layout.output (l, out);
  54                   Out.newline out))
  55
  56 val depth: int ref = ref 0
  57 fun getDepth () = !depth
  58 fun indent () = depth := !depth + 3
  59 fun unindent () = depth := !depth - 3
  60
  61 fun message (verb: Verbosity.t, th: unit -> Layout.t): unit =
  62    if Verbosity.<= (verb, !verbosity)
  63       then let
  64               val out = Out.error
  65               val lay = th ()
  66            in
  67               if Layout.isEmpty lay
  68                  then ()
  69               else (Layout.output (Layout.indent (lay, !depth), out)
  70                     ; Out.newline out)
  71            end
  72    else ()
  73
  74 fun messageStr (verb, s: string): unit =
  75    message (verb, fn () => Layout.str s)
  76
  77 fun time () =
  78    let
  79       open Time
  80       val {children, self, gc, ...} = times ()
  81       fun add {utime, stime} = utime + stime
  82    in
  83       (add self + add children, add gc)
  84    end
  85
  86 fun timeToString {total, gc} =
  87    let
  88       fun fmt (x, n) = Real.format (x, Real.Format.fix (SOME n))
  89       val toReal = Real.fromIntInf o Time.toMilliseconds
  90       val per =
  91          if Time.equals (total, Time.zero)
  92             then "0"
  93          else fmt (100.0 * (toReal gc / toReal total), 0)
  94       fun t2s t =
  95          fmt (Real./ (toReal t, 1000.0), 2)
  96    in concat [t2s (Time.- (total, gc)), " + ", t2s gc, " (", per, "% GC)"]
  97    end
  98
  99 fun trace (verb, name: string) (f: 'a -> 'b) (a: 'a): 'b =
 100    if Verbosity.<= (verb, !verbosity)
 101       then
 102          let
 103             val _ = messageStr (verb, concat [name, " starting"])
 104             val (t, gc) = time ()
 105             val _ = indent ()
 106             fun done () =
 107                let
 108                   val _ = unindent ()
 109                   val (t', gc') = time ()
 110                in
 111                   timeToString {total = Time.- (t', t),
 112                                 gc = Time.- (gc', gc)}
 113                end
 114          in (f a
 115              before messageStr (verb, concat [name, " finished in ", done ()]))
 116             handle e =>
 117                (messageStr (verb, concat [name, " raised in ", done ()])
 118                 ; messageStr (verb, concat [name, " raised: ", Exn.toString e])
 119                 ; (case Exn.history e of
 120                       [] => ()
 121                     | history =>
 122                          (messageStr (verb, concat [name, " raised with history: "])
 123                           ; indent ()
 124                           ; (List.foreach
 125                              (history, fn s =>
 126                               messageStr (verb, s)))
 127                           ; unindent ()))
 128                 ; raise e)
 129          end
 130    else
 131       f a
 132
 133 type traceAccum = {verb: verbosity,
 134                    total: Time.t ref,
 135                    totalGC: Time.t ref}
 136
 137 val traceAccum: (verbosity * string) -> (traceAccum * (unit -> unit)) =
 138    fn (verb, name) =>
 139    let
 140      val total = ref Time.zero
 141      val totalGC = ref Time.zero
 142    in
 143      ({verb = verb, total = total, totalGC = totalGC},
 144       fn () => messageStr (verb,
 145                            concat [name,
 146                                    " totals ",
 147                                    timeToString
 148                                    {total = !total,
 149                                     gc = !totalGC}]))
 150    end
 151
 152 val ('a, 'b) traceAdd: (traceAccum * string) -> ('a -> 'b) -> 'a -> 'b =
 153    fn ({verb, total, totalGC}, name) =>
 154    fn f =>
 155    fn a =>
 156    if Verbosity.<= (verb, !verbosity)
 157      then let
 158             val (t, gc) = time ()
 159             fun done ()
 160               = let
 161                   val (t', gc') = time ()
 162                 in
 163                   total := Time.+ (!total, Time.- (t', t))
 164                   ; totalGC := Time.+ (!totalGC, Time.- (gc', gc))
 165                 end
 166           in
 167             (f a
 168              before done ())
 169             handle e =>
 170                (messageStr (verb, concat [name, " raised"])
 171                 ; (case Exn.history e of
 172                       [] => ()
 173                     | history =>
 174                          (messageStr (verb, concat [name, " raised with history: "])
 175                           ; indent ()
 176                           ; (List.foreach
 177                              (history, fn s =>
 178                               messageStr (verb, s)))
 179                           ; unindent ()))
 180                 ; raise e)
 181           end
 182      else f a
 183
 184 val ('a, 'b) traceBatch: (verbosity * string) -> ('a -> 'b) ->
 185                          (('a -> 'b) * (unit -> unit)) =
 186    fn (verb, name) =>
 187    let
 188      val (ta,taMsg) = traceAccum (verb, name)
 189    in
 190      fn f =>
 191      (traceAdd (ta,name) f, taMsg)
 192    end
 193
 194 (*------------------------------------*)
 195 (*               Errors               *)
 196 (*------------------------------------*)
 197
 198 val numErrors: int ref = ref 0
 199
 200 val errorThreshhold: int ref = ref 20
 201
 202 val die = Process.fail
 203
 204 local
 205    fun msg (kind: string, r: Region.t, msg: Layout.t, extra: Layout.t): unit =
 206       let
 207          open Layout
 208          val r = Region.toString r
 209          val msg = Layout.toString msg
 210          val msg =
 211             Layout.str
 212             (concat [String.fromChar (Char.toUpper (String.sub (msg, 0))),
 213                      String.dropPrefix (msg, 1),
 214                      "."])
 215          in
 216             outputl (align [seq [str (concat [kind, ": "]), str r, str "."],
 217                             indent (align [msg,
 218                                            indent (extra, 2)],
 219                                     2)],
 220                      Out.error)
 221       end
 222 in
 223    fun warning (r, m, e) = msg ("Warning", r, m, e)
 224    fun error (r, m, e) =
 225       let
 226          val _ = Int.inc numErrors
 227          val _ = msg ("Error", r, m, e)
 228       in
 229          if !numErrors = !errorThreshhold
 230             then die "compilation aborted: too many errors"
 231          else ()
 232       end
 233 end
 234
 235 fun errorStr (r, msg) = error (r, Layout.str msg, Layout.empty)
 236
 237 fun checkForErrors (name: string) =
 238    if !numErrors > 0
 239       then die (concat ["compilation aborted: ", name, " reported errors"])
 240    else ()
 241
 242 fun checkFile (f: File.t, {fail: string -> 'a, name, ok: unit -> 'a}): 'a = let
 243    fun check (test, msg, k) =
 244       if test f then
 245          k ()
 246       else
 247          fail (concat ["File ", name, " ", msg])
 248    in
 249       check (File.doesExist, "does not exist", fn () =>
 250              check (File.canRead, "cannot be read", ok))
 251    end
 252
 253 (*---------------------------------------------------*)
 254 (*                  Compiler Passes                  *)
 255 (*---------------------------------------------------*)
 256
 257 datatype 'a display =
 258    NoDisplay
 259   | Layout of 'a -> Layout.t
 260   | Layouts of 'a * (Layout.t -> unit) -> unit
 261
 262 fun 'a sizeMessage (name: string, a: 'a): Layout.t =
 263    let open Layout
 264    in str (concat [name, " size = ",
 265                    Int.toCommaString (MLton.size a), " bytes"])
 266    end
 267
 268 val diagnosticWriter: (Layout.t -> unit) option ref = ref NONE
 269
 270 fun diagnostics f =
 271    case !diagnosticWriter of
 272       NONE => ()
 273     | SOME w => f w
 274
 275 fun diagnostic f = diagnostics (fn disp => disp (f ()))
 276
 277 fun saveToFile ({suffix: string},
 278                 style,
 279                 a: 'a,
 280                 d: 'a display): unit =
 281    let
 282       fun doit f =
 283          trace (Pass, "display")
 284          Ref.fluidLet
 285          (inputFile, concat [!inputFile, ".", suffix], fn () =>
 286           File.withOut (!inputFile, fn out =>
 287                         f (fn l => (Layout.outputl (l, out)))))
 288    in
 289       case d of
 290          NoDisplay => ()
 291        | Layout layout =>
 292             doit (fn output =>
 293                   (outputHeader (style, output)
 294                    ; output (layout a)))
 295        | Layouts layout =>
 296             doit (fn output =>
 297                   (outputHeader (style, output)
 298                    ; layout (a, output)))
 299    end
 300
 301 fun maybeSaveToFile ({name: string, suffix: string},
 302                      style: style,
 303                      a: 'a,
 304                      d: 'a display): unit =
 305    if not (List.exists (!keepPasses, fn re =>
 306                         Regexp.Compiled.matchesAll (re, name)))
 307       then ()
 308    else saveToFile ({suffix = concat [name, ".", suffix]}, style, a, d)
 309
 310 (* Code for diagnosing a pass. *)
 311 val wrapDiagnosing =
 312    fn {name: string,
 313        thunk: unit -> 'a} =>
 314    if not (List.exists (!diagPasses, fn re =>
 315                         Regexp.Compiled.matchesAll (re, name)))
 316       then thunk
 317    else fn () =>
 318         let
 319            val result = ref NONE
 320            val _ =
 321               saveToFile
 322               ({suffix = concat [name, ".diagnostic"]}, No, (),
 323                Layouts (fn ((), disp) =>
 324                         (diagnosticWriter := SOME disp
 325                          ; result := SOME (thunk ())
 326                          ; diagnosticWriter := NONE)))
 327         in
 328            valOf (!result)
 329         end
 330
 331 (* Code for profiling a pass. *)
 332 val wrapProfiling =
 333    fn {name: string,
 334        thunk: unit -> 'a} =>
 335    if MLton.Profile.isOn
 336       then if not (List.exists (!profPasses, fn re =>
 337                                 Regexp.Compiled.matchesAll (re, name)))
 338               then thunk
 339            else fn () =>
 340                 let
 341                    open MLton.Profile
 342                    val d = Data.malloc ()
 343                 in
 344                    Exn.finally
 345                    (fn () => withData (d, thunk),
 346                     fn () => (Data.write (d, concat [!inputFile, ".", name, ".mlmon"])
 347                               ; Data.free d))
 348                 end
 349    else thunk
 350
 351 fun pass {display: 'a display,
 352           name: string,
 353           suffix: string,
 354           stats: 'a -> Layout.t,
 355           style: style,
 356           thunk: unit -> 'a}: 'a =
 357    let
 358       val thunk = wrapDiagnosing {name = name, thunk = thunk}
 359       val thunk = wrapProfiling {name = name, thunk = thunk}
 360       val result = trace (Pass, name) thunk ()
 361       val verb = Detail
 362       val _ = message (verb, fn () => Layout.str (concat [name, " stats"]))
 363       val _ = indent ()
 364       val _ = message (verb, fn () => sizeMessage (suffix, result))
 365       val _ = message (verb, fn () => stats result)
 366       val _ = message (verb, PropertyList.stats)
 367       val _ = message (verb, HashSet.stats)
 368       val _ = unindent ()
 369       val _ = checkForErrors name
 370       val _ = maybeSaveToFile ({name = name, suffix = suffix},
 371                                style, result, display)
 372    in
 373       result
 374    end
 375
 376 fun passTypeCheck {display: 'a display,
 377                    name: string,
 378                    stats: 'a -> Layout.t,
 379                    style: style,
 380                    suffix: string,
 381                    thunk: unit -> 'a,
 382                    typeCheck = tc: 'a -> unit}: 'a =
 383    let
 384       val result = pass {display = display,
 385                          name = name,
 386                          stats = stats,
 387                          style = style,
 388                          suffix = suffix,
 389                          thunk = thunk}
 390       val _ =
 391          if !typeCheck
 392             then trace (Pass, "typeCheck") tc result
 393          else ()
 394    in
 395       result
 396    end
 397
 398 end