diff --git a/basis/Foreign.sml b/basis/Foreign.sml index ecdd842e..4115a0c5 100644 --- a/basis/Foreign.sml +++ b/basis/Foreign.sml @@ -1,3139 +1,3091 @@ (* Title: Foreign Function Interface: main part Author: David Matthews Copyright David Matthews 2015-16, 2018-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature FOREIGN = sig exception Foreign of string structure Memory: sig eqtype volatileRef val volatileRef: SysWord.word -> volatileRef val setVolatileRef: volatileRef * SysWord.word -> unit val getVolatileRef: volatileRef -> SysWord.word eqtype voidStar val voidStar2Sysword: voidStar -> SysWord.word val sysWord2VoidStar: SysWord.word -> voidStar val null: voidStar val ++ : voidStar * word -> voidStar val -- : voidStar * word -> voidStar (* Remember an address except across loads. *) val memoise: ('a -> voidStar) ->'a -> unit -> voidStar exception Memory (* malloc - allocate memory. N.B. argument is the number of bytes. Raises Memory exception if it cannot allocate. *) val malloc: word -> voidStar (* free - free allocated memory. *) val free: voidStar -> unit val get8: voidStar * Word.word -> Word8.word val get16: voidStar * Word.word -> Word.word val get32: voidStar * Word.word -> Word32.word val get64: voidStar * Word.word -> SysWord.word val set8: voidStar * Word.word * Word8.word -> unit val set16: voidStar * Word.word * Word.word -> unit val set32: voidStar * Word.word * Word32.word -> unit val set64: voidStar * Word.word * SysWord.word -> unit val getFloat: voidStar * Word.word -> real val getDouble: voidStar * Word.word -> real val setFloat: voidStar * Word.word * real -> unit val setDouble: voidStar * Word.word * real -> unit val getAddress: voidStar * Word.word -> voidStar val setAddress: voidStar * Word.word * voidStar -> unit end structure System: sig type voidStar = Memory.voidStar type externalSymbol val loadLibrary: string -> voidStar and loadExecutable: unit -> voidStar and freeLibrary: voidStar -> unit and getSymbol: voidStar * string -> voidStar and externalFunctionSymbol: string -> externalSymbol and externalDataSymbol: string -> externalSymbol and addressOfExternal: externalSymbol -> voidStar end structure LibFFI: sig eqtype abi (* List of ABIs defined in libffi for this platform. *) val abiList: (string * abi) list (* The default Abi. *) val abiDefault: abi (* Type codes. *) val ffiTypeCodeVoid: Word.word and ffiTypeCodeInt: Word.word and ffiTypeCodeFloat: Word.word and ffiTypeCodeDouble: Word.word and ffiTypeCodeUInt8: Word.word and ffiTypeCodeSInt8: Word.word and ffiTypeCodeUInt16: Word.word and ffiTypeCodeSInt16: Word.word and ffiTypeCodeUInt32: Word.word and ffiTypeCodeSInt32: Word.word and ffiTypeCodeUInt64: Word.word and ffiTypeCodeSInt64: Word.word and ffiTypeCodeStruct: Word.word and ffiTypeCodePointer: Word.word (* Predefined types. These are addresses so have to be reloaded in each session. *) eqtype ffiType val ffiType2voidStar: ffiType -> Memory.voidStar val voidStar2ffiType: Memory.voidStar -> ffiType val getFFItypeVoid: unit -> ffiType and getFFItypeUint8: unit -> ffiType and getFFItypeSint8: unit -> ffiType and getFFItypeUint16: unit -> ffiType and getFFItypeSint16: unit -> ffiType and getFFItypeUint32: unit -> ffiType and getFFItypeSint32: unit -> ffiType and getFFItypeUint64: unit -> ffiType and getFFItypeSint64: unit -> ffiType and getFFItypeFloat: unit -> ffiType and getFFItypeDouble: unit -> ffiType and getFFItypePointer: unit -> ffiType and getFFItypeUChar: unit -> ffiType and getFFItypeSChar: unit -> ffiType and getFFItypeUShort: unit -> ffiType and getFFItypeSShort: unit -> ffiType and getFFItypeUint: unit -> ffiType and getFFItypeSint: unit -> ffiType and getFFItypeUlong: unit -> ffiType and getFFItypeSlong: unit -> ffiType val extractFFItype: ffiType -> { size: word, align: word, typeCode: word, elements: ffiType list } val createFFItype: { size: word, align: word, typeCode: word, elements: ffiType list } -> ffiType end structure Error: sig type syserror = LibrarySupport.syserror val getLastError: unit -> SysWord.word val setLastError: SysWord.word -> unit val fromWord: SysWord.word -> syserror and toWord: syserror -> SysWord.word end type library type symbol val loadLibrary: string -> library val loadExecutable: unit -> library val getSymbol: library -> string -> symbol val symbolAsAddress: symbol -> Memory.voidStar val externalFunctionSymbol: string -> symbol and externalDataSymbol: string -> symbol structure LowLevel: sig type ctype = { size: Word.word, (* Size in bytes *) align: Word.word, (* Alignment *) ffiType: unit -> LibFFI.ffiType } val cTypeVoid: ctype and cTypePointer: ctype and cTypeInt8: ctype and cTypeChar: ctype and cTypeUint8: ctype and cTypeUchar: ctype and cTypeInt16: ctype and cTypeUint16: ctype and cTypeInt32: ctype and cTypeUint32: ctype and cTypeInt64: ctype and cTypeUint64: ctype and cTypeInt: ctype and cTypeUint: ctype and cTypeLong: ctype and cTypeUlong: ctype and cTypeFloat: ctype and cTypeDouble: ctype val cStruct: ctype list -> ctype val callwithAbi: LibFFI.abi -> ctype list -> ctype -> symbol -> Memory.voidStar * Memory.voidStar -> unit val call: ctype list -> ctype -> symbol -> Memory.voidStar * Memory.voidStar -> unit val cFunctionWithAbi: LibFFI.abi -> ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar val cFunction: ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar end type 'a conversion val makeConversion: { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } -> 'a conversion val breakConversion: 'a conversion -> { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } val cVoid: unit conversion val cPointer: Memory.voidStar conversion val cInt8: int conversion val cUint8: int conversion val cChar: char conversion val cUchar: Word8.word conversion val cInt16: int conversion val cUint16: int conversion val cInt32: int conversion val cUint32: int conversion val cInt64: int conversion val cUint64: int conversion val cInt32Large: LargeInt.int conversion val cUint32Large: LargeInt.int conversion val cInt64Large: LargeInt.int conversion val cUint64Large: LargeInt.int conversion val cShort: int conversion val cUshort: int conversion val cInt: int conversion val cUint: int conversion val cLong: int conversion val cUlong: int conversion val cIntLarge: LargeInt.int conversion val cUintLarge: LargeInt.int conversion val cLongLarge: LargeInt.int conversion val cUlongLarge: LargeInt.int conversion val cString: string conversion val cByteArray: Word8Vector.vector conversion val cFloat: real conversion val cDouble: real conversion (* When a pointer e.g. a string may be null. *) val cOptionPtr: 'a conversion -> 'a option conversion type 'a closure val cFunction: ('a->'b) closure conversion val buildClosure0withAbi: (unit -> 'a) * LibFFI.abi * unit * 'a conversion -> (unit -> 'a) closure val buildClosure0: (unit -> 'a) * unit * 'a conversion -> (unit -> 'a) closure val buildClosure1withAbi: ('a -> 'b) * LibFFI.abi * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure1: ('a -> 'b) * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure2withAbi: ('a * 'b -> 'c) * LibFFI.abi * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure2: ('a * 'b -> 'c) * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure3withAbi: ('a * 'b *'c -> 'd) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure3: ('a * 'b *'c -> 'd) * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure4withAbi: ('a * 'b * 'c * 'd -> 'e) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure4: ('a * 'b * 'c * 'd -> 'e) * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure5withAbi: ('a * 'b * 'c * 'd * 'e -> 'f) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure5: ('a * 'b * 'c * 'd * 'e -> 'f) * ('a conversion * 'b conversion * 'c conversion* 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure6withAbi: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure val buildClosure6: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure (* Remove the "free" from a conversion. Used if extra memory allocated by the argument must not be freed when the function returns. *) val permanent: 'a conversion -> 'a conversion (* Call by reference. *) val cStar: 'a conversion -> 'a ref conversion (* Pass a const pointer *) val cConstStar: 'a conversion -> 'a conversion (* Fixed size vector. It is treated as a struct and passed by value or embedded in a structure. *) val cVectorFixedSize: int * 'a conversion -> 'a vector conversion (* Pass an ML vector as a pointer to a C array. *) and cVectorPointer: 'a conversion -> 'a vector conversion (* Pass an ML array as a pointer to a C array and, on return, update each element of the ML array from the C array. *) and cArrayPointer: 'a conversion -> 'a array conversion (* structs. *) val cStruct2: 'a conversion * 'b conversion -> ('a * 'b) conversion val cStruct3: 'a conversion * 'b conversion * 'c conversion -> ('a*'b*'c)conversion val cStruct4: 'a conversion * 'b conversion * 'c conversion * 'd conversion -> ('a*'b*'c*'d)conversion val cStruct5: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion -> ('a*'b*'c*'d*'e)conversion val cStruct6: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion -> ('a*'b*'c*'d*'e*'f)conversion val cStruct7: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion -> ('a*'b*'c*'d*'e*'f*'g)conversion val cStruct8: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion -> ('a*'b*'c*'d*'e*'f*'g*'h)conversion val cStruct9: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i)conversion val cStruct10: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j)conversion val cStruct11: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k)conversion val cStruct12: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l)conversion val cStruct13: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m)conversion val cStruct14: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n)conversion val cStruct15: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o)conversion val cStruct16: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p)conversion val cStruct17: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q)conversion val cStruct18: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r)conversion val cStruct19: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s)conversion val cStruct20: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion * 't conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s*'t)conversion val buildCall0withAbi: LibFFI.abi * symbol * unit * 'a conversion -> unit -> 'a val buildCall0: symbol * unit * 'a conversion -> unit -> 'a val buildCall1withAbi: LibFFI.abi * symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall1: symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall2withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall2: symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall3withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall3: symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall4withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall4: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall5withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall5: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall6withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall6: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall7withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall7: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall8withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall8: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall9withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall9: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall10withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall10: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall11withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall11: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall12withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall12: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall13withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall13: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall14withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o val buildCall14: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o end; structure Foreign:> FOREIGN = struct fun id x = x exception Foreign = RunCall.Foreign open ForeignConstants structure Memory = ForeignMemory infix 6 ++ -- (* Internal utility function. *) fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) local val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg))) end structure System = struct type voidStar = Memory.voidStar type externalSymbol = voidStar fun loadLibrary(s: string): voidStar = ffiGeneral (2, s) and loadExecutable(): voidStar = ffiGeneral (3, ()) and freeLibrary(s: voidStar): unit = ffiGeneral (4, s) and getSymbol(lib: voidStar, s: string): voidStar = ffiGeneral (5, (lib, s)) (* Create an external symbol object. The first word of this is filled in with the address after the code is exported and linked. On a small number of platforms different relocations are required for functions and for data. *) val externalFunctionSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtFn" and externalDataSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtData" (* An external symbol is a memory cell containing the value in the first word followed by the symbol name. Because the first word is the value it can be treated as a Sysword.word value. When it is created the value is zero and the address of the target is only set once the symbol has been exported and the value set by the linker. *) fun addressOfExternal(ext: externalSymbol): voidStar = if Memory.voidStar2Sysword ext = 0w0 then raise Foreign "External symbol has not been set" else ext end structure Error = struct type syserror = LibrarySupport.syserror fun toWord (s: syserror): SysWord.word = RunCall.unsafeCast s and fromWord (w: SysWord.word) : syserror = RunCall.unsafeCast w local val callGetError = RunCall.rtsCallFast1 "PolyFFIGetError" in fun getLastError(): SysWord.word = let val mem = RunCall.allocateByteMemory(0w1, 0wx41) val () = callGetError mem val () = RunCall.clearMutableBit mem in RunCall.unsafeCast mem end end val setLastError: SysWord.word -> unit = RunCall.rtsCallFast1 "PolyFFISetError" end structure LibFFI = struct type abi = Word.word val abiList: (string * abi) list = ffiGeneral (50, ()) local fun getConstant (n: int) : Word.word = ffiGeneral (51, n) in val abiDefault = getConstant 0 and ffiTypeCodeVoid = getConstant 1 and ffiTypeCodeInt = getConstant 2 and ffiTypeCodeFloat = getConstant 3 and ffiTypeCodeDouble = getConstant 4 and ffiTypeCodeUInt8 = getConstant 5 and ffiTypeCodeSInt8 = getConstant 6 and ffiTypeCodeUInt16 = getConstant 7 and ffiTypeCodeSInt16 = getConstant 8 and ffiTypeCodeUInt32 = getConstant 9 and ffiTypeCodeSInt32 = getConstant 10 and ffiTypeCodeUInt64 = getConstant 11 and ffiTypeCodeSInt64 = getConstant 12 and ffiTypeCodeStruct = getConstant 13 and ffiTypeCodePointer = getConstant 14 end type ffiType = Memory.voidStar val ffiType2voidStar = id and voidStar2ffiType = id local fun getFFItype (n: int) (): ffiType = ffiGeneral (52, n) in val getFFItypeVoid = getFFItype 0 and getFFItypeUint8 = getFFItype 1 and getFFItypeSint8 = getFFItype 2 and getFFItypeUint16 = getFFItype 3 and getFFItypeSint16 = getFFItype 4 and getFFItypeUint32 = getFFItype 5 and getFFItypeSint32 = getFFItype 6 and getFFItypeUint64 = getFFItype 7 and getFFItypeSint64 = getFFItype 8 and getFFItypeFloat = getFFItype 9 and getFFItypeDouble = getFFItype 10 and getFFItypePointer = getFFItype 11 and getFFItypeUChar = getFFItype 12 and getFFItypeSChar = getFFItype 13 and getFFItypeUShort = getFFItype 14 and getFFItypeSShort = getFFItype 15 and getFFItypeUint = getFFItype 16 and getFFItypeSint = getFFItype 17 and getFFItypeUlong = getFFItype 18 and getFFItypeSlong = getFFItype 19 end fun extractFFItype (s: ffiType) = let val (size: word, align: word, typ: word, elem: Memory.voidStar) = ffiGeneral (53, s) (* Unpack the "elements". *) open Memory fun loadElements i = let val a = getAddress(elem, i) in if a = null then [] else a :: loadElements(i+0w1) end val elements = if elem = sysWord2VoidStar 0w0 then [] else loadElements 0w0 in { size=size, align=align, typeCode = typ, elements = elements } end (* Construct a new FFItype in allocated memory. *) fun createFFItype { size: word, align: word, typeCode: word, elements: ffiType list }: ffiType = ffiGeneral (54, (size, align, typeCode, elements)) end type library = unit -> Memory.voidStar type symbol = unit -> Memory.voidStar (* Load the library but memoise it so if we reference the library in another session we will reload it. We load the library immediately so that if there is an error we get the error immediately. *) fun loadLibrary (name: string): library = Memory.memoise System.loadLibrary name and loadExecutable (): library = Memory.memoise System.loadExecutable () (* To get a symbol we memoise a function that forces a library load if necessary and then gets the symbol. *) fun getSymbol(lib: library) (name: string): symbol = Memory.memoise (fn s => System.getSymbol(lib(), s)) name (* This forces the symbol to be loaded. The result is NOT memoised. *) fun symbolAsAddress(s: symbol): Memory.voidStar = s() (* Create an external symbol. This can only be used after linking. *) fun externalFunctionSymbol(name: string): symbol = let val r = System.externalFunctionSymbol name in fn () => System.addressOfExternal r end and externalDataSymbol(name: string): symbol = let val r = System.externalDataSymbol name in fn () => System.addressOfExternal r end structure LowLevel = struct type ctype = { size: Word.word, (* Size in bytes *) align: Word.word, (* Alignment *) ffiType: unit -> LibFFI.ffiType } local open LibFFI Memory in val cTypeVoid = { size= #size saVoid, align= #align saVoid, ffiType = memoise getFFItypeVoid () } val cTypePointer = { size= #size saPointer, align= #align saPointer, ffiType = memoise getFFItypePointer () } val cTypeInt8 = { size= #size saSint8, align= #align saSint8, ffiType = memoise getFFItypeSint8 () } val cTypeChar = cTypeInt8 val cTypeUint8 = { size= #size saUint8, align= #align saUint8, ffiType = memoise getFFItypeUint8 () } val cTypeUchar = cTypeUint8 val cTypeInt16 = { size= #size saSint16, align= #align saSint16, ffiType = memoise getFFItypeSint16 () } val cTypeUint16 = { size= #size saUint16, align= #align saUint16, ffiType = memoise getFFItypeUint16 () } val cTypeInt32 = { size= #size saSint32, align= #align saSint32, ffiType = memoise getFFItypeSint32 () } val cTypeUint32 = { size= #size saUint32, align= #align saUint32, ffiType = memoise getFFItypeUint32 () } val cTypeInt64 = { size= #size saSint64, align= #align saSint64, ffiType = memoise getFFItypeSint64 () } val cTypeUint64 = { size= #size saUint64, align= #align saUint64, ffiType = memoise getFFItypeUint64 () } val cTypeInt = { size= #size saSint, align= #align saSint, ffiType = memoise getFFItypeSint () } val cTypeUint = { size= #size saUint, align= #align saUint, ffiType = memoise getFFItypeUint () } val cTypeLong = { size= #size saSlong, align= #align saSlong, ffiType = memoise getFFItypeSlong () } val cTypeUlong = { size= #size saUlong, align= #align saUlong, ffiType = memoise getFFItypeUlong () } val cTypeFloat = { size= #size saFloat, align= #align saFloat, ffiType = memoise getFFItypeFloat () } val cTypeDouble = { size= #size saDouble, align= #align saDouble, ffiType = memoise getFFItypeDouble () } fun cStruct(fields: ctype list): ctype = let (* The total alignment is the maximum alignment of the fields. *) val align = foldl(fn ({align, ...}, a) => Word.max(align, a)) 0w1 fields (* Each field needs to be on its alignment. Finally we round up the size to the total alignment. *) val size = alignUp(foldl(fn ({align, size, ...}, s) => alignUp(s, align) + size) 0w0 fields, align) val types = map #ffiType fields (* Make the type but only when it's used. *) fun ffiType () = LibFFI.createFFItype { size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = map (fn t => t()) types } in {align=align, size=size, ffiType=memoise ffiType ()} end local fun getType ctype = Memory.voidStar2Sysword(#ffiType ctype ()) + val callbackException: unit -> unit = RunCall.rtsCallFast0 "PolyFFICallbackException" in fun callwithAbi (abi: abi) (argTypes: ctype list) (resType: ctype): symbol -> voidStar * voidStar -> unit = let (* Compile the intermediate function. *) val functionCaller: LargeWord.word * LargeWord.word * LargeWord.word -> unit = RunCall.foreignCall(Word.toInt abi, List.map getType argTypes, getType resType) (* The result function. *) fun callFunction (fnAddr: unit->voidStar) (args, resMem) = functionCaller(voidStar2Sysword(fnAddr()), voidStar2Sysword args, voidStar2Sysword resMem) in callFunction end fun call x = callwithAbi abiDefault x (* Have to make it a fun to avoid value restriction *) (* Build a call-back function. Returns a function to take the actual ML function, create a callback and then return the address. *) fun cFunctionWithAbi (abi: abi) (argTypes: ctype list) (resType: ctype) (cbFun: voidStar * voidStar -> unit): voidStar = let - fun callBack(args, resMem) = cbFun(sysWord2VoidStar args, sysWord2VoidStar resMem) + fun callBack(args, resMem) = + cbFun(sysWord2VoidStar args, sysWord2VoidStar resMem) + handle _ => callbackException() val cCallBack = RunCall.buildCallBack(Word.toInt abi, List.map getType argTypes, getType resType) callBack in sysWord2VoidStar cCallBack end fun cFunction x = cFunctionWithAbi abiDefault x end end end type 'a conversion = { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store a value in C memory *) updateML: Memory.voidStar * 'a -> unit, (* Update ML value after call - only used in cStar. *) updateC: Memory.voidStar * 'a -> unit, (* Update C value after callback - only used in cStar. *) ctype: LowLevel.ctype } fun makeConversion { load, store, ctype } = { load = load, store = store, ctype = ctype, updateML = fn _ => (), updateC = fn _ => () } fun breakConversion({load, store, ctype, ... }: 'a conversion) = { load = load, store = store, ctype = ctype } (* Conversions *) local open LibFFI Memory LowLevel fun checkRangeShort(i, min, max) = if i < min orelse i > max then raise Overflow else i fun checkRangeLong(i: LargeInt.int, min, max) = if i < min orelse i > max then raise Overflow else i fun noFree _ = () (* None of these allocate extra memory or need to update. *) in val cVoid: unit conversion = makeConversion{ load=fn _ => (), store=fn _ => noFree, ctype = cTypeVoid } (* cPointer should only be used to base other conversions on. *) val cPointer: voidStar conversion = makeConversion { load=fn a => getAddress(a, 0w0), store=fn(a, v) => (setAddress(a, 0w0, v); noFree), ctype = cTypePointer } local fun load(m: voidStar): int = Word8.toIntX(get8(m, 0w0)) fun store(m: voidStar, i: int) = (set8(m, 0w0, Word8.fromInt(checkRangeShort(i, ~128, 127))); noFree) in val cInt8: int conversion = makeConversion { load=load, store=store, ctype = cTypeInt8 } end local (* Char is signed in C but unsigned in ML. *) fun load(m: voidStar): char = Char.chr(Word8.toInt(get8(m, 0w0))) fun store(m: voidStar, i: char) = (set8(m, 0w0, Word8.fromInt(Char.ord i)); noFree) in val cChar: char conversion = makeConversion{ load=load, store=store, ctype = cTypeChar } end local (* Uchar - convert as Word8.word. *) fun load(m: voidStar): Word8.word = get8(m, 0w0) fun store(m: voidStar, i: Word8.word) = (set8(m, 0w0, i); noFree) in val cUchar: Word8.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUchar } end local fun load(m: voidStar): int = Word8.toInt(get8(m, 0w0)) fun store(m: voidStar, i: int) = (set8(m, 0w0, Word8.fromInt(checkRangeShort(i, 0, 255))); noFree) in val cUint8: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint8 } end local (* Because the word length is greater than the length returned by get16 we have to do something special to get the sign bit correct. That isn't necessary in the other cases. *) fun load(m: voidStar): int = let (* Could be done with shifts *) val r = Word.toInt(get16(m, 0w0)) in if r >= 32768 then r - 65536 else r end fun store(m: voidStar, i: int) = (set16(m, 0w0, Word.fromInt(checkRangeShort(i, ~32768, 32767))); noFree) in val cInt16: int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt16 } end local fun load(m: voidStar): int = Word.toInt(get16(m, 0w0)) fun store(m: voidStar, i: int) = (set16(m, 0w0, Word.fromInt(checkRangeShort(i, 0, 65535))); noFree) in val cUint16: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint16 } end local fun load(m: voidStar): int = Word32.toIntX(get32(m, 0w0)) val checkRange = if wordSize = 0w4 andalso isSome (Int.maxInt) then fn i => i (* We're using fixed precision 31-bit - no check necessary. *) else let (* These will overflow on fixed precision 31-bit. *) val max32 = Int32.toInt(valOf Int32.maxInt) val min32 = ~max32 - 1 in fn i => checkRangeShort(i, min32, max32) end fun store(m: voidStar, i: int) = (set32(m, 0w0, Word32.fromInt(checkRange i)); noFree) in val cInt32: int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt32 } end local fun load(m: voidStar): LargeInt.int = Word32.toLargeIntX(get32(m, 0w0)) fun store(m: voidStar, i: LargeInt.int) = (set32(m, 0w0, Word32.fromLargeInt(checkRangeLong(i, ~2147483648, 2147483647))); noFree) in val cInt32Large: LargeInt.int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt32 } end local fun load(m: voidStar): int = Word32.toInt(get32(m, 0w0)) val checkRange = if wordSize = 0w4 andalso isSome (Int.maxInt) then fn i => if i < 0 then raise Overflow else i (* Fixed precision 31-bit *) else let (* This will overflow on fixed precision 31-bit. *) val max32 = Int32.toInt(valOf Int32.maxInt) val max32Unsigned = max32 * 2 + 1 in fn i => checkRangeShort(i, 0, max32Unsigned) end fun store(m: voidStar, i: int) = (set32(m, 0w0, Word32.fromInt(checkRange i)); noFree) in val cUint32: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end local fun load(m: voidStar): LargeInt.int = Word32.toLargeInt(get32(m, 0w0)) fun store(m: voidStar, i: LargeInt.int) = (set32(m, 0w0, Word32.fromLargeInt(checkRangeLong(i, 0, 4294967295))); noFree) in val cUint32Large: LargeInt.int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end local fun loadLarge(m: voidStar): LargeInt.int = if sysWordSize = 0w4 then let val v1 = get32(m, 0w0) and v2 = get32(m, 0w1) in if bigEndian then IntInf.<<(Word32.toLargeIntX v1, 0w32) + Word32.toLargeInt v2 else IntInf.<<(Word32.toLargeIntX v2, 0w32) + Word32.toLargeInt v1 end else SysWord.toLargeIntX(get64(m, 0w0)) fun loadShort(m: voidStar): int = if sysWordSize = 0w4 then Int.fromLarge(loadLarge m) else SysWord.toIntX(get64(m, 0w0)) val max = IntInf.<<(1, 0w63) - 1 and min = ~ (IntInf.<<(1, 0w63)) fun storeLarge(m: voidStar, i: LargeInt.int) = if sysWordSize = 0w4 then let val _ = checkRangeLong(i, min, max) val lo = Word32.fromLargeInt i and hi = Word32.fromLargeInt (IntInf.~>>(i, 0w32)) in if bigEndian then (set32(m, 0w0, hi); set32(m, 0w1, lo)) else (set32(m, 0w0, lo); set32(m, 0w1, hi)); noFree end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, min, max))); noFree) fun storeShort(m: voidStar, i: int) = if sysWordSize = 0w4 orelse not (isSome Int.maxInt) then (* 32-bit or arbitrary precision. *) storeLarge(m, LargeInt.fromInt i) else (* Fixed precision 64-bit - no need for a range check. *) (set64(m, 0w0, SysWord.fromInt i); noFree) in val cInt64: int conversion = makeConversion{ load=loadShort, store=storeShort, ctype = cTypeInt64 } and cInt64Large: LargeInt.int conversion = makeConversion{ load=loadLarge, store=storeLarge, ctype = cTypeInt64 } end local fun loadLarge(m: voidStar): LargeInt.int = if sysWordSize = 0w4 then let val v1 = get32(m, 0w0) and v2 = get32(m, 0w1) in if bigEndian then IntInf.<<(Word32.toLargeInt v1, 0w32) + Word32.toLargeInt v2 else IntInf.<<(Word32.toLargeInt v2, 0w32) + Word32.toLargeInt v1 end else SysWord.toLargeInt(get64(m, 0w0)) fun loadShort(m: voidStar): int = if wordSize = 0w4 then Int.fromLarge(loadLarge m) else SysWord.toInt(get64(m, 0w0)) val max = IntInf.<<(1, 0w64) - 1 fun storeLarge(m: voidStar, i: LargeInt.int) = if sysWordSize = 0w4 then let val _ = checkRangeLong(i, 0, max) val lo = Word32.fromLargeInt i and hi = Word32.fromLargeInt (IntInf.~>>(i, 0w32)) in if bigEndian then (set32(m, 0w0, hi); set32(m, 0w1, lo)) else (set32(m, 0w0, lo); set32(m, 0w1, hi)); noFree end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, 0, max))); noFree) fun storeShort(m: voidStar, i: int) = if sysWordSize = 0w4 orelse not (isSome Int.maxInt) then (* 32-bit or arbitrary precision. *) storeLarge(m, LargeInt.fromInt i) else if i < 0 (* Fixed precision 64-bit - just check it's not negative. *) then raise Overflow else (set64(m, 0w0, SysWord.fromInt i); noFree) in val cUint64: int conversion = makeConversion{ load=loadShort, store=storeShort, ctype = cTypeUint64 } and cUint64Large: LargeInt.int conversion = makeConversion{ load=loadLarge, store=storeLarge, ctype = cTypeUint64 } end local fun load(m: voidStar): real = getFloat(m, 0w0) fun store(m: voidStar, v: real) = (setFloat(m, 0w0, v); noFree) in val cFloat: real conversion = makeConversion{ load=load, store=store, ctype = cTypeFloat } end local fun load(m: voidStar): real = getDouble(m, 0w0) fun store(m: voidStar, v: real) = (setDouble(m, 0w0, v); noFree) in val cDouble: real conversion = makeConversion{ load=load, store=store, ctype = cTypeDouble } end val cShort = if #size saSShort = #size saSint16 then cInt16 (*else if #size saSShort = #size saSint32 then cInt32*) else raise Foreign "Unable to find type for short" val cUshort = if #size saUShort = #size saUint16 then cUint16 (*else if #size saUShort = #size saUint32 then cUint32*) else raise Foreign "Unable to find type for unsigned" val cInt = (*if #size saSint = #size saSint16 then cInt16 else *)if #size saSint = #size saSint32 then cInt32 else if #size saSint = #size saSint64 then cInt64 else raise Foreign "Unable to find type for int" val cIntLarge = (*if #size saSint = #size saSint16 then cInt16 else *)if #size saSint = #size saSint32 then cInt32Large else if #size saSint = #size saSint64 then cInt64Large else raise Foreign "Unable to find type for int" val cUint = (*if #size saUint = #size saUint16 then cUint16 else *)if #size saUint = #size saUint32 then cUint32 else if #size saUint = #size saUint64 then cUint64 else raise Foreign "Unable to find type for unsigned" val cUintLarge = (*if #size saUint = #size saUint16 then cUint16 else *)if #size saUint = #size saUint32 then cUint32Large else if #size saUint = #size saUint64 then cUint64Large else raise Foreign "Unable to find type for unsigned" val cLong = (*if #size saSlong = #size saSint16 then cInt16 else *)if #size saSlong = #size saSint32 then cInt32 else if #size saSlong = #size saSint64 then cInt64 else raise Foreign "Unable to find type for long" val cLongLarge = (*if #size saSlong = #size saSint16 then cInt16 else *)if #size saSlong = #size saSint32 then cInt32Large else if #size saSlong = #size saSint64 then cInt64Large else raise Foreign "Unable to find type for long" val cUlong = (*if #size saUlong = #size saUint16 then cUint16 else *)if #size saUlong = #size saUint32 then cUint32 else if #size saUlong = #size saUint64 then cUint64 else raise Foreign "Unable to find type for unsigned long" val cUlongLarge = (*if #size saUlong = #size saUint16 then cUint16 else *)if #size saUlong = #size saUint32 then cUint32Large else if #size saUlong = #size saUint64 then cUint64Large else raise Foreign "Unable to find type for unsigned long" local fun load(s: voidStar): string = let (* The location contains the address of the string. *) val sAddr = getAddress(s, 0w0) fun sLen i = if get8(sAddr, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(sAddr, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let val sLen = Word.fromInt(String.size s) val sMem = malloc(sLen + 0w1) val () = CharVector.appi(fn(i, ch) => set8(sMem, Word.fromInt i, Word8.fromInt(Char.ord ch))) s val () = set8(sMem, sLen, 0w0) in setAddress(v, 0w0, sMem); fn () => Memory.free sMem end in val cString: string conversion = makeConversion { load=load, store=store, ctype = cTypePointer } end (* This is used if we want to pass NULL rather than a pointer in some cases. *) fun cOptionPtr({load, store, updateML, updateC, ctype}:'a conversion): 'a option conversion = if #typeCode(extractFFItype(#ffiType ctype ())) <> ffiTypeCodePointer then raise Foreign "cOptionPtr must be applied to a pointer type" else let fun loadOpt(s: voidStar) = if getAddress(s, 0w0) = null then NONE else SOME(load s) fun storeOpt(v: voidStar, NONE) = (setAddress(v, 0w0, null); fn _ => ()) | storeOpt(v: voidStar, SOME s) = store(v, s) (* Do we have update here? *) fun updateMLOpt(_, NONE) = () | updateMLOpt(v: voidStar, SOME s) = updateML(v, s) fun updateCOpt(_, NONE) = () | updateCOpt(v, SOME s) = updateC(v, s) in { load=loadOpt, store=storeOpt, updateML = updateMLOpt, updateC = updateCOpt, ctype = cTypePointer } end local (* Word8Vector.vector to C array of bytes. It is only possible to do this one way because conversion from a C array requires us to know the size. *) fun load _ = raise Foreign "cByteArray cannot convert from C to ML" fun store(v: voidStar, s: Word8Vector.vector) = let open Word8Vector val sLen = Word.fromInt(length s) val sMem = malloc sLen val () = appi(fn(i, b) => set8(sMem, Word.fromInt i, b)) s in setAddress(v, 0w0, sMem); fn () => Memory.free sMem end in val cByteArray: Word8Vector.vector conversion = makeConversion{ load=load, store=store, ctype = cTypePointer } end end (* Remove the free part from the store fn. This is intended for situations where an argument should not be deleted once the function completes. *) fun permanent({load, store, ctype, updateML, updateC }: 'a conversion): 'a conversion = let fun storeP args = (ignore (store args); fn () => ()) in { load=load, store=storeP, updateML = updateML, updateC = updateC, ctype=ctype } end val op ++ = Memory.++ fun cStruct2(a: 'a conversion, b: 'b conversion): ('a*'b)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ... }} = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {align=alignb, ... }} = b val offsetb = alignUp(sizea, alignb) fun load s = (loada s, loadb(s ++ offsetb)) and store (x, (a, b)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) in fn () => ( freea(); freeb() ) end and updateML(s, (a, b)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b)) and updateC(x, (a, b)) = (updateCa(x, a); updateCb(x ++ offsetb, b)) in {load=load, store=store, updateML = updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb]} end fun cStruct3(a: 'a conversion, b: 'b conversion, c: 'c conversion): ('a*'b*'c)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {align=alignc, ...} } = c val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc)) and store (x, (a, b, c)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) in fn () => ( freea(); freeb(); freec() ) end and updateML(s, (a, b, c)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c)) and updateC(x, (a, b, c)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec]} end fun cStruct4(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion): ('a*'b*'c*'d)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {align=alignd, ...} } = d val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd)) and store (x, (a, b, c, d)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) in fn () => ( freea(); freeb(); freec(); freed() ) end and updateML(s, (a, b, c, d)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d)) and updateC(x, (a, b, c, d)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped]} end fun cStruct5(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion): ('a*'b*'c*'d*'e)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {align=aligne, ...} } = e val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete)) and store (x, (a, b, c, d, e)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) in fn () => ( freea(); freeb(); freec(); freed(); freee() ) end and updateML(s, (a, b, c, d, e)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e)) and updateC(x, (a, b, c, d, e)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee]} end fun cStruct6(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion): ('a*'b*'c*'d*'e*'f)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {align=alignf, ...} } = f val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf)) and store (x, (a, b, c, d, e, f)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef() ) end and updateML(s, (a, b, c, d, e, f)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f)) and updateC(x, (a, b, c, d, e, f)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef]} end fun cStruct7(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion): ('a*'b*'c*'d*'e*'f*'g)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {align=aligng, ...} } = g val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg)) and store (x, (a, b, c, d, e, f, g)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg() ) end and updateML(s, (a, b, c, d, e, f, g)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g)) and updateC(x, (a, b, c, d, e, f, g)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg]} end fun cStruct8(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion): ('a*'b*'c*'d*'e*'f*'g*'h)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {align=alignh, ...} } = h val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth)) and store (x, (a, b, c, d, e, f, g, h)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh() ) end and updateML(s, (a, b, c, d, e, f, g, h)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g); updateMLh(s ++ offseth, h)) and updateC(x, (a, b, c, d, e, f, g, h)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh]} end fun cStruct9(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {align=aligni, ...} } = i val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti)) and store (x, (a, b, c, d, e, f, g, h, i)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei() ) end and updateML(s, (a, b, c, d, e, f, g, h, i)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g); updateMLh(s ++ offseth, h); updateMLi(s ++ offseti, i)) and updateC(x, (a, b, c, d, e, f, g, h, i)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei]} end fun cStruct10(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {align=alignj, ...} } = j val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj)) and store (x, (a, b, c, d, e, f, g, h, i, j)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j)) and updateC(x, (a, b, c, d, e, f, g, h, i, j)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej]} end fun cStruct11(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {align=alignk, ...} } = k val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk)) and store (x, (a, b, c, d, e, f, g, h, i, j, k)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek]} end fun cStruct12(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {align=alignl, ...} } = l val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel]} end fun cStruct13(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {align=alignm, ...} } = m val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem]} end nonfix o fun cStruct14(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {align=alignn, ...} } = n val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen]} end fun cStruct15(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {align=aligno, ...} } = o val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo]} end fun cStruct16(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {align=alignp, ...} } = p val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep]} end fun cStruct17(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {align=alignq, ...} } = q val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq]} end fun cStruct18(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {align=alignr, ...} } = r val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper]} end fun cStruct19(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion, s: 's conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {size=sizer, align=alignr, ...} } = r and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = ctypes as {align=aligns, ...} } = s val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) val offsets = alignUp(offsetr + sizer, aligns) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr), loads(s ++ offsets)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) and frees = stores(x ++ offsets, s) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer(); frees() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r); updateMLs(x ++ offsets, s)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r); updateCs(x ++ offsets, s)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes]} end fun cStruct20(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion, s: 's conversion, t: 't conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s*'t)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {size=sizer, align=alignr, ...} } = r and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = ctypes as {size=sizes, align=aligns, ...} } = s and {load=loadt, store=storet, updateML=updateMLt, updateC=updateCt, ctype = ctypet as {align=alignt, ...} } = t val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) val offsets = alignUp(offsetr + sizer, aligns) val offsett = alignUp(offsets + sizes, alignt) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr), loads(s ++ offsets), loadt(s ++ offsett)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) and frees = stores(x ++ offsets, s) and freet = storet(x ++ offsett, t) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer(); frees(); freet() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r); updateMLs(x ++ offsets, s); updateMLt(x ++ offsett, t)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r); updateCs(x ++ offsets, s); updateCt(x ++ offsett, t)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes, ctypet]} end (* Conversion for call-by-reference. *) local open Memory LowLevel in fun cStar({load=loada, store=storea, ctype=ctypea, ...}: 'a conversion): 'a ref conversion = let fun store(m, ref s) = let (* When we pass a ref X into a cStar cX function we need to allocate a memory cell big enough for a cX value. Then we copy the current value of the ML into this. We set the argument, a pointer, to the address of the cell. *) val mem = malloc(#size ctypea) val () = setAddress(m, 0w0, mem) val freea = storea(mem, s) in fn () => (free mem; freea()) end (* Called to update the ML value when the C . *) fun updateML(m, s) = s := loada(getAddress(m, 0w0)) (* Used when an ML callback receives a cStar argument. *) fun load s = ref(loada(getAddress(s, 0w0))) (* Used when a callback has returned to update the C value. If storea allocates then there's nothing we can do. *) fun updateC(m, ref s) = ignore(storea(getAddress(m, 0w0), s)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Similar to cStar but without the need to update the result. *) fun cConstStar({load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype=ctypea}: 'a conversion): 'a conversion = let fun load s = loada(getAddress(s, 0w0)) fun store(m, s) = let val mem = malloc(#size ctypea) val () = setAddress(m, 0w0, mem) val freea = storea(mem, s) in fn () => (free mem; freea()) end (* Do we have to do anything here? Could we pass a const pointer to a structure with variable fields? *) fun updateML(m, s) = updateMLa(getAddress(m, 0w0), s) and updateC(m, s) = updateCa(getAddress(m, 0w0), s) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Fixed size vector. It is treated as a struct and passed by value or embedded in a structure. *) fun cVectorFixedSize(n, {load=loadEl, store=storeEl, updateML=updateMLel, updateC=updateCel, ctype={size=sizeEl, align=alignEl, ffiType=ffiTypeEl}, ...}: 'a conversion) : 'a vector conversion = let val arraySize = sizeEl * Word.fromInt n fun ffiTypeArray () = LibFFI.createFFItype { size = arraySize, align = alignEl, typeCode=LibFFI.ffiTypeCodeStruct, elements = List.tabulate (n, fn _ => ffiTypeEl()) } val arrayType = { size = arraySize, align = alignEl, ffiType = ffiTypeArray } fun load(v: voidStar): 'a vector = Vector.tabulate(n, fn i => loadEl(v ++ Word.fromInt i)) fun store(v: voidStar, s: 'a vector) = let val sLen = Vector.length s val _ = sLen <= n orelse raise Foreign "vector too long" (* Store the values. Make a list of the free fns in case they allocate *) val frees = Vector.foldli(fn(i, el, l) => storeEl(v ++ Word.fromInt i, el) :: l) [] s; in fn () => List.app (fn f => f()) frees end (* If we have a ref in here we need to update *) fun updateML(v, s) = Vector.appi(fn (i, el) => updateMLel(v ++ Word.fromInt i, el)) s and updateC(v, s) = Vector.appi(fn (i, el) => updateCel(v ++ Word.fromInt i, el)) s in { load = load, store = store, updateML=updateML, updateC=updateC, ctype = arrayType } end (* Pass an ML vector as a pointer to a C array. *) fun cVectorPointer ({store=storeEl, updateML=updateMLel, ctype={size=sizeEl, ...}, ...}: 'a conversion) : 'a vector conversion = let (* We can't determine the size so can't construct a suitable ML value. *) fun load _ = raise Foreign "Cannot return a cVectorPointer from C to ML" fun store(m, s) = let val mem = malloc(sizeEl * Word.fromInt(Vector.length s)) val () = setAddress(m, 0w0, mem) (* Store the values. Make a list of the free fns in case they allocate *) val frees = Vector.foldli(fn(i, el, l) => storeEl(mem ++ (sizeEl * Word.fromInt i), el) :: l) [] s; in fn () => (List.app (fn f => f()) frees; free mem) end (* This is only appropriate if the elements are refs. *) fun updateML(v, s) = let val addr = getAddress(v, 0w0) in Vector.appi(fn (i, el) => updateMLel(addr ++ (sizeEl * Word.fromInt i), el)) s end (* updateC can't actually be used because we can't load a suitable value *) and updateC _ = raise Foreign "Cannot return a cVectorPointer from C to ML" in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Pass an ML array as a pointer to a C array and, on return, update each element of the ML array from the C array. *) fun cArrayPointer ({load=loadEl, store=storeEl, ctype={size=sizeEl, ...}, ...}: 'a conversion) : 'a array conversion = let (* We can't determine the size so can't construct a suitable ML value. *) fun load _ = raise Foreign "Cannot return a cArrayPointer from C to ML" fun store(m, s) = let val mem = malloc(sizeEl * Word.fromInt(Array.length s)) val () = setAddress(m, 0w0, mem) (* Store the values. Make a list of the free fns in case they allocate *) val frees = Array.foldli(fn(i, el, l) => storeEl(mem ++ (sizeEl * Word.fromInt i), el) :: l) [] s; in fn () => (List.app (fn f => f()) frees; free mem) end (* updateML is used after a C function returns. It needs to update each element. *) fun updateML(v, s) = let val addr = getAddress(v, 0w0) in Array.modifyi(fn (i, _) => loadEl(addr ++ (sizeEl * Word.fromInt i))) s end (* updateC can't actually be used because we can't load a suitable value *) and updateC _ = raise Foreign "Cannot return a cArrayPointer from C to ML" in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end end (* Calls with conversion. *) (* Note: it may be possible to have general functions to compute offsets but we don't do that because this way the compiler can compute the offsets as constants during inline expansion. *) local open LibFFI Memory LowLevel in fun buildCall0withAbi(abi: abi, fnAddr, (), {ctype = resType, load= resLoad, ...} : 'a conversion): unit->'a = let val callF = callwithAbi abi [] resType fnAddr in fn () => let val rMem = malloc(#size resType) in let val () = callF(Memory.null, rMem) val result = resLoad rMem in free rMem; result end handle exn => (free rMem; raise exn) end end fun buildCall0(symbol, argTypes, resType) = buildCall0withAbi (abiDefault, symbol, argTypes, resType) fun buildCall1withAbi (abi: abi, fnAddr, { ctype = argType, store = argStore, updateML = argUpdate, ...}: 'a conversion, { ctype = resType, load= resLoad, ...}: 'b conversion): 'a ->'b = let val callF = callwithAbi abi [argType] resType fnAddr (* Allocate space for argument and result. *) val argOffset = alignUp(#size resType, #align argType) val argSpace = argOffset + #size argType in fn x => let val rMem = malloc argSpace val argAddr = rMem ++ argOffset val freea = argStore (argAddr, x) fun freeAll () = (freea(); free rMem) in let val () = callF(argAddr, rMem) val result = resLoad rMem in argUpdate (argAddr, x); freeAll (); result end handle exn => (freeAll (); raise exn) end end fun buildCall1(symbol, argTypes, resType) = buildCall1withAbi (abiDefault, symbol, argTypes, resType) fun buildCall2withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion), resConv: 'c conversion): 'a * 'b -> 'c = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct2(arg1Conv, arg2Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall2(symbol, argTypes, resType) = buildCall2withAbi (abiDefault, symbol, argTypes, resType) fun buildCall3withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion), resConv: 'd conversion): 'a * 'b *'c -> 'd = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct3(arg1Conv, arg2Conv, arg3Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall3(symbol, argTypes, resType) = buildCall3withAbi (abiDefault, symbol, argTypes, resType) fun buildCall4withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion), resConv: 'e conversion): 'a * 'b *'c * 'd -> 'e = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct4(arg1Conv, arg2Conv, arg3Conv, arg4Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall4(symbol, argTypes, resType) = buildCall4withAbi (abiDefault, symbol, argTypes, resType) fun buildCall5withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion), resConv: 'f conversion): 'a * 'b *'c * 'd * 'e -> 'f = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct5(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall5(symbol, argTypes, resType) = buildCall5withAbi (abiDefault, symbol, argTypes, resType) fun buildCall6withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion), resConv: 'g conversion): 'a * 'b *'c * 'd * 'e * 'f -> 'g = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct6(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall6(symbol, argTypes, resType) = buildCall6withAbi (abiDefault, symbol, argTypes, resType) fun buildCall7withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion), resConv: 'h conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g -> 'h = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct7(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall7(symbol, argTypes, resType) = buildCall7withAbi (abiDefault, symbol, argTypes, resType) fun buildCall8withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion), resConv: 'i conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h -> 'i = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct8(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall8(symbol, argTypes, resType) = buildCall8withAbi (abiDefault, symbol, argTypes, resType) fun buildCall9withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion), resConv: 'j conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct9(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall9(symbol, argTypes, resType) = buildCall9withAbi (abiDefault, symbol, argTypes, resType) fun buildCall10withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion), resConv: 'k conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct10(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall10(symbol, argTypes, resType) = buildCall10withAbi (abiDefault, symbol, argTypes, resType) fun buildCall11withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion), resConv: 'l conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct11(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall11(symbol, argTypes, resType) = buildCall11withAbi (abiDefault, symbol, argTypes, resType) fun buildCall12withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion), resConv: 'm conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct12(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall12(symbol, argTypes, resType) = buildCall12withAbi (abiDefault, symbol, argTypes, resType) fun buildCall13withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion, arg13Conv: 'm conversion), resConv: 'n conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv, #ctype arg13Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct13(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall13(symbol, argTypes, resType) = buildCall13withAbi (abiDefault, symbol, argTypes, resType) fun buildCall14withAbi (abi: abi, fnAddr, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion, arg7Conv: 'g conversion, arg8Conv: 'h conversion, arg9Conv: 'i conversion, arg10Conv: 'j conversion, arg11Conv: 'k conversion, arg12Conv: 'l conversion, arg13Conv: 'm conversion, arg14Conv: 'n conversion), resConv: 'o conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o = let val { ctype = resType, load = resLoad, ...} = resConv val callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv, #ctype arg11Conv, #ctype arg12Conv, #ctype arg13Conv, #ctype arg14Conv] resType fnAddr val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = cStruct14(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv, arg14Conv) val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => let val rMem = malloc argResSpace val freeArgs = storeArgs(rMem, mlArgs) fun freeAll() = (freeArgs(); free rMem) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall14(symbol, argTypes, resType) = buildCall14withAbi (abiDefault, symbol, argTypes, resType) end - (* A closure is a memoised address. *) - type 'a closure = unit -> Memory.voidStar + (* A closure is simply an address. *) + type 'a closure = Memory.voidStar local open Memory LowLevel fun load _ = raise Foreign "Cannot return a closure" - (* "dememoise" the value when we store it. This means that the closure is actually - created when the value is first stored and then it is cached. *) - and store(v, cl: ('a->'b) closure) = (Memory.setAddress(v, 0w0, cl()); fn () => ()) + and store(v, cl: ('a->'b) closure) = (Memory.setAddress(v, 0w0, cl); fn () => ()) in val cFunction: ('a->'b) closure conversion = makeConversion { load=load, store=store, ctype = LowLevel.cTypePointer } end local open LibFFI Memory LowLevel in fun buildClosure0withAbi(f: unit-> 'a, abi: abi, (), resConv: 'a conversion): (unit->'a) closure = let fun callback (f: unit -> 'a) (_: voidStar, res: voidStar): unit = ignore(#store resConv (res, f ())) (* Ignore the result of #store resConv. What this means is if the callback returns something, e.g. a string, that requires dynamic allocation there will be a memory leak. *) val makeCallback = cFunctionWithAbi abi [] (#ctype resConv) in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure0(f, argConv, resConv) = buildClosure0withAbi(f, abiDefault, argConv, resConv) fun buildClosure1withAbi (f: 'a -> 'b, abi: abi, argConv: 'a conversion, resConv: 'b conversion) : ('a -> 'b) closure = let fun callback (f: 'a -> 'b) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - val arg1 = #load argConv arg1Addr + val arg1 = #load argConv args val result = f arg1 - val () = #updateC argConv (arg1Addr, arg1) + val () = #updateC argConv (args, arg1) in ignore(#store resConv (res, result)) end val makeCallback = cFunctionWithAbi abi [#ctype argConv] (#ctype resConv) in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure1(f, argConv, resConv) = buildClosure1withAbi(f, abiDefault, argConv, resConv) fun buildClosure2withAbi (f: 'a * 'b -> 'c, abi: abi, (arg1Conv: 'a conversion, arg2Conv: 'b conversion), resConv: 'c conversion) : ('a * 'b -> 'c) closure = let + val { load=loadArgs, updateC=updateArgs, ...} = cStruct2(arg1Conv, arg2Conv) + fun callback (f: 'a *'b -> 'c) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - and arg2Addr = getAddress(args, 0w1) - val arg1 = #load arg1Conv arg1Addr - and arg2 = #load arg2Conv arg2Addr - - val result = f (arg1, arg2) - - val () = #updateC arg1Conv(arg1Addr, arg1) - and () = #updateC arg2Conv(arg2Addr, arg2) + val mlArgs = loadArgs args + val result = f mlArgs + val () = updateArgs(args, mlArgs) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure2(f, argConv, resConv) = buildClosure2withAbi(f, abiDefault, argConv, resConv) fun buildClosure3withAbi (f, abi, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion), resConv: 'd conversion) = let + val { load=loadArgs, updateC=updateArgs, ...} = cStruct3(arg1Conv, arg2Conv, arg3Conv) + fun callback (f: 'a *'b * 'c -> 'd) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - and arg2Addr = getAddress(args, 0w1) - and arg3Addr = getAddress(args, 0w2) - val arg1 = #load arg1Conv arg1Addr - and arg2 = #load arg2Conv arg2Addr - and arg3 = #load arg3Conv arg3Addr - - val result = f (arg1, arg2, arg3) - - val () = #updateC arg1Conv(arg1Addr, arg1) - and () = #updateC arg2Conv(arg2Addr, arg2) - and () = #updateC arg3Conv(arg3Addr, arg3) + val mlArgs = loadArgs args + val result = f mlArgs + val () = updateArgs(args, mlArgs) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure3(f, argConv, resConv) = buildClosure3withAbi(f, abiDefault, argConv, resConv) fun buildClosure4withAbi (f, abi, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion), resConv: 'e conversion) = let + val { load=loadArgs, updateC=updateArgs, ...} = cStruct4(arg1Conv, arg2Conv, arg3Conv, arg4Conv) + fun callback (f: 'a *'b * 'c * 'd -> 'e) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - and arg2Addr = getAddress(args, 0w1) - and arg3Addr = getAddress(args, 0w2) - and arg4Addr = getAddress(args, 0w3) - val arg1 = #load arg1Conv arg1Addr - and arg2 = #load arg2Conv arg2Addr - and arg3 = #load arg3Conv arg3Addr - and arg4 = #load arg4Conv arg4Addr - - val result = f (arg1, arg2, arg3, arg4) - - val () = #updateC arg1Conv(arg1Addr, arg1) - and () = #updateC arg2Conv(arg2Addr, arg2) - and () = #updateC arg3Conv(arg3Addr, arg3) - and () = #updateC arg4Conv(arg4Addr, arg4) + val mlArgs = loadArgs args + val result = f mlArgs + val () = updateArgs(args, mlArgs) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure4(f, argConv, resConv) = buildClosure4withAbi(f, abiDefault, argConv, resConv) fun buildClosure5withAbi (f, abi, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion), resConv: 'f conversion) = let + val { load=loadArgs, updateC=updateArgs, ...} = + cStruct5(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv) + fun callback (f: 'a *'b * 'c * 'd * 'e -> 'f) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - and arg2Addr = getAddress(args, 0w1) - and arg3Addr = getAddress(args, 0w2) - and arg4Addr = getAddress(args, 0w3) - and arg5Addr = getAddress(args, 0w4) - val arg1 = #load arg1Conv arg1Addr - and arg2 = #load arg2Conv arg2Addr - and arg3 = #load arg3Conv arg3Addr - and arg4 = #load arg4Conv arg4Addr - and arg5 = #load arg5Conv arg5Addr - - val result = f (arg1, arg2, arg3, arg4, arg5) - - val () = #updateC arg1Conv(arg1Addr, arg1) - and () = #updateC arg2Conv(arg2Addr, arg2) - and () = #updateC arg3Conv(arg3Addr, arg3) - and () = #updateC arg4Conv(arg4Addr, arg4) - and () = #updateC arg5Conv(arg5Addr, arg5) + val mlArgs = loadArgs args + val result = f mlArgs + val () = updateArgs(args, mlArgs) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure5(f, argConv, resConv) = buildClosure5withAbi(f, abiDefault, argConv, resConv) fun buildClosure6withAbi (f, abi, (arg1Conv: 'a conversion, arg2Conv: 'b conversion, arg3Conv: 'c conversion, arg4Conv: 'd conversion, arg5Conv: 'e conversion, arg6Conv: 'f conversion), resConv: 'g conversion) = let + val { load=loadArgs, updateC=updateArgs, ...} = + cStruct6(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv) + fun callback (f: 'a *'b * 'c * 'd * 'e * 'f -> 'g) (args: voidStar, res: voidStar): unit = let - val arg1Addr = getAddress(args, 0w0) - and arg2Addr = getAddress(args, 0w1) - and arg3Addr = getAddress(args, 0w2) - and arg4Addr = getAddress(args, 0w3) - and arg5Addr = getAddress(args, 0w4) - and arg6Addr = getAddress(args, 0w5) - val arg1 = #load arg1Conv arg1Addr - and arg2 = #load arg2Conv arg2Addr - and arg3 = #load arg3Conv arg3Addr - and arg4 = #load arg4Conv arg4Addr - and arg5 = #load arg5Conv arg5Addr - and arg6 = #load arg6Conv arg6Addr - - val result = f (arg1, arg2, arg3, arg4, arg5, arg6) - - val () = #updateC arg1Conv(arg1Addr, arg1) - and () = #updateC arg2Conv(arg2Addr, arg2) - and () = #updateC arg3Conv(arg3Addr, arg3) - and () = #updateC arg4Conv(arg4Addr, arg4) - and () = #updateC arg5Conv(arg5Addr, arg5) - and () = #updateC arg6Conv(arg6Addr, arg6) + val mlArgs = loadArgs args + val result = f mlArgs + val () = updateArgs(args, mlArgs) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in - Memory.memoise (fn () => makeCallback(callback f)) () + makeCallback(callback f) end fun buildClosure6(f, argConv, resConv) = buildClosure6withAbi(f, abiDefault, argConv, resConv) end end; diff --git a/libpolyml/polyffi.cpp b/libpolyml/polyffi.cpp index 20c40df5..43e4041f 100644 --- a/libpolyml/polyffi.cpp +++ b/libpolyml/polyffi.cpp @@ -1,668 +1,678 @@ /* Title: New Foreign Function Interface Copyright (c) 2015, 2018, 2019 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_DLFCN_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_STRING_H #include #endif #include "globals.h" // TODO: Do we need this?? // We need to include globals.h before in mingw64 otherwise // it messes up POLYUFMT/POLYSFMT. #include #include #include "arb.h" #include "save_vec.h" #include "polyffi.h" #include "run_time.h" #include "sys.h" #include "processes.h" #include "polystring.h" #if (defined(_WIN32)) #include #include "winstartup.h" /* For hApplicationInstance. */ #endif #include "scanaddrs.h" #include "diagnostics.h" #include "reals.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg); + POLYEXTERNALSYMBOL void PolyFFICallbackException(); } static struct _abiTable { const char *abiName; ffi_abi abiCode; } abiTable[] = { // Unfortunately the ABI entries are enums rather than #defines so we // can't test individual entries. #ifdef X86_WIN32 {"sysv", FFI_SYSV}, {"stdcall", FFI_STDCALL}, {"thiscall", FFI_THISCALL}, {"fastcall", FFI_FASTCALL}, {"ms_cdecl", FFI_MS_CDECL}, #elif defined(X86_WIN64) {"win64", FFI_WIN64}, #elif defined(X86_ANY) #if (defined(__i386__) || defined(__i386)) {"sysv", FFI_SYSV}, #else {"unix64", FFI_UNIX64}, #endif #endif { "default", FFI_DEFAULT_ABI} }; // Table of constants returned by call 51 static int constantTable[] = { FFI_DEFAULT_ABI, // Default ABI FFI_TYPE_VOID, // Type codes FFI_TYPE_INT, FFI_TYPE_FLOAT, FFI_TYPE_DOUBLE, FFI_TYPE_UINT8, FFI_TYPE_SINT8, FFI_TYPE_UINT16, FFI_TYPE_SINT16, FFI_TYPE_UINT32, FFI_TYPE_SINT32, FFI_TYPE_UINT64, FFI_TYPE_SINT64, FFI_TYPE_STRUCT, FFI_TYPE_POINTER, FFI_SIZEOF_ARG // Minimum size for result space }; // Table of predefined ffi types static ffi_type *ffiTypeTable[] = { &ffi_type_void, &ffi_type_uint8, &ffi_type_sint8, &ffi_type_uint16, &ffi_type_sint16, &ffi_type_uint32, &ffi_type_sint32, &ffi_type_uint64, &ffi_type_sint64, &ffi_type_float, &ffi_type_double, &ffi_type_pointer, &ffi_type_uchar, // These are all aliases for the above &ffi_type_schar, &ffi_type_ushort, &ffi_type_sshort, &ffi_type_uint, &ffi_type_sint, &ffi_type_ulong, &ffi_type_slong }; // Callback entry table static struct _cbStructEntry { PolyWord mlFunction; // The ML function to call void *closureSpace; // Space allocated for the closure void *resultFunction; // Executable address for the function. Needed to free. } *callbackTable; static unsigned callBackEntries = 0; static PLock callbackTableLock; // Mutex to protect table. static Handle mkAbitab(TaskData *taskData, void*, char *p); static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data); static Handle toSysWord(TaskData *taskData, void *p) { return Make_sysword(taskData, (uintptr_t)p); } static Handle poly_ffi(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, code->Word()); switch (c) { case 0: // malloc { POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word()); return toSysWord(taskData, malloc(size)); } case 1: // free { void *mem = *(void**)(args->WordP()); free(mem); return taskData->saveVec.push(TAGGED(0)); } case 2: // Load library { TempString libName(args->Word()); #if (defined(_WIN32)) HINSTANCE lib = LoadLibrary(libName); if (lib == NULL) { char buf[256]; #if (defined(UNICODE)) _snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", (LPCTSTR)libName, GetLastError()); #else _snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", (const char*)libName, GetLastError()); #endif buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else void *lib = dlopen(libName, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, lib); } case 3: // Load address of executable. { #if (defined(_WIN32)) HINSTANCE lib = hApplicationInstance; #else void *lib = dlopen(NULL, RTLD_LAZY); if (lib == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, lib); } case 4: // Unload library - Is this actually going to be used? { #if (defined(_WIN32)) HMODULE hMod = *(HMODULE*)(args->WordP()); if (! FreeLibrary(hMod)) raise_syscall(taskData, "FreeLibrary failed", GetLastError()); #else void *lib = *(void**)(args->WordP()); if (dlclose(lib) != 0) { char buf[256]; snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return taskData->saveVec.push(TAGGED(0)); } case 5: // Load the address of a symbol from a library. { TempCString symName(args->WordP()->Get(1)); #if (defined(_WIN32)) HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress()); void *sym = (void*)GetProcAddress(hMod, symName); if (sym == NULL) { char buf[256]; _snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", (LPCSTR)symName, GetLastError()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #else void *lib = *(void**)(args->WordP()->Get(0).AsAddress()); void *sym = dlsym(lib, symName); if (sym == NULL) { char buf[256]; snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror()); buf[sizeof(buf)-1] = 0; // Terminate just in case raise_exception_string(taskData, EXC_foreign, buf); } #endif return toSysWord(taskData, sym); } // Libffi functions case 50: // Return a list of available ABIs return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]), (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); case 51: // A constant from the table { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(constantTable) / sizeof(constantTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return Make_arbitrary_precision(taskData, constantTable[index]); } case 52: // Return an FFI type { unsigned index = get_C_unsigned(taskData, args->Word()); if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0])) raise_exception_string(taskData, EXC_foreign, "Index out of range"); return toSysWord(taskData, ffiTypeTable[index]); } case 53: // Extract fields from ffi type. { ffi_type *ffit = *(ffi_type**)(args->WordP()); Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size); Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment); Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type); Handle elemHandle = toSysWord(taskData, ffit->elements); Handle resHandle = alloc_and_save(taskData, 4); resHandle->WordP()->Set(0, sizeHandle->Word()); resHandle->WordP()->Set(1, alignHandle->Word()); resHandle->WordP()->Set(2, typeHandle->Word()); resHandle->WordP()->Set(3, elemHandle->Word()); return resHandle; } case 54: // Construct an ffi type. { // This is probably only used to create structs. size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0)); unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1)); unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2)); unsigned nElems = 0; for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nElems++; size_t space = sizeof(ffi_type); // If we need the elements add space for the elements plus // one extra for the zero terminator. if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *); ffi_type *result = (ffi_type*)calloc(1, space); // Raise an exception rather than returning zero. if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type **elem = 0; if (nElems != 0) elem = (ffi_type **)(result+1); result->size = size; result->alignment = align; result->type = type; result->elements = elem; if (elem != 0) { for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *elem++ = *(ffi_type**)(e.AsAddress()); } *elem = 0; } return toSysWord(taskData, result); } case 55: // Create a CIF. This contains all the types and some extra information. // The result is in allocated memory followed immediately by the argument type vector. { ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0)); ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress(); unsigned nArgs = 0; for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) nArgs++; // Allocate space for the cif followed by the argument type vector size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); ffi_cif *cif = (ffi_cif *)malloc(space); if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); ffi_type **atypes = (ffi_type **)(cif+1); // Copy the arguments types. ffi_type **at = atypes; for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) { PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; *at++ = *(ffi_type**)(e.AsAddress()); } ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); if (status == FFI_BAD_TYPEDEF) raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); else if (status == FFI_BAD_ABI) raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); else if (status != FFI_OK) raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); return toSysWord(taskData, cif); } case 56: // Call a function. { ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress(); void *f = *(void**)args->WordP()->Get(1).AsAddress(); void *res = *(void**)args->WordP()->Get(2).AsAddress(); void **arg = *(void***)args->WordP()->Get(3).AsAddress(); ffi_call(cif, FFI_FN(f), res, arg); // Do we need to save the value of errno/GetLastError here? return taskData->saveVec.push(TAGGED(0)); } case 57: // Create a callback. { #ifdef INTERPRETED raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter"); #endif Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0)); ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress(); void *resultFunction; // Allocate the memory. resultFunction is set to the executable address in or related to // the memory. ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction); if (closure == 0) raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory"); PLocker pLocker(&callbackTableLock); // Find a free entry in the table if there is one. unsigned entryNo = 0; while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++; if (entryNo == callBackEntries) { // Need to grow the table. struct _cbStructEntry *newTable = (struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry)); if (newTable == 0) raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table"); callbackTable = newTable; callBackEntries++; } callbackTable[entryNo].mlFunction = mlFunction->Word(); callbackTable[entryNo].closureSpace = closure; callbackTable[entryNo].resultFunction = resultFunction; if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK) raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed"); return toSysWord(taskData, resultFunction); } case 58: // Free an existing callback. { // The address returned from call 57 above is the executable address that can // be passed as a callback function. The writable memory address returned // as the result of ffi_closure_alloc may or may not be the same. To be safe // we need to search the table. void *resFun = *(void**)args->Word().AsAddress(); PLocker pLocker(&callbackTableLock); for (unsigned i = 0; i < callBackEntries; i++) { if (callbackTable[i].resultFunction == resFun) { ffi_closure_free(callbackTable[i].closureSpace); callbackTable[i].closureSpace = 0; callbackTable[i].resultFunction = 0; callbackTable[i].mlFunction = TAGGED(0); // Release the ML function return taskData->saveVec.push(TAGGED(0)); } } raise_exception_string(taskData, EXC_foreign, "Invalid callback entry"); } default: { char msg[100]; sprintf(msg, "Unknown ffi function: %d", c); raise_exception_string(taskData, EXC_foreign, msg); return 0; } } } // Construct an entry in the ABI table. static Handle mkAbitab(TaskData *taskData, void *arg, char *p) { struct _abiTable *ab = (struct _abiTable *)p; // Construct a pair of the string and the code Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); Handle code = Make_arbitrary_precision(taskData, ab->abiCode); Handle result = alloc_and_save(taskData, 2); result->WordP()->Set(0, name->Word()); result->WordP()->Set(1, code->Word()); return result; } // This is the C function that will get control when any callback is made. The "data" // argument is the index of the entry in the callback table. static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data) { uintptr_t cbIndex = (uintptr_t)data; ASSERT(cbIndex < callBackEntries); // We should get the task data for the thread that is running this code. // If this thread has been created by the foreign code we will have to // create a new one here. TaskData *taskData = processes->GetTaskDataForThread(); if (taskData == 0) { try { taskData = processes->CreateNewTaskData(0, 0, 0, TAGGED(0)); } catch (std::bad_alloc &) { ::Exit("Unable to create thread data - insufficient memory"); } catch (MemoryException &) { ::Exit("Unable to create thread data - insufficient memory"); } } taskData->PreRTSCall(); // We may get multiple calls to call-backs and we mustn't risk // overflowing the save-vec. Handle mark = taskData->saveVec.mark(); // In the future we might want to call C functions without some of the // overhead that comes with an RTS call which may allocate in ML // memory. If we do that we also have to ensure that callbacks // don't allocate, so this code would have to change. Handle mlEntryHandle; { // Get the ML function. Lock to avoid another thread moving // callbackTable under our feet. PLocker pLocker(&callbackTableLock); struct _cbStructEntry *cbEntry = &callbackTable[cbIndex]; mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction); } // Create a pair of the arg vector and the result pointer. Handle argHandle = toSysWord(taskData, args); Handle resHandle = toSysWord(taskData, ret); // Result must go in here. Handle pairHandle = alloc_and_save(taskData, 2); pairHandle->WordP()->Set(0, argHandle->Word()); pairHandle->WordP()->Set(1, resHandle->Word()); taskData->EnterCallbackFunction(mlEntryHandle, pairHandle); taskData->PostRTSCall(); taskData->saveVec.reset(mark); } class PolyFFI: public RtsModule { public: virtual void GarbageCollect(ScanAddress *process); }; // Declare this. It will be automatically added to the table. static PolyFFI polyFFIModule; // We need to scan the callback table. void PolyFFI::GarbageCollect(ScanAddress *process) { for (unsigned i = 0; i < callBackEntries; i++) process->ScanRuntimeWord(&callbackTable[i].mlFunction); } // General interface to IO. Ideally the various cases will be made into // separate functions. POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedCode = taskData->saveVec.push(code); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = poly_ffi(taskData, pushedArg, pushedCode); } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // These functions are needed in the compiler POLYUNSIGNED PolySizeFloat() { return TAGGED((POLYSIGNED)ffi_type_float.size).AsUnsigned(); } POLYUNSIGNED PolySizeDouble() { return TAGGED((POLYSIGNED)ffi_type_double.size).AsUnsigned(); } // Get either errno or GetLastError POLYUNSIGNED PolyFFIGetError(PolyWord addr) { #if (defined(_WIN32)) addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); #else addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno)); #endif return 0; } // The argument is a SysWord.word value i.e. the address of a byte cell. POLYUNSIGNED PolyFFISetError(PolyWord err) { #if (defined(_WIN32)) SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned())); #else errno = err.AsObjPtr()->Get(0).AsSigned(); #endif return 0; } // Create an external function reference. The value returned has space for // an address followed by the name of the external symbol. Because the // address comes at the beginning it can be used in the same way as the // SysWord value returned by the get-symbol call from a library. POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, true); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } // Create an external reference to data. On a small number of platforms // different forms of relocation are needed for data and for functions. POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle pushedArg = taskData->saveVec.push(arg); Handle result = 0; try { result = creatEntryPointObject(taskData, pushedArg, false); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); if (result == 0) return TAGGED(0).AsUnsigned(); else return result->Word().AsUnsigned(); } + +// Called if a callback raises an exception. There's nothing we +// can do because we don't have anything to pass back to C. +void PolyFFICallbackException() +{ + Crash("An ML function called from foreign code raised an exception. Unable to continue."); +} + struct _entrypts polyFFIEPT[] = { { "PolyFFIGeneral", (polyRTSFunction)&PolyFFIGeneral}, { "PolySizeFloat", (polyRTSFunction)&PolySizeFloat}, { "PolySizeDouble", (polyRTSFunction)&PolySizeDouble}, { "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError}, { "PolyFFISetError", (polyRTSFunction)&PolyFFISetError}, { "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn}, { "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData }, + { "PolyFFICallbackException", (polyRTSFunction)&PolyFFICallbackException }, { NULL, NULL} // End of list. }; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index f3b7e8fe..15622773 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,1999 +1,2013 @@ (* Copyright (c) 2000 Cambridge University Technical Services Limited Updated David C.J. Matthews 2008-9, 2012, 2013, 2015-19 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Title: Initialise ML Global Declarations. Author: Dave Matthews,Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor INITIALISE_ ( structure LEX: LEXSIG structure TYPETREE : TYPETREESIG structure STRUCTVALS : STRUCTVALSIG structure VALUEOPS : VALUEOPSSIG structure CODETREE : CODETREESIG structure EXPORTTREE: EXPORTTREESIG structure DATATYPEREP: DATATYPEREPSIG structure TYPEIDCODE: TYPEIDCODESIG structure MAKE: MAKESIG structure ADDRESS : AddressSig structure DEBUG: DEBUGSIG structure DEBUGGER : DEBUGGERSIG structure PRETTY : PRETTYSIG structure PRINTTABLE: PRINTTABLESIG structure MISC : sig val unescapeString : string -> string exception Conversion of string; (* string to int conversion failure *) end structure VERSION: sig val compilerVersion: string val versionNumber: int end structure UNIVERSALTABLE: sig type universal = Universal.universal type univTable type 'a tag = 'a Universal.tag val univLookup: univTable * 'a tag * string -> 'a option val fold: (string * universal * 'a -> 'a) -> 'a -> univTable -> 'a end sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = TYPETREE.Sharing = EXPORTTREE.Sharing = PRETTY.Sharing = CODETREE.Sharing = MAKE.Sharing = ADDRESS = DATATYPEREP.Sharing = TYPEIDCODE.Sharing = DEBUGGER.Sharing = LEX.Sharing = PRINTTABLE.Sharing = UNIVERSALTABLE ) : sig type gEnv val initGlobalEnv : {globalTable : gEnv, intIsArbitraryPrecision: bool } -> unit end = struct open STRUCTVALS; open TYPETREE open VALUEOPS; open CODETREE; open ADDRESS; open MAKE; open MISC; open EXPORTTREE open DATATYPEREP val intInfType = mkTypeConstruction ("int", intInfConstr, [], []) and realType = mkTypeConstruction ("real", realConstr, [], []) and charType = mkTypeConstruction ("char", charConstr, [], []) and wordType = mkTypeConstruction ("word", wordConstr, [], []) val declInBasis = [DeclaredAt inBasis] fun applyList _ [] = () | applyList f (h :: t) = (f h : unit; applyList f t); fun initGlobalEnv{globalTable : gEnv, intIsArbitraryPrecision: bool } = let val Env globalEnv = MAKE.gEnvAsEnv globalTable val enterGlobalValue = #enterVal globalEnv; val enterGlobalType = #enterType globalEnv; (* Some routines to help make the types. *) local (* careful - STRUCTVALS.intType differs from TYPETREE.intType *) open TYPETREE; in (* Make some type variables *) fun makeEqTV () = mkTypeVar (generalisable, true, false, false) fun makeTV () = mkTypeVar (generalisable, false, false, false) fun makePrintTV() = mkTypeVar (generalisable, false, false, true) fun makeTypeVariable() = makeTv {value=emptyType, level=generalisable, equality=false, nonunifiable=false, printable=false} (* Make some functions *) infixr 5 ->> fun a ->> b = mkFunctionType (a, b); infix 7 **; fun a ** b = mkProductType [a, b]; (* Type identifiers for the types of the declarations. *) val Int = if intIsArbitraryPrecision then intInfType else fixedIntType val String = stringType; val Bool = boolType; val Unit = unitType; val Char = charType; val Word = wordType; val Real = realType val Exn = exnType val mkTypeConstruction = mkTypeConstruction; val () = setPreferredInt(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr) end; fun makePolymorphic(tvs, c) = let open TYPEIDCODE val tvs = List.filter(fn TypeVar tv => not justForEqualityTypes orelse tvEquality tv | _ => false) tvs in if null tvs then c else mkInlproc(c, List.length tvs, "", [], 0) end (* Function to make a type identifier with a pretty printer that just prints "?". None of the types are equality types so the equality function is empty. *) local fun monotypePrinter _ = PRETTY.PrettyString "?" in fun defaultEqAndPrintCode () = let open TypeValue val code = createTypeValue{ eqCode = CodeZero, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedEither (* Assume this for the moment *), sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end end fun makeTypeAbbreviation(name, fullName, typeVars, typeResult, locations) = makeTypeConstructor( name, typeVars, makeTypeFunction(basisDescription fullName, (typeVars, typeResult)), locations) (* Make an opaque type and add it to an environment. *) fun makeAndDeclareOpaqueType(typeName, fullName, env) = let val typeconstr = makeTypeConstructor(typeName, [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription fullName), declInBasis); in #enterType env (typeName, TypeConstrSet(typeconstr, [])); mkTypeConstruction (typeName, typeconstr, [], declInBasis) end; (* List of something *) fun List (base : types) : types = mkTypeConstruction ("list", tsConstr listConstr, [base], declInBasis); (* ref something *) fun Ref (base : types) : types = mkTypeConstruction ("ref", refConstr, [base], declInBasis); fun Option (base : types) : types = mkTypeConstruction ("option", tsConstr optionConstr, [base], declInBasis); (* Type-dependent functions. *) fun mkSpecialFun (name:string, typeof:types, opn: typeDependent) : values = makeOverloaded (name, typeof, opn); (* Overloaded functions. *) fun mkOverloaded (name:string) (typeof: types) : values = mkSpecialFun(name, typeof, TypeDep) (* Make a structure. Returns the table as an environment so that entries can be added to the structure. *) fun makeStructure(parentEnv, name) = let val str as Struct{signat=Signatures{tab, ...}, ...} = makeEmptyGlobal name val () = #enterStruct parentEnv (name, str) val Env env = makeEnv tab in env end val () = enterGlobalType ("unit", TypeConstrSet(unitConstr, [])); local val falseCons = mkGconstr ("false", Bool, createNullaryConstructor(EnumForm{tag=0w0, maxTag=0w1}, [], "false"), true, 2, declInBasis) val trueCons = mkGconstr ("true", Bool, createNullaryConstructor(EnumForm{tag=0w1, maxTag=0w1}, [], "true"), true, 2, declInBasis) val boolEnv = makeStructure(globalEnv, "Bool") (* Bool structure *) val notFn = mkGvar("not", Bool ->> Bool, mkUnaryFn BuiltIns.NotBoolean, declInBasis) in val () = #enterType boolEnv ("bool", TypeConstrSet(boolConstr, [trueCons, falseCons])) val () = #enterVal boolEnv ("true", trueCons) val () = #enterVal boolEnv ("false", falseCons) val () = #enterVal boolEnv ("not", notFn) end; val () = enterGlobalType ("int", TypeConstrSet(if intIsArbitraryPrecision then intInfConstr else fixedIntConstr, [])) val () = enterGlobalType ("char", TypeConstrSet(charConstr, [])) val () = enterGlobalType ("string", TypeConstrSet(stringConstr, [])) val () = enterGlobalType ("real", TypeConstrSet(realConstr, [])) val () = (* Enter :: and nil. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors listConstr) val () = enterGlobalType ("list", listConstr); val () = (* Enter NONE and SOME. *) List.app(fn(tv as Value{name, ...}) => enterGlobalValue(name, tv)) (tsConstructors optionConstr) val () = enterGlobalType ("option", optionConstr); local val refCons = let val a = mkTypeVar(generalisable, false, false, false) in mkGconstr ("ref", a ->> Ref a, createUnaryConstructor(RefForm, [a], "ref"), false, 1, declInBasis) end in val () = enterGlobalType ("ref", TypeConstrSet(refConstr, [refCons])); val () = enterGlobalValue ("ref", refCons); end local open BuiltIns fun monoTypePrinter _ = PRETTY.PrettyString "?" val idCode = let open TypeValue val equalLongWordFn = mkInlproc( mkBinary(LargeWordComparison TestEqual, mkLoadArgument 0, mkLoadArgument 1), 2, "EqualLargeWord()", [], 0) val code = createTypeValue{ eqCode=equalLongWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode = boxedNever, sizeCode = singleWord } in Global (genCode(code, [], 0) ()) end in val largeWordType = makeTypeConstructor("word", [], makeFreeId(0, idCode, true, basisDescription "LargeWord.word"), declInBasis) val LargeWord = mkTypeConstruction ("LargeWord.word", largeWordType, [], declInBasis) end val () = enterGlobalType ("exn", TypeConstrSet(exnConstr, [])); val () = enterGlobalType ("word", TypeConstrSet(wordConstr, [])); val runCallEnv = makeStructure(globalEnv, "RunCall") fun enterRunCall (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal runCallEnv (name, value) end local (* unsafeCast. Can be used to convert any value to any type. *) val a = makeTV () val b = makeTV () val unsafeCastEntry = mkInlproc (mkLoadArgument 0 (* just the parameter *), 1, "unsafeCast(1)", [], 0) in val () = enterRunCall ("unsafeCast", makePolymorphic([a, b], unsafeCastEntry), a ->> b) end local val a = makeTV() and b = makeTV() open BuiltIns in (* isShort - test if a value is tagged rather than being an address. *) val () = enterRunCall ("isShort", makePolymorphic([a], mkUnaryFn IsTaggedValue), a ->> Bool) (* pointer equality *) val () = enterRunCall ("pointerEq", makePolymorphic([a], mkBinaryFn(WordComparison{test=TestEqual, isSigned=false})), a ** a ->> Bool) (* load a word. The index is in words and is always zero or positive. *) val () = enterRunCall ("loadWord", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=false})), a ** Word ->> b) (* Load a word from an immutable. *) val () = enterRunCall ("loadWordFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLWord{isImmutable=true})), a ** Word ->> b) (* load a byte. The index is in bytes and is always zero or positive. Probably the result should be a Word8.word value or a char. *) val () = enterRunCall ("loadByte", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=false})), a ** Word ->> b) (* Load a byte from an immutable. *) val () = enterRunCall ("loadByteFromImmutable", makePolymorphic([a, b], mkLoadOperationFn(LoadStoreMLByte{isImmutable=true})), a ** Word ->> b) (* Get the length of a heap cell. *) val () = enterRunCall ("memoryCellLength", makePolymorphic([a], mkUnaryFn MemoryCellLength), a ->> Word) (* Return the flags. Perhaps this could return a Word8.word value instead of a word. *) val () = enterRunCall ("memoryCellFlags", makePolymorphic([a], mkUnaryFn MemoryCellFlags), a ->> Word) (* Return the number of bytes per word. This is a constant since we have separate pre-built compilers for 32-bit and 64-bit. N.B. The byte order is not a constant since we only have a single pre-built compiler for little-endian and big-endian interpreted code. *) val () = enterRunCall ("bytesPerWord", mkConst(toMachineWord wordSize), Word) (* Store a word *) val () = enterRunCall ("storeWord", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLWord{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Store a byte *) val () = enterRunCall ("storeByte", makePolymorphic([a, b], mkStoreOperationFn(LoadStoreMLByte{isImmutable=false})), mkProductType[a, Word, b] ->> Unit) (* Lock a mutable cell. *) val () = enterRunCall ("clearMutableBit", makePolymorphic([a], mkUnaryFn ClearMutableFlag), a ->> Unit) (* Allocate a byte cell. The second argument is the flags byte. It might be better if this were a Word8.word value. *) val () = enterRunCall ("allocateByteMemory", makePolymorphic([a], mkBinaryFn AllocateByteMemory), Word ** Word ->> a) (* Allocate a word cell. *) val () = enterRunCall ("allocateWordMemory", makePolymorphic([a, b], mkAllocateWordMemoryFn), mkProductType[Word, Word, a] ->> b) (* Byte vector operations. *) val () = enterRunCall ("byteVectorEqual", makePolymorphic([a], mkBlockOperationFn BlockOpEqualByte), mkProductType[a, a, Word, Word, Word] ->> Bool) val () = enterRunCall ("byteVectorCompare", makePolymorphic([a], mkBlockOperationFn BlockOpCompareByte), mkProductType[a, a, Word, Word, Word] ->> Int) (* Block moves. *) val () = enterRunCall ("moveBytes", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=true})), mkProductType[a, a, Word, Word, Word] ->> Unit) val () = enterRunCall ("moveWords", makePolymorphic([a], mkBlockOperationFn (BlockOpMove{isByteMove=false})), mkProductType[a, a, Word, Word, Word] ->> Unit) (* Untagged loads and stores. *) val () = enterRunCall ("loadUntagged", mkLoadOperationFn LoadStoreUntaggedUnsigned, String ** Word ->> Word) val () = enterRunCall ("storeUntagged", mkStoreOperationFn LoadStoreUntaggedUnsigned, mkProductType[String, Word, Word] ->> Unit) end local val debugOpts = [] (* Place to add debugging if necessary. *) (* [tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), tagInject assemblyCodeTag true] *) fun makeCall rtsCall n entryName = rtsCall (entryName, n, debugOpts) val makeFastCall = makeCall CODETREE.Foreign.rtsCallFast (* We need to wrap this so that the arguments are passed in registers. *) fun makeRunCallTupled (argTypes, resultType, callN) : codetree = let val width = List.length argTypes val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkCall (f, args, resultType) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 0) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end (* "Full" calls pass the thread Id as the first parameter. *) fun makeRunCallTupledFull (argTypes, resultType) = let val width = List.length argTypes val callN = toMachineWord(makeFastCall(width + 1)) val name = "rtsCall" ^ Int.toString width; local val f = mkLoadClosure 0 (* first item from enclosing scope *) val tuple = mkLoadArgument 0 (* the inner parameter *) val args = case argTypes of [singleType] => [(tuple, singleType)] | argTypes => let val argVals = List.tabulate(width, fn n => mkInd (n, tuple)) in ListPair.zipEq(argVals, argTypes) end in val innerBody = mkEnv( [ mkDec(0, mkCall (f, (getCurrentThreadId, GeneralType) :: args, resultType)), mkNullDec checkRTSException ], mkLoadLocal 0) end local (* The closure contains the address of the RTS call. *) val f = mkEval(mkConst callN, [mkLoadArgument 0]) (* This creates the actual call. *) val innerLambda = mkInlproc (innerBody, 1, name ^ "(1)", [mkLoadLocal 0], 1) in val outerBody = mkEnv([mkDec (0, f)], innerLambda) end val outerLambda = mkInlproc (outerBody, 1, name, [], 1) in outerLambda end local val a = makeTV () and b = makeTV () fun makeInlCode(makeCall, name) = let val call1 = toMachineWord(makeCall 1) val body = mkEval(mkConst call1, [mkLoadArgument 0]) val proc = mkInlproc (body, 1, name, [], 0) in makePolymorphic([a, b], proc) end in val rtsCallFast1Entry = makeInlCode(makeFastCall, "rtsCallFast1") end local val a = makeTV () and b = makeTV () and c = makeTV () and d = makeTV () and e = makeTV () and f = makeTV () fun makeRtsCall(n, makeCall) = makeRunCallTupled(List.tabulate(n, fn _ => GeneralType), GeneralType, toMachineWord(makeCall n)) fun makeFullRtsCall n = makeRunCallTupledFull(List.tabulate(n, fn _ => GeneralType), GeneralType) in val rtsCallFull0Entry = makePolymorphic([a], makeFullRtsCall 0) and rtsCallFast0Entry = makePolymorphic([a], makeRtsCall(0, makeFastCall)) val rtsCall0Type = String ->> Unit ->> a val rtsCall1Type = String ->> a ->> b val rtsCallFull1Entry = makePolymorphic([a, b], makeFullRtsCall 1) val rtsCallFull2Entry = makePolymorphic([a, b, c], makeFullRtsCall 2) and rtsCallFast2Entry = makePolymorphic([a, b, c], makeRtsCall(2, makeFastCall)) val rtsCall2Type = String ->> TYPETREE.mkProductType [a,b] ->> c val rtsCallFull3Entry = makePolymorphic([a, b, c, d], makeFullRtsCall 3) val rtsCallFast3Entry = makePolymorphic([a, b, c, d], makeRtsCall(3, makeFastCall)) val rtsCall3Type = String ->> TYPETREE.mkProductType [a,b,c] ->> d val rtsCallFull4Entry = makePolymorphic([a, b, c, d, e], makeFullRtsCall 4) val rtsCallFast4Entry = makePolymorphic([a, b, c, d, e], makeRtsCall(4, makeFastCall)) val rtsCall4Type = String ->> TYPETREE.mkProductType [a,b,c,d] ->> e val rtsCallFull5Entry = makePolymorphic([a, b, c, d, e, f], makeFullRtsCall 5) val rtsCall5Type = String ->> TYPETREE.mkProductType [a,b,c,d,e] ->> f end in val () = enterRunCall ("rtsCallFull0", rtsCallFull0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFast0", rtsCallFast0Entry, rtsCall0Type) val () = enterRunCall ("rtsCallFull1", rtsCallFull1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFast1", rtsCallFast1Entry, rtsCall1Type) val () = enterRunCall ("rtsCallFull2", rtsCallFull2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFast2", rtsCallFast2Entry, rtsCall2Type) val () = enterRunCall ("rtsCallFull3", rtsCallFull3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast3", rtsCallFast3Entry, rtsCall3Type) val () = enterRunCall ("rtsCallFast4", rtsCallFast4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull4", rtsCallFull4Entry, rtsCall4Type) val () = enterRunCall ("rtsCallFull5", rtsCallFull5Entry, rtsCall5Type) val makeRunCallTupled = makeRunCallTupled (* Needed for reals. *) end local (* Create nullary exception. *) fun makeException0(name, id) = let val exc = Value{ name = name, typeOf = TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Create exception with parameter. *) and makeException1(name, id, exType) = let val exc = Value{ name = name, typeOf = exType ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord id)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in #enterVal runCallEnv (name, exc) end (* Exception numbers. Most of these are hard-coded in the RTS. *) val EXC_interrupt = 1 val EXC_syserr = 2 val EXC_size = 4 val EXC_overflow = 5 val EXC_divide = 7 val EXC_conversion = 8 val EXC_XWindows = 10 val EXC_subscript = 11 val EXC_thread = 12 val EXC_foreign = 23 val EXC_Bind = 100 (* In Match compiler. *) val EXC_Match = 101 val EXC_Fail = 103 in val () = List.app makeException0 [ ("Interrupt", EXC_interrupt), ("Size", EXC_size), ("Bind", EXC_Bind), ("Div", EXC_divide), ("Match", EXC_Match), ("Overflow", EXC_overflow), ("Subscript", EXC_subscript) ] val () = List.app makeException1 [ ("Fail", EXC_Fail, String), ("Conversion", EXC_conversion, String), ("XWindows", EXC_XWindows, String), ("Foreign", EXC_foreign, String), ("Thread", EXC_thread, String), ("SysErr", EXC_syserr, String ** Option LargeWord) ] end local val arg0 = mkLoadArgument 0 + val arg1 = mkLoadArgument 1 local val callForeignCall = mkEval(mkConst (toMachineWord CODETREE.Foreign.foreignCall), [arg0]) val innerBody = mkEval(mkLoadClosure 0, [mkInd(0, arg0), mkInd(1, arg0), mkInd(2, arg0)]) val outerBody = mkEnv([mkDec(0, callForeignCall)], mkInlproc(innerBody, 1, "foreignCall(1)(1)", [mkLoadLocal 0], 0)) in val foreignCallEntry = mkInlproc(outerBody, 1, "foreignCall(1)", [], 1) end - - val buildCallBackEntry = mkConst (toMachineWord CODETREE.Foreign.buildCallBack) + + local + (* Build a callback. First apply the compiler to the abi/argtype/restype values. + Then apply the result to a function to generate the final C callback code. + The C callback code calls the function with two arguments. Here we have to + pass it a function that expects a tuple and unwrap it. *) + val innerMost = + mkInlproc(mkEval(mkLoadClosure 0, [mkTuple[arg0, arg1]]), 2, "buildCallBack(1)(1)2", [mkLoadArgument 0], 0) + val resultFn = + mkInlproc(mkEval(mkLoadClosure 0, [innerMost]), 1, "buildCallBack(1)(1)", [mkLoadLocal 0], 0) + val firstBuild = mkEval(mkConst (toMachineWord CODETREE.Foreign.buildCallBack), [arg0]) + val outerBody = mkEnv([mkDec(0, firstBuild)], resultFn) + in + val buildCallBackEntry = mkInlproc(outerBody, 1, "buildCallBack(1)", [], 1) + end val abiType = Int and ffiType = LargeWord val foreignCallType = mkProductType[abiType, List ffiType, ffiType] ->> mkProductType[LargeWord, LargeWord, LargeWord] ->> Unit val buildCallBackType = mkProductType[abiType, List ffiType, ffiType] ->> (mkProductType[LargeWord, LargeWord] ->> Unit) ->> LargeWord in val () = enterRunCall ("foreignCall", foreignCallEntry, foreignCallType) val () = enterRunCall ("buildCallBack", buildCallBackEntry, buildCallBackType) end (* Standard Basis structures for basic types. These contain the definitions of the basic types and operations on them. The structures are extended in the basis library and overloaded functions are extracted from them. *) local val largeIntEnv = makeStructure(globalEnv, "LargeInt") (* The comparison operations take two arbitrary precision ints and a general "compare" function that returns a fixed precision int. *) val compareType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> fixedIntType] ->> Bool val arithType = mkProductType[intInfType, intInfType, intInfType ** intInfType ->> intInfType] ->> intInfType fun enterArbitrary(name, oper, typ) = let val value = mkGvar (name, typ, mkArbitraryFn oper, declInBasis) in #enterVal largeIntEnv (name, value) end in val () = #enterType largeIntEnv ("int", TypeConstrSet(intInfConstr, [])) (* These functions are used internally. *) val () = enterArbitrary("less", ArbCompare BuiltIns.TestLess, compareType) val () = enterArbitrary("greater", ArbCompare BuiltIns.TestGreater, compareType) val () = enterArbitrary("lessEq", ArbCompare BuiltIns.TestLessEqual, compareType) val () = enterArbitrary("greaterEq", ArbCompare BuiltIns.TestGreaterEqual, compareType) val () = enterArbitrary("add", ArbArith BuiltIns.ArithAdd, arithType) val () = enterArbitrary("subtract", ArbArith BuiltIns.ArithSub, arithType) val () = enterArbitrary("multiply", ArbArith BuiltIns.ArithMult, arithType) end local val fixedIntEnv = makeStructure(globalEnv, "FixedInt") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal fixedIntEnv (name, value) end val compareType = fixedIntType ** fixedIntType ->> Bool and binaryType = fixedIntType ** fixedIntType ->> fixedIntType fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=true}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, FixedPrecisionArith oper, binaryType) in val () = #enterType fixedIntEnv ("int", TypeConstrSet(fixedIntConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("quot", ArithQuot) val () = enterBinaryOp("rem", ArithRem) end local open BuiltIns val largeWordEnv = makeStructure(globalEnv, "LargeWord") fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal largeWordEnv (name, value) end val compareType = LargeWord ** LargeWord ->> Bool and binaryType = LargeWord ** LargeWord ->> LargeWord and shiftType = LargeWord ** Word ->> LargeWord (* The shift amount is a Word. *) fun enterComparison(name, test) = enterBinary(name, LargeWordComparison test, compareType) and enterBinaryOp(name, oper) = enterBinary(name, LargeWordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, LargeWordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, LargeWordShift oper, shiftType) in val () = #enterType largeWordEnv ("word", TypeConstrSet(largeWordType, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val LargeWord = LargeWord end local val wordStructEnv = makeStructure(globalEnv, "Word") open BuiltIns fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal wordStructEnv (name, value) end val compareType = Word ** Word ->> Bool and binaryType = Word ** Word ->> Word fun enterComparison(name, test) = enterBinary(name, WordComparison{test=test, isSigned=false}, compareType) and enterBinaryOp(name, oper) = enterBinary(name, WordArith oper, binaryType) and enterBinaryLogical(name, oper) = enterBinary(name, WordLogical oper, binaryType) and enterBinaryShift(name, oper) = enterBinary(name, WordShift oper, binaryType) val toLargeWordFn = mkGvar ("toLargeWord", Word ->> LargeWord, mkUnaryFn UnsignedToLongWord, declInBasis) and toLargeWordXFn = mkGvar ("toLargeWordX", Word ->> LargeWord, mkUnaryFn SignedToLongWord, declInBasis) and fromLargeWordFn = mkGvar ("fromLargeWord", LargeWord ->> Word, mkUnaryFn LongWordToTagged, declInBasis) in val () = #enterType wordStructEnv ("word", TypeConstrSet(wordConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("div", ArithDiv) val () = enterBinaryOp("mod", ArithMod) val () = enterBinaryLogical("orb", LogicalOr) val () = enterBinaryLogical("andb", LogicalAnd) val () = enterBinaryLogical("xorb", LogicalXor) val () = enterBinaryShift("<<", ShiftLeft) val () = enterBinaryShift(">>", ShiftRightLogical) val () = enterBinaryShift("~>>", ShiftRightArithmetic) val () = #enterVal wordStructEnv ("toLargeWord", toLargeWordFn) val () = #enterVal wordStructEnv ("toLargeWordX", toLargeWordXFn) val () = #enterVal wordStructEnv ("fromLargeWord", fromLargeWordFn) end local val charEnv = makeStructure(globalEnv, "Char") open BuiltIns (* Comparison functions are the same as Word. *) fun enterComparison(name, test) = let val typ = Char ** Char ->> Bool val entry = mkBinaryFn(WordComparison{test=test, isSigned=false}) val value = mkGvar (name, typ, entry, declInBasis) in #enterVal charEnv (name, value) end in val () = #enterType charEnv ("char", TypeConstrSet(charConstr, [])) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) end local val stringEnv = makeStructure(globalEnv, "String") in val () = #enterType stringEnv ("string", TypeConstrSet(stringConstr, [])) end local val realEnv = makeStructure(globalEnv, "Real") (* These are only used in Real so are included here rather than in RunCall. rtsCallFastRealtoReal is used for functions such as sqrt. rtsCallFastGeneraltoReal is used for Real.fromLargeInt. *) val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealtoReal (entryName, debugOpts) and makeFastRealRealRealCall entryName = CODETREE.Foreign.rtsCallFastRealRealtoReal (entryName, debugOpts) and makeFastIntInfRealCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoReal (entryName, debugOpts) and makeFastRealGeneralRealCall entryName = CODETREE.Foreign.rtsCallFastRealGeneraltoReal (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([DoubleFloatType, DoubleFloatType], DoubleFloatType, toMachineWord makeFastRealRealRealCall) and rtsCallFastRI_REntry = makeRunCallTupled([DoubleFloatType, GeneralType], DoubleFloatType, toMachineWord makeFastRealGeneralRealCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], DoubleFloatType, toMachineWord makeFastIntInfRealCall) val rtsCallFastF_F = mkGvar ("rtsCallFastR_R", String ->> Real ->> Real, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastRR_R", String ->> Real ** Real ->> Real, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastRI_R", String ->> Real ** Int ->> Real, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_R", String ->> intInfType ->> Real, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal realEnv (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal realEnv (name, value) end val compareType = Real ** Real ->> Bool and binaryType = Real ** Real ->> Real and unaryType = Real ->> Real and realToFixType = Real ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecDouble), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecDouble), binaryType) in val () = #enterType realEnv ("real", TypeConstrSet(realConstr, [])) val () = #enterVal realEnv ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal realEnv ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal realEnv ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal realEnv ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* real is not an eqtype. *) (* Included unordered mainly because it's easy to implement isNan. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecDouble, unaryType) val () = enterUnary("abs", RealAbs PrecDouble, unaryType) val () = enterUnary("fromFixedInt", RealFixedInt PrecDouble, fixedIntType ->> Real) val () = enterUnary("truncFix", RealToInt(PrecDouble, TO_ZERO), realToFixType) val () = enterUnary("roundFix", RealToInt(PrecDouble, TO_NEAREST), realToFixType) val () = enterUnary("ceilFix", RealToInt(PrecDouble, TO_POSINF), realToFixType) val () = enterUnary("floorFix", RealToInt(PrecDouble, TO_NEGINF), realToFixType) end local val real32Env = makeStructure(globalEnv, "Real32") val floatType = mkTypeConstruction ("real", floatConstr, [], []) val Float = floatType val debugOpts = [] (* Place to add debugging if necessary. *) fun makeFastFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloattoFloat (entryName, debugOpts) and makeFastFloatFloatFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatFloattoFloat (entryName, debugOpts) and makeFastIntInfFloatCall entryName = CODETREE.Foreign.rtsCallFastGeneraltoFloat (entryName, debugOpts) and makeFastFloatGeneralFloatCall entryName = CODETREE.Foreign.rtsCallFastFloatGeneraltoFloat (entryName, debugOpts) val rtsCallFastR_REntry = makeRunCallTupled([SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatCall) (* This needs to be tupled. *) val rtsCallFastRR_REntry = makeRunCallTupled([SingleFloatType, SingleFloatType], SingleFloatType, toMachineWord makeFastFloatFloatFloatCall) and rtsCallFastRI_REntry = makeRunCallTupled([SingleFloatType, GeneralType], SingleFloatType, toMachineWord makeFastFloatGeneralFloatCall) val rtsCallFastI_REntry = makeRunCallTupled([GeneralType], SingleFloatType, toMachineWord makeFastIntInfFloatCall) val rtsCallFastF_F = mkGvar ("rtsCallFastF_F", String ->> Float ->> Float, rtsCallFastR_REntry, declInBasis) val rtsCallFastFF_F = mkGvar ("rtsCallFastFF_F", String ->> Float ** Float ->> Float, rtsCallFastRR_REntry, declInBasis) val rtsCallFastFG_F = mkGvar ("rtsCallFastFI_F", String ->> Float ** Int ->> Float, rtsCallFastRI_REntry, declInBasis) val rtsCallFastG_F = mkGvar ("rtsCallFastI_F", String ->> intInfType ->> Float, rtsCallFastI_REntry, declInBasis) fun enterUnary(name, oper, typ) = let val value = mkGvar (name, typ, mkUnaryFn oper, declInBasis) in #enterVal real32Env (name, value) end fun enterBinary(name, oper, typ) = let val value = mkGvar (name, typ, mkBinaryFn oper, declInBasis) in #enterVal real32Env (name, value) end val compareType = Float ** Float ->> Bool and binaryType = Float ** Float ->> Float and unaryType = Float ->> Float and floatToFixType = Float ->> fixedIntType open BuiltIns IEEEReal fun enterComparison(name, test) = enterBinary(name, RealComparison(test, PrecSingle), compareType) and enterBinaryOp(name, oper) = enterBinary(name, RealArith(oper, PrecSingle), binaryType) in val () = #enterType real32Env ("real", TypeConstrSet(floatConstr, [])) val () = enterUnary("toLarge", BuiltIns.FloatToDouble, floatType ->> Real) (* Conversion with the current rounding mode. *) and () = enterUnary("fromReal", BuiltIns.DoubleToFloat NONE, Real ->> floatType) (* There are various versions of this function for each of the rounding modes. *) and () = enterUnary("fromRealRound", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEAREST), Real ->> floatType) and () = enterUnary("fromRealTrunc", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_ZERO), Real ->> floatType) and () = enterUnary("fromRealCeil", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_POSINF), Real ->> floatType) and () = enterUnary("fromRealFloor", BuiltIns.DoubleToFloat (SOME IEEEReal.TO_NEGINF), Real ->> floatType) val () = #enterVal real32Env ("rtsCallFastR_R", rtsCallFastF_F) val () = #enterVal real32Env ("rtsCallFastRR_R", rtsCallFastFF_F) val () = #enterVal real32Env ("rtsCallFastRI_R", rtsCallFastFG_F) val () = #enterVal real32Env ("rtsCallFastI_R", rtsCallFastG_F) val () = enterComparison("<", TestLess) val () = enterComparison("<=", TestLessEqual) val () = enterComparison(">", TestGreater) val () = enterComparison(">=", TestGreaterEqual) val () = enterComparison("==", TestEqual) (* Real32.real is not an eqtype. *) val () = enterComparison("unordered", TestUnordered) val () = enterBinaryOp("+", ArithAdd) val () = enterBinaryOp("-", ArithSub) val () = enterBinaryOp("*", ArithMult) val () = enterBinaryOp("/", ArithDiv) val () = enterUnary("~", RealNeg PrecSingle, unaryType) val () = enterUnary("abs", RealAbs PrecSingle, unaryType) val () = enterUnary("truncFix", RealToInt(PrecSingle, TO_ZERO), floatToFixType) val () = enterUnary("roundFix", RealToInt(PrecSingle, TO_NEAREST), floatToFixType) val () = enterUnary("ceilFix", RealToInt(PrecSingle, TO_POSINF), floatToFixType) val () = enterUnary("floorFix", RealToInt(PrecSingle, TO_NEGINF), floatToFixType) end val bootstrapEnv = makeStructure(globalEnv, "Bootstrap") fun enterBootstrap (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis) in #enterVal bootstrapEnv (name, value) end local val threadEnv = makeStructure(globalEnv, "Thread") open TypeValue fun monoTypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode=equalWordFn, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord } (* Thread.thread type. This is an equality type with pointer equality. *) val threadConstr= makeTypeConstructor ( "thread", [], makeFreeId(0, Global (genCode(code, [], 0) ()), true, basisDescription "thread"), [DeclaredAt inBasis]) val threadType = mkTypeConstruction ("thread", threadConstr, [], []); val selfFunction = mkGvar ("self", Unit ->> threadType, getCurrentThreadIdFn, declInBasis) val atIncrFunction = mkGvar("atomicIncr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicIncrement, declInBasis) val atDecrFunction = mkGvar("atomicDecr", Ref Word ->> Word, mkUnaryFn BuiltIns.AtomicDecrement, declInBasis) val atResetFunction = mkGvar("atomicReset", Ref Word ->> Unit, mkUnaryFn BuiltIns.AtomicReset, declInBasis) in val () = #enterType threadEnv ("thread", TypeConstrSet(threadConstr, [])) val () = #enterVal threadEnv ("self", selfFunction) val () = #enterVal threadEnv ("atomicIncr", atIncrFunction) val () = #enterVal threadEnv ("atomicDecr", atDecrFunction) val () = #enterVal threadEnv ("atomicReset", atResetFunction) end local val fmemEnv = makeStructure(globalEnv, "ForeignMemory") val a = makeTV() (* We don't have Word8.word or Word32.word at this point so the easiest way to deal with this is to make them polymorphic. *) val get8Function = mkGvar("get8", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC8), declInBasis) val get16Function = mkGvar("get16", LargeWord ** Word ->> Word, mkLoadOperationFn LoadStoreC16, declInBasis) val get32Function = mkGvar("get32", LargeWord ** Word ->> a, makePolymorphic([a], mkLoadOperationFn LoadStoreC32), declInBasis) val get64Function = mkGvar("get64", LargeWord ** Word ->> LargeWord, mkLoadOperationFn LoadStoreC64, declInBasis) val getFloatFunction = mkGvar("getFloat", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCFloat, declInBasis) val getDoubleFunction = mkGvar("getDouble", LargeWord ** Word ->> Real, mkLoadOperationFn LoadStoreCDouble, declInBasis) val set8Function = mkGvar("set8", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC8), declInBasis) val set16Function = mkGvar("set16", mkProductType[LargeWord, Word, Word] ->> Unit, mkStoreOperationFn LoadStoreC16, declInBasis) val set32Function = mkGvar("set32", mkProductType[LargeWord, Word, a] ->> Unit, makePolymorphic([a], mkStoreOperationFn LoadStoreC32), declInBasis) val set64Function = mkGvar("set64", mkProductType[LargeWord, Word, LargeWord] ->> Unit, mkStoreOperationFn LoadStoreC64, declInBasis) val setFloatFunction = mkGvar("setFloat", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCFloat, declInBasis) val setDoubleFunction = mkGvar("setDouble", mkProductType[LargeWord, Word, Real] ->> Unit, mkStoreOperationFn LoadStoreCDouble, declInBasis) in val () = #enterVal fmemEnv ("get8", get8Function) val () = #enterVal fmemEnv ("get16", get16Function) val () = #enterVal fmemEnv ("get32", get32Function) val () = #enterVal fmemEnv ("get64", get64Function) val () = #enterVal fmemEnv ("getFloat", getFloatFunction) val () = #enterVal fmemEnv ("getDouble", getDoubleFunction) val () = #enterVal fmemEnv ("set8", set8Function) val () = #enterVal fmemEnv ("set16", set16Function) val () = #enterVal fmemEnv ("set32", set32Function) val () = #enterVal fmemEnv ("set64", set64Function) val () = #enterVal fmemEnv ("setFloat", setFloatFunction) val () = #enterVal fmemEnv ("setDouble", setDoubleFunction) end local fun addVal (name : string, value : 'a, typ : types) : unit = enterBootstrap (name, mkConst (toMachineWord value), typ) (* These are only used during the bootstrap phase. Replacements are installed once the appropriate modules of the basis library are compiled. *) fun intOfString s = let val radix = if String.size s >= 3 andalso String.substring(s, 0, 2) = "0x" orelse String.size s >= 4 andalso String.substring(s, 0, 3) = "~0x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Int.scan radix) s of NONE => raise Conversion "Invalid integer constant" | SOME res => res end fun wordOfString s = let val radix = if String.size s > 2 andalso String.sub(s, 2) = #"x" then StringCvt.HEX else StringCvt.DEC in case StringCvt.scanString (Word.scan radix) s of NONE => raise Conversion "Invalid word constant" | SOME res => res end open PRINTTABLE val convstringCode = genCode(mkConst(toMachineWord unescapeString), [], 0) () val convintCode = genCode(mkConst(toMachineWord intOfString), [], 0) () val convwordCode = genCode(mkConst(toMachineWord wordOfString), [], 0) () in (* Conversion overloads used to be set by the ML bootstrap code. It's simpler to do that here but to maintain compatibility with the 5.6 compiler we need to define these. Once we've rebuilt the compiler this can be removed along with the code that uses it. *) val () = addVal ("convStringName", "convString": string, String) val () = addVal ("convInt", intOfString : string -> int, String ->> intInfType) val () = addVal ("convWord", wordOfString : string -> word, String ->> Word) (* Convert a string, recognising and converting the escape codes. *) val () = addVal ("convString", unescapeString: string -> string, String ->> String) (* Flag to indicate which version of Int to compile *) val () = addVal ("intIsArbitraryPrecision", intIsArbitraryPrecision, Bool) (* Install the overloads now. *) val () = addOverload("convString", stringConstr, convstringCode) val () = addOverload("convInt", fixedIntConstr, convintCode) val () = addOverload("convInt", intInfConstr, convintCode) val () = addOverload("convWord", wordConstr, convwordCode) end (* The only reason we have vector here is to get equality right. We need vector to be an equality type and to have a specific equality function. *) local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" (* The equality function takes the base equality type as an argument. The inner function takes two arguments which are the two vectors to compare, checks the lengths and if they're equal applies the base equality to each field. *) val eqCode = mkInlproc( mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)), mkMutualDecs[(2, (* Loop function. *) mkProc( mkIf( (* Finished? *) mkEqualWord(mkLoadClosure 0, mkLoadArgument 0), CodeTrue, (* Yes, all equal. *) mkIf( mkEval( TypeValue.extractEquality(mkLoadClosure 2), (* Base equality fn *) [ mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 3, mkLoadArgument 0), mkLoadOperation(LoadStoreMLWord{isImmutable=true}, mkLoadClosure 4, mkLoadArgument 0) ]), mkEval(mkLoadClosure 1, (* Recursive call with index+1. *) [ mkBinary(BuiltIns.WordArith BuiltIns.ArithAdd, mkLoadArgument 0, mkConst(toMachineWord 1)) ]), CodeFalse (* Not equal elements - result false *) ) ), 1, "vector-loop", [mkLoadLocal 0 (* Length *), mkLoadLocal 2 (* Loop function *), mkLoadClosure 0 (* Base equality function *), mkLoadArgument 0 (* Vector 0 *), mkLoadArgument 1 (* Vector 1 *)], 0))] ], mkIf( (* Test the lengths. *) mkEqualWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEval(mkLoadLocal 2, [CodeZero]), CodeFalse (* Not same length- result false *) ) ), 2, "vector-eq", [mkLoadArgument 0], 3), 1, "vector-eq()", [], 0) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedAlways, 1, "boxed-vector", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-vector", [], 0)} in Global (genCode(code, [], 0) ()) end in val vectorType = makeTypeConstructor("vector", [makeTypeVariable()], makeFreeId(1, idCode, true, basisDescription "vector"), declInBasis) val () = enterGlobalType ("vector", TypeConstrSet(vectorType, [])) end (* We also need a type with byte-wise equality. *) local fun monoTypePrinter _ = PRETTY.PrettyString "?" (* This is a monotype equality function that takes two byte vectors and compares them byte-by-byte for equality. Because they are vectors of bytes it's unsafe to load the whole words which could look like addresses if the bottom bit happens to be zero. *) val eqCode = mkProc( mkEnv([ (* Length of the items. *) mkDec(0, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 0)), mkDec(1, mkUnary(BuiltIns.MemoryCellLength, mkLoadArgument 1)) ], mkIf( (* Test the lengths. *) mkEqualWord(mkLoadLocal 0, mkLoadLocal 1), (* Equal - test the contents. *) mkEnv([ (* ByteVecEqual takes a byte length so we have to multiply by the number of bytes per word. *) mkDec(2, mkBinary(BuiltIns.WordArith BuiltIns.ArithMult, mkConst(toMachineWord RunCall.bytesPerWord), mkLoadLocal 0)) ], mkBlockOperation{kind=BlockOpEqualByte, leftBase=mkLoadArgument 0, rightBase=mkLoadArgument 1, leftIndex=CodeZero, rightIndex=CodeZero, length=mkLoadLocal 2}), CodeFalse (* Not same length- result false *) ) ), 2, "byteVector-eq", [], 3) val idCode = (* Polytype *) let open TypeValue val code = createTypeValue{ eqCode=eqCode, printCode=mkConst (toMachineWord (ref monoTypePrinter)), boxedCode=boxedAlways, sizeCode=singleWord} in Global (genCode(code, [], 0) ()) end in val byteVectorType = makeTypeConstructor("byteVector", [], makeFreeId(0, idCode, true, basisDescription "byteVector"), declInBasis) val () = #enterType bootstrapEnv ("byteVector", TypeConstrSet(byteVectorType, [])) end (* We also need array and Array2.array to be passed through here so that they have the special property of being eqtypes even if their argument is not. "array" is defined to be in the global environment. *) val () = enterGlobalType ("array", TypeConstrSet(arrayConstr, [])) val () = #enterType bootstrapEnv ("array", TypeConstrSet(array2Constr, [])) val () = #enterType bootstrapEnv ("byteArray", TypeConstrSet(byteArrayConstr, [])) (* "=', '<>', PolyML.print etc are type-specific function which appear to be polymorphic. The compiler recognises these and treats them specially. For (in)equality that means generating type-specific versions of the equality operations; for print etc that means printing in a type-specific way. They can become true polymorphic functions and lose their type-specificity. For (in)equality that means defaulting to structure equality which is normal and expected behaviour. For print etc that means losing the ability to print and just printing "?" so it's important to avoid that happening. "open" treats type-specific functions specially and retains the type-specificity. That's important to allow the prelude code to expand the PolyML structure. *) local val eqType = let val a = makeEqTV () in a ** a ->> Bool end val eqVal = mkSpecialFun("=", eqType, Equal) in val () = enterGlobalValue ("=", eqVal) end local val neqType = let val a = makeEqTV () in a ** a ->> Bool end val neqVal = mkSpecialFun("<>", neqType, NotEqual) in val () = enterGlobalValue ("<>", neqVal) end val polyMLEnv = makeStructure(globalEnv, "PolyML") val enterPolyMLVal = #enterVal polyMLEnv local (* This version of the environment must match that used in the NameSpace structure. *) open TYPETREE (* Create a new structure for them. *) val nameSpaceEnv = makeStructure(polyMLEnv, "NameSpace") (* Substructures. *) val valuesEnv = makeStructure(nameSpaceEnv, "Values") and typesEnv = makeStructure(nameSpaceEnv, "TypeConstrs") and fixesEnv = makeStructure(nameSpaceEnv, "Infixes") and structsEnv = makeStructure(nameSpaceEnv, "Structures") and sigsEnv = makeStructure(nameSpaceEnv, "Signatures") and functsEnv = makeStructure(nameSpaceEnv, "Functors") (* Types for the basic values. These are opaque. *) val valueVal = makeAndDeclareOpaqueType("value", "PolyML.NameSpace.Values.value", valuesEnv) (* Representation of the type of a value. *) val Types = makeAndDeclareOpaqueType("typeExpression", "PolyML.NameSpace.Values.typeExpression", valuesEnv) val typeVal = makeAndDeclareOpaqueType("typeConstr", "PolyML.NameSpace.TypeConstrs.typeConstr", typesEnv) val fixityVal = makeAndDeclareOpaqueType("fixity", "PolyML.NameSpace.Infixes.fixity", fixesEnv) val signatureVal = makeAndDeclareOpaqueType("signatureVal", "PolyML.NameSpace.Signatures.signatureVal", sigsEnv) val structureVal = makeAndDeclareOpaqueType("structureVal", "PolyML.NameSpace.Structures.structureVal", structsEnv) val functorVal = makeAndDeclareOpaqueType("functorVal", "PolyML.NameSpace.Functors.functorVal", functsEnv) (* nameSpace type. Labelled record. *) fun createFields(name, vType): { name: string, typeof: types} list = let val enterFun = String ** vType ->> Unit val lookupFun = String ->> Option vType val allFun = Unit ->> List (String ** vType) in [mkLabelEntry("enter" ^ name, enterFun), mkLabelEntry("lookup" ^ name, lookupFun), mkLabelEntry("all" ^ name, allFun)] end (* We have to use the same names as we use in the env type because we're passing "env" values through the bootstrap. *) val valTypes = [("Val", valueVal), ("Type", typeVal), ("Fix", fixityVal), ("Struct", structureVal), ("Sig", signatureVal), ("Funct", functorVal)] val fields = List.foldl (fn (p,l) => createFields p @ l) [] valTypes val recordType = makeTypeAbbreviation("nameSpace", "PolyML.NameSpace.nameSpace", [], mkLabelled(sortLabels fields, true), declInBasis); val () = #enterType nameSpaceEnv ("nameSpace", TypeConstrSet(recordType, [])); (* The result type of the compiler includes valueVal etc. *) val resultFields = List.map TYPETREE.mkLabelEntry [("values", List(String ** valueVal)), ("fixes", List(String ** fixityVal)), ("types", List(String ** typeVal)), ("structures", List(String ** structureVal)), ("signatures", List(String ** signatureVal)), ("functors", List(String ** functorVal))] in val nameSpaceType = mkTypeConstruction ("nameSpace", recordType, [], declInBasis) val execResult = mkLabelled(sortLabels resultFields, true) type execResult = { fixes: (string * fixStatus) list, values: (string * values) list, structures: (string * structVals) list, signatures: (string * signatures) list, functors: (string * functors) list, types: (string * typeConstrSet) list } val valueVal = valueVal val typeVal = typeVal val fixityVal = fixityVal val signatureVal = signatureVal val structureVal = structureVal val functorVal = functorVal val Types = Types val valuesEnv = valuesEnv and typesEnv = typesEnv and fixesEnv = fixesEnv and structsEnv = structsEnv and sigsEnv = sigsEnv and functsEnv = functsEnv end local val typeconstr = locationConstr val () = #enterType polyMLEnv ("location", typeconstr); in val Location = mkTypeConstruction ("location", tsConstr typeconstr, [], declInBasis) end (* Interface to the debugger. *) local open TYPETREE val debuggerEnv = makeStructure(polyMLEnv, "DebuggerInterface") (* Make these opaque at this level. *) val locationPropList = makeAndDeclareOpaqueType("locationPropList", "PolyML.DebuggerInterface.locationPropList", debuggerEnv) val typeId = makeAndDeclareOpaqueType("typeId", "PolyML.DebuggerInterface.typeId", debuggerEnv) val machineWordType = makeAndDeclareOpaqueType("machineWord", "PolyML.DebuggerInterface.machineWord", debuggerEnv) (* For long term security keep these as different from global types and sigs. Values in the static environment need to be copied before they are global. *) val localType = makeAndDeclareOpaqueType("localType", "PolyML.DebuggerInterface.localType", debuggerEnv) val localTypeConstr = makeAndDeclareOpaqueType("localTypeConstr", "PolyML.DebuggerInterface.localTypeConstr", debuggerEnv) val localSig = makeAndDeclareOpaqueType("localSig", "PolyML.DebuggerInterface.localSig", debuggerEnv) open DEBUGGER (* Entries in the static list. This type is only used within the implementation of DebuggerInterface in the basis library and does not appear in the final signature. *) val environEntryConstr = makeTypeConstructor("environEntry", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.DebuggerInterface.environEntry"), declInBasis) val environEntryType = mkTypeConstruction ("environEntry", environEntryConstr, [], declInBasis) val constrs = (* Order is significant. *) [ ("EnvEndFunction", mkProductType[String, Location, localType]), ("EnvException", mkProductType[String, localType, locationPropList]), ("EnvStartFunction", mkProductType[String, Location, localType]), ("EnvStructure", mkProductType[String, localSig, locationPropList]), ("EnvTConstr", String ** localTypeConstr), ("EnvTypeid", typeId ** typeId), ("EnvVConstr", mkProductType[String, localType, Bool, Int, locationPropList]), ("EnvValue", mkProductType[String, localType, locationPropList]) ] (* This representation must match the representation defined in DEBUGGER_.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> environEntryType, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal debuggerEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType debuggerEnv ("environEntry", TypeConstrSet(environEntryConstr, constructors)) (* Debug state type. *) val debugStateConstr = makeTypeAbbreviation("debugState", "PolyML.DebuggerInterface.debugState", [], mkProductType[List environEntryType, List machineWordType, Location], declInBasis) val () = #enterType debuggerEnv ("debugState", TypeConstrSet(debugStateConstr, [])) val debugStateType = mkTypeConstruction ("debugState", debugStateConstr, [], declInBasis) in val () = applyList (fn (name, v, t) => #enterVal debuggerEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("makeValue", toMachineWord(makeValue: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeException", toMachineWord(makeException: debugState -> string * types * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, locationPropList, machineWordType] ->> valueVal), ("makeConstructor", toMachineWord(makeConstructor: debugState -> string * types * bool * int * locationProp list * machineWord -> values), debugStateType ->> mkProductType[String, localType, Bool, Int, locationPropList, machineWordType] ->> valueVal), ("makeAnonymousValue", toMachineWord(makeAnonymousValue: debugState -> types * machineWord -> values), debugStateType ->> mkProductType[localType, machineWordType] ->> valueVal), ("makeStructure", toMachineWord(makeStructure: debugState -> string * signatures * locationProp list * machineWord -> structVals), debugStateType ->> mkProductType[String, localSig, locationPropList, machineWordType] ->> structureVal), ("makeTypeConstr", toMachineWord(makeTypeConstr: debugState -> typeConstrSet -> typeConstrSet), debugStateType ->> localTypeConstr ->> typeVal), ("unitValue", toMachineWord(mkGvar("", unitType, CodeZero, []): values), valueVal), (* Used as a default *) ("setOnEntry", toMachineWord(setOnEntry: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExit", toMachineWord(setOnExit: (string * PolyML.location -> unit) option -> unit), Option (String ** Location ->> Unit) ->> Unit), ("setOnExitException", toMachineWord(setOnExitException: (string * PolyML.location -> exn -> unit) option -> unit), Option (String ** Location ->> Exn ->> Unit) ->> Unit), ("setOnBreakPoint", toMachineWord(setOnBreakPoint: (PolyML.location * bool ref -> unit) option -> unit), Option (Location ** Ref Bool ->> Unit) ->> Unit) ] end local val typeconstr = contextConstr in val () = #enterType polyMLEnv ("context", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) end local val typeconstr = prettyConstr in val () = #enterType polyMLEnv ("pretty", typeconstr); val () = List.app(fn(tv as Value{name, ...}) => #enterVal polyMLEnv(name, tv)) (tsConstructors typeconstr) val PrettyType = mkTypeConstruction ("pretty", tsConstr typeconstr, [], declInBasis) end local val printType = let val a = makePrintTV () in a ->> a end; val printVal = mkSpecialFun("print", printType, Print); in val () = enterPolyMLVal ("print", printVal); end; local val makeStringType = let val a = makePrintTV () in a ->> String end; val makeStringVal = mkSpecialFun("makestring", makeStringType, MakeString); in val () = enterPolyMLVal ("makestring", makeStringVal); end; local val prettyType = let val a = makePrintTV () in a ** fixedIntType ->> PrettyType end; val prettyVal = mkSpecialFun("prettyRepresentation", prettyType, GetPretty); in val () = enterPolyMLVal ("prettyRepresentation", prettyVal); end; local (* addPrettyPrinter is the new function to install a pretty printer. *) val a = makeTV () val b = makeTV () val addPrettyType = (TYPETREE.fixedIntType ->> b ->> a ->> PrettyType) ->> Unit; val addPrettyVal = mkSpecialFun("addPrettyPrinter", addPrettyType, AddPretty); in val () = enterPolyMLVal ("addPrettyPrinter", addPrettyVal); end; (* This goes in RunCall since it's only for the basis library. *) local val addOverloadType = let val a = makeTV () and b = makeTV () in (a ->> b) ->> String ->> Unit end; val addOverloadVal = mkSpecialFun("addOverload", addOverloadType, AddOverload); in val () = #enterVal runCallEnv ("addOverload", addOverloadVal); end local (* Add a function to switch the default integer type. *) fun setType isArbitrary = setPreferredInt(if isArbitrary then intInfConstr else fixedIntConstr) in val () = #enterVal runCallEnv ("setDefaultIntTypeArbitrary", mkGvar ("setDefaultIntTypeArbitrary", Bool ->> Unit, mkConst (toMachineWord setType), declInBasis)) end local val sourceLocVal = mkSpecialFun("sourceLocation", Unit ->> Location, GetLocation); in val () = enterPolyMLVal ("sourceLocation", sourceLocVal); end; local (* This is used as one of the arguments to the compiler function. *) open TYPETREE val uniStructEnv = makeStructure(bootstrapEnv, "Universal") fun enterUniversal (name : string, entry : codetree, typ : types) : unit = let val value = mkGvar (name, typ, entry, declInBasis); in #enterVal uniStructEnv (name, value) end; local fun polyTypePrinter _ _ = PRETTY.PrettyString "?" open TypeValue val idCode = let val code = createTypeValue{ eqCode=CodeZero, (* Not an equality type *) printCode=mkConst (toMachineWord (ref polyTypePrinter)), boxedCode=mkInlproc(boxedEither(* Assume worst case *), 1, "boxed-tag", [], 0), sizeCode=mkInlproc(singleWord, 1, "size-tag", [], 0)} in Global (genCode(code, [], 0) ()) end in (* type 'a tag *) val tagConstr = makeTypeConstructor("tag", [makeTypeVariable()], makeFreeId(1, idCode, false, basisDescription "tag"), declInBasis); val () = #enterType uniStructEnv ("tag", TypeConstrSet(tagConstr, [])) end (* type universal *) val univConstr = makeTypeConstructor("universal", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "universal"), declInBasis); val () = #enterType uniStructEnv ("universal", TypeConstrSet(univConstr, [])); fun Tag base = mkTypeConstruction ("tag", tagConstr, [base], declInBasis) val Universal = mkTypeConstruction ("universal", univConstr, [], declInBasis) val a = makeTV() (* val tagInject : 'a tag -> 'a -> universal *) val injectType = Tag a ->> a ->> Universal val () = enterUniversal ("tagInject", makePolymorphic([a], mkConst (toMachineWord (Universal.tagInject: 'a Universal.tag -> 'a -> Universal.universal))), injectType) (* We don't actually need tagIs and tagProject since this is only used for the compiler. Universal is redefined in the basis library. *) val projectType = Tag a ->> Universal ->> a val () = enterUniversal ("tagProject", makePolymorphic([a], mkConst (toMachineWord(Universal.tagProject: 'a Universal.tag -> Universal.universal -> 'a))), projectType) val testType = Tag a ->> Universal ->> Bool val () = enterUniversal ("tagIs", makePolymorphic([a], mkConst (toMachineWord(Universal.tagIs: 'a Universal.tag -> Universal.universal -> bool))), testType) in val Tag = Tag and Universal = Universal end local open TYPETREE (* Parsetree properties datatype. *) val propConstr = makeTypeConstructor("ptProperties", [], makeFreeId(0, defaultEqAndPrintCode(), false, basisDescription "PolyML.ptProperties"), declInBasis); val PtProperties = mkTypeConstruction ("ptProperties", propConstr, [], declInBasis) (* Parsetree type. *) val parseTreeConstr = makeTypeAbbreviation("parseTree", "PolyML.parseTree", [], Location ** List PtProperties, declInBasis); val ParseTree = mkTypeConstruction ("parseTree", parseTreeConstr, [], declInBasis) val () = #enterType polyMLEnv ("parseTree", TypeConstrSet(parseTreeConstr, [])); val constrs = (* Order is significant. *) [ ("PTbreakPoint", Ref Bool), ("PTcompletions", List String), ("PTdeclaredAt", Location), ("PTdefId", fixedIntType), ("PTfirstChild", Unit ->> ParseTree), ("PTnextSibling", Unit ->> ParseTree), ("PTopenedAt", Location), ("PTparent", Unit ->> ParseTree), ("PTpreviousSibling", Unit ->> ParseTree), ("PTprint", fixedIntType ->> PrettyType), ("PTreferences", Bool ** List Location), ("PTrefId", fixedIntType), ("PTstructureAt", Location), ("PTtype", Types) ]; (* This representation must match the representation defined in ExportTree.sml. *) val numConstrs = List.length constrs val {constrs=constrReps, ...} = chooseConstrRepr(constrs, []) val constructors = ListPair.map (fn ((s,t), code) => mkGconstr(s, t ->> PtProperties, code, false, numConstrs, declInBasis)) (constrs, constrReps) val () = List.app (fn c => #enterVal polyMLEnv(valName c, c)) constructors (* Put these constructors onto the type. *) val () = #enterType polyMLEnv ("ptProperties", TypeConstrSet(propConstr, constructors)); in val ParseTree = ParseTree and PtProperties = PtProperties end local open TYPETREE val compilerType : types = mkProductType[nameSpaceType, Unit ->> Option Char, List Universal] ->> mkProductType[Option ParseTree, Option (Unit ->> execResult)] type compilerType = nameSpace * (unit -> char option) * Universal.universal list -> exportTree option * (unit->execResult) option in val () = enterBootstrap ("use", mkConst (toMachineWord ((useIntoEnv globalTable []): string -> unit)), String ->> Unit) val () = enterBootstrap ("useWithParms", mkConst (toMachineWord ((useIntoEnv globalTable): Universal.universal list -> string -> unit)), List Universal ->> String ->> Unit) val () = enterPolyMLVal("compiler", mkGvar ("compiler", compilerType, mkConst (toMachineWord (compiler: compilerType)), declInBasis)); val () = enterBootstrap("globalSpace", mkConst (toMachineWord(gEnvAsNameSpace globalTable: nameSpace)), nameSpaceType) end; local val ty = TYPETREE.mkOverloadSet[] val addType = ty ** ty ->> ty; val negType = ty ->> ty; val cmpType = ty ** ty ->> Bool; in val () = enterGlobalValue ("+", mkOverloaded "+" addType); val () = enterGlobalValue ("-", mkOverloaded "-" addType); val () = enterGlobalValue ("*", mkOverloaded "*" addType); val () = enterGlobalValue ("~", mkOverloaded "~" negType); val () = enterGlobalValue ("abs", mkOverloaded "abs" negType); val () = enterGlobalValue (">=", mkOverloaded ">=" cmpType); val () = enterGlobalValue ("<=", mkOverloaded "<=" cmpType); val () = enterGlobalValue (">", mkOverloaded ">" cmpType); val () = enterGlobalValue ("<", mkOverloaded "<" cmpType); (* The following overloads are added in ML97 *) val () = enterGlobalValue ("div", mkOverloaded "div" addType); val () = enterGlobalValue ("mod", mkOverloaded "mod" addType); val () = enterGlobalValue ("/", mkOverloaded "/" addType); end; local open DEBUG; local open TYPETREE val fields = [ mkLabelEntry("location", Location), mkLabelEntry("hard", Bool), mkLabelEntry("message", PrettyType), mkLabelEntry("context", Option PrettyType) ] in val errorMessageProcType = mkLabelled(sortLabels fields, true) ->> Unit type errorMessageProcType = { location: location, hard: bool, message: pretty, context: pretty option } -> unit end local open TYPETREE val optNav = Option(Unit->>ParseTree) val fields = [ mkLabelEntry("parent", optNav), mkLabelEntry("next", optNav), mkLabelEntry("previous", optNav) ] in val navigationType = mkLabelled(sortLabels fields, true) type navigationType = { parent: (unit->exportTree) option, next: (unit->exportTree) option, previous: (unit->exportTree) option } end type 'a tag = 'a Universal.tag in val () = applyList (fn (name, v, t) => enterBootstrap(name, mkConst v, t)) [ ("compilerVersion", toMachineWord (VERSION.compilerVersion: string), String), ("compilerVersionNumber", toMachineWord (VERSION.versionNumber: int), Int), ("lineNumberTag", toMachineWord (lineNumberTag : (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("offsetTag", toMachineWord (offsetTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("fileNameTag", toMachineWord (fileNameTag: string tag), Tag String), ("bindingCounterTag", toMachineWord (bindingCounterTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("maxInlineSizeTag", toMachineWord (maxInlineSizeTag: FixedInt.int tag), Tag fixedIntType), ("assemblyCodeTag", toMachineWord (assemblyCodeTag: bool tag), Tag Bool), ("parsetreeTag", toMachineWord (parsetreeTag: bool tag), Tag Bool), ("codetreeTag", toMachineWord (codetreeTag: bool tag), Tag Bool), ("icodeTag", toMachineWord (icodeTag: bool tag), Tag Bool), ("lowlevelOptimiseTag", toMachineWord (lowlevelOptimiseTag: bool tag), Tag Bool), ("codetreeAfterOptTag", toMachineWord (codetreeAfterOptTag: bool tag), Tag Bool), ("inlineFunctorsTag", toMachineWord (inlineFunctorsTag: bool tag), Tag Bool), ("debugTag", toMachineWord (debugTag: bool tag), Tag Bool), ("printDepthFunTag", toMachineWord (DEBUG.printDepthFunTag: (unit->FixedInt.int) tag), Tag (Unit->>fixedIntType)), ("errorDepthTag", toMachineWord (DEBUG.errorDepthTag: FixedInt.int tag), Tag fixedIntType), ("lineLengthTag", toMachineWord (DEBUG.lineLengthTag: FixedInt.int tag), Tag fixedIntType), ("profileAllocationTag", toMachineWord (DEBUG.profileAllocationTag: FixedInt.int tag), Tag fixedIntType), ("printOutputTag", toMachineWord (PRETTY.printOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)) , ("compilerOutputTag", toMachineWord (PRETTY.compilerOutputTag: (pretty->unit) tag), Tag (PrettyType->>Unit)), ("errorMessageProcTag", toMachineWord (LEX.errorMessageProcTag: errorMessageProcType tag), Tag errorMessageProcType), ("rootTreeTag", toMachineWord (EXPORTTREE.rootTreeTag: navigation tag), Tag navigationType), ("reportUnreferencedIdsTag", toMachineWord (reportUnreferencedIdsTag: bool tag), Tag Bool), ("reportExhaustiveHandlersTag", toMachineWord (reportExhaustiveHandlersTag: bool tag), Tag Bool), ("narrowOverloadFlexRecordTag", toMachineWord (narrowOverloadFlexRecordTag: bool tag), Tag Bool), ("createPrintFunctionsTag", toMachineWord (createPrintFunctionsTag: bool tag), Tag Bool), ("reportDiscardedValuesTag", toMachineWord (reportDiscardedValuesTag: FixedInt.int tag), Tag fixedIntType) ] end; (* PolyML.CodeTree structure. This exports the CodeTree structure into the ML space. *) local open CODETREE val codetreeEnv = makeStructure(polyMLEnv, "CodeTree") fun createType typeName = makeAndDeclareOpaqueType(typeName, "PolyML.CodeTree." ^ typeName, codetreeEnv) val CodeTree = createType "codetree" and MachineWord = createType "machineWord" and CodeBinding = createType "codeBinding" (* For the moment export these only for the general argument and result types. *) fun simpleFn (code, nArgs, name, closure, nLocals) = mkFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleInlineFn (code, nArgs, name, closure, nLocals) = mkInlineFunction{body=code, argTypes=List.tabulate(nArgs, fn _ => GeneralType), resultType=GeneralType, name=name, closure=closure, numLocals=nLocals} and simpleCall(func, args) = mkCall(func, List.map (fn c => (c, GeneralType)) args, GeneralType) in val CodeTree = CodeTree val () = applyList (fn (name, v, t) => #enterVal codetreeEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("pretty", toMachineWord (CODETREE.pretty: codetree -> pretty), CodeTree ->> PrettyType), ("mkConstant", toMachineWord(mkConst: machineWord -> codetree), MachineWord ->> CodeTree), ("genCode", toMachineWord (genCode: codetree * Universal.universal list * int -> (unit->codetree)), mkProductType[CodeTree, List Universal, Int] ->> (Unit ->> CodeTree)), ("evalue", toMachineWord (evalue: codetree -> machineWord option), CodeTree ->> Option MachineWord), ("mkFunction", toMachineWord (simpleFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkInlineFunction", toMachineWord (simpleInlineFn: codetree * int * string * codetree list * int -> codetree), mkProductType[CodeTree, Int, String, List CodeTree, Int] ->> CodeTree), ("mkCall", toMachineWord (simpleCall: codetree * codetree list -> codetree), CodeTree ** List CodeTree ->> CodeTree), ("mkLoadLocal", toMachineWord (mkLoadLocal: int -> codetree), Int ->> CodeTree), ("mkLoadArgument", toMachineWord (mkLoadArgument: int -> codetree), Int ->> CodeTree), ("mkLoadClosure", toMachineWord (mkLoadClosure: int -> codetree), Int ->> CodeTree), ("mkDec", toMachineWord (mkDec: int * codetree -> codeBinding), Int ** CodeTree ->> CodeBinding), ("mkInd", toMachineWord (mkInd: int * codetree -> codetree), Int ** CodeTree ->> CodeTree), ("mkIf", toMachineWord (mkIf: codetree * codetree * codetree -> codetree), mkProductType[CodeTree, CodeTree, CodeTree] ->> CodeTree), ("mkWhile", toMachineWord (mkWhile: codetree * codetree -> codetree), CodeTree ** CodeTree ->> CodeTree), ("mkLoop", toMachineWord (mkLoop: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkBeginLoop", toMachineWord (mkBeginLoop: codetree * (int * codetree) list -> codetree), CodeTree ** List(Int ** CodeTree) ->> CodeTree), ("mkEnv", toMachineWord (mkEnv: codeBinding list * codetree -> codetree), List CodeBinding ** CodeTree ->> CodeTree), ("mkMutualDecs", toMachineWord (mkMutualDecs: (int * codetree) list -> codeBinding), List(Int ** CodeTree) ->> CodeBinding), ("mkTuple", toMachineWord (mkTuple: codetree list -> codetree), List CodeTree ->> CodeTree), ("mkRaise", toMachineWord (mkRaise: codetree -> codetree), CodeTree ->> CodeTree), ("mkHandle", toMachineWord (mkHandle: codetree * codetree * int -> codetree), mkProductType[CodeTree, CodeTree, Int] ->> CodeTree), ("mkNullDec", toMachineWord (mkNullDec: codetree -> codeBinding), CodeTree ->> CodeBinding) ] end local (* Finish off the NameSpace structure now we have types such as pretty. *) open TYPETREE (* The exported versions expect full name spaces as arguments. Because we convert the exported versions to machineWord and give them types as data structures the compiler can't actually check that the type we give matched the internal type. *) fun makeTypeEnv NONE = { lookupType = fn _ => NONE, lookupStruct = fn _ => NONE } | makeTypeEnv(SOME(nameSpace: nameSpace)): printTypeEnv = { lookupType = fn s => case #lookupType nameSpace s of NONE => NONE | SOME t => SOME(t, NONE), lookupStruct = fn s => case #lookupStruct nameSpace s of NONE => NONE | SOME t => SOME(t, NONE) } local (* Values substructure. This also has operations related to type expressions. *) fun codeForValue (Value{access = Global code, class = ValBound, ...}) = code | codeForValue _ = raise Fail "Not a global value" and exportedDisplayTypeExp(ty, depth, nameSpace: nameSpace option) = TYPETREE.display(ty, depth, makeTypeEnv nameSpace) and exportedDisplayValues(valu, depth, nameSpace: nameSpace option) = displayValues(valu, depth, makeTypeEnv nameSpace) and propsForValue (Value {locations, typeOf, ...}) = PTtype typeOf :: mapLocationProps locations fun isConstructor (Value{class = Exception, ...}) = true | isConstructor (Value{class = Constructor _, ...}) = true | isConstructor _ = false fun isException (Value{class = Exception, ...}) = true | isException _ = false in val () = applyList (fn (name, v, t) => #enterVal valuesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord (valName: values -> string), valueVal ->> String), ("print", toMachineWord (printValues: values * FixedInt.int -> pretty), mkProductType[valueVal, fixedIntType] ->> PrettyType), ("printWithType", toMachineWord (exportedDisplayValues: values * FixedInt.int * nameSpace option -> pretty), mkProductType[valueVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("printType", toMachineWord(exportedDisplayTypeExp: types * FixedInt.int * nameSpace option -> pretty), mkProductType[Types, fixedIntType, Option nameSpaceType] ->> PrettyType), ("typeof", toMachineWord (valTypeOf: values -> types), valueVal ->> Types), ("code", toMachineWord (codeForValue: values -> codetree), valueVal ->> CodeTree), ("properties", toMachineWord (propsForValue: values ->ptProperties list), valueVal ->> List PtProperties), ("isConstructor", toMachineWord(isConstructor: values -> bool), valueVal ->> Bool), ("isException", toMachineWord(isException: values -> bool), valueVal ->> Bool) ] end local (* TypeConstrs substructure. *) fun exportedDisplayTypeConstr(tyCons, depth, nameSpace: nameSpace option) = TYPETREE.displayTypeConstrs(tyCons, depth, makeTypeEnv nameSpace) and propsForTypeConstr (TypeConstrSet(TypeConstrs {locations, ...}, _)) = mapLocationProps locations and nameForType (TypeConstrSet(TypeConstrs{name, ...}, _)) = name in val () = applyList (fn (name, v, t) => #enterVal typesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForType: typeConstrSet -> string), typeVal ->> String), ("print", toMachineWord (exportedDisplayTypeConstr: typeConstrSet * FixedInt.int * nameSpace option -> pretty), mkProductType[typeVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForTypeConstr: typeConstrSet ->ptProperties list), typeVal ->> List PtProperties) ] end local (* Structures substructure *) fun exportedDisplayStructs(str, depth, nameSpace: nameSpace option) = displayStructures(str, depth, makeTypeEnv nameSpace) and codeForStruct (Struct{access = Global code, ...}) = code | codeForStruct _ = raise Fail "Not a global structure" and propsForStruct (Struct {locations, ...}) = mapLocationProps locations and nameForStruct (Struct{name, ...}) = name fun nameSpaceForStruct(baseStruct as Struct{signat=Signatures { tab, ...}, ...}): nameSpace = let open UNIVERSALTABLE fun lookupVal s = case univLookup (tab, valueVar, s) of NONE => NONE | SOME v => SOME(makeSelectedValue(v, baseStruct)) and lookupType s = case univLookup (tab, typeConstrVar, s) of NONE => NONE | SOME t => SOME(makeSelectedType(t, baseStruct)) and lookupStruct s = case univLookup (tab, structVar, s) of NONE => NONE | SOME s => SOME(makeSelectedStructure(s, baseStruct)) local fun extractItems t tab = UNIVERSALTABLE.fold (fn (s, u, l) => if Universal.tagIs t u then (s, Universal.tagProject t u) :: l else l ) [] tab in fun allValues() = map(fn (s, v) => (s, makeSelectedValue(v, baseStruct))) (extractItems valueVar tab) and allTypes() = map(fn (s, t) => (s, makeSelectedType(t, baseStruct))) (extractItems typeConstrVar tab) and allStructs() = map(fn (s, v) => (s, makeSelectedStructure(v, baseStruct))) (extractItems structVar tab) end fun enterFunction _ = raise Fail "updating a structure is not possible." (* Raise an exception for any attempt to enter a new value. Return empty for the classes that can't exist in a structure. *) in { lookupVal = lookupVal, lookupType = lookupType, lookupStruct = lookupStruct, lookupFix = fn _ => NONE, lookupSig = fn _ => NONE, lookupFunct = fn _ => NONE, enterVal = enterFunction, enterType = enterFunction, enterFix = enterFunction, enterStruct = enterFunction, enterSig = enterFunction, enterFunct = enterFunction, allVal = allValues, allType = allTypes, allStruct = allStructs, allFix = fn () => [], allSig = fn () => [], allFunct = fn () => [] } end in val () = applyList (fn (name, v, t) => #enterVal structsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForStruct: structVals -> string), structureVal ->> String), ("print", toMachineWord (exportedDisplayStructs: structVals * FixedInt.int * nameSpace option -> pretty), mkProductType[structureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForStruct: structVals -> codetree), structureVal ->> CodeTree), ("properties", toMachineWord (propsForStruct: structVals ->ptProperties list), structureVal ->> List PtProperties), ("contents", toMachineWord(nameSpaceForStruct: structVals -> nameSpace), structureVal ->> nameSpaceType) ] end local (* Signatures substructure *) fun exportedDisplaySigs(sign, depth, nameSpace: nameSpace option) = displaySignatures(sign, depth, makeTypeEnv nameSpace) and propsForSig (Signatures {locations, ...}) = mapLocationProps locations and nameForSig (Signatures{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal sigsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForSig: signatures -> string), signatureVal ->> String), ("print", toMachineWord (exportedDisplaySigs: signatures * FixedInt.int * nameSpace option -> pretty), mkProductType[signatureVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("properties", toMachineWord (propsForSig: signatures ->ptProperties list), signatureVal ->> List PtProperties) ] end local (* Functors substructure *) fun exportedDisplayFunctors(funct, depth, nameSpace: nameSpace option) = displayFunctors(funct, depth, makeTypeEnv nameSpace) and codeForFunct (Functor{access = Global code, ...}) = code | codeForFunct _ = raise Fail "Not a global functor" and propsForFunctor (Functor {locations, ...}) = mapLocationProps locations and nameForFunctor (Functor{name, ...}) = name in val () = applyList (fn (name, v, t) => #enterVal functsEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFunctor: functors -> string), functorVal ->> String), ("print", toMachineWord (exportedDisplayFunctors: functors * FixedInt.int * nameSpace option -> pretty), mkProductType[functorVal, fixedIntType, Option nameSpaceType] ->> PrettyType), ("code", toMachineWord (codeForFunct: functors -> codetree), functorVal ->> CodeTree), ("properties", toMachineWord (propsForFunctor: functors ->ptProperties list), functorVal ->> List PtProperties) ] end local (* Infixes substructure *) fun nameForFix(FixStatus(s, _)) = s in val () = applyList (fn (name, v, t) => #enterVal fixesEnv (name, mkGvar (name, t, mkConst v, declInBasis))) [ ("name", toMachineWord(nameForFix: fixStatus -> string), fixityVal ->> String), ("print", toMachineWord (displayFixStatus: fixStatus -> pretty), fixityVal ->> PrettyType) ] end in end in () end (* initGlobalEnv *); end;