src/Pure/ML-Systems/polyml_common.ML
author wenzelm
Sun Mar 01 23:36:12 2009 +0100 (2009-03-01)
changeset 30190 479806475f3c
parent 30187 b92b3375e919
child 30619 0226c07352db
permissions -rw-r--r--
use long names for old-style fold combinators;
wenzelm@26215
     1
(*  Title:      Pure/ML-Systems/polyml_common.ML
wenzelm@26215
     2
wenzelm@26215
     3
Compatibility file for Poly/ML -- common part for 4.x and 5.x.
wenzelm@26215
     4
*)
wenzelm@26215
     5
wenzelm@28443
     6
exception Interrupt = SML90.Interrupt;
wenzelm@28443
     7
wenzelm@26215
     8
use "ML-Systems/exn.ML";
wenzelm@26215
     9
use "ML-Systems/multithreading.ML";
wenzelm@26215
    10
use "ML-Systems/time_limit.ML";
wenzelm@26220
    11
use "ML-Systems/system_shell.ML";
wenzelm@28268
    12
use "ML-Systems/ml_name_space.ML";
wenzelm@26215
    13
wenzelm@26215
    14
wenzelm@26215
    15
(** ML system and platform related **)
wenzelm@26215
    16
wenzelm@26474
    17
val forget_structure = PolyML.Compiler.forgetStructure;
wenzelm@26474
    18
wenzelm@26474
    19
wenzelm@26215
    20
(* Compiler options *)
wenzelm@26215
    21
wenzelm@26215
    22
val ml_system_fix_ints = false;
wenzelm@26215
    23
wenzelm@26215
    24
PolyML.Compiler.printInAlphabeticalOrder := false;
wenzelm@26215
    25
PolyML.Compiler.maxInlineSize := 80;
wenzelm@26215
    26
wenzelm@26215
    27
wenzelm@26215
    28
(* old Poly/ML emulation *)
wenzelm@26215
    29
wenzelm@26215
    30
local
wenzelm@26215
    31
  val orig_exit = exit;
wenzelm@26215
    32
in
wenzelm@26215
    33
  open PolyML;
wenzelm@26215
    34
  val exit = orig_exit;
wenzelm@26215
    35
  fun quit () = exit 0;
wenzelm@26215
    36
end;
wenzelm@26215
    37
wenzelm@26215
    38
wenzelm@26215
    39
(* restore old-style character / string functions *)
wenzelm@26215
    40
wenzelm@26215
    41
val ord = SML90.ord;
wenzelm@26215
    42
val chr = SML90.chr;
wenzelm@26215
    43
val explode = SML90.explode;
wenzelm@26215
    44
val implode = SML90.implode;
wenzelm@26215
    45
wenzelm@26215
    46
wenzelm@26215
    47
(* compiler-independent timing functions *)
wenzelm@26215
    48
wenzelm@26215
    49
fun start_timing () =
wenzelm@30187
    50
  let
wenzelm@30187
    51
    val timer = Timer.startCPUTimer ();
wenzelm@30187
    52
    val time = Timer.checkCPUTimer timer;
wenzelm@30187
    53
  in (timer, time) end;
wenzelm@26215
    54
wenzelm@30187
    55
fun end_timing (timer, {sys, usr}) =
wenzelm@30187
    56
  let
wenzelm@30187
    57
    open Time;  (*...for Time.toString, Time.+ and Time.- *)
wenzelm@30187
    58
    val {sys = sys2, usr = usr2} = Timer.checkCPUTimer timer;
wenzelm@30187
    59
    val user = usr2 - usr;
wenzelm@30187
    60
    val all = user + sys2 - sys;
wenzelm@30187
    61
    val message = "User " ^ toString user ^ "  All "^ toString all ^ " secs" handle Time => "";
wenzelm@30187
    62
  in {message = message, user = user, all = all} end;
wenzelm@26215
    63
wenzelm@26215
    64
fun check_timer timer =
wenzelm@26215
    65
  let
wenzelm@26215
    66
    val {sys, usr} = Timer.checkCPUTimer timer;
wenzelm@26215
    67
    val gc = Timer.checkGCTime timer;    (* FIXME already included in usr? *)
wenzelm@26215
    68
  in (sys, usr, gc) end;
wenzelm@26215
    69
wenzelm@26215
    70
wenzelm@26215
    71
(* prompts *)
wenzelm@26215
    72
wenzelm@26215
    73
fun ml_prompts p1 p2 = (PolyML.Compiler.prompt1 := p1; PolyML.Compiler.prompt2 := p2);
wenzelm@26215
    74
wenzelm@26215
    75
wenzelm@26215
    76
(* toplevel pretty printing (see also Pure/pure_setup.ML) *)
wenzelm@26215
    77
wenzelm@26215
    78
fun make_pp _ pprint (str, blk, brk, en) _ _ obj =
wenzelm@26215
    79
  pprint obj (str, fn ind => blk (ind, false), fn wd => brk (wd, 0),
wenzelm@26215
    80
    fn () => brk (99999, 0), en);
wenzelm@26215
    81
wenzelm@26215
    82
(*print depth*)
wenzelm@26215
    83
local
wenzelm@26215
    84
  val depth = ref 10;
wenzelm@26215
    85
in
wenzelm@26215
    86
  fun get_print_depth () = ! depth;
wenzelm@26215
    87
  fun print_depth n = (depth := n; PolyML.print_depth n);
wenzelm@26215
    88
end;
wenzelm@26215
    89
wenzelm@26215
    90
wenzelm@26215
    91
wenzelm@26215
    92
(** interrupts **)
wenzelm@26215
    93
wenzelm@26215
    94
local
wenzelm@26215
    95
wenzelm@26215
    96
val sig_int = 2;
wenzelm@26215
    97
val default_handler = Signal.SIG_HANDLE (fn _ => Process.interruptConsoleProcesses ());
wenzelm@26215
    98
wenzelm@26215
    99
val _ = Signal.signal (sig_int, default_handler);
wenzelm@26380
   100
val _ = PolyML.onEntry (fn () => (Signal.signal (sig_int, default_handler); ()));
wenzelm@26215
   101
wenzelm@26215
   102
fun change_signal new_handler f x =
wenzelm@26215
   103
  let
wenzelm@26215
   104
    (*RACE wrt. other signals!*)
wenzelm@26215
   105
    val old_handler = Signal.signal (sig_int, new_handler);
wenzelm@26215
   106
    val result = Exn.capture (f old_handler) x;
wenzelm@26215
   107
    val _ = Signal.signal (sig_int, old_handler);
wenzelm@26215
   108
  in Exn.release result end;
wenzelm@26215
   109
wenzelm@26215
   110
in
wenzelm@26215
   111
wenzelm@26215
   112
fun interruptible f = change_signal default_handler (fn _ => f);
wenzelm@26215
   113
wenzelm@26215
   114
fun uninterruptible f =
wenzelm@26215
   115
  change_signal Signal.SIG_IGN
wenzelm@26215
   116
    (fn old_handler => f (fn g => change_signal old_handler (fn _ => g)));
wenzelm@26215
   117
wenzelm@26215
   118
end;
wenzelm@26215
   119
wenzelm@26215
   120
wenzelm@26215
   121
wenzelm@26215
   122
(** OS related **)
wenzelm@26215
   123
wenzelm@26215
   124
(* current directory *)
wenzelm@26215
   125
wenzelm@26215
   126
val cd = OS.FileSys.chDir;
wenzelm@26215
   127
val pwd = OS.FileSys.getDir;
wenzelm@26215
   128
wenzelm@28488
   129
fun process_id () =
wenzelm@28488
   130
  Word.fmt StringCvt.DEC (Word.fromLargeWord (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())));
wenzelm@26215
   131
wenzelm@26215
   132
wenzelm@26215
   133
(* getenv *)
wenzelm@26215
   134
wenzelm@26215
   135
fun getenv var =
wenzelm@26215
   136
  (case OS.Process.getEnv var of
wenzelm@26215
   137
    NONE => ""
wenzelm@26215
   138
  | SOME txt => txt);
wenzelm@26215
   139
wenzelm@26215
   140
wenzelm@26215
   141
(* profile execution *)
wenzelm@26215
   142
wenzelm@26215
   143
fun profile 0 f x = f x
wenzelm@26215
   144
  | profile n f x =
wenzelm@26215
   145
      let
wenzelm@26215
   146
        val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler n;
wenzelm@26215
   147
        val res = Exn.capture f x;
wenzelm@26215
   148
        val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
wenzelm@26215
   149
      in Exn.release res end;
wenzelm@26215
   150