-- Copyright 1993-1998, by the Cecil Project
-- Department of Computer Science and Engineering, University of Washington
-- See the LICENSE file for license information.


-- quitting
method exit(error_code@:int):none (** does_not_return, sends(),
				      does_io, formals_escape(f) **) {
  prim c_++ {
    printf("\n\nexiting program with code %d\n", error_code->asInt());
    fatalHandler(currentEnv);
    vortex_exit(error_code->asInt());
  }
}


method object_size(obj:any):int (** return_type(int), sends(),
				    formals_escape(f) **) {
  prim c_++: "
    int sz = cecilSize(obj);
#ifdef DISPATCHERS
    RETURN(asTaggedInt(sz));
#else
    BP(asTaggedInt(sz));
#endif
  "
}

method individual_object_size(obj:any):indexed[int] (** return_type(i_vector),
						        sends(),
						        formals_escape(f) **) {
  prim c_++: "
    OOP object_size_vector = cecilIndividualSizes(obj);
#ifdef DISPATCHERS
    RETURN(object_size_vector);
#else
    BP(object_size_vector);
#endif
  "
}

method object_size_histogram(obj:any):int (** return_type(int), sends(),
					      formals_escape(f) **) {
  prim c_++: "
    int sz = cecilSizeHistogram(obj);
#ifdef DISPATCHERS
    RETURN(asTaggedInt(sz));
#else
    BP(asTaggedInt(sz));
#endif
  "
}

method PIC_statistics():void (** return_type(void), sends(), does_io **) {
  prim c_++: "
    thePICs->stubStatistics(false);
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method detailed_PIC_statistics():void (** return_type(void), sends(), does_io **) {
  prim c_++: "
    thePICs->stubStatistics(true);
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

-- timing Cecil programs

-- Accuracy is machine-dependent.
--DOCSHORT Current CPU time in milliseconds.
method cpu_time():int (** return_type(int), sends() **) {
  prim c_++:"
#ifdef DISPATCHERS
    RETURN(asTaggedInt(timeInMSec()));
#else
    BP(asTaggedInt(timeInMSec()));
#endif
"
}

--DOCSHORT CPU execution time of closure in milliseconds
method time(closure:&():void):int (** inline **) {
    let start:int := cpu_time();
    eval(closure);
    let end:int := cpu_time();
    end - start }


-- Used to get semi-accurate results for small benchmarks.  First run the
-- closure once to warm up the PICs & then run ten times inside the timer.
-- NB:  We assume that each time the closure is evaluated, the same thing
-- happens (programs need to cleanup program globals, etc. explicitly).
method benchmark_closure(cls:&():void):void (** inline **) {
    eval(cls);            -- run it once to warm up PICs
    garbage_collect();    -- cleanup
    profiling_on();
    let t:int := time({   -- run it ten times
	10.do(&(i:int){ eval(cls) });
    });
    profiling_off();
    print_line("Time: " || (t/10).print_string || " ms.");
}


--DOC The `system' function invokes the Unix `system' system call with the
--DOC given command, and passes the returned value to the user.  The
--DOC `if_error' closure is invoked if the system call returns a non-zero
--DOC result.

-- for invoking system calls
method system(s@:string):int {
    system(s.as_vstring);
}
-- let us not post-process the return code
method system(s@:vstring):int (** return_type(int), sends(),
			          does_io, formals_escape(f) **) {
  prim c_++: "
    char* str = AS_C_STRING(s);
    int res = system(str);
#ifdef DISPATCHERS
    RETURN(asTaggedInt(res));
#else
    BP(asTaggedInt(res));
#endif
  "
}
-- a wrapper with an error closure
method system(s@:string, if_error:&(i:int):int):int {
    let var res:int := system(s);
    if(res != 0, { res := eval(if_error, res) });
    res }


-- for accessing the debugger from within a Cecil program
prim c_++: "
extern \"C++\" {
#include \"debug.h\"
}
";

-- NB: sends() is a lie when a program is built with the evalutor, but
-- we've decided to ignore reflection that goes through the debugger.
method breakpoint():void (** return_type(void), sends(), does_io **){
  prim c_++: "
    printf(\"Breakpoint...\\n\");
    debugger(IF_DEBUG_ELSE(currentEnv->asEnv()->dynamicEnv, currentEnv));
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}


-- for accessing the C++ runtime system from within a Cecil program
method sys_breakpoint():void (** return_type(void), sends(), does_io **) {
  prim c_++: "
    breakpoint();
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}


--DOCSHORT Unix command-line arguments
concrete representation argv isa i_indexed[string];

method length(t@:argv):int (** return_type(int), sends(),
			       formals_escape(f) **) {
  prim c_++: "
#ifdef DISPATCHERS
    RETURN(asTaggedInt(global_argc));
#else
    BP(asTaggedInt(global_argc));
#endif
  "
}

-- we don't dispatch on the key, to avoid making that a constrained position
-- for all fetch's in the system.  similarly for store below.
-- MAYBE THIS SHOULD NOT DO IO???
method fetch(t@:argv, i:int, if_absent:&():string):string
                 (** sends(r1 = eval([if_absent])),
		     return_type(r1,i_vstring),
		     does_io, formals_escape(f,f,f) **) {
  prim c_++: "
    if (! i->isInt()) {
      fatalEnv(currentEnv, \"can only index argv with ints\");
    }
    int arg = i->asInt();
    if (arg < 0 || arg >= global_argc) {
      TAIL_SEND(eval, 0, 1, (if_absent),
                \"1#fetch(@argv,b,c)\");
    } else {
#ifdef DISPATCHERS
      RETURN(NEW_STRING(global_argv[arg]));
#else
      BP(NEW_STRING(global_argv[arg]));
#endif
    }"
}


--DOC Unix environment variables can be read and modified.

concrete object env isa m_table_like[string,string];

method fetch(t@:env, name:string):string {
    t.fetch_internal(name.as_vstring) }
method fetch_internal(t@:env, name@:vstring):string
				(** return_type(i_vstring), sends(),
				    does_io, formals_escape(f,f) **) {
  prim c_++ {
    char* str = AS_C_STRING(name);
    char* value = getenv(str);
    if (!value) value = ""; // Not found, return 0 length string
#ifdef DISPATCHERS
    RETURN(NEW_STRING(value));
#else
    BP(NEW_STRING(value));
#endif
  }
}

prim c_++ {
#if VORTEX_SUN4
  extern "C" int putenv (char* string);
#elif VORTEX_SOLARIS || VORTEX_LINUX
  extern "C" int putenv (const char* string);
#else
  // already defined in system header file
#endif
};

method store(t@:env, n:string, v:string):void {
    t.store_internal(n.as_vstring, v.as_vstring);
}
method store_internal(t@:env, n@:vstring, v@:vstring):void
					(** return_type(void), sends(),
					    does_io, formals_escape(f,f,f) **) {
  prim c_++: "
    char* buf = (char *)malloc(NUM_ELEMS(n) + NUM_ELEMS(v) + 2);
    sprintf(buf, \"%s=%s\", VEC_ELEMS(n,char), VEC_ELEMS(v,char));
    putenv(buf);
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}


prim c_++ {
  #ifdef ACCURATE_GC_LIB
    extern "C" {
      #include "accurate-gc/src/gc.h"
    }
  #endif
};

method garbage_collect():void (** return_type(void), sends() **){
  prim c_++: "
#ifdef BOEHM_GC_LIB
    GC_gcollect();
#endif
#ifdef GREATCIRCLE_GC_LIB
    gcCollect();
#endif
#ifdef ACCURATE_GC_LIB
    garbage_collect();
#endif
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method print_heap():void (** return_type(void), sends(), does_io **) {
  prim c_++: "
#ifdef ACCURATE_GC_LIB
    print_memory();
#else
    printf(\"Can only print heap in presence of \"
	   \"accurate garbage collection\\n\");
#endif
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method process_size():int (** return_type(int), sends() **) {
  prim c_++: "
    int ps = processSize();
#ifdef DISPATCHERS
    RETURN(asTaggedInt(ps));
#else
    BP(asTaggedInt(ps));
#endif
  "
}


prim c_++ {
#ifdef INDEXED_FIELDS
  extern char* getCompilationDate();
#else
  extern "C++" char* getCompilationDate();
#endif
};

method compile_date():string (** return_type(i_vstring), sends() **) {
  prim c_++: "
    char* value = getCompilationDate();
#ifdef DISPATCHERS
    RETURN(NEW_STRING(value));
#else
    BP(NEW_STRING(value));
#endif
  "
}


prim c_++ {
#ifdef PROFILED
  extern "C" void moncontrol(int);
#endif
};


-- reset or print-and-reset the runtime system's counters.
-- Both operations are no-ops unless we phase2 compiled -DCOUNTERS
prim c_++ {
    extern 
#ifndef INDEXED_FIELDS
    "C++"
#endif
    void zeroCounters();
};
method zero_runtime_counters():void (** return_type(void), sends() **) {
  prim c_++: "
    zeroCounters();
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}
prim c_++ {
    extern 
#ifndef INDEXED_FIELDS
    "C++"
#endif
    void printCounters();
};
method print_and_zero_runtime_counters():void (** return_type(void), 
					       sends() **) {
  prim c_++: "
    printCounters();
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method profiling_on():void (** return_type(void), sends() **) {
  prim c_++: "
#ifdef PROFILED
    moncontrol(1);
#endif
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method profiling_off():void (** return_type(void), sends() **) {
  prim c_++: "
#ifdef PROFILED
    moncontrol(0);
#endif
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

method profile(c@closure:&():`T):T {
    profiling_on();
    let result:T := eval(c);
    profiling_off();
    result }

method profile(b@:bool, c:&():`T):T {
    if(b, { profile(c) }, c) }