/* --- Copyright University of Sussex 2003. All rights reserved. ---------- > File: $popvision/lib/excall.p > Purpose: Call external functions with offset-vector arguments > Author: David Young, May 16 2003 (see revisions) > Documentation: HELP * EXCALL */ /* For calling external routines which require addresses of vector elements. Used thus: excall ext_foo(p, q, BVEC x[i], DVEC y[j], v, w); where BVEC x[i] means to pass the address of the i'th element of the byte vector b (whose type is not checked). Other arguments are passed as usual. Each comma-separated expression in the argument list must put exactly one item on the stack, except for x[i] forms which must leave two, the vector and the index. The number of comma-separated expressions must match the number of arguments declared for the external routine. The main issue is avoiding garbage collections between getting addresses and calling the external procedure. The code below is designed to avoid this by avoiding creating structures or expanding the stack above the immediately previous high point between the sysFIELDs that get the addresses and the sysFIELD that calls the external routine. One apparent exception might be a routine that returns a ddecimal, but testing suggests that the structure is not built until after the external function returns. It's hard to be certain that this means a GC can *never* take place at this point - so an option is provided to set pop_after_gc to trigger a mishap after any GC in the critical region. When this option is on, routines that return ddecimals cannot be used. The sysFIELDs should not trigger a GC themselves, as they use fixed records. */ compile_mode:pop11 +strict; section; vars excall_check_gc = false; lvars excall_vecno = 0; define lconstant excall_name /* -> word */; ;;; New name for an lconstant. (Cannot trust gensym not to get reset!) consword('excall_bXbZmahb_' >< (excall_vecno + 1 ->> excall_vecno)) enddefine; define lconstant compile_exargs(n) -> (veclist, ivec_var); ;;; Compiles an argument list of length n for excall. ;;; Returns a list containing a pair for each indexed vector argument. ;;; Each pair has the type of vector as specified by the keyword ;;; in the code, and its position in the argument list. dlocal pop_autoload = false; lconstant vecwords = [BVEC IVEC FVEC DVEC]; ;;; Plant code to save stack length lvars stacklen = sysNEW_LVAR(); sysCALL("stacklength"); sysPOP(stacklen); ;;; Set up vector to hold indices of indexed argument vectors. Generally ;;; use a compile-time vector to avoid garbage, but a recursive call of ;;; the calling procedure, from within the argument code, will invalidate ;;; this - so we have to detect such a call and use a run-time vector ;;; instead in such cases. lvars ivec_const = excall_name(); ;;; name of compile-time vector sysLCONSTANT(ivec_const, 0); lvars nvec_const = excall_name(); ;;; name of number of indexed args sysLCONSTANT(nvec_const, 0); lvars ivec_var = sysNEW_LVAR(); ;;; name of vector at run-time ;;; Check whether compile-time index vector already in use (i.e. ;;; a recursive call has been made) lvars l1 = sysNEW_LABEL(), l2 = sysNEW_LABEL(); sysPUSH(nvec_const); sysIFNOT(l2); ;;; skip if no indexed vectors sysPUSHQ(1); sysPUSH(ivec_const); sysCALL("fast_subscrv"); sysIFSO(l1); ;;; Not in use if in element one sysPUSH(ivec_const); ;;; Use compile-time vector sysPOP(ivec_var); sysGOTO(l2); sysLABEL(l1); sysPUSH(nvec_const); ;;; Use vector created at run-time sysCALL("initv"); sysPOP(ivec_var); sysLABEL(l2); ;;; Compile argument expressions, noting positions of any that ;;; are vectors with subscripts in veclist, and planting code to store the ;;; subscripts themselves in a vector at run-time. ;;; n is number of arguments. Both a run-time check and a ;;; compile-time check are used to check consistency with this. lvars veclist = [], argno = 0, index_no = 0; pop11_need_nextitem("(") -> ; unless pop11_try_nextitem(")") then ;;; trap empty case repeat argno + 1 -> argno; lvars nxt = pop11_try_nextitem(vecwords); if nxt then ;;; introduces a vector element conspair(nxt, argno) :: veclist -> veclist; pop11_comp_expr_to("[") -> ; pop11_comp_expr_to("]") -> ; pop11_need_nextitem([ , ) ]) -> nxt; sysPUSHQ(index_no + 1 ->> index_no); ;;; indx->ivec(index_no) sysPUSH(ivec_var); sysUCALL("fast_subscrv"); else pop11_comp_expr_to([ , ) ]) -> nxt endif; quitif (nxt == ")") endrepeat; endunless; ncrev(veclist) -> veclist; ;;; so order corresponds to run-time index vec lvars ivec = initv(index_no); ;;; compile-time index vec if index_no > 0 then false -> ivec(1) endif; ;;; not in use initially sysPASSIGN(ivec, ivec_const); ;;; assign to lconstant sysPASSIGN(index_no > 0 and index_no, nvec_const); ;;; no. of indexed args ;;; Compile-time check on number of arguments unless argno == n then mishap(argno, n, 2, 'excall: Wrong number of arguments') endunless; ;;; Run-time check on number of arguments sysCALL("stacklength"); sysPUSH(stacklen); sysCALL("-"); sysPUSHQ(n); ;;; stack should have increased this much sysCALL("=="); lvars l4 = sysNEW_LABEL(); sysIFSO(l4); sysPUSHQ(0); sysPUSHQ('excall: Stack length incorrect'); sysCALL("mishap"); sysLABEL(l4); enddefine; define lconstant exarg_addresses(nargs, veclist, ivec_var); ;;; Plant code to convert vector/subscript pairs into addresses. ;;; The stack increases by 2 before the first conversion; that ;;; high-water-mark is not subsequently exceeded, so we should not ;;; get a GC in critical code. lconstant twords = newassoc( [[BVEC byte] [IVEC int] [FVEC float] [DVEC dfloat]]); lvars v, index_no = 0; for v in veclist do ;;; argument vector to top of stack lvars (type, i) = destpair(v); unless i == nargs then sysSWAP(1, nargs-i+1) endunless; ;;; index onto stack sysPUSHQ(index_no + 1 ->> index_no); sysPUSH(ivec_var); sysCALL("fast_subscrv"); sysSWAP(1, 2); ;;; index below vec ;;; Replace n,vec by address ;;; Bits 8 & 9 set in final arg: address mode, fixed structure sysFIELD(false, conspair(twords(type), 1), false, 8:1400); ;;; Replace address in proper place on stack unless i == nargs then sysSWAP(1, nargs-i+1) endunless; endfor enddefine; define lconstant check_typespec(wd) -> (n, spec); ;;; Check that the typespec for this word is an external procedure ;;; and return the number of arguments. ;;; Code adapted from exacc.p lvars id, fldmode, spec = false; if sys_current_ident(wd <> "':typespec'") ->> id then fast_destpair(fast_idval(id)) -> (fldmode, spec) endif; unless spec then mishap(wd, 1, 'excall: No typespec - external declaration made?') endunless; ;;; I think deref_struct1 not needed here unless spec.isvector then mishap(wd, 1, 'excall: External object not declared as a function') endunless; if ispair(subscrv(1,spec) ->> n) then front(n) -> n endif; ;;; nargs unless n then mishap(wd, 1, 'excall: Does not work with variadic functions') endunless; if excall_check_gc then lvars res_type = subscrv(2, spec); unless not(res_type) or res_type == "sfloat" or res_type == "int" then mishap(wd, res_type, 2, 'excall: Function result only sfloat or int when GC check on') endunless endif enddefine; define syntax excall; lvars func_name = itemread(), (nargs, spec) = check_typespec(func_name), (veclist, ivec_var) = compile_exargs(nargs); ;;; Optionally protect against GC if excall_check_gc then lconstant gc_error = mishap(% 0, 'excall error: GC during critical code, please report' %); sysLOCAL("pop_after_gc"); ;;; to restore if mishap occurs lvars save_pop_after_gc = sysNEW_LVAR(); ;;; to restore in other cases sysPUSH("pop_after_gc"); ;;; stack increases by 2 here sysPUSHQ(gc_error); ;;; so GC should not occur when sysPOP("pop_after_gc"); ;;; exarg_addresses code runs sysPOP(save_pop_after_gc); endif; ;;; Get addresses of vector elements. ;;; From here code is GC-sensitive, but should not trigger one exarg_addresses(nargs, veclist, ivec_var); ;;; Plant call to the external function. sysPUSH(func_name); sysFIELD(nargs, spec, true, 1); ;;; can checking (or whatever) trigger GC? if excall_check_gc then ;;; End of GC-sensitive code - restore pop_after_gc ;;; (Does not rely on localisation as current procedure may do more work.) sysPUSH(save_pop_after_gc); sysPOP("pop_after_gc"); endif; ;;; Reset first element of argument vector to enable reuse if veclist /== [] then sysPUSHQ(false); sysPUSHQ(1); sysPUSH(ivec_var); sysUCALL("fast_subscrv"); endif; pop11_FLUSHED(%%) -> pop_expr_inst; false -> updater(pop_expr_inst); ;;; no update mode enddefine; endsection; /* --- Revision History --------------------------------------------------- --- David Young, Jul 7 2003 Set pop_autoload to in compile_exargs (was v.v. slow) --- David Young, Jun 4 2003 Changed code that stores the vector indices during argument compilation. Originally these were kept on the stack, and stack swapping was used to bring them to the top then reinsert the address into the correct place. This meant a potentially large number of swaps for a long argument list. Now a vector is used to store the indices - this is allocated at compile-time for the normal case, but if a recursive call to the same code is made from the argument list it is necessary to allocate a vector at run-time, creating garbage. --- David Young, May 19 2003 Made GC-checking optional so that function results can be ddecimal. Testing indicates that this is safe under V15.52 on Solaris. --- David Young, May 17 2003 Corrected "double" in field spec to "dfloat" */