src/Pure/ML-Systems/polyml.ML
author wenzelm
Thu Dec 20 21:11:58 2007 +0100 (2007-12-20)
changeset 25732 308315ee2b6d
parent 25125 23d4cab56a7f
child 26084 a7475459c740
permissions -rw-r--r--
added ML-Systems/universal.ML;
wenzelm@2341
     1
(*  Title:      Pure/ML-Systems/polyml.ML
wenzelm@2341
     2
    ID:         $Id$
wenzelm@2341
     3
wenzelm@25732
     4
Compatibility file for Poly/ML (version 4.1.3, 4.1.4, 4.2.0, also shared by 5.x).
wenzelm@2341
     5
*)
wenzelm@2341
     6
wenzelm@23965
     7
use "ML-Systems/exn.ML";
wenzelm@25732
     8
if List.exists (fn s => s = "Universal") (PolyML.Compiler.structureNames ()) then ()
wenzelm@25732
     9
else use "ML-Systems/universal.ML";
wenzelm@24688
    10
use "ML-Systems/multithreading.ML";
wenzelm@24688
    11
use "ML-Systems/time_limit.ML";
wenzelm@23921
    12
wenzelm@25023
    13
wenzelm@25023
    14
(** ML system and platform related **)
wenzelm@25023
    15
wenzelm@25125
    16
(* Compiler options *)
wenzelm@25125
    17
wenzelm@24598
    18
val ml_system_fix_ints = false;
wenzelm@24598
    19
wenzelm@25125
    20
PolyML.Compiler.printInAlphabeticalOrder := false;
wenzelm@25023
    21
PolyML.Compiler.maxInlineSize := 80;
wenzelm@23921
    22
wenzelm@16374
    23
wenzelm@17077
    24
(* String compatibility *)
wenzelm@17077
    25
wenzelm@16516
    26
(*low-level pointer equality*)
wenzelm@16516
    27
val pointer_eq = Address.wordEq;
wenzelm@16502
    28
wenzelm@16502
    29
wenzelm@11078
    30
(* old Poly/ML emulation *)
wenzelm@2341
    31
wenzelm@11078
    32
local
wenzelm@11078
    33
  val orig_exit = exit;
wenzelm@11078
    34
in
wenzelm@11078
    35
  open PolyML;
wenzelm@11078
    36
  val exit = orig_exit;
wenzelm@11078
    37
  fun quit () = exit 0;
wenzelm@7148
    38
end;
paulson@6042
    39
wenzelm@2341
    40
wenzelm@11078
    41
(* restore old-style character / string functions *)
wenzelm@3588
    42
wenzelm@11078
    43
val ord = SML90.ord;
wenzelm@11078
    44
val chr = SML90.chr;
wenzelm@11078
    45
val explode = SML90.explode;
wenzelm@11078
    46
val implode = SML90.implode;
wenzelm@11078
    47
wenzelm@14870
    48
skalberg@14519
    49
(* compiler-independent timing functions *)
wenzelm@2341
    50
wenzelm@21298
    51
fun start_timing () =
wenzelm@21298
    52
  let val CPUtimer = Timer.startCPUTimer();
wenzelm@21298
    53
      val time = Timer.checkCPUTimer(CPUtimer)
wenzelm@21298
    54
  in  (CPUtimer,time)  end;
wenzelm@21298
    55
wenzelm@21298
    56
fun end_timing (CPUtimer, {sys,usr}) =
wenzelm@21298
    57
  let open Time  (*...for Time.toString, Time.+ and Time.- *)
wenzelm@21298
    58
      val {sys=sys2,usr=usr2} = Timer.checkCPUTimer(CPUtimer)
wenzelm@21298
    59
  in  "User " ^ toString (usr2-usr) ^
wenzelm@21298
    60
      "  All "^ toString (sys2-sys + usr2-usr) ^
wenzelm@21298
    61
      " secs"
wenzelm@21298
    62
      handle Time => ""
wenzelm@21298
    63
  end;
wenzelm@21298
    64
wenzelm@21298
    65
fun check_timer timer =
wenzelm@21298
    66
  let
wenzelm@21298
    67
    val {sys, usr} = Timer.checkCPUTimer timer;
wenzelm@21298
    68
    val gc = Timer.checkGCTime timer;    (* FIXME already included in usr? *)
wenzelm@21298
    69
  in (sys, usr, gc) end;
wenzelm@2341
    70
wenzelm@14870
    71
wenzelm@4977
    72
(* prompts *)
wenzelm@4977
    73
wenzelm@4984
    74
fun ml_prompts p1 p2 = (PolyML.Compiler.prompt1 := p1; PolyML.Compiler.prompt2 := p2);
wenzelm@4977
    75
wenzelm@4977
    76
wenzelm@24290
    77
(* toplevel pretty printing (see also Pure/pure_setup.ML) *)
wenzelm@2341
    78
wenzelm@11078
    79
fun make_pp _ pprint (str, blk, brk, en) _ _ obj =
wenzelm@2341
    80
  pprint obj (str, fn ind => blk (ind, false), fn wd => brk (wd, 0),
wenzelm@2341
    81
    fn () => brk (99999, 0), en);
wenzelm@2341
    82
wenzelm@24329
    83
(*print depth*)
wenzelm@24329
    84
local
wenzelm@24329
    85
  val depth = ref 10;
wenzelm@24329
    86
in
wenzelm@24329
    87
  fun get_print_depth () = ! depth;
wenzelm@24329
    88
  fun print_depth n = (depth := n; PolyML.print_depth n);
wenzelm@24329
    89
end;
wenzelm@24329
    90
wenzelm@2341
    91
wenzelm@3588
    92
(* ML command execution -- 'eval' *)
wenzelm@3588
    93
wenzelm@24598
    94
fun use_text (tune: string -> string) name (print, err) verbose txt =
wenzelm@3588
    95
  let
wenzelm@24598
    96
    val in_buffer = ref (explode (tune txt));
wenzelm@5090
    97
    val out_buffer = ref ([]: string list);
wenzelm@21715
    98
    fun output () = implode (rev (case ! out_buffer of "\n" :: cs => cs | cs => cs));
wenzelm@5090
    99
wenzelm@5038
   100
    fun get () =
wenzelm@5090
   101
      (case ! in_buffer of
wenzelm@5038
   102
        [] => ""
wenzelm@5090
   103
      | c :: cs => (in_buffer := cs; c));
wenzelm@5090
   104
    fun put s = out_buffer := s :: ! out_buffer;
wenzelm@5090
   105
wenzelm@5038
   106
    fun exec () =
wenzelm@5090
   107
      (case ! in_buffer of
wenzelm@5038
   108
        [] => ()
wenzelm@5090
   109
      | _ => (PolyML.compiler (get, put) (); exec ()));
wenzelm@5090
   110
  in
wenzelm@22144
   111
    exec () handle exn =>
wenzelm@22144
   112
      (err ((if name = "" then "" else "Error in " ^ name ^ "\n") ^ output ()); raise exn);
wenzelm@10914
   113
    if verbose then print (output ()) else ()
wenzelm@5090
   114
  end;
wenzelm@3588
   115
wenzelm@24598
   116
fun use_file tune output verbose name =
wenzelm@24598
   117
  let
wenzelm@24598
   118
    val instream = TextIO.openIn name;
wenzelm@24598
   119
    val txt = TextIO.inputAll instream before TextIO.closeIn instream;
wenzelm@24598
   120
  in use_text tune name output verbose txt end;
wenzelm@21770
   121
wenzelm@11078
   122
wenzelm@15832
   123
(*eval command line arguments*)
wenzelm@15832
   124
local
wenzelm@15832
   125
  fun println s =
wenzelm@15832
   126
    (TextIO.output (TextIO.stdOut, s ^ "\n"); TextIO.flushOut TextIO.stdOut);
wenzelm@21715
   127
  fun eval "-q" = ()
wenzelm@24598
   128
    | eval txt = use_text (fn x => x) "" (println, println) false txt;
wenzelm@15832
   129
in
wenzelm@24296
   130
  val _ = PolyML.onEntry (fn () =>
wenzelm@24296
   131
   (Signal.signal (2, Signal.SIG_HANDLE (fn _ => Process.interruptConsoleProcesses ()));
wenzelm@24296
   132
    app eval (CommandLine.arguments ())));
wenzelm@15832
   133
end;
wenzelm@15832
   134
wenzelm@15832
   135
wenzelm@11078
   136
wenzelm@11078
   137
(** interrupts **)
wenzelm@11078
   138
wenzelm@11078
   139
exception Interrupt = SML90.Interrupt;
wenzelm@11078
   140
wenzelm@11078
   141
local
wenzelm@11078
   142
wenzelm@11078
   143
val sig_int = 2;
wenzelm@11078
   144
wenzelm@11078
   145
fun change_signal new_handler f x =
wenzelm@11078
   146
  let
wenzelm@11078
   147
    (*RACE wrt. other signals*)
wenzelm@11078
   148
    val old_handler = Signal.signal (sig_int, new_handler);
wenzelm@23965
   149
    val result = Exn.capture f x;
wenzelm@11078
   150
    val _ = Signal.signal (sig_int, old_handler);
wenzelm@23965
   151
  in Exn.release result end;
wenzelm@5813
   152
wenzelm@11078
   153
val default_handler = Signal.SIG_HANDLE (fn _ => Process.interruptConsoleProcesses ());
wenzelm@11078
   154
wenzelm@11078
   155
in
wenzelm@11078
   156
wenzelm@11078
   157
val _ = Signal.signal (sig_int, default_handler);
wenzelm@11078
   158
wenzelm@12989
   159
fun ignore_interrupt f = change_signal Signal.SIG_IGN f;
wenzelm@12989
   160
fun raise_interrupt f = change_signal default_handler f;
wenzelm@11078
   161
wenzelm@11078
   162
end;
wenzelm@5813
   163
wenzelm@5813
   164
wenzelm@5813
   165
wenzelm@3588
   166
(** OS related **)
wenzelm@2341
   167
wenzelm@21281
   168
use "ML-Systems/polyml-posix.ML";
wenzelm@16659
   169
wenzelm@16659
   170
wenzelm@23826
   171
(* current directory *)
wenzelm@23826
   172
wenzelm@23826
   173
val cd = OS.FileSys.chDir;
wenzelm@23826
   174
val pwd = OS.FileSys.getDir;
wenzelm@23826
   175
wenzelm@23826
   176
wenzelm@3588
   177
(* system command execution *)
wenzelm@2341
   178
wenzelm@3588
   179
(*execute Unix command which doesn't take any input from stdin and
wenzelm@11078
   180
  sends its output to stdout; could be done more easily by Unix.execute,
wenzelm@11078
   181
  but that function doesn't use the PATH*)
wenzelm@3588
   182
fun execute command =
wenzelm@3588
   183
  let
wenzelm@11078
   184
    val tmp_name = OS.FileSys.tmpName ();
wenzelm@11078
   185
    val is = (OS.Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name);
wenzelm@11078
   186
    val result = TextIO.inputAll is;
wenzelm@11078
   187
  in
wenzelm@11078
   188
    TextIO.closeIn is;
wenzelm@11078
   189
    OS.FileSys.remove tmp_name;
wenzelm@11078
   190
    result
wenzelm@11078
   191
  end;
wenzelm@7855
   192
wenzelm@11078
   193
(*plain version; with return code*)
wenzelm@11078
   194
fun system cmd =
wenzelm@11078
   195
  if OS.Process.isSuccess (OS.Process.system cmd) then 0 else 1;
wenzelm@2341
   196
wenzelm@2341
   197
wenzelm@17824
   198
(*Convert a process ID to a decimal string (chiefly for tracing)*)
wenzelm@25732
   199
fun string_of_pid pid =
wenzelm@23139
   200
  Word.fmt StringCvt.DEC (Word.fromLargeWord (Posix.Process.pidToWord pid));
wenzelm@17824
   201
wenzelm@17824
   202
wenzelm@3588
   203
(* getenv *)
wenzelm@3588
   204
wenzelm@11078
   205
fun getenv var =
wenzelm@11078
   206
  (case OS.Process.getEnv var of
wenzelm@11078
   207
    NONE => ""
wenzelm@11078
   208
  | SOME txt => txt);
paulson@15028
   209
paulson@15028
   210
wenzelm@16659
   211
(* profile execution *)
wenzelm@16659
   212
wenzelm@16659
   213
fun profile 0 f x = f x
wenzelm@16659
   214
  | profile n f x =
wenzelm@24851
   215
      let
wenzelm@24851
   216
        val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler n;
wenzelm@24851
   217
        val res = Exn.capture f x;
wenzelm@24851
   218
        val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
wenzelm@24851
   219
      in Exn.release res end;
wenzelm@16659
   220