diff options
| -rw-r--r-- | src/ChangeLog | 6 | ||||
| -rw-r--r-- | src/boot/ast.boot | 341 | ||||
| -rw-r--r-- | src/boot/translator.boot | 95 | ||||
| -rw-r--r-- | src/interp/sys-os.boot | 6 |
4 files changed, 334 insertions, 114 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 02f1f0d8..4596fc9f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2008-10-21 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/ast.boot: Expand on native call translation. + * interp/sys-os.boot (oa_filedesc_read): Adjust declaration. + (oa_filedesc_write): Likewise. + 2008-10-20 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/debug.lisp (WHOCALLED): Fix thinko. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 1e8a1452..a8018467 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -1209,7 +1209,66 @@ genTypeAlias(head,body) == [op,:args] := head ["DEFTYPE",op,args,backquote(body,args)] ---% Native datatype translation +--% +--% Native Interface Translation +--% + +-- The Native Interface Translation support the following datatypes +-- void: No value, useful only as function return type. +-- +-- char: Character type, corresponds to C type 'char'. +-- +-- byte: 8-bit data type for the unit of information; corresponds +-- to C type 'unsigned char'. +-- +-- int: Native integer data type. Ideally should be wide enough +-- to represent native address space. However, only ECL +-- and GCL seems to give that guarantee at the moment. +-- +-- float: single precision datatype for floating poing values. +-- Corresponds to C type 'float'. On most architecture, +-- this is a 32-bit precision IEEE 756 data type. +-- +-- double: double precision datatype for floating point values. +-- Corresponds to C type 'double'. On most architecture, +-- this is a 64-bit precision IEEE 756 data type. +-- +-- string: a data type for strings of characters. The general +-- semantics is that a string is passed by value (e.g. +-- copied into a separate storage) to a native +-- function. In many cases, that is appropriate (e.g. +-- mkdir "foo") if just wasteful. In other cases, that is +-- not appropriate, as the native function may expect a +-- pass-by-reference semantics, e.g. modify the argument. +-- Consequently, argument types may be combined with the +-- modifiers `readonly' and `writeonly'. Note that a +-- function return type may not use modifiers. +-- Corresponds to C's notion of NUL-terminated string, +-- 'char*'. In particular, the length of a string is +-- stored as separate datum part of the data being +-- transmitted. +-- +-- buffer: A data type constructor for array of simple data +-- (e.g. array of bytes, array of float, array of double). +-- This is used to communicate data between native +-- functions and OpenAxiom functions. The `buffer' type +-- constructor must be used in conjunction with one of the +-- modifier `readonly' or `writeonly', and instantiated +-- with one of `char', `byte', `int', `float', and `double'. +-- It cannot be used a function return type. +-- Note that the length of the array is not stored as +-- part of the data being transmitted. + +$NativeSimpleDataTypes == + '(char byte int float double) + +$NativeSimpleReturnTypes == + [:$NativeSimpleDataTypes,:'(void string)] + +++ Returns true if `t' is a simple native data type. +isSimpleNativeType t == + t in $NativeSimpleReturnTypes + coreSymbol: %Symbol -> %Symbol coreSymbol s == INTERN(SYMBOL_-NAME s, "AxiomCore") @@ -1224,22 +1283,270 @@ unknownNativeTypeError t == nativeType t == - null t => t - -- for the time being, approximate `data buffer' by `pointer to data' - t = "buffer" or t = "pointer" => - %hasFeature KEYWORD::GCL => "FIXNUM" - %hasFeature KEYWORD::ECL => KEYWORD::POINTER_-VOID - %hasFeature KEYWORD::SBCL => ["*",true] + t = nil => t + atom t => + t' := rest ASSOC(coreSymbol t,$NativeTypeTable) => + t' := + %hasFeature KEYWORD::SBCL => bfColonColon("SB-ALIEN", t') + %hasFeature KEYWORD::CLISP => bfColonColon("FFI",t') + t' + -- ??? decree we have not discovered Unicode yet. + t = "string" and %hasFeature KEYWORD::SBCL => + [t',KEYWORD::EXTERNAL_-FORMAT,KEYWORD::ASCII, + KEYWORD::ELEMENT_-TYPE, "BASE-CHAR"] + t' + t = "byte" => + %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),8] + %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT8") + %hasFeature KEYWORD::ECL => KEYWORD::UNSIGNED_-BYTE + -- approximate by 'char' for GCL + nativeType "char" + unknownNativeTypeError t + -- composite, reference type. + first t = "buffer" => + %hasFeature KEYWORD::GCL => "OBJECT" + %hasFeature KEYWORD::ECL => KEYWORD::OBJECT + %hasFeature KEYWORD::SBCL => ["*",nativeType second t] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER") unknownNativeTypeError t - t' := rest ASSOC(coreSymbol t,$NativeTypeTable) => - t' := - %hasFeature KEYWORD::SBCL => bfColonColon("SB-ALIEN", t') - %hasFeature KEYWORD::CLISP => bfColonColon("FFI",t') - t' - -- ??? decree we have not discovered Unicode yet. - t = "string" and %hasFeature KEYWORD::SBCL => - [t',KEYWORD::EXTERNAL_-FORMAT,KEYWORD::ASCII, - KEYWORD::ELEMENT_-TYPE, "BASE-CHAR"] - t' unknownNativeTypeError t + + +++ Check that `t' is a valid return type for a native function, and +++ returns its translation +nativeReturnType t == + t in $NativeSimpleReturnTypes => nativeType t + coreError strconc('"invalid return type for native function: ", + SYMBOL_-NAME t) + + +++ Check that `t' is a valid parameter type for a native function, +++ and returns its translation. +nativeArgumentType t == + t in $NativeSimpleDataTypes => nativeType t + -- Allow 'string' for `pass-by-value' + t = "string" => nativeType t + -- anything else must use a modified reference type. + atom t or #t ^= 2 => + coreError '"invalid argument type for a native function" + [m,[c,t']] := t + -- Require a modifier. + not (m in '(readonly writeonly)) => + coreError '"missing modifier for argument type for a native function" + -- Only 'pointer' and 'buffer' can be instantiated. + not (c in '(buffer pointer)) => + coreError '"expect 'buffer' or 'pointer' type instance" + not (t' in $NativeSimpleDataTypes) => + coreError '"expected simple native data type" + nativeType second t + + +++ True if objects of type native type `t' are sensible to GC. +needsStableReference? t == + not atom t and first t in '(readonly writeonly) + +++ coerce argument `a' to native type `t', in preparation for +++ a call to a native functions. +coerceToNativeType(a,t) == + -- GCL, ECL, and CLISP don't do it this way. + %hasFeature KEYWORD::GCL or %hasFeature KEYWORD::ECL + or %hasFeature KEYWORD::CLISP => a + %hasFeature KEYWORD::SBCL => + not needsStableReference? t => a + [.,[c,y]] := t + c = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] + c = "pointer" => [bfColonColon("SB-SYS","ALIEN-SAP"),a] + needsStableReference? t => + fatalError strconc('"don't know how to coerce argument for native type", + SYMBOL_-NAME c) + fatalError '"don't know how to coerce argument for native type" + + +++ Generate GCL native translation for import op: s -> t for op' +++ `argtypes' is the list of GCL FFI names for types in `s'. +++ `rettype' is the GCL FFI name for `t'. +genGCLnativeTranslation(op,s,t,op') == + argtypes := [nativeArgumentType x for x in s] + rettype := nativeReturnType t + -- If a simpel DEFENTRY will do, go for it + and/[isSimpleNativeType x for x in [t,:s]] => + [["DEFENTRY", op, argtypes, [rettype, SYMBOL_-NAME op']]] + -- Otherwise, do it the hard way. + [["CLINES",ccode], ["DEFENTRY", op, argtypes, [rettype, cop]]] where + cop := strconc(SYMBOL_-NAME op','"__stub") + ccode := + "strconc"/[gclTypeInC t, '" ", cop, '"(", + :[cparm(x,a) for x in tails s for a in tails cargs], + '") { ", (t ^= "void" => '"return "; ""), + SYMBOL_-NAME op', '"(", + :[gclArgsInC(x,a) for x in tails s for a in tails cargs], + '"); }" ] + where cargs := [mkCArgName i for i in 0..(#s - 1)] + mkCArgName i == strconc('"x",STRINGIMAGE i) + cparm(x,a) == + strconc(gclTypeInC first x, '" ", first a, + (rest x => '", "; '"")) + gclTypeInC x == + x in $NativeSimpleDataTypes => SYMBOL_-NAME x + x = "void" => '"void" + x = "string" => '"char*" + '"object" + gclArgInC(x,a) == + x in $NativeSimpleDataTypes => a + x = "string" => strconc(a,'"->st.st__self") + [.,[.,y]] := x + y = "char" => strconc(a,'"->st.st__self") + y = "byte" => strconc(a,'"->ust.ust__self") + y = "int" => strconc(a,'"->fixa.fixa__self") + y = "float" => strconc(a,'"->sfa.sfa__self") + y = "double" => strconc(a,'"->lfa.lfa__self") + coreError '"unknown argument type" + gclArgsInC(x,a) == + strconc(gclArgInC(first x, first a), + (rest x => '", "; '"")) + +genECLnativeTranslation(op,s,t,op') == + args := nil + argtypes := nil + for x in s repeat + argtypes := [nativeReturnType x,:argtypes] + args := [GENSYM(),:args] + argtypes := nreverse argtypes + args := nreverse args + rettype := nativeReturnType t + [["DEFUN",op, args, + [bfColonColon("FFI","C-INLINE"),args,argtypes, + rettype, callTemplate(op',#args,s), + KEYWORD::ONE_-LINER, true]]] where + callTemplate(op,n,s) == + "strconc"/[SYMBOL_-NAME op,'"(", + :[sharpArg(i,x) for i in 0..(n-1) for x in s],'")"] + sharpArg(i,x) == + i = 0 => strconc('"(#0)",selectDatum x) + strconc('",",'"(#", STRINGIMAGE i, '")", selectDatum x) + selectDatum x == + isSimpleNativeType x => '"" + [.,[c,y]] := x + c = "buffer" => + y = "char" or y = "byte" => '"->vector.self.ch" + y = "int" => '"->vector.self.fix" + y = "float" => '"->vector.self.sf" + y = "double" => '"->vector.self.df" + coreError '"unknown argument to buffer type constructor" + c = "pointer" => "" + coreError '"unknown type constructor" + +genCLISPnativeTranslation(op,s,t,op') == + -- check parameter types and return types. + rettype := nativeReturnType t + argtypes := [nativeArgumentType x for x in s] + + -- There is a curious bug in the CLisp's FFI support whereby + -- foreign declarations compiled separately will have the wrong + -- types when used in other modules. We work around that problem + -- by defining forwarding functions to the foreign declarations + -- in the same module the latter are declared. Even if and when + -- that bug is fixed, we still need forwarding function because, + -- CLISP's FFI takes every step to ensure that Lisp world objects + -- do not mix with C world object, presumably because they are not + -- from the same class. Consequently, we must allocate C-storage, + -- copy data there, pass pointers to them, and possibly copy + -- them back. Ugh. + n := INTERN strconc(SYMBOL_-NAME op, '"%clisp-hack") + parms := [GENSYM '"parm" for x in s] -- parameters of the forward decl. + + -- Now, separate non-simple data from the rest. This is a triple-list + -- of the form ((parameter boot-time . ffi-type) ...) + unstableArgs := nil + for p in parms for x in s for y in argtypes repeat + needsStableReference? x => + unstableArgs := [[p,x,:y],:unstableArgs] + + -- The actual FFI declaration for the native call. Note that + -- parameter of non-simple datatype are described as being poinyers. + foreignDecl := + [bfColonColon("FFI","DEF-CALL-OUT"),n, + [KEYWORD::NAME,SYMBOL_-NAME op'], + [KEYWORD::ARGUMENTS,:[[a, x] for x in argtypes for a in parms]], + [KEYWORD::RETURN_-TYPE, rettype], + [KEYWORD::LANGUAGE,KEYWORD::STDC]] + + -- The forwarding function. We have to introduce local foreign + -- variables to hold the address of converted Lisp obejcts. Then + -- we have to copy back those that are `writeonly' to simulate + -- the reference semantics. Don't try ever try to pass around + -- gigantic buffer, you might find out that it is insanely inefficient. + forwardingFun := + null unstableArgs => ["DEFUN",op,parms, [n,:parms]] + localPairs := [[a,x,y,:GENSYM '"loc"] for [a,x,:y] in unstableArgs] + call := + [n,:[actualArg(p,localPairs) for p in parms]] where + actualArg(p,pairs) == + a' := rest ASSOC(p,pairs) => rest rest a' + p + -- Fix up the call if there is any `writeonly' parameter. + call := + fixups := [q | not null (q := copyBack p) for p in localPairs] where + copyBack [p,x,y,:a] == + x isnt ["writeonly",:.] => nil + ["SETF", p, [bfColonColon("FFI","FOREIGN-VALUE"), a]] + null fixups => [call] + [["PROG1",call, :fixups]] + -- Set up local foreign variables to hold address of traveling data + for [p,x,y,:a] in localPairs repeat + call := + [[bfColonColon("FFI","WITH-FOREIGN-OBJECT"), + [a, ["FUNCALL", + ["INTERN",'"getCLISPType",'"BOOTTRAN"], p], p], :call]] + -- Finally, define the forwarding function. + ["DEFUN",op,parms,:call] + $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp] + [forwardingFun] + +getCLISPType a == + [bfColonColon("FFI","C-ARRAY"), #a] + + +genSBCLnativeTranslation(op,s,t,op') == + -- check return type and argument types. + rettype := nativeReturnType t + argtypes := [nativeArgumentType x for x in s] + + args := [GENSYM() for x in s] + unstableArgs := nil + newArgs := nil + for a in args for x in s repeat + newArgs := [coerceToNativeType(a,x), :newArgs] + if needsStableReference? x then + unstableArgs := [a,:unstableArgs] + newArgs := nreverse newArgs + unstableArgs = nreverse unstableArgs + + null unstableArgs => + [["DEFUN",op,args, + [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), + [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', + ["FUNCTION",rettype,:argtypes]], :args]]] + [["DEFUN",op,args, + [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"),unstableArgs, + [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), + [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', + ["FUNCTION",rettype,:argtypes]], :newArgs]]]] + + +++ Generate an import declaration for `op' as equivalent of the +++ foreign signature `sig'. Here, `foreign' operationally means that +++ the entity is from the C language world. +genImportDeclaration(op, sig) == + sig isnt ["Signature", op', m] => coreError '"invalid signature" + m isnt ["Mapping", t, s] => coreError '"invalid function type" + if not null s and SYMBOLP s then s := [s] + + %hasFeature KEYWORD::GCL => genGCLnativeTranslation(op,s,t,op') + %hasFeature KEYWORD::SBCL => genSBCLnativeTranslation(op,s,t,op') + %hasFeature KEYWORD::CLISP => genCLISPnativeTranslation(op,s,t,op') + %hasFeature KEYWORD::ECL => genECLnativeTranslation(op,s,t,op') + fatalError '"import declaration not implemented for this Lisp" + + + diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 66cf4b56..feb87971 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -352,101 +352,6 @@ shoeConsoleTrees s == shoeAddComment l== strconc('"; ", first l) -++ True if objects of type native type `t' are sensible to GC. -needsStableReference? t == - %hasFeature KEYWORD::GCL => false -- - %hasFeature KEYWORD::SBCL or %hasFeature KEYWORD::CLISP - or %hasFeature KEYWORD::ECL => t = "pointer" or t = "buffer" - true -- don't know; conservatively answer `yes'. - - -++ coerce argument `a' to native type `t', in preparation for -++ a call to a native functions. -coerceToNativeType(a,t) == - %hasFeature KEYWORD::GCL => a - %hasFeature KEYWORD::SBCL => - t = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] - t = "string" => a -- 'string's are automatically converted. - needsStableReference? t => - fatalError '"don't know how to coerce argument for native type" - a - %hasFeature KEYWORD::CLISP or %hasFeature KEYWORD::ECL => - needsStableReference? t => - fatalError '"don't know how to coerce argument for native type" - a - fatalError '"don't know how to coerce argument for native type" - -++ filter out arguments that need stable references during call -++ to native function, and convert all arguments as necessary. -prepareArgumentsForNativeCall(args,types) == - unstableArgs := [a for a in args for t in types - | needsStableReference? t] - preparedArgs := [coerceToNativeType(a,t) - for a in args for t in types] - [unstableArgs,preparedArgs] - - -++ Generate an import declaration for `op' as equivalent of the -++ foreign signature `sig'. Here, `foreign' operationally means that -++ the entity is from the C language world. -genImportDeclaration(op, sig) == - sig isnt ["Signature", op', m] => coreError '"invalid signature" - m isnt ["Mapping", t, s] => coreError '"invalid function type" - if not null s and SYMBOLP s then s := [s] - - -- we don't deal with non-trivial return values (yet) - needsStableReference? t => - fatalError '"non trivial return type for native function" - - %hasFeature KEYWORD::GCL => - [["DEFENTRY", op, [nativeType x for x in s], - [nativeType t, SYMBOL_-NAME op']]] - - args := [GENSYM() for x in s] - %hasFeature KEYWORD::SBCL => - [unstableArgs,newArgs] := prepareArgumentsForNativeCall(args,s) - null unstableArgs => - [["DEFUN",op,args, - [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), - [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', - ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :args]]] - [["DEFUN",op,args, - [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"),unstableArgs, - [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"), - [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op', - ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :newArgs]]]] - - %hasFeature KEYWORD::CLISP => - -- there is a curious bug in the CLisp's FFI support whereby - -- foreign declarations compiled separately will have the wrong - -- types when used in other modules. We work around that problem - -- by defining forwarding functions to the foreign declarations - -- in the same module the latter are declared. - foreignDecl := - n := INTERN strconc(SYMBOL_-NAME op, '"%clisp-hack") - [bfColonColon("FFI","DEF-CALL-OUT"),n, - [KEYWORD::NAME,SYMBOL_-NAME op'], - [KEYWORD::ARGUMENTS,:[[a, nativeType x] for x in s for a in args]], - [KEYWORD::RETURN_-TYPE, nativeType t], - [KEYWORD::LANGUAGE,KEYWORD::STDC]] - forwardingFun := - ["DEFUN",op,args, - [n,:[coerceToNativeType(a,t) for a in args for x in s]]] - $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp] - [forwardingFun] - - %hasFeature KEYWORD::ECL => - [["DEFUN",op, args, - [bfColonColon("FFI","C-INLINE"),args,[nativeType x for x in s], - nativeType t, "strconc"/callTemplate(op',#args), - KEYWORD::ONE_-LINER, true]]] where - callTemplate(op,n) == - [SYMBOL_-NAME op,'"(",:[:sharpArg i for i in 0..(n-1)],'")"] - sharpArg i == - i = 0 => ['"#0"] - ['",",'"#", STRINGIMAGE i] - fatalError '"import declaration not implemented for this Lisp" - shoeOutParse stream == $inputStream := stream $stack := [] diff --git a/src/interp/sys-os.boot b/src/interp/sys-os.boot index 3ab992a8..8478299e 100644 --- a/src/interp/sys-os.boot +++ b/src/interp/sys-os.boot @@ -79,11 +79,13 @@ import writeablep: string -> int for writeablep -- 1: exists and write access granted -- 2: inexistent but write access to parent directory granted. -import oa__filedesc__read: (int,buffer,int) -> int for readFromFileHandle +import oa__filedesc__read: (int,writeonly buffer byte,int) -> int + for readFromFileHandle -- -1: failure; otherwise -- actual read bytes count -import oa__filedesc__write: (int,buffer,int) -> int for writeToFileHandle +import oa__filedesc__write: (int,readonly buffer byte,int) -> int + for writeToFileHandle -- -1: failure; otherwise -- actual written bytes count |