//
//  Bridge.m
//  uimac
//
//  Created by Craig Federighi on 4/25/07.
//  Copyright 1999-2008 (see COPYING for details)
//

#import "Bridge.h"

/* The following two define are a workaround for an incompatibility between
 Ocaml 3.11.2 (and older) and the Mac OS X header files */
#define uint64 uint64_caml
#define int64 int64_caml

#define CAML_NAME_SPACE
#include <caml/callback.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/signals.h>
#import <ExceptionHandling/NSExceptionHandler.h>

#include <pthread.h>
#include <stdarg.h>

/*
 CMF, April 2007:  Alternate strategy for solving UI crashes based on
 http://alan.petitepomme.net/cwn/2005.03.08.html#9:
 1) Run OCaml in a separate thread from the Cocoa main run loop.
 2) Handle all calls to OCaml as callbacks -- have an OCaml thread
    hang in C-land and use mutexes and conditions to pass control from the
    C calling thread to the OCaml callback thread.

 Value Conversion Done in Bridge Thread:
 Value creation/conversion (like calls to caml_named_value or caml_copy_string)
 or access calls (like Field) need to occur in the OCaml thread.  We do this by
 passing C args for conversion to the bridgeThreadWait() thread.

 Example of vulnerability:
 Field(caml_reconItems,j) could dereference caml_reconItems
 when the GC (running independently in an OCaml thread) could be moving it.
*/

pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER;
pthread_cond_t init_cond = PTHREAD_COND_INITIALIZER;
static BOOL doneInit = NO;

pthread_mutex_t global_call_lock = PTHREAD_MUTEX_INITIALIZER;
pthread_cond_t global_call_cond = PTHREAD_COND_INITIALIZER;
pthread_mutex_t global_res_lock = PTHREAD_MUTEX_INITIALIZER;
pthread_cond_t global_res_cond = PTHREAD_COND_INITIALIZER;

@implementation Bridge
static Bridge *_instance = NULL;

const char **the_argv;

- (void)_ocamlStartup:(id)ignore
{

    NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
	pthread_mutex_lock(&init_lock);

    /* Initialize ocaml gc, etc. */
    caml_startup((char **)the_argv); // cast to avoid warning, caml_startup assumes non-const,
                                 // NSApplicationMain assumes const

        // Register these with the collector
        // NSLog(@"*** _ocamlStartup - back from startup; signalling! (%d)", pthread_self());
    doneInit = TRUE;
        pthread_cond_signal(&init_cond);
	pthread_mutex_unlock(&init_lock);

        // now start the callback thread
        // NSLog(@"*** _ocamlStartup - calling callbackThreadCreate (%d)", pthread_self());
        const value *f = caml_named_value("callbackThreadCreate");
        (void)caml_callback_exn(*f,Val_unit);
    [pool release];
}

+ (void)startup:(const char **)argv
{
        if (_instance) return;

        _instance = [[Bridge alloc] init];

        [[NSExceptionHandler defaultExceptionHandler] setDelegate:_instance];
        [[NSExceptionHandler defaultExceptionHandler] setExceptionHandlingMask:
                (NSLogUncaughtExceptionMask  | NSLogTopLevelExceptionMask)];

        // Init OCaml in another thread and wait for it to be ready
	pthread_mutex_lock(&init_lock);
        the_argv = argv;
        [NSThread detachNewThreadSelector:@selector(_ocamlStartup:)
                toTarget:_instance withObject:nil];

        // NSLog(@"*** waiting for completion of caml_init");
        while (!doneInit) pthread_cond_wait(&init_cond, &init_lock);
	pthread_mutex_unlock(&init_lock);
        // NSLog(@"*** caml_init complete!");
}

#if MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_5
typedef unsigned int NSUInteger;
#endif
- (BOOL)exceptionHandler:(NSExceptionHandler *)sender shouldLogException:(NSException *)exception mask:(NSUInteger)aMask
{
        // if (![[exception name] isEqual:@"OCamlException"]) return YES;

    NSString *msg = [NSString stringWithFormat:@"Uncaught exception: %@", [exception reason]];
    msg = [[msg componentsSeparatedByString:@"\n"] componentsJoinedByString:@" "];
    NSLog(@"%@", msg);
    NSRunAlertPanel(@"Fatal error", @"%@", @"Exit", nil, nil, msg);
        exit(1);
        return FALSE;
}

@end


// CallState struct is allocated on the C thread stack and then handed
// to the OCaml callback thread to perform value conversion and issue the call
typedef struct  {
        enum { SafeCall, OldCall, FieldAccess } opCode;

        // New style calls
        const char *argTypes;
        va_list args;

        // Field access
        value *valueP;
        long fieldIndex;
        char fieldType;

        // Return values
        char *exception;
        void *retV;
        BOOL _autorelease;

        // for old style (unsafe) calls
        value call, a1, a2, a3, ret;
        int argCount;
} CallState;

static CallState *_CallState = NULL;
static CallState *_RetState = NULL;

// Our OCaml callback server thread -- waits for call then makes them
// Called from thread spawned from OCaml
CAMLprim value bridgeThreadWait(value ignore)
{
        CAMLparam0();
        CAMLlocal1 (args);
        args = caml_alloc_tuple(3);

        // NSLog(@"*** bridgeThreadWait init!  (%d) Taking lock...", pthread_self());
        while (TRUE) {
                // unblock ocaml while we wait for work
                caml_enter_blocking_section();

                pthread_mutex_lock(&global_call_lock);
                while (!_CallState) pthread_cond_wait(&global_call_cond, &global_call_lock);

                // pick up our work and free up the call lock for other threads
                CallState *cs = _CallState;
                _CallState = NULL;
                pthread_mutex_unlock(&global_call_lock);

	// NSLog(@"*** bridgeThreadWait: have call -- leaving caml_blocking_section");

                // we have a call to do -- get the ocaml lock
                caml_leave_blocking_section();

	// NSLog(@"*** bridgeThreadWait: doing call");

        NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];

                char retType = 'v';
                value e = Val_unit;
                if (cs->opCode == SafeCall) {
                        int i;
                        char *fname = va_arg(cs->args, char *);
                        const value *f = caml_named_value(fname);
                        // varargs with C-based args -- convert them to OCaml values based on type code string
                        const char *p = cs->argTypes;
                        retType = *p++;
                        int argCount = 0;
                        for(; *p != '\0'; p++) {
                                const char *str;
                                switch (*p) {
                                        case 's':
                                                str = va_arg(cs->args, const char *);
                                                Store_field (args, argCount, caml_copy_string(str));
                                                break;
                                        case 'S':
                                                str = [va_arg(cs->args, NSString *) UTF8String];
                                                Store_field (args, argCount, caml_copy_string(str));
                                                break;
                                        case 'i':
                                                Store_field (args, argCount, Val_long(va_arg(cs->args, long)));
                                                break;
                                        case '@':
                                                Store_field (args, argCount, [va_arg(cs->args, OCamlValue *) value]);
                                                break;
                                        default:
                                                NSCAssert1(0, @"Unknown input type '%c'", *p);
                                                break;
                                }
                                argCount++;
                                NSCAssert(argCount <= 3, @"More than 3 arguments");
                        }
                        // Call OCaml -- TODO: add support for > 3 args
                        if (argCount == 3) e = caml_callback3_exn(*f,Field(args,0),Field(args,1),Field(args,2));
                        else if (argCount == 2) e = caml_callback2_exn(*f,Field(args,0),Field(args,1));
                        else if (argCount == 1) e = caml_callback_exn(*f,Field(args,0));
                        else e = caml_callback_exn(*f,Val_unit);
                        for (i = 0; i < argCount; i++) Store_field (args, i, Val_unit);
                } else if (cs->opCode == OldCall) {
                        // old style (unsafe) version where OCaml values were passed directly from C thread
                        if (cs->argCount == 3) e = caml_callback3_exn(cs->call,cs->a1,cs->a2,cs->a3);
                        else if (cs->argCount == 2) e = caml_callback2_exn(cs->call,cs->a1,cs->a2);
                        else e = caml_callback_exn(cs->call,cs->a1);
                        retType = 'v';
                } else if (cs->opCode == FieldAccess) {
                        long index = cs->fieldIndex;
                        e = (index == -1) ? Val_long(Wosize_val(*cs->valueP)) : Field(*cs->valueP, index);
                        retType = cs->fieldType;
                }

                // Process return value
                cs->_autorelease = FALSE;
                cs->ret = e; // OCaml return type -- unsafe...
                if (!Is_exception_result(e)) {
                        switch (retType) {
                                case 'S':
                                        *((NSString **)&cs->retV) = (e == Val_unit) ? NULL : [[NSString alloc] initWithUTF8String:String_val(e)];
                                        cs->_autorelease = TRUE;
                                        break;
                                case 'N':
                                        if (Is_long (e)) {
                                                *((NSNumber **)&cs->retV) = [[NSNumber alloc] initWithLong:Long_val(e)];
                                        } else {
                                                *((NSNumber **)&cs->retV) = [[NSNumber alloc] initWithDouble:Double_val(e)];
                                        }
                                        cs->_autorelease = TRUE;
                                        break;
                                case '@':
                                        *((NSObject **)&cs->retV) = (e == Val_unit) ? NULL : [[OCamlValue alloc] initWithValue:e];
                                        cs->_autorelease = TRUE;
                                        break;
                                case 'i':
                                        *((long *)&cs->retV) = Long_val(e);
                                        break;
                                case 'x':
                                        break;
                                default:
                                        NSCAssert1(0, @"Unknown return type '%c'", retType);
                                        break;
                        }
                }

                if (Is_exception_result(e)) {
                        // get exception string -- it will get thrown back in the calling thread
                    const value *f = caml_named_value("unisonExnInfo");
                    // We leak memory here...
                    cs->exception = strdup(String_val(caml_callback(*f,Extract_exception(e))));
                }

	    [pool release];

	// NSLog(@"*** bridgeThreadWait: returning");

                // we're done, signal back
                pthread_mutex_lock(&global_res_lock);
                _RetState = cs;
                pthread_cond_signal(&global_res_cond);
                pthread_mutex_unlock(&global_res_lock);
        }
        // Never get here...
        CAMLreturn (Val_unit);
}

void *_passCall(CallState *cs)
{
    pthread_mutex_lock(&global_call_lock);
        _CallState = cs;

        // signal so call can happen on other thread
        pthread_mutex_lock(&global_res_lock);
        pthread_cond_signal(&global_call_cond);
        pthread_mutex_unlock(&global_call_lock);

        // NSLog(@"*** _passCall (%d) -- performing signal and waiting", pthread_self());

        // wait until done -- make sure the result is for our call
        while (_RetState != cs) pthread_cond_wait(&global_res_cond, &global_res_lock);
        _RetState = NULL;
        pthread_mutex_unlock(&global_res_lock);

        // NSLog(@"*** doCallback -- back with result");
        if (cs->exception) {
                @throw [NSException exceptionWithName:@"OCamlException"
                                reason:[NSString stringWithUTF8String:cs->exception]
                                userInfo:nil];
        }
        if (cs->_autorelease) [((id)cs->retV) autorelease];
    return cs->retV;
}

void *ocamlCall(const char *argTypes, ...)
{
        CallState cs;
        cs.opCode = SafeCall;
        cs.exception = NULL;
        cs.argTypes = argTypes;
        va_start(cs.args, argTypes);
        void * res = _passCall(&cs);

        va_end(cs.args);
        return res;
}

void *getField(value *vP, long index, char type)
{
        CallState cs;
        cs.opCode = FieldAccess;
        cs.valueP = vP;
        cs.fieldIndex = index;
        cs.fieldType = type;
        cs.exception = NULL;
        return _passCall(&cs);
}

@implementation OCamlValue

- initWithValue:(long)v
{
        [super init];
        _v = v;
        caml_register_global_root((value *)&_v);
        return self;
}

- (long)count
{
        return (long)getField((value *) &_v, -1, 'i');
}

- (void *)getField:(long)i withType:(char)t
{
        return getField((value *)&_v, i, t);
}

- (long)value
{
        // Unsafe to use!
        return _v;
}

- (void)dealloc
{
        _v = Val_unit;
    caml_remove_global_root((value *)&_v);
        [super dealloc];
}
@end


// Legacy OCaml call API -- no longer needed
#if 0

extern value doCallback (value c, int argcount, value v1, value v2, value v3, BOOL exitOnException);
extern value Callback_checkexn(value c,value v);
extern value Callback2_checkexn(value c,value v1,value v2);
extern value Callback3_checkexn(value c,value v1,value v2,value v3);

void reportExn(const char *msg) {
    NSString *s = [NSString stringWithFormat:@"Uncaught exception: %s", msg];
    s = [[s componentsSeparatedByString:@"\n"] componentsJoinedByString:@" "];
    NSLog(@"%@",s);
    NSRunAlertPanel(@"Fatal error",s,@"Exit",nil,nil);
}

// FIXME!  Claim is that value conversion must also happen in the OCaml thread...
value doCallback (value c, int argcount, value v1, value v2, value v3, BOOL exitOnException) {
        // NSLog(@"*** doCallback: (%d) -- trying to acquire global lock", pthread_self());
        CallState cs;
        cs.opCode = OldCall;
        cs.exception = NULL;
        cs.call = c;
        cs.a1 = v1;
        cs.a2 = v2;
        cs.a3 = v3;
        cs.argCount = argcount;
        @try {
                return _passCall(&cs);
        } @catch (NSException *ex) {
                if (exitOnException) {
                        reportExn(cs.exception);
                        exit(1);
                }
                @throw ex;
        }
}

value Callback_checkexn(value c,value v) {
    return doCallback(c, 1, v, 0, 0, TRUE);
}

value Callback2_checkexn(value c,value v1,value v2) {
    return doCallback(c, 2, v1, v2, 0, TRUE);
}

value Callback3_checkexn(value c,value v1,value v2,value v3) {
    return doCallback(c, 3, v1, v2, v3, TRUE);
}
#endif
