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