Bridge.m (15625B)
1 // 2 // Bridge.m 3 // uimac 4 // 5 // Created by Craig Federighi on 4/25/07. 6 // Copyright 1999-2008 (see COPYING for details) 7 // 8 9 #import "Bridge.h" 10 11 /* The following two define are a workaround for an incompatibility between 12 Ocaml 3.11.2 (and older) and the Mac OS X header files */ 13 #define uint64 uint64_caml 14 #define int64 int64_caml 15 16 #define CAML_NAME_SPACE 17 #include <caml/callback.h> 18 #include <caml/alloc.h> 19 #include <caml/mlvalues.h> 20 #include <caml/memory.h> 21 #include <caml/signals.h> 22 #import <ExceptionHandling/NSExceptionHandler.h> 23 24 #include <pthread.h> 25 #include <stdarg.h> 26 27 /* 28 CMF, April 2007: Alternate strategy for solving UI crashes based on 29 http://alan.petitepomme.net/cwn/2005.03.08.html#9: 30 1) Run OCaml in a separate thread from the Cocoa main run loop. 31 2) Handle all calls to OCaml as callbacks -- have an OCaml thread 32 hang in C-land and use mutexes and conditions to pass control from the 33 C calling thread to the OCaml callback thread. 34 35 Value Conversion Done in Bridge Thread: 36 Value creation/conversion (like calls to caml_named_value or caml_copy_string) 37 or access calls (like Field) need to occur in the OCaml thread. We do this by 38 passing C args for conversion to the bridgeThreadWait() thread. 39 40 Example of vulnerability: 41 Field(caml_reconItems,j) could dereference caml_reconItems 42 when the GC (running independently in an OCaml thread) could be moving it. 43 */ 44 45 pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; 46 pthread_cond_t init_cond = PTHREAD_COND_INITIALIZER; 47 static BOOL doneInit = NO; 48 49 pthread_mutex_t global_call_lock = PTHREAD_MUTEX_INITIALIZER; 50 pthread_cond_t global_call_cond = PTHREAD_COND_INITIALIZER; 51 pthread_mutex_t global_res_lock = PTHREAD_MUTEX_INITIALIZER; 52 pthread_cond_t global_res_cond = PTHREAD_COND_INITIALIZER; 53 54 @implementation Bridge 55 static Bridge *_instance = NULL; 56 57 const char **the_argv; 58 59 - (void)_ocamlStartup:(id)ignore 60 { 61 62 NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; 63 pthread_mutex_lock(&init_lock); 64 65 /* Initialize ocaml gc, etc. */ 66 caml_startup((char **)the_argv); // cast to avoid warning, caml_startup assumes non-const, 67 // NSApplicationMain assumes const 68 69 // Register these with the collector 70 // NSLog(@"*** _ocamlStartup - back from startup; signalling! (%d)", pthread_self()); 71 doneInit = TRUE; 72 pthread_cond_signal(&init_cond); 73 pthread_mutex_unlock(&init_lock); 74 75 // now start the callback thread 76 // NSLog(@"*** _ocamlStartup - calling callbackThreadCreate (%d)", pthread_self()); 77 const value *f = caml_named_value("callbackThreadCreate"); 78 (void)caml_callback_exn(*f,Val_unit); 79 [pool release]; 80 } 81 82 + (void)startup:(const char **)argv 83 { 84 if (_instance) return; 85 86 _instance = [[Bridge alloc] init]; 87 88 [[NSExceptionHandler defaultExceptionHandler] setDelegate:_instance]; 89 [[NSExceptionHandler defaultExceptionHandler] setExceptionHandlingMask: 90 (NSLogUncaughtExceptionMask | NSLogTopLevelExceptionMask)]; 91 92 // Init OCaml in another thread and wait for it to be ready 93 pthread_mutex_lock(&init_lock); 94 the_argv = argv; 95 [NSThread detachNewThreadSelector:@selector(_ocamlStartup:) 96 toTarget:_instance withObject:nil]; 97 98 // NSLog(@"*** waiting for completion of caml_init"); 99 while (!doneInit) pthread_cond_wait(&init_cond, &init_lock); 100 pthread_mutex_unlock(&init_lock); 101 // NSLog(@"*** caml_init complete!"); 102 } 103 104 #if MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_5 105 typedef unsigned int NSUInteger; 106 #endif 107 - (BOOL)exceptionHandler:(NSExceptionHandler *)sender shouldLogException:(NSException *)exception mask:(NSUInteger)aMask 108 { 109 // if (![[exception name] isEqual:@"OCamlException"]) return YES; 110 111 NSString *msg = [NSString stringWithFormat:@"Uncaught exception: %@", [exception reason]]; 112 msg = [[msg componentsSeparatedByString:@"\n"] componentsJoinedByString:@" "]; 113 NSLog(@"%@", msg); 114 NSRunAlertPanel(@"Fatal error", @"%@", @"Exit", nil, nil, msg); 115 exit(1); 116 return FALSE; 117 } 118 119 @end 120 121 122 // CallState struct is allocated on the C thread stack and then handed 123 // to the OCaml callback thread to perform value conversion and issue the call 124 typedef struct { 125 enum { SafeCall, OldCall, FieldAccess } opCode; 126 127 // New style calls 128 const char *argTypes; 129 va_list args; 130 131 // Field access 132 value *valueP; 133 long fieldIndex; 134 char fieldType; 135 136 // Return values 137 char *exception; 138 void *retV; 139 BOOL _autorelease; 140 141 // for old style (unsafe) calls 142 value call, a1, a2, a3, ret; 143 int argCount; 144 } CallState; 145 146 static CallState *_CallState = NULL; 147 static CallState *_RetState = NULL; 148 149 // Our OCaml callback server thread -- waits for call then makes them 150 // Called from thread spawned from OCaml 151 CAMLprim value bridgeThreadWait(value ignore) 152 { 153 CAMLparam0(); 154 CAMLlocal1 (args); 155 args = caml_alloc_tuple(3); 156 157 // NSLog(@"*** bridgeThreadWait init! (%d) Taking lock...", pthread_self()); 158 while (TRUE) { 159 // unblock ocaml while we wait for work 160 caml_enter_blocking_section(); 161 162 pthread_mutex_lock(&global_call_lock); 163 while (!_CallState) pthread_cond_wait(&global_call_cond, &global_call_lock); 164 165 // pick up our work and free up the call lock for other threads 166 CallState *cs = _CallState; 167 _CallState = NULL; 168 pthread_mutex_unlock(&global_call_lock); 169 170 // NSLog(@"*** bridgeThreadWait: have call -- leaving caml_blocking_section"); 171 172 // we have a call to do -- get the ocaml lock 173 caml_leave_blocking_section(); 174 175 // NSLog(@"*** bridgeThreadWait: doing call"); 176 177 NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; 178 179 char retType = 'v'; 180 value e = Val_unit; 181 if (cs->opCode == SafeCall) { 182 int i; 183 char *fname = va_arg(cs->args, char *); 184 const value *f = caml_named_value(fname); 185 // varargs with C-based args -- convert them to OCaml values based on type code string 186 const char *p = cs->argTypes; 187 retType = *p++; 188 int argCount = 0; 189 for(; *p != '\0'; p++) { 190 const char *str; 191 switch (*p) { 192 case 's': 193 str = va_arg(cs->args, const char *); 194 Store_field (args, argCount, caml_copy_string(str)); 195 break; 196 case 'S': 197 str = [va_arg(cs->args, NSString *) UTF8String]; 198 Store_field (args, argCount, caml_copy_string(str)); 199 break; 200 case 'i': 201 Store_field (args, argCount, Val_long(va_arg(cs->args, long))); 202 break; 203 case '@': 204 Store_field (args, argCount, [va_arg(cs->args, OCamlValue *) value]); 205 break; 206 default: 207 NSCAssert1(0, @"Unknown input type '%c'", *p); 208 break; 209 } 210 argCount++; 211 NSCAssert(argCount <= 3, @"More than 3 arguments"); 212 } 213 // Call OCaml -- TODO: add support for > 3 args 214 if (argCount == 3) e = caml_callback3_exn(*f,Field(args,0),Field(args,1),Field(args,2)); 215 else if (argCount == 2) e = caml_callback2_exn(*f,Field(args,0),Field(args,1)); 216 else if (argCount == 1) e = caml_callback_exn(*f,Field(args,0)); 217 else e = caml_callback_exn(*f,Val_unit); 218 for (i = 0; i < argCount; i++) Store_field (args, i, Val_unit); 219 } else if (cs->opCode == OldCall) { 220 // old style (unsafe) version where OCaml values were passed directly from C thread 221 if (cs->argCount == 3) e = caml_callback3_exn(cs->call,cs->a1,cs->a2,cs->a3); 222 else if (cs->argCount == 2) e = caml_callback2_exn(cs->call,cs->a1,cs->a2); 223 else e = caml_callback_exn(cs->call,cs->a1); 224 retType = 'v'; 225 } else if (cs->opCode == FieldAccess) { 226 long index = cs->fieldIndex; 227 e = (index == -1) ? Val_long(Wosize_val(*cs->valueP)) : Field(*cs->valueP, index); 228 retType = cs->fieldType; 229 } 230 231 // Process return value 232 cs->_autorelease = FALSE; 233 cs->ret = e; // OCaml return type -- unsafe... 234 if (!Is_exception_result(e)) { 235 switch (retType) { 236 case 'S': 237 *((NSString **)&cs->retV) = (e == Val_unit) ? NULL : [[NSString alloc] initWithUTF8String:String_val(e)]; 238 cs->_autorelease = TRUE; 239 break; 240 case 'N': 241 if (Is_long (e)) { 242 *((NSNumber **)&cs->retV) = [[NSNumber alloc] initWithLong:Long_val(e)]; 243 } else { 244 *((NSNumber **)&cs->retV) = [[NSNumber alloc] initWithDouble:Double_val(e)]; 245 } 246 cs->_autorelease = TRUE; 247 break; 248 case '@': 249 *((NSObject **)&cs->retV) = (e == Val_unit) ? NULL : [[OCamlValue alloc] initWithValue:e]; 250 cs->_autorelease = TRUE; 251 break; 252 case 'i': 253 *((long *)&cs->retV) = Long_val(e); 254 break; 255 case 'x': 256 break; 257 default: 258 NSCAssert1(0, @"Unknown return type '%c'", retType); 259 break; 260 } 261 } 262 263 if (Is_exception_result(e)) { 264 // get exception string -- it will get thrown back in the calling thread 265 const value *f = caml_named_value("unisonExnInfo"); 266 // We leak memory here... 267 cs->exception = strdup(String_val(caml_callback(*f,Extract_exception(e)))); 268 } 269 270 [pool release]; 271 272 // NSLog(@"*** bridgeThreadWait: returning"); 273 274 // we're done, signal back 275 pthread_mutex_lock(&global_res_lock); 276 _RetState = cs; 277 pthread_cond_signal(&global_res_cond); 278 pthread_mutex_unlock(&global_res_lock); 279 } 280 // Never get here... 281 CAMLreturn (Val_unit); 282 } 283 284 void *_passCall(CallState *cs) 285 { 286 pthread_mutex_lock(&global_call_lock); 287 _CallState = cs; 288 289 // signal so call can happen on other thread 290 pthread_mutex_lock(&global_res_lock); 291 pthread_cond_signal(&global_call_cond); 292 pthread_mutex_unlock(&global_call_lock); 293 294 // NSLog(@"*** _passCall (%d) -- performing signal and waiting", pthread_self()); 295 296 // wait until done -- make sure the result is for our call 297 while (_RetState != cs) pthread_cond_wait(&global_res_cond, &global_res_lock); 298 _RetState = NULL; 299 pthread_mutex_unlock(&global_res_lock); 300 301 // NSLog(@"*** doCallback -- back with result"); 302 if (cs->exception) { 303 @throw [NSException exceptionWithName:@"OCamlException" 304 reason:[NSString stringWithUTF8String:cs->exception] 305 userInfo:nil]; 306 } 307 if (cs->_autorelease) [((id)cs->retV) autorelease]; 308 return cs->retV; 309 } 310 311 void *ocamlCall(const char *argTypes, ...) 312 { 313 CallState cs; 314 cs.opCode = SafeCall; 315 cs.exception = NULL; 316 cs.argTypes = argTypes; 317 va_start(cs.args, argTypes); 318 void * res = _passCall(&cs); 319 320 va_end(cs.args); 321 return res; 322 } 323 324 void *getField(value *vP, long index, char type) 325 { 326 CallState cs; 327 cs.opCode = FieldAccess; 328 cs.valueP = vP; 329 cs.fieldIndex = index; 330 cs.fieldType = type; 331 cs.exception = NULL; 332 return _passCall(&cs); 333 } 334 335 @implementation OCamlValue 336 337 - initWithValue:(long)v 338 { 339 [super init]; 340 _v = v; 341 caml_register_global_root((value *)&_v); 342 return self; 343 } 344 345 - (long)count 346 { 347 return (long)getField((value *) &_v, -1, 'i'); 348 } 349 350 - (void *)getField:(long)i withType:(char)t 351 { 352 return getField((value *)&_v, i, t); 353 } 354 355 - (long)value 356 { 357 // Unsafe to use! 358 return _v; 359 } 360 361 - (void)dealloc 362 { 363 _v = Val_unit; 364 caml_remove_global_root((value *)&_v); 365 [super dealloc]; 366 } 367 @end 368 369 370 // Legacy OCaml call API -- no longer needed 371 #if 0 372 373 extern value doCallback (value c, int argcount, value v1, value v2, value v3, BOOL exitOnException); 374 extern value Callback_checkexn(value c,value v); 375 extern value Callback2_checkexn(value c,value v1,value v2); 376 extern value Callback3_checkexn(value c,value v1,value v2,value v3); 377 378 void reportExn(const char *msg) { 379 NSString *s = [NSString stringWithFormat:@"Uncaught exception: %s", msg]; 380 s = [[s componentsSeparatedByString:@"\n"] componentsJoinedByString:@" "]; 381 NSLog(@"%@",s); 382 NSRunAlertPanel(@"Fatal error",s,@"Exit",nil,nil); 383 } 384 385 // FIXME! Claim is that value conversion must also happen in the OCaml thread... 386 value doCallback (value c, int argcount, value v1, value v2, value v3, BOOL exitOnException) { 387 // NSLog(@"*** doCallback: (%d) -- trying to acquire global lock", pthread_self()); 388 CallState cs; 389 cs.opCode = OldCall; 390 cs.exception = NULL; 391 cs.call = c; 392 cs.a1 = v1; 393 cs.a2 = v2; 394 cs.a3 = v3; 395 cs.argCount = argcount; 396 @try { 397 return _passCall(&cs); 398 } @catch (NSException *ex) { 399 if (exitOnException) { 400 reportExn(cs.exception); 401 exit(1); 402 } 403 @throw ex; 404 } 405 } 406 407 value Callback_checkexn(value c,value v) { 408 return doCallback(c, 1, v, 0, 0, TRUE); 409 } 410 411 value Callback2_checkexn(value c,value v1,value v2) { 412 return doCallback(c, 2, v1, v2, 0, TRUE); 413 } 414 415 value Callback3_checkexn(value c,value v1,value v2,value v3) { 416 return doCallback(c, 3, v1, v2, v3, TRUE); 417 } 418 #endif