/* $Id: pl-pro.c,v 1.40 1998/04/15 15:17:07 jan Exp $ Copyright (c) 1990 Jan Wielemaker. All rights reserved. See ../LICENCE to find out about your rights. jan@swi.psy.uva.nl Purpose: Support for virtual machine */ #ifdef SECURE_GC #define O_SECURE 1 /* include checkData() */ #endif #include "pl-incl.h" #ifdef HAVE_MALLOC_H #include #endif /******************************** * CALLING THE INTERPRETER * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Starts a new Prolog toplevel. Resets I/O to point to the user and stops the debugger. Restores I/O and debugger on exit. The Prolog predicate `$break' is called to actually built the break environment. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ word pl_break() { fid_t cid = PL_open_foreign_frame(); term_t goal = PL_new_term_ref(); word rval; PL_put_atom_chars(goal, "$break"); rval = pl_break1(goal); PL_discard_foreign_frame(cid); return rval; } word pl_break1(term_t goal) { extern int Input, Output; bool rval; int inSave = Input; int outSave = Output; long skipSave = debugstatus.skiplevel; int suspSave = debugstatus.suspendTrace; int traceSave, debugSave; tracemode(FALSE, &traceSave); debugmode(FALSE, &debugSave); Input = 0; Output = 1; resetTracer(); { fid_t cid = PL_open_foreign_frame(); rval = callProlog(MODULE_user, goal, FALSE); PL_discard_foreign_frame(cid); } debugstatus.suspendTrace = suspSave; debugstatus.skiplevel = skipSave; tracemode(traceSave, NULL); debugmode(debugSave, NULL); Output = outSave; Input = inSave; return rval; } word pl_notrace1(term_t goal) { bool rval; long skipSave = debugstatus.skiplevel; bool traceSave = debugstatus.tracing; rval = callProlog(NULL, goal, FALSE); debugstatus.skiplevel = skipSave; debugstatus.tracing = traceSave; return rval; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Call a prolog goal from C. The argument must be an instantiated term like for the Prolog predicate call/1. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int callProlog(Module module, term_t goal, int debug) { term_t g = PL_new_term_ref(); functor_t fd; Procedure proc; int flags = (debug ? PL_Q_NORMAL : PL_Q_NODEBUG); PL_strip_module(goal, &module, g); if ( !PL_get_functor(g, &fd) ) return warning("callProlog(): Illegal goal"); proc = lookupProcedure(fd, module); { int arity = arityFunctor(fd); term_t args = PL_new_term_refs(arity); qid_t qid; int n, rval; for(n=0; ncritical > 0 ) /* abort in critical region: delay */ { pl_notrace(); LD->aborted = TRUE; succeed; } if ( !trueFeature(READLINE_FEATURE) ) PopTty(&ttytab); LD->outofstack = FALSE; resetRead(); closeFiles(FALSE); resetReferences(); #ifdef O_PROFILE pl_reset_profiler(); #endif resetStacks(); resetTracer(); resetSignals(); resetForeign(); longjmp(abort_context, 1); /*NOTREACHED*/ fail; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Initial entry point from C to start the Prolog engine. Saves abort context, clears the stack and finally starts the virtual machine interpreter with the toplevel goal. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ bool prolog(volatile atom_t goal) { bool rval; if ( setjmp(abort_context) != 0 ) { goal = ATOM_abort; } else { debugstatus.debugging = FALSE; } emptyStacks(); #ifdef O_LIMIT_DEPTH depth_limit = (unsigned long)DEPTH_NO_LIMIT; #endif gc_status.blocked = 0; gc_status.requested = FALSE; #if O_SHIFT_STACKS shift_status.blocked = 0; #endif LD->in_arithmetic = 0; tracemode(FALSE, NULL); debugmode(FALSE, NULL); debugstatus.suspendTrace = 0; can_abort = TRUE; { fid_t fid = PL_open_foreign_frame(); Procedure p = lookupProcedure(lookupFunctorDef(goal, 0), MODULE_system); for(;;) { qid_t qid; term_t except; *valTermRef(exception_printed) = 0; qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0); rval = PL_next_solution(qid); if ( !rval && (except = PL_exception(qid)) ) { Word p1 = valTermRef(exception_printed); Word p2 = valTermRef(except); predicate_t pred = PL_predicate("unhandled_exception", 2, "$toplevel"); deRef(p1); deRef(p2); { fid_t fid2 = PL_open_foreign_frame(); term_t t0 = PL_new_term_refs(2); PL_put_atom(t0, *p1 == *p2 ? ATOM_true : ATOM_false); PL_put_term(t0+1, except); PL_call_predicate(NULL, FALSE, pred, t0); PL_close_foreign_frame(fid2); pl_notrace(); } PL_close_query(qid); continue; } PL_close_query(qid); break; } PL_discard_foreign_frame(fid); } can_abort = FALSE; return rval; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Cut (!) as called via the meta-call mechanism has no effect. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ word pl_metacut(void) { succeed; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Just for debugging now and then. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int trap_gdb() { return 0; } #if O_SECURE || O_DEBUG || defined(O_MAINTENANCE) /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - checkData(p) verifies p points to valid Prolog data and generates a system error otherwise. The checks performed are much more rigid than those during normal execution. Arity of terms is limited to 100 as a kind of heuristic. Note that we expect terms on the global stack. This is true in the interpreter, but not everywere in the system (records use terms on the heap). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define onGlobal(p) onStack(global, p) #define onLocal(p) onStack(local, p) #define onHeap(p) ((char *)p >= (char *)hBase && (char *)p <= (char *)hTop) static void printk(char *fm, ...) { va_list args; va_start(args, fm); Sfprintf(Serror, "[DATA INCONSISTENCY: "); Svfprintf(Serror, fm, args); Sfprintf(Serror, "]\n"); va_end(args); trap_gdb(); } word checkData(Word p) { int arity; int n; Word p2; while(isRef(*p)) { p2 = unRef(*p); if ( p2 > p ) printk("Reference to higher address"); if ( !onLocal(p2) && !onGlobal(p2) ) printk("Illegal reference pointer at 0x%x --> 0x%x", p, p2); return checkData(p2); } if ( isVar(*p) ) return 0x737473; /* just a random number */ if ( isTaggedInt(*p) ) return *p; if ( isIndirect(*p) ) { if ( storage(*p) != STG_GLOBAL ) printk("Indirect data not on global"); if ( isBignum(*p) ) return (word) valBignum(*p); if ( isReal(*p) ) return (word) valReal(*p); if ( isString(*p) ) { if ( sizeString(*p) != strlen(valString(*p)) ) printk("String has inconsistent length: 0x%x", *p); return *addressIndirect(*p); } printk("Illegal indirect datatype"); } if ( isAtom(*p) ) return *p; /* now it should be a term */ if ( tag(*p) != TAG_COMPOUND || storage(*p) != STG_GLOBAL ) printk("Illegal term at: %p: 0x%x", p, *p); { word key = 0L; Functor f = valueTerm(*p); if ( !onGlobal(f) ) printk("Term at %p not on global stack", f); if ( tag(f->definition) != TAG_ATOM || storage(f->definition) != STG_GLOBAL ) printk("Illegal term: 0x%x", *p); arity = arityFunctor(f->definition); if (arity <= 0 || arity > 100) printk("Illegal arity"); for(n=0; narguments[n]); return key; } } #endif /* TEST */