1 /* vm.h -*- mode:c; coding:utf-8; -*- 2 * 3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com> 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions 7 * are met: 8 * 9 * 1. Redistributions of source code must retain the above copyright 10 * notice, this list of conditions and the following disclaimer. 11 * 12 * 2. Redistributions in binary form must reproduce the above copyright 13 * notice, this list of conditions and the following disclaimer in the 14 * documentation and/or other materials provided with the distribution. 15 * 16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 * 28 * $Id: $ 29 */ 30 #ifndef SAGITTARIUS_PRIVATE_VM_H_ 31 #define SAGITTARIUS_PRIVATE_VM_H_ 32 33 #include "sagittariusdefs.h" 34 #include "subr.h" /* for SgSubrProc */ 35 #include "thread.h" 36 #include "clos.h" 37 #ifdef HAVE_SETJMP_H 38 # include <setjmp.h> 39 #else 40 # error TODO implement own set jmp 41 #endif 42 43 #define SG_VM_STACK_SIZE 10000 44 45 SG_CLASS_DECL(Sg_BoxClass); 46 SG_CLASS_DECL(Sg_VMClass); 47 48 #define SG_CLASS_BOX (&Sg_BoxClass) 49 #define SG_CLASS_VM (&Sg_VMClass) 50 51 struct SgBoxRec 52 { 53 SG_HEADER; 54 SgObject value; 55 }; 56 57 #define SG_BOX(obj) ((SgBox*)(obj)) 58 #define SG_BOXP(obj) SG_XTYPEP(obj, SG_CLASS_BOX) 59 60 /* continuation frame */ 61 typedef struct SgContFrameRec 62 { 63 struct SgContFrameRec *prev; /* previous frame */ 64 int size; /* size of argument frame */ 65 SgWord *pc; /* next PC */ 66 SgObject cl; /* cl register value */ 67 SgObject *fp; /* fp register value */ 68 SgObject env[1]; /* saved arguments */ 69 } SgContFrame; 70 71 #define CONT_FRAME_SIZE (sizeof(SgContFrame)/sizeof(SgObject)) 72 73 typedef SgObject SgCContinuationProc(SgObject result, void **data); 74 75 /* 76 We need to treat c-stack not the same way as Scheme stack, otherwise 77 it'll consume c-stack infinitely. 78 */ 79 typedef struct SgCStackRec 80 { 81 struct SgCStackRec *prev; 82 SgContFrame *cont; 83 jmp_buf jbuf; 84 } SgCStack; 85 86 typedef struct SgContinucationRec 87 { 88 struct SgContinucationRec * prev; 89 struct SgContinucationRec * floating; 90 SgContFrame *cont; 91 SgObject winders; 92 SgCStack *cstack; 93 SgObject ehandler; 94 SgObject xhandler; 95 int errorReporting; 96 int rewindBefore; 97 } SgContinuation; 98 99 #define SG_CONTINUATION(obj) ((SgContinuation*)obj) 100 #define SG_VM_FLOATING_EP(vm) \ 101 ((vm)->escapePoint? (vm)->escapePoint->floating : (vm)->escapePointFloating) 102 #define SG_VM_FLOATING_EP_SET(vm, ep) \ 103 do { \ 104 if ((vm)->escapePoint) { \ 105 (vm)->escapePoint->floating = (ep); \ 106 } else { \ 107 (vm)->escapePointFloating = (ep); \ 108 } \ 109 } while (0) 110 111 112 typedef struct SgVMProfilerRec SgVMProfiler; 113 114 typedef enum { 115 COMPILING, 116 COMPILED, 117 RUNNING, 118 IMPORTING, 119 FINISHED 120 } SgVMState; 121 122 typedef enum { 123 SG_VM_ESCAPE_NONE, 124 SG_VM_ESCAPE_CONT, 125 SG_VM_ESCAPE_ERROR, 126 SG_VM_ESCAPE_RAISE 127 } SgVMEscapeReason; 128 129 enum { 130 SG_VM_NEW, /* This VM is just created and not attached 131 to the running thread. */ 132 SG_VM_RUNNABLE, /* This VM is attached to a thread which is 133 runnable or blocked. */ 134 SG_VM_STOPPED, /* The thread attached to this VM is stopped 135 by the inspector thread for debugging*/ 136 SG_VM_TERMINATED /* The thread attached to this VM is 137 terminated. */ 138 }; 139 140 enum { 141 SG_VM_REQUEST_SUSPEND = 1L, 142 SG_VM_REQUEST_TERMINATE = 2L, 143 }; 144 145 enum { 146 SG_ERROR_BEING_HANDLED = (1L << 0), 147 SG_ERROR_BEING_REPORTED = (1L << 1) 148 }; 149 150 #define SG_VM_RUNTIME_FLAG_IS_SET(vm, flag) ((vm)->runtimeFlags & (flag)) 151 #define SG_VM_RUNTIME_FLAG_SET(vm, flag) ((vm)->runtimeFlags |= (flag)) 152 #define SG_VM_RUNTIME_FLAG_CLEAR(vm, flag) ((vm)->runtimeFlags &= ~(flag)) 153 154 #define DEFAULT_VALUES_SIZE 32 155 156 typedef struct values_buffer_t 157 { 158 int buffer_size; 159 SgObject values_buffer[1]; 160 } SgValuesBuffer; 161 162 #define SG_ALLOC_VALUES_BUFFER(vm, size) \ 163 do { \ 164 (vm)->extra_values = \ 165 SG_NEW2(SgValuesBuffer*, \ 166 sizeof(SgValuesBuffer)+sizeof(SgObject)*((size)-1)); \ 167 (vm)->extra_values->buffer_size = (size); \ 168 } while (0) 169 170 #define SG_VALUES_REF(vm, i) \ 171 (((i) < DEFAULT_VALUES_SIZE) \ 172 ? (vm)->values[i] \ 173 : (vm)->extra_values->values_buffer[(i)-DEFAULT_VALUES_SIZE]) 174 175 #define SG_VALUES_SET(vm, i, v) \ 176 do { \ 177 if ((i) < DEFAULT_VALUES_SIZE) { \ 178 (vm)->values[i] = (v); \ 179 } else { \ 180 (vm)->extra_values->values_buffer[(i)-DEFAULT_VALUES_SIZE] = (v); \ 181 } \ 182 } while (0) 183 184 struct SgVMRec 185 { 186 SG_HEADER; 187 SgInternalThread thread; /* the system thread executing this VM. */ 188 int threadErrorP: 1; /* if thread ended with exception or not */ 189 int threadState: 31; /* thread state. */ 190 SgInternalMutex vmlock; /* mutex to be used to lock this VM. */ 191 SgInternalCond cond; 192 SgVM *canceller; 193 SgVM *inspector; 194 SgObject name; /* Scheme thread name. */ 195 SgObject specific; /* Scheme thread specific data. */ 196 SgProcedure *thunk; /* Entry point of this VM */ 197 SgObject result; /* thread result */ 198 199 unsigned int flags; /* flags */ 200 unsigned int runtimeFlags; /* flags for runtime */ 201 /* Registers */ 202 SgWord *pc; /* program counter */ 203 SgObject ac; /* accumelator */ 204 SgObject cl; /* current closure */ 205 SgObject *fp; /* frame pointer */ 206 SgObject *sp; /* stack pointer */ 207 SgContFrame *cont; /* saved continuation frame */ 208 /* values buffer */ 209 int valuesCount; 210 SgObject values[DEFAULT_VALUES_SIZE]; 211 SgValuesBuffer *extra_values; 212 213 /* 214 load path 215 */ 216 SgObject loadPath; 217 SgObject dynamicLoadPath; 218 /* 219 Stack: 220 */ 221 SgObject *stack; /* for convenient */ 222 SgObject *stackEnd; 223 224 /* Ports */ 225 SgPort *currentOutputPort; 226 SgPort *currentInputPort; 227 SgPort *currentErrorPort; 228 SgPort *logPort; /* it's not often used.. */ 229 230 /* return point */ 231 SgCStack *cstack; 232 SgContinuation *escapePoint; 233 SgContinuation *escapePointFloating; 234 SgVMEscapeReason escapeReason; 235 void *escapeData[2]; 236 237 /* libraries */ 238 SgObject currentLibrary; 239 /* dynamic winders */ 240 SgObject dynamicWinders; 241 /* 242 exception handlers 243 this is a list of procedures 244 */ 245 SgObject exceptionHandlers; 246 247 /* parameters */ 248 SgObject parameters; 249 250 /* gc related */ 251 int finalizerPending; 252 int attentionRequest; 253 int stopRequest; 254 255 /* statistics */ 256 SgVMState state; 257 int profilerRunning; 258 SgVMProfiler *profiler; 259 260 /* temporary storage for compiled cache 261 storage structure: 262 ((#<code-builder> ...) 263 (#<code-builder> ...) 264 ...) 265 compiled codes are always appended the first list. 266 when importing a library, first list will be appended. 267 */ 268 SgObject cache; 269 /* Sandbox is a hashtable which contains replaced binding. 270 if it's not available then #f is set. */ 271 SgObject sandbox; 272 }; 273 274 /* 275 flag 32bit 276 log level optimization reader/mode misc(cache) 277 00000000 00000000 00000000 00000000 278 */ 279 typedef enum { 280 /* cache mode */ 281 SG_DISABLE_CACHE = 0x00000001, 282 SG_NO_DEBUG_INFO = 0x00000002, 283 SG_CACHE_MASK = 0x000000FF, 284 /* reader mode */ 285 SG_R6RS_MODE = 0x00000100, /* 00000001 */ 286 SG_COMPATIBLE_MODE = 0x00000200, /* 00000010 */ 287 SG_R7RS_MODE = 0x00000400, /* 00000100 */ 288 289 /* optimization */ 290 SG_NO_INLINE_ASM = 0x00010000, 291 SG_NO_INLINE_LOCAL = 0x00020000, 292 SG_NO_LAMBDA_LIFT = 0x00040000, 293 SG_NO_LIBRARY_INLINING = 0x00080000, 294 SG_NO_CONST_INLINING = 0x00100000, 295 SG_ALLOW_OVERWRITE = 0x00200000, 296 SG_ERROR_UNBOUND = 0x00400000, 297 /* log level */ 298 SG_FATAL_LEVEL = 0x01000000, 299 SG_ERROR_LEVEL = 0x02000000, 300 SG_WARN_LEVEL = 0x04000000, 301 SG_INFO_LEVEL = 0x08000000, 302 SG_DEBUG_LEVEL = 0x10000000, 303 SG_TRACE_LEVEL = 0x20000000, 304 SG_LOG_LEVEL_MASK = 0xff000000, 305 306 } VMFlags; 307 308 #define SG_VM(obj) ((SgVM *)obj) 309 #define SG_VMP(obj) SG_XTYPEP(obj, SG_CLASS_VM) 310 311 #define SG_VM_SET_FLAG(vm, flag) ((vm)->flags = ((vm)->flags | (flag))) 312 #define SG_VM_UNSET_FLAG(vm, flag) ((vm)->flags = ((vm)->flags & (~(flag)))) 313 #define SG_VM_IS_SET_FLAG(vm, flag) (((vm)->flags & (flag))) 314 315 #define SG_VM_LOG_LEVEL(vm, level) (((vm)->flags & SG_LOG_LEVEL_MASK) >= level) 316 317 #define SG_CCONT_DATA_SIZE 6 318 319 #define SG_LET_FRAME_SIZE 2 320 #define SG_FRAME_SIZE CONT_FRAME_SIZE 321 322 323 /* from Gauche */ 324 /* Unwind protect */ 325 #define SG_UNWIND_PROTECT \ 326 do { \ 327 SgCStack cstack; \ 328 cstack.prev = Sg_VM()->cstack; \ 329 cstack.cont = NULL; \ 330 Sg_VM()->cstack = &cstack; \ 331 if (setjmp(cstack.jbuf) == 0) { 332 333 #define SG_WHEN_ERROR \ 334 } else { 335 336 #define SG_NEXT_HANDLER \ 337 do { \ 338 if (Sg_VM()->cstack->prev) { \ 339 Sg_VM()->cstack = Sg_VM()->cstack->prev; \ 340 longjmp(Sg_VM()->cstack->jbuf, 1); \ 341 } \ 342 else Sg_Exit(1); \ 343 } while (0) 344 345 #define SG_END_PROTECT \ 346 } \ 347 Sg_VM()->cstack = Sg_VM()->cstack->prev; \ 348 } while (0) 349 350 351 SG_CDECL_BEGIN 352 353 SG_EXTERN SgVM* Sg_NewVM(SgVM *proto, SgObject name); 354 SG_EXTERN SgVM* Sg_NewThreadVM(SgVM *proto, SgObject name); 355 SG_EXTERN SgVM* Sg_SetVMStack(SgVM *vm, SgObject *stack, int stackSize); 356 SG_EXTERN SgObject Sg_Compile(SgObject sexp, SgObject env); 357 SG_EXTERN SgObject Sg_Apply(SgObject proc, SgObject args); 358 SG_EXTERN SgObject Sg_Apply0(SgObject proc); 359 SG_EXTERN SgObject Sg_Apply1(SgObject proc, SgObject arg); 360 SG_EXTERN SgObject Sg_Apply2(SgObject proc, SgObject arg0, SgObject arg1); 361 SG_EXTERN SgObject Sg_Apply3(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2); 362 SG_EXTERN SgObject Sg_Apply4(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2, SgObject arg3); 363 SG_EXTERN SgObject Sg_VMApply0(SgObject proc); 364 SG_EXTERN SgObject Sg_VMApply1(SgObject proc, SgObject arg); 365 SG_EXTERN SgObject Sg_VMApply2(SgObject proc, SgObject arg0, SgObject arg1); 366 SG_EXTERN SgObject Sg_VMApply3(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2); 367 SG_EXTERN SgObject Sg_VMApply4(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2, SgObject arg3); 368 SG_EXTERN SgObject Sg_VMApply(SgObject proc, SgObject args); 369 SG_EXTERN SgObject Sg_VMCallCC(SgObject proc); 370 SG_EXTERN SgObject Sg_VMCallPC(SgObject proc); 371 SG_EXTERN SgVM* Sg_VM(); /* get vm */ 372 SG_EXTERN int Sg_SetCurrentVM(SgVM *vm); 373 SG_EXTERN int Sg_AttachVM(SgVM *vm); 374 SG_EXTERN void Sg_VMDumpCode(SgCodeBuilder *cb); 375 376 SG_EXTERN SgObject Sg_AddLoadPath(SgString *path, int appendP); 377 SG_EXTERN SgObject Sg_AddDynamicLoadPath(SgString *path, int appendP); 378 379 /* eval */ 380 SG_EXTERN SgObject Sg_Eval(SgObject sexp, SgObject env); 381 SG_EXTERN SgObject Sg_VMEval(SgObject sexp, SgObject env); 382 SG_EXTERN SgObject Sg_Environment(SgObject lib, SgObject spec); 383 SG_EXTERN SgObject Sg_VMEnvironment(SgObject lib, SgObject spec); 384 385 /* dynamic-wind */ 386 SG_EXTERN void Sg_VMPushCC(SgCContinuationProc *after, void **data, int datasize); 387 SG_EXTERN SgObject Sg_VMDynamicWind(SgObject before, SgObject thunk, SgObject after); 388 /* c-friendly wrapper from Gauche */ 389 SG_EXTERN SgObject Sg_VMDynamicWindC(SgSubrProc *before, SgSubrProc *body, SgSubrProc *after, void *data); 390 391 /* IO */ 392 SG_EXTERN SgObject Sg_CurrentOutputPort(); 393 SG_EXTERN SgObject Sg_CurrentErrorPort(); 394 SG_EXTERN SgObject Sg_CurrentInputPort(); 395 396 SG_EXTERN SgObject Sg_VMCurrentLibrary(); 397 398 /* exception */ 399 SG_EXTERN SgObject Sg_GetStackTrace(); 400 SG_EXTERN SgObject Sg_GetStackTraceFromCont(SgContFrame *cont); 401 SG_EXTERN SgObject Sg_VMThrowException(SgVM *vm, SgObject exception, 402 int continuableP); 403 SG_EXTERN void Sg_VMDefaultExceptionHandler(SgObject exception); 404 SG_EXTERN SgObject Sg_VMWithErrorHandler(SgObject handler, SgObject thunk, 405 int rewindBefore); 406 SG_EXTERN void Sg_ReportError(SgObject e, SgObject out); 407 SG_EXTERN void Sg_ReportErrorInternal(SgObject e, SgObject out); 408 /* pretty printer for stack trace */ 409 SG_EXTERN void Sg_FormatStackTrace(SgObject e, SgObject out); 410 411 /* finalizer */ 412 SG_EXTERN SgObject Sg_VMFinalizerRun(SgVM *vm); 413 414 /* debuging */ 415 SG_EXTERN void Sg_VMPrintFrame(); 416 SG_EXTERN void Sg_VMPrintFrameOf(SgVM *vm); 417 418 /* root? */ 419 SG_EXTERN int Sg_MainThreadP(); 420 SG_EXTERN int Sg_RootVMP(SgVM *vm); 421 422 /* values */ 423 SG_EXTERN SgObject Sg_VMValues(SgVM *vm, SgObject args); 424 SG_EXTERN SgObject Sg_VMValues2(SgVM *vm, SgObject v1, SgObject v2); 425 SG_EXTERN SgObject Sg_VMValues3(SgVM *vm, SgObject v1, 426 SgObject v2, SgObject v3); 427 SG_EXTERN SgObject Sg_VMValues4(SgVM *vm, SgObject v1, 428 SgObject v2, SgObject v3, SgObject v4); 429 SG_EXTERN SgObject Sg_VMValues5(SgVM *vm, SgObject v1, 430 SgObject v2, SgObject v3, SgObject v4, 431 SgObject v5); 432 433 SG_EXTERN void Sg_VMAcquireGlobalLock(); 434 SG_EXTERN void Sg_VMReleaseGlobalLock(); 435 436 SG_EXTERN void Sg_EnableSandbox(); 437 SG_EXTERN void Sg_DisableSandbox(); 438 439 SG_EXTERN SgObject Sg_VMAttachStackTrace(SgVM *vm, SgObject condition, 440 int skipTop); 441 442 /* it would be too dangerous to exporse */ 443 /* SG_EXTERN SgObject Sg_RootVM(); */ 444 445 SG_CDECL_END 446 447 #endif /* SAGITTARIUS_VM_H_ */ 448 /* 449 end of file 450 Local Variables: 451 coding: utf-8-unix 452 End: 453 */ 454