src/Pure/ML-Systems/polyml.ML
author wenzelm
Fri Nov 10 23:22:10 2006 +0100 (2006-11-10)
changeset 21298 6d2306b2376d
parent 21281 0767e7dad549
child 21715 9c19f90272e8
permissions -rw-r--r--
tuned names of start_timing,/end_timing/check_timer;
removed obsolete ML compatibility fragments;
wenzelm@2341
     1
(*  Title:      Pure/ML-Systems/polyml.ML
wenzelm@2341
     2
    ID:         $Id$
wenzelm@2341
     3
wenzelm@14870
     4
Compatibility file for Poly/ML (version 4.0, 4.1, 4.1.x).
wenzelm@2341
     5
*)
wenzelm@2341
     6
wenzelm@16374
     7
(** ML system and platform related **)
wenzelm@16374
     8
wenzelm@17077
     9
(* String compatibility *)
wenzelm@17077
    10
wenzelm@17077
    11
structure String =
wenzelm@17077
    12
struct
wenzelm@17077
    13
  fun isSuffix s1 s2 =
wenzelm@17077
    14
    let val n1 = size s1 and n2 = size s2
wenzelm@17077
    15
    in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end;
wenzelm@17077
    16
  open String;
wenzelm@17077
    17
end;
wenzelm@17077
    18
wenzelm@18504
    19
structure Substring =
wenzelm@18504
    20
struct
wenzelm@18504
    21
  open Substring;
wenzelm@18504
    22
  val full = all;
wenzelm@18504
    23
end;
wenzelm@18504
    24
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
webertj@14850
    72
(* bounded time execution *)
webertj@14850
    73
wenzelm@21281
    74
(*dummy implementation*)
webertj@18760
    75
fun interrupt_timeout time f x =
webertj@18760
    76
  f x;
webertj@18760
    77
wenzelm@14870
    78
wenzelm@4977
    79
(* prompts *)
wenzelm@4977
    80
wenzelm@4984
    81
fun ml_prompts p1 p2 = (PolyML.Compiler.prompt1 := p1; PolyML.Compiler.prompt2 := p2);
wenzelm@4977
    82
wenzelm@4977
    83
wenzelm@3588
    84
(* toplevel pretty printing (see also Pure/install_pp.ML) *)
wenzelm@2341
    85
wenzelm@11078
    86
fun make_pp _ pprint (str, blk, brk, en) _ _ obj =
wenzelm@2341
    87
  pprint obj (str, fn ind => blk (ind, false), fn wd => brk (wd, 0),
wenzelm@2341
    88
    fn () => brk (99999, 0), en);
wenzelm@2341
    89
wenzelm@2341
    90
wenzelm@3588
    91
(* ML command execution -- 'eval' *)
wenzelm@3588
    92
wenzelm@7890
    93
local
wenzelm@7890
    94
wenzelm@7890
    95
fun drop_last [] = []
wenzelm@7890
    96
  | drop_last [x] = []
wenzelm@7890
    97
  | drop_last (x :: xs) = x :: drop_last xs;
wenzelm@7890
    98
wenzelm@7890
    99
in
wenzelm@7890
   100
wenzelm@10914
   101
fun use_text (print, err) verbose txt =
wenzelm@3588
   102
  let
wenzelm@5090
   103
    val in_buffer = ref (explode txt);
wenzelm@5090
   104
    val out_buffer = ref ([]: string list);
wenzelm@15832
   105
    fun output () = implode (drop_last (rev (! out_buffer)));
wenzelm@5090
   106
wenzelm@5038
   107
    fun get () =
wenzelm@5090
   108
      (case ! in_buffer of
wenzelm@5038
   109
        [] => ""
wenzelm@5090
   110
      | c :: cs => (in_buffer := cs; c));
wenzelm@5090
   111
    fun put s = out_buffer := s :: ! out_buffer;
wenzelm@5090
   112
wenzelm@5038
   113
    fun exec () =
wenzelm@5090
   114
      (case ! in_buffer of
wenzelm@5038
   115
        [] => ()
wenzelm@5090
   116
      | _ => (PolyML.compiler (get, put) (); exec ()));
wenzelm@5090
   117
  in
wenzelm@10914
   118
    exec () handle exn => (err (output ()); raise exn);
wenzelm@10914
   119
    if verbose then print (output ()) else ()
wenzelm@5090
   120
  end;
wenzelm@3588
   121
wenzelm@11078
   122
end;
wenzelm@11078
   123
wenzelm@11078
   124
wenzelm@15832
   125
(*eval command line arguments*)
wenzelm@15832
   126
local
wenzelm@15832
   127
  fun println s =
wenzelm@15832
   128
    (TextIO.output (TextIO.stdOut, s ^ "\n"); TextIO.flushOut TextIO.stdOut);
wenzelm@15851
   129
  val eval = use_text (println, println) true;
wenzelm@15832
   130
in
wenzelm@15832
   131
  val _ = PolyML.onEntry (fn () => app eval (CommandLine.arguments ()));
wenzelm@15832
   132
end;
wenzelm@15832
   133
wenzelm@15832
   134
wenzelm@11078
   135
wenzelm@11078
   136
(** interrupts **)
wenzelm@11078
   137
wenzelm@11078
   138
exception Interrupt = SML90.Interrupt;
wenzelm@11078
   139
wenzelm@11078
   140
local
wenzelm@11078
   141
wenzelm@12989
   142
fun capture f x = ((f x): unit; NONE) handle exn => SOME exn;
wenzelm@11078
   143
wenzelm@12989
   144
fun release NONE = ()
wenzelm@12989
   145
  | release (SOME exn) = raise exn;
wenzelm@3588
   146
wenzelm@11078
   147
val sig_int = 2;
wenzelm@11078
   148
wenzelm@11078
   149
fun change_signal new_handler f x =
wenzelm@11078
   150
  let
wenzelm@11078
   151
    (*RACE wrt. other signals*)
wenzelm@11078
   152
    val old_handler = Signal.signal (sig_int, new_handler);
wenzelm@11078
   153
    val result = capture f x;
wenzelm@11078
   154
    val _ = Signal.signal (sig_int, old_handler);
wenzelm@11078
   155
  in release result end;
wenzelm@5813
   156
wenzelm@11078
   157
val default_handler = Signal.SIG_HANDLE (fn _ => Process.interruptConsoleProcesses ());
wenzelm@11078
   158
wenzelm@11078
   159
in
wenzelm@11078
   160
wenzelm@11078
   161
val _ = Signal.signal (sig_int, default_handler);
wenzelm@11078
   162
wenzelm@12989
   163
fun ignore_interrupt f = change_signal Signal.SIG_IGN f;
wenzelm@12989
   164
fun raise_interrupt f = change_signal default_handler f;
wenzelm@11078
   165
wenzelm@11078
   166
end;
wenzelm@5813
   167
wenzelm@5813
   168
wenzelm@5813
   169
wenzelm@3588
   170
(** OS related **)
wenzelm@2341
   171
wenzelm@21281
   172
use "ML-Systems/polyml-posix.ML";
wenzelm@16659
   173
wenzelm@16659
   174
wenzelm@3588
   175
(* system command execution *)
wenzelm@2341
   176
wenzelm@3588
   177
(*execute Unix command which doesn't take any input from stdin and
wenzelm@11078
   178
  sends its output to stdout; could be done more easily by Unix.execute,
wenzelm@11078
   179
  but that function doesn't use the PATH*)
wenzelm@3588
   180
fun execute command =
wenzelm@3588
   181
  let
wenzelm@11078
   182
    val tmp_name = OS.FileSys.tmpName ();
wenzelm@11078
   183
    val is = (OS.Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name);
wenzelm@11078
   184
    val result = TextIO.inputAll is;
wenzelm@11078
   185
  in
wenzelm@11078
   186
    TextIO.closeIn is;
wenzelm@11078
   187
    OS.FileSys.remove tmp_name;
wenzelm@11078
   188
    result
wenzelm@11078
   189
  end;
wenzelm@7855
   190
wenzelm@11078
   191
(*plain version; with return code*)
wenzelm@11078
   192
fun system cmd =
wenzelm@11078
   193
  if OS.Process.isSuccess (OS.Process.system cmd) then 0 else 1;
wenzelm@2341
   194
wenzelm@2341
   195
wenzelm@17824
   196
(*Convert a process ID to a decimal string (chiefly for tracing)*)
wenzelm@17824
   197
fun string_of_pid pid = 
wenzelm@17824
   198
    Word.fmt StringCvt.DEC (Word.fromLargeWord (Posix.Process.pidToWord pid));
wenzelm@17824
   199
wenzelm@17824
   200
wenzelm@3588
   201
(* getenv *)
wenzelm@3588
   202
wenzelm@11078
   203
fun getenv var =
wenzelm@11078
   204
  (case OS.Process.getEnv var of
wenzelm@11078
   205
    NONE => ""
wenzelm@11078
   206
  | SOME txt => txt);
paulson@15028
   207
paulson@15028
   208
wenzelm@16659
   209
(* profile execution *)
wenzelm@16659
   210
wenzelm@16659
   211
local
wenzelm@16659
   212
wenzelm@16659
   213
fun no_profile () =
wenzelm@16659
   214
  RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
paulson@15028
   215
wenzelm@16659
   216
in
paulson@15699
   217
wenzelm@16659
   218
fun profile 0 f x = f x
wenzelm@16659
   219
  | profile n f x =
wenzelm@16659
   220
     (RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler n;
wenzelm@16659
   221
      let val y = f x handle exn => (no_profile (); raise exn)
wenzelm@16659
   222
      in no_profile (); y end);
wenzelm@16659
   223
wenzelm@16659
   224
end;