diff --git a/basis/Foreign.sml b/basis/Foreign.sml index 8180efae..6675b87c 100644 --- a/basis/Foreign.sml +++ b/basis/Foreign.sml @@ -1,3025 +1,2822 @@ (* 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 (* alloca: allocate temporary memory on the C-stack and call the function. The memory is deallocated when the function returns or raises and exception. *) val alloca: word * (voidStar -> 'a) -> 'a 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 - (* 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 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 datatype cTypeForm = - CTypeDouble | CTypeFloat | CTypePointer | CTypeSInt8 | CTypeSInt16 | CTypeSInt32 | CTypeSInt64 | - CTypeUInt8 | CTypeUInt16 | CTypeUInt32 | CTypeUInt64 | CTypeStruct of cType list + CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt + | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } eqtype abi val abiList: (string * abi) list val abiDefault: abi - - 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 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 cStruct: cType list -> cType - val callwithAbi: abi -> ctype list -> ctype -> symbol -> Memory.voidStar * Memory.voidStar -> unit - val call: ctype list -> ctype -> symbol -> Memory.voidStar * Memory.voidStar -> unit + val callwithAbi: abi -> cType list -> cType -> symbol -> Memory.voidStar * Memory.voidStar -> unit + val call: cType list -> cType -> symbol -> Memory.voidStar * Memory.voidStar -> unit val cFunctionWithAbi: - abi -> ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar + abi -> cType list -> cType -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar val cFunction: - ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar + 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 + 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 + 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) * LowLevel.abi * unit * 'a conversion -> (unit -> 'a) closure val buildClosure0: (unit -> 'a) * unit * 'a conversion -> (unit -> 'a) closure val buildClosure1withAbi: ('a -> 'b) * LowLevel.abi * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure1: ('a -> 'b) * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure2withAbi: ('a * 'b -> 'c) * LowLevel.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) * LowLevel.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) * LowLevel.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) * LowLevel.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) * LowLevel.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: LowLevel.abi * symbol * unit * 'a conversion -> unit -> 'a val buildCall0: symbol * unit * 'a conversion -> unit -> 'a val buildCall1withAbi: LowLevel.abi * symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall1: symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall2withAbi: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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: LowLevel.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 - open 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 val loadLibrary: string -> voidStar = RunCall.rtsCallFull1 "PolyFFILoadLibrary" and loadExecutable: unit -> voidStar = RunCall.rtsCallFull0 "PolyFFILoadExecutable" and freeLibrary: voidStar -> unit = RunCall.rtsCallFull1 "PolyFFIUnloadLibrary" and getSymbol: voidStar * string -> voidStar = RunCall.rtsCallFull2 "PolyFFIGetSymbolAddress" (* 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 val toWord = LibrarySupport.syserrorToWord and fromWord = LibrarySupport.syserrorFromWord 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 - local - fun getConstant (n: int) : Word.word = ffiGeneral (51, n) - in - val 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 - (* These are currently still used in the conversions. *) - 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 (* This must match the type in ForeignCall. *) datatype cTypeForm = - CTypeDouble | CTypeFloat | CTypePointer | CTypeSInt8 | CTypeSInt16 | CTypeSInt32 | CTypeSInt64 | - CTypeUInt8 | CTypeUInt16 | CTypeUInt32 | CTypeUInt64 | CTypeStruct of cType list + CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt + | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } - type ctype = - { - size: Word.word, (* Size in bytes *) - align: Word.word, (* Alignment *) - ffiType: unit -> LibFFI.ffiType - } - type abi = Foreign.abi val abiList = Foreign.abiList (* One of the items in the list should be ("default", abi) *) val abiDefault = #2(valOf(List.find(fn ("default", _) => true | _ => false) abiList)) 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 () } + open Memory + in + val cTypeInt8 = { size= 0w1, align= 0w1, typeForm = CTypeSignedInt } + val cTypeUint8 = { size= 0w1, align= 0w1, typeForm = CTypeUnsignedInt } + val cTypeInt16 = { size= 0w2, align= 0w2, typeForm = CTypeSignedInt } + val cTypeUint16 = { size= 0w2, align= 0w2, typeForm = CTypeUnsignedInt } + val cTypeInt32 = { size= 0w4, align= 0w4, typeForm = CTypeSignedInt } + val cTypeUint32 = { size= 0w4, align= 0w4, typeForm = CTypeUnsignedInt } + val cTypeInt64 = { size= 0w8, align= 0w8, typeForm = CTypeSignedInt } + val cTypeUint64 = { size= 0w8, align= 0w8, typeForm = CTypeUnsignedInt } 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 () } + (* The sizes of these are dependent on the ABI. *) + val cTypeVoid = + { size= #size saVoid, align= #align saVoid, typeForm = CTypeVoid } + val cTypePointer = + { size= #size saPointer, align= #align saPointer, typeForm = CTypePointer } val cTypeInt = - { size= #size saSint, align= #align saSint, ffiType = memoise getFFItypeSint () } + { size= #size saSint, align= #align saSint, typeForm = CTypeSignedInt } val cTypeUint = - { size= #size saUint, align= #align saUint, ffiType = memoise getFFItypeUint () } + { size= #size saUint, align= #align saUint, typeForm = CTypeSignedInt } val cTypeLong = - { size= #size saSlong, align= #align saSlong, ffiType = memoise getFFItypeSlong () } + { size= #size saSlong, align= #align saSlong, typeForm = CTypeSignedInt } val cTypeUlong = - { size= #size saUlong, align= #align saUlong, ffiType = memoise getFFItypeUlong () } + { size= #size saUlong, align= #align saUlong, typeForm = CTypeSignedInt } val cTypeFloat = - { size= #size saFloat, align= #align saFloat, ffiType = memoise getFFItypeFloat () } + { size= #size saFloat, align= #align saFloat, typeForm = CTypeFloatingPt } val cTypeDouble = - { size= #size saDouble, align= #align saDouble, ffiType = memoise getFFItypeDouble () } + { size= #size saDouble, align= #align saDouble, typeForm = CTypeFloatingPt } - fun cStruct(fields: ctype list): ctype = + 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 ()} + {align=align, size=size, typeForm=CTypeStruct fields} end local - fun getType ctype = Memory.voidStar2Sysword(#ffiType ctype ()) + fun getType (ctype: cType) : ctype = RunCall.unsafeCast ctype val callbackException: unit -> unit = RunCall.rtsCallFast0 "PolyFFICallbackException" in - fun callwithAbi (abi: abi) (argTypes: ctype list) (resType: ctype): symbol -> voidStar * voidStar -> unit = + 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 = (*Foreign.*)foreignCall(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) + fun cFunctionWithAbi (abi: abi) (argTypes: cType list) (resType: cType) (cbFun: voidStar * voidStar -> unit): voidStar = let fun callBack(args, resMem) = cbFun(sysWord2VoidStar args, sysWord2VoidStar resMem) handle _ => callbackException() val cCallBack = (*Foreign.*)buildCallBack(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 + 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 + open 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 (* Previously there was a "noFree" function and that was used for the fn _ => () cases. For some reason it wasn't optimised away so explicit fn values are used now. *) in val cVoid: unit conversion = makeConversion{ load=fn _ => (), store=fn _ => fn _ => (), 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); fn _ => ()), 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))); fn _ => ()) 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)); fn _ => ()) 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); fn _ => ()) 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))); fn _ => ()) 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))); fn _ => ()) 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))); fn _ => ()) 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)); fn _ => ()) 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))); fn _ => ()) 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)); fn _ => ()) 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))); fn _ => ()) 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)); fn _ => () end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, min, max))); fn _ => ()) 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); fn _ => ()) 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)); fn _ => () end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, 0, max))); fn _ => ()) 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); fn _ => ()) 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); fn _ => ()) 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); fn _ => ()) 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 + fun cOptionPtr({load, store, updateML, updateC, ctype={typeForm=CTypePointer, ...}}:'a conversion): 'a option conversion = 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 + | cOptionPtr _ = raise Foreign "cOptionPtr must be applied to a pointer type" 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.++ (* structs. These are also used when preparing arguments for function calls. The usual case is to apply these to existing conversions. We want the sizes and alignments to be compile-time constants and that means avoiding folds that will be compiled into loops. *) fun cStruct2(a: 'a conversion, b: 'b conversion): ('a*'b)conversion = let - val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = {size=sizea, align=aligna, ffiType=typea, ... }} = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ... }} = b + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ... }} = a + and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, 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)) (* These are frequently constants but if we use LowLevel.cStruct we use foldl and that doesn't reduce constants. *) val align = Word.max(aligna, alignb) val size = offsetb + sizeb - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = [typea(), typeb()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val ctype = {align=align, size=size, typeForm=LowLevel.CTypeStruct[ctypea, ctypeb]} in {load=load, store=store, updateML = updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, alignc)) val size = offsetc + sizec - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = [typea(), typeb(), typec()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct [ctypea, ctypeb, ctypec] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, alignd))) val size = offsetd + sized - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = [typea(), typeb(), typec(), typed()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct [ctypea, ctypeb, ctypec, ctyped] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, aligne)))) val size = offsete + sizee - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = [typea(), typeb(), typec(), typed(), typee()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct [ctypea, ctypeb, ctypec, ctyped, ctypee] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, alignf))))) val size = offsetf + sizef - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = [typea(), typeb(), typec(), typed(), typee(), typef()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct [ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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(x, (a, b, c, d, e, f, g)) = (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)) 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, aligng)))))) val size = offsetg + sizeg - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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(x, (a, b, c, d, e, f, g, h)) = (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)) 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, alignh))))))) val size = offseth + sizeh - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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(x, (a, b, c, d, e, f, g, h, i)) = (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)) 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, aligni)))))))) val size = offseti + sizei - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, alignj))))))))) val size = offsetj + sizej - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, alignk)))))))))) val size = offsetk + sizek - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, alignl))))))))))) val size = offsetl + sizel - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, alignm)))))))))))) val size = offsetm + sizem - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, alignn))))))))))))) val size = offsetn + sizen - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, aligno)))))))))))))) val size = offseto + sizeo - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o - and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = {size=sizep, align=alignp, ffiType=typep, ...} } = p + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, Word.max(aligno, alignp))))))))))))))) val size = offsetp + sizep - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo(), typep()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o - and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = {size=sizep, align=alignp, ffiType=typep, ...} } = p - and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = {size=sizeq, align=alignq, ffiType=typeq, ...} } = q + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, Word.max(aligno, Word.max(alignp, alignq)))))))))))))))) val size = offsetq + sizeq - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo(), typep(), typeq()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o - and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = {size=sizep, align=alignp, ffiType=typep, ...} } = p - and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = {size=sizeq, align=alignq, ffiType=typeq, ...} } = q - and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = {size=sizer, align=alignr, ffiType=typer, ...} } = r + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, Word.max(aligno, Word.max(alignp, Word.max(alignq, alignr))))))))))))))))) val size = offsetr + sizer - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo(), typep(), typeq(), typer()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o - and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = {size=sizep, align=alignp, ffiType=typep, ...} } = p - and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = {size=sizeq, align=alignq, ffiType=typeq, ...} } = q - and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = {size=sizer, align=alignr, ffiType=typer, ...} } = r - and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = {size=sizes, align=aligns, ffiType=types, ...} } = s + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, Word.max(aligno, Word.max(alignp, Word.max(alignq, Word.max(alignr, aligns)))))))))))))))))) val size = offsets + sizes - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo(), typep(), typeq(), typer(), types()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct [ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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 = {size=sizea, align=aligna, ffiType=typea, ...} } = a - and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = {size=sizeb, align=alignb, ffiType=typeb, ...} } = b - and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = {size=sizec, align=alignc, ffiType=typec, ...} } = c - and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = {size=sized, align=alignd, ffiType=typed, ...} } = d - and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = {size=sizee, align=aligne, ffiType=typee, ...} } = e - and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = {size=sizef, align=alignf, ffiType=typef, ...} } = f - and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = {size=sizeg, align=aligng, ffiType=typeg, ...} } = g - and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = {size=sizeh, align=alignh, ffiType=typeh, ...} } = h - and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = {size=sizei, align=aligni, ffiType=typei, ...} } = i - and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = {size=sizej, align=alignj, ffiType=typej, ...} } = j - and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = {size=sizek, align=alignk, ffiType=typek, ...} } = k - and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = {size=sizel, align=alignl, ffiType=typel, ...} } = l - and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = {size=sizem, align=alignm, ffiType=typem, ...} } = m - and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = {size=sizen, align=alignn, ffiType=typen, ...} } = n - and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = {size=sizeo, align=aligno, ffiType=typeo, ...} } = o - and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = {size=sizep, align=alignp, ffiType=typep, ...} } = p - and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = {size=sizeq, align=alignq, ffiType=typeq, ...} } = q - and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = {size=sizer, align=alignr, ffiType=typer, ...} } = r - and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = {size=sizes, align=aligns, ffiType=types, ...} } = s - and {load=loadt, store=storet, updateML=updateMLt, updateC=updateCt, ctype = {size=sizet, align=alignt, ffiType=typet, ...} } = t + val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, align=aligna, ...} } = 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 {size=sizet, 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)) val align = Word.max(aligna, Word.max(alignb, Word.max(alignc, Word.max(alignd, Word.max(aligne, Word.max(alignf, Word.max(aligng, Word.max(alignh, Word.max(aligni, Word.max(alignj, Word.max(alignk, Word.max(alignl, Word.max(alignm, Word.max(alignn, Word.max(aligno, Word.max(alignp, Word.max(alignq, Word.max(alignr, Word.max(aligns, alignt))))))))))))))))))) val size = offsett + sizet - fun ffiType () = - LibFFI.createFFItype { - size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, - elements = [typea(), typeb(), typec(), typed(), typee(), typef(), typeg(), typeh(), typei(), typej(), - typek(), typel(), typem(), typen(), typeo(), typep(), typeq(), typer(), types(), typet()] } - val ctype = {align=align, size=size, ffiType=Memory.memoise ffiType ()} + val typeForm = LowLevel.CTypeStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, + ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes, ctypet] + val ctype = {align=align, size=size, typeForm=typeForm} in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = ctype} 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) + ctype=ctypeEl as {size=sizeEl, align=alignEl, ...}, ...}: '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 } + val ffiTypeArray = LowLevel.CTypeStruct(List.tabulate (n, fn _ => ctypeEl)) + val arrayType = { size = arraySize, align = alignEl, typeForm = 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 + open Memory LowLevel fun buildCall(argConv, resConv, callF) = let val { ctype = resType, load = resLoad, ...} = resConv val { store=storeArgs, ctype={size=argSize, ...}, updateML=updateArgs, ...} = argConv val resultOffset = alignUp(argSize, #align resType) val argResSpace = resultOffset + #size resType in fn mlArgs => alloca(argResSpace, fn rMem => let val freeArgs = storeArgs(rMem, mlArgs) val resultAddr = rMem++resultOffset in let val () = callF(rMem, resultAddr) val result = resLoad resultAddr in updateArgs(rMem, mlArgs); freeArgs(); result end handle exn => (freeArgs(); raise exn) end) end in fun buildCall0withAbi(abi: abi, fnAddr, (), {ctype = resType, load= resLoad, ...} : 'a conversion): unit->'a = let val callF = callwithAbi abi [] resType fnAddr in fn () => alloca(#size resType, fn rMem => (callF(Memory.null, rMem); resLoad rMem)) 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 => alloca(argSpace, fn rMem => let val argAddr = rMem ++ argOffset val freea = argStore (argAddr, x) in let val () = callF(argAddr, rMem) val result = resLoad rMem in argUpdate (argAddr, x); freea (); result end handle exn => (freea(); 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv] (#ctype resConv) fnAddr val argConv = cStruct2(arg1Conv, arg2Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv] (#ctype resConv) fnAddr val argConv = cStruct3(arg1Conv, arg2Conv, arg3Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv] (#ctype resConv) fnAddr val argConv = cStruct4(arg1Conv, arg2Conv, arg3Conv, arg4Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv] (#ctype resConv) fnAddr val argConv = cStruct5(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv] (#ctype resConv) fnAddr val argConv = cStruct6(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv] (#ctype resConv) fnAddr val argConv = cStruct7(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv] (#ctype resConv) fnAddr val argConv = cStruct8(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv] (#ctype resConv) fnAddr val argConv = cStruct9(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv) in buildCall(argConv, resConv, callF) 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 callF = callwithAbi abi [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv, #ctype arg7Conv, #ctype arg8Conv, #ctype arg9Conv, #ctype arg10Conv] (#ctype resConv) fnAddr val argConv = cStruct10(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv) in buildCall(argConv, resConv, callF) 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 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 resConv) fnAddr val argConv = cStruct11(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv) in buildCall(argConv, resConv, callF) 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 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 resConv) fnAddr val argConv = cStruct12(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv) in buildCall(argConv, resConv, callF) 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 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 resConv) fnAddr val argConv = cStruct13(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv) in buildCall(argConv, resConv, callF) 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 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] (#ctype resConv) fnAddr val argConv = cStruct14(arg1Conv, arg2Conv, arg3Conv, arg4Conv, arg5Conv, arg6Conv, arg7Conv, arg8Conv, arg9Conv, arg10Conv, arg11Conv, arg12Conv, arg13Conv, arg14Conv) in buildCall(argConv, resConv, callF) end fun buildCall14(symbol, argTypes, resType) = buildCall14withAbi (abiDefault, symbol, argTypes, resType) end (* A closure is now a "closure cell" (in 32-in-64) or a single word cell containing the address of a code (in native address versions). It can be used exactly like a SysWord.word except that the code can be garbage-collected if the cell is no longer reachable. *) type 'a closure = Memory.voidStar local open Memory LowLevel fun load _ = raise Foreign "Cannot return a closure" (* Store the address of the code. Touch the closure after the function returns to ensure it cannot be GCed earlier. That would only happen if this resulted in a callback to a different function during the execution. *) and store(v, cl: ('a->'b) closure) = (Memory.setAddress(v, 0w0, cl); fn () => RunCall.touch cl) in val cFunction: ('a->'b) closure conversion = makeConversion { load=load, store=store, ctype = LowLevel.cTypePointer } end local - open LibFFI Memory LowLevel + open 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 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 arg1 = #load argConv args val result = f arg1 val () = #updateC argConv (args, arg1) in ignore(#store resConv (res, result)) end val makeCallback = cFunctionWithAbi abi [#ctype argConv] (#ctype resConv) in 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 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 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 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 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 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 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 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 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 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 makeCallback(callback f) end fun buildClosure6(f, argConv, resConv) = buildClosure6withAbi(f, abiDefault, argConv, resConv) end end; diff --git a/basis/Windows.sml b/basis/Windows.sml index 2cb68e96..0eecec78 100644 --- a/basis/Windows.sml +++ b/basis/Windows.sml @@ -1,971 +1,967 @@ (* Title: Standard Basis Library: Windows signature and structure Author: David Matthews Copyright David Matthews 2000, 2005, 2012, 2018, 2019 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. 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 WINDOWS = sig structure Key : sig include BIT_FLAGS val allAccess : flags val createLink : flags val createSubKey : flags val enumerateSubKeys : flags val execute : flags val notify : flags val queryValue : flags val read : flags val setValue : flags val write : flags end structure Reg : sig eqtype hkey val classesRoot : hkey val currentUser : hkey val localMachine : hkey val users : hkey val performanceData : hkey val currentConfig : hkey val dynData : hkey datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey val createKeyEx : hkey * string * Key.flags -> create_result val openKeyEx : hkey * string * Key.flags -> hkey val closeKey : hkey -> unit val deleteKey : hkey * string -> unit val deleteValue : hkey * string -> unit val enumKeyEx : hkey * int -> string option val enumValueEx : hkey * int -> string option datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string val queryValueEx : hkey * string -> value option val setValueEx : hkey * string * value -> unit end structure Config: sig val platformWin32s : SysWord.word val platformWin32Windows : SysWord.word val platformWin32NT : SysWord.word val platformWin32CE : SysWord.word val getVersionEx: unit -> { majorVersion: SysWord.word, minorVersion: SysWord.word, buildNumber: SysWord.word, platformId: SysWord.word, csdVersion: string } val getWindowsDirectory: unit -> string val getSystemDirectory: unit -> string val getComputerName: unit -> string val getUserName: unit -> string end structure DDE : sig type info val startDialog : string * string -> info val executeString : info * string * int * Time.time -> unit val stopDialog : info -> unit end val getVolumeInformation : string -> { volumeName : string, systemName : string, serialNumber : SysWord.word, maximumComponentLength : int } val findExecutable : string -> string option val launchApplication : string * string -> unit val openDocument : string -> unit val simpleExecute : string * string -> OS.Process.status type ('a,'b) proc val execute : string * string -> ('a, 'b) proc val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream val reap : ('a, 'b) proc -> OS.Process.status structure Status : sig type status = SysWord.word val accessViolation : status val arrayBoundsExceeded : status val breakpoint : status val controlCExit : status val datatypeMisalignment : status val floatDenormalOperand : status val floatDivideByZero : status val floatInexactResult : status val floatInvalidOperation : status val floatOverflow : status val floatStackCheck : status val floatUnderflow : status val guardPageViolation : status val integerDivideByZero : status val integerOverflow : status val illegalInstruction : status val invalidDisposition : status val invalidHandle : status val inPageError : status val noncontinuableException: status val pending : status val privilegedInstruction : status val singleStep : status val stackOverflow : status val timeout : status val userAPC : status end val fromStatus : OS.Process.status -> Status.status val exit : Status.status -> 'a end structure Windows :> WINDOWS = struct open Foreign val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) (* Conversion for a fixed size char array. *) fun cCHARARRAY n : string conversion = let (* Make it a struct of chars *) - val { size=sizeC, align=alignC, ffiType=ffiTypeC } = LowLevel.cTypeChar + val { size=sizeC, align=alignC, ... } = LowLevel.cTypeChar val arraySize = sizeC * Word.fromInt n - fun ffiType () = - LibFFI.createFFItype { - size = arraySize, align = alignC, typeCode=LibFFI.ffiTypeCodeStruct, - elements = List.tabulate (n, fn _ => ffiTypeC()) } - val arrayType: LowLevel.ctype = - { size = arraySize, align = alignC, ffiType = ffiType } + val arrayType: LowLevel.cType = + { size = arraySize, align = alignC, typeForm = LowLevel.CTypeStruct(List.tabulate (n, fn _ => LowLevel.cTypeChar)) } open Memory fun load(v: voidStar): string = let (* It should be null-terminated but just in case... *) fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(v, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let (* The length must be less than the size to allow for the null *) val sLen = size s val _ = sLen < n orelse raise Fail "string too long" in CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; set8(v, Word.fromInt sLen, 0w0); fn () => () end in makeConversion { load = load, store = store, ctype = arrayType } end (* These are called XXX32.DLL on both 32-bit and 64-bit. *) fun kernel name = getSymbol(loadLibrary "kernel32.dll") name and shell sym = getSymbol(loadLibrary "shell32.DLL") sym and advapi sym = getSymbol(loadLibrary "advapi32.DLL") sym (* We need to use the Pascal calling convention on 32-bit Windows. *) val winAbi = case List.find (fn ("stdcall", _) => true | _ => false) LowLevel.abiList of SOME(_, abi) => abi | NONE => LowLevel.abiDefault (* As well as setting the abi we can also use the old argument order. *) fun winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) val MAX_PATH = 0w260 (* Convert a C string to ML. *) fun fromCstring buff = let open Memory (* We can't use #load cString because the argument is the address of the address of the string. *) fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end structure Key = struct type flags = SysWord.word fun toWord f = f fun fromWord f = f val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) val queryValue = 0wx0001 and setValue = 0wx0002 and createSubKey = 0wx0004 and enumerateSubKeys = 0wx0008 and notify = 0wx0010 and createLink = 0wx0020 val read = flags[0wx00020000, queryValue, enumerateSubKeys, notify] and write = flags[0wx00020000, setValue, createSubKey] val execute = read val allAccess = flags[0wx000f0000, queryValue, setValue, createSubKey, enumerateSubKeys, notify, createLink] (* all is probably equivalent to allAccess. *) val all = flags[allAccess, createLink, createSubKey, enumerateSubKeys, execute, notify, queryValue, read, setValue, write] val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all end structure Reg = struct datatype hkey = PREDEFINED of SysWord.word | SUBKEY of Memory.volatileRef val classesRoot = PREDEFINED 0wx80000000 and currentUser = PREDEFINED 0wx80000001 and localMachine = PREDEFINED 0wx80000002 and users = PREDEFINED 0wx80000003 and performanceData = PREDEFINED 0wx80000004 and currentConfig = PREDEFINED 0wx80000005 and dynData = PREDEFINED 0wx80000006 datatype create_result = CREATED_NEW_KEY of hkey | OPENED_EXISTING_KEY of hkey datatype value = SZ of string | DWORD of SysWord.word | BINARY of Word8Vector.vector | MULTI_SZ of string list | EXPAND_SZ of string local val invalidHandle = valOf(OS.syserror "ERROR_INVALID_HANDLE") in (* When a subkey is opened the value is stored in a volatile ref. This prevents the key from persisting. *) fun getHkeyValue(PREDEFINED w) = Memory.sysWord2VoidStar w | getHkeyValue(SUBKEY v) = let val w = Memory.getVolatileRef v in if w = 0w0 then raise OS.SysErr("ERROR_INVALID_HANDLE", SOME invalidHandle) else Memory.sysWord2VoidStar w end end (* Check the result and raise an exception if it's non-zero. *) fun checkLResult 0 = () | checkLResult nonZero = let val err = Error.fromWord(SysWord.fromInt nonZero) in raise OS.SysErr(OS.errorMsg err, SOME err) end local val openKey = winCall5 (advapi "RegOpenKeyExA") (cPointer, cString, cDWORD, cDWORD, cStar cPointer) cLong in fun openKeyEx(hkey, key, flags) = let val keyRes = ref Memory.null val result = openKey(getHkeyValue hkey, key, 0, SysWord.toInt(Key.toWord flags), keyRes) in checkLResult result; SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes))) end end local val createKey = winCall9 (advapi "RegCreateKeyExA") (cPointer, cString, cDWORD, cPointer, cDWORD, cDWORD, cPointer, cStar cPointer, cStar cDWORD) cLong in fun createKeyEx(hkey, key, flags) = let val keyRes = ref Memory.null val disp = ref 0 val REG_OPTION_NON_VOLATILE = 0 val REG_CREATED_NEW_KEY = 1 val result = createKey(getHkeyValue hkey, key, 0, Memory.null, REG_OPTION_NON_VOLATILE, SysWord.toInt(Key.toWord flags), Memory.null, keyRes, disp) in checkLResult result; (if ! disp = REG_CREATED_NEW_KEY then CREATED_NEW_KEY else OPENED_EXISTING_KEY) (SUBKEY(Memory.volatileRef(Memory.voidStar2Sysword(!keyRes)))) end end local val regCloseKey = winCall1 (advapi "RegCloseKey") cPointer cLong in fun closeKey hkey = checkLResult(regCloseKey(getHkeyValue hkey)) end local val regDeleteValue = winCall2 (advapi "RegDeleteValueA") (cPointer, cString) cLong in fun deleteValue(hkey, key) = checkLResult(regDeleteValue(getHkeyValue hkey, key)) end local val regDeleteKey = winCall2 (advapi "RegDeleteKeyA") (cPointer, cString) cLong in fun deleteKey(hkey, key) = checkLResult(regDeleteKey(getHkeyValue hkey, key)) end local val regEnumKeyEx = winCall8 (advapi "RegEnumKeyExA") (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong val regEnumVal = winCall8 (advapi "RegEnumValueA") (cPointer, cDWORD, cPointer, cStar cDWORD, cPointer, cPointer, cPointer, cPointer) cLong val regQueryInfoKey = winCall12 (advapi "RegQueryInfoKeyA") (cPointer, cPointer, cPointer, cPointer, cStar cDWORD, cStar cDWORD, cPointer, cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cPointer) cLong fun getInfo hkey = let open Memory val nSubKeys = ref 0 and maxSubKeyLen = ref 0 and nValues = ref 0 and maxValueNameLen = ref 0 and maxValueLen = ref 0 val result = regQueryInfoKey(getHkeyValue hkey, null, null, null, nSubKeys, maxSubKeyLen, null, nValues, maxValueNameLen, maxValueLen, null, null) in checkLResult result; { nSubKeys = !nSubKeys, maxSubKeyLen = !maxSubKeyLen, nValues = ! nValues, maxValueNameLen = !maxValueNameLen, maxValueLen= !maxValueLen} end in fun enumKeyEx(hkey, n) = let val {nSubKeys, maxSubKeyLen, ...} = getInfo hkey in if n >= nSubKeys then NONE else let open Memory val buff = malloc(Word.fromInt(maxSubKeyLen + 1)) val buffLen = ref(maxSubKeyLen + 1) val result = regEnumKeyEx(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) in checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); SOME(fromCstring buff) before free buff end end and enumValueEx(hkey, n) = let val {nValues, maxValueNameLen, ...} = getInfo hkey in if n >= nValues then NONE else let open Memory val buff = malloc(Word.fromInt(maxValueNameLen + 1)) val buffLen = ref(maxValueNameLen + 1) val result = regEnumVal(getHkeyValue hkey, n, buff, buffLen, null, null, null, null) in checkLResult result handle exn as OS.SysErr _ => (free buff; raise exn); SOME(fromCstring buff) before free buff end end end local val queryVal = winCall6 (advapi "RegQueryValueExA") (cPointer, cString, cPointer, cStar cDWORD, cPointer, cStar cDWORD) cLong val ERROR_MORE_DATA = 234 val ERROR_FILE_NOT_FOUND = 2 fun unpackString v = let val len = Word8Vector.length v in if len = 0 then "" else Byte.unpackStringVec(Word8VectorSlice.slice(v, 0, SOME(len -1))) end fun unpackStringList v = let val len = Word8Vector.length v fun unpack start i = if i >= len orelse Word8Vector.sub(v, i) = 0w0 then if i = start then [] else Byte.unpackStringVec(Word8VectorSlice.slice(v, start, SOME(i - start))) :: unpack (i+1) (i+1) else unpack start (i+1) in unpack 0 0 end (* Repeat allocating the buffer until it's big enough. *) fun requery(hkey, valueName, buff, buffSize) = let open Memory val buffSizeRef = ref buffSize val typeVal = ref 0 val result = queryVal(getHkeyValue hkey, valueName, Memory.null, typeVal, buff, buffSizeRef) in (* Returns 0 (success) if the buffer is null. Return ERROR_MORE_DATA if it is not null but not big enough. *) if result = ERROR_MORE_DATA orelse result = 0 andalso ! buffSizeRef > buffSize then let val () = free buff val buff = malloc(Word.fromInt(!buffSizeRef)) in requery(hkey, valueName, buff, !buffSizeRef) end else if result = 0 then (* Big enough - return result. N.B. This could be NULL. *) let val v = Word8Vector.tabulate(! buffSizeRef, fn i => get8(buff, Word.fromInt i)) val () = free buff in case !typeVal of 1 => SOME(SZ(unpackString v)) | 4 => SOME(DWORD(PackWord32Little.subVec(v, 0))) | 2 => SOME(EXPAND_SZ(unpackString v)) | 7 => SOME(MULTI_SZ(unpackStringList v)) | _ => SOME(BINARY v) end else if result = ERROR_FILE_NOT_FOUND then NONE else (free buff; checkLResult result; raise Match (* Unused: we've raised an exception *)) end in fun queryValueEx (hkey, valueName) = requery(hkey, valueName, Memory.null, 0) end local val setValue = winCall6 (advapi "RegSetValueExA") (cPointer, cString, cDWORD, cDWORD, cByteArray, cDWORD) cLong fun packString s = let val len = String.size s val arr = Word8Array.array(len+1, 0w0) in Byte.packString(arr, 0, Substring.full s); Word8Array.vector arr end fun packStringList sl = let (* The string list is packed as a set of null-terminated strings with a final null at the end. *) (* TODO: Check for nulls in the strings themselves? *) fun totalSize n [] = n | totalSize n (s::sl) = totalSize (n + String.size s + 1) sl val len = totalSize 1 sl val arr = Word8Array.array(len, 0w0) fun pack _ [] = () | pack n (s::sl) = ( Byte.packString(arr, n, Substring.full s); pack (n + String.size s + 1) sl ) in pack 0 sl; Word8Array.vector arr end fun valuesToTypeVal(SZ s) = (1, packString s) | valuesToTypeVal(EXPAND_SZ s) = (2, packString s) | valuesToTypeVal(BINARY s) = (3, s) | valuesToTypeVal(DWORD n) = let (* Pack the 32 bit value into an array, then extract that. *) val arr = Word8Array.array(4, 0w0) in PackWord32Little.update(arr, 0, n); (4, Word8Array.vector arr) end | valuesToTypeVal(MULTI_SZ s) = (7, packStringList s) in fun setValueEx(hkey, name, v) = let val (t, s) = valuesToTypeVal v val length = Word8Vector.length s val result = setValue(getHkeyValue hkey, name, 0, t, s, length) in checkLResult result end end end structure DDE = struct type info = SysWord.word (* Actually a volatile word containing the conversation handle. *) val startDialog: string * string -> info = RunCall.rtsCallFull2 "PolyWindowsDDEStartDialogue" and stopDialog: info -> unit = RunCall.rtsCallFull1 "PolyWindowsDDEClose" local val winCall: info * string -> bool = RunCall.rtsCallFull2 "PolyWindowsDDEExecute" in (* The timeout and retry count apply only in the case of a busy result. The Windows call takes a timeout parameter as the length of time to wait for a response and maybe we should use it for that as well. *) fun executeString (info, cmd, retry, delay) = let fun try n = if winCall(info, cmd) then () (* Succeeded. *) else if n = 0 then raise OS.SysErr("DDE Server busy", NONE) else ( OS.IO.poll([], SOME delay); try (n-1) ) in try retry end end end (* DDE *) local val getVol = winCall8(kernel "GetVolumeInformationA") (cString, cPointer, cDWORD, cStar cDWORD, cStar cDWORD, cStar cDWORD, cPointer, cDWORD) cInt in fun getVolumeInformation root = let open Memory val volBuffer = malloc (MAX_PATH+0w1) and sysBuffer = malloc (MAX_PATH+0w1) val volSerial = ref 0 and volMaxComponent = ref 0 and fileSysFlags = ref 0 in if getVol(root, volBuffer, Word.toInt(MAX_PATH+0w1), volSerial, volMaxComponent, fileSysFlags, sysBuffer, Word.toInt(MAX_PATH+0w1)) = 0 then let val err = Error.fromWord(Error.getLastError()) in free volBuffer; free sysBuffer; raise OS.SysErr(OS.errorMsg err, SOME err) end else { volumeName = fromCstring volBuffer, systemName = fromCstring sysBuffer, serialNumber = SysWord.fromInt (!volSerial), maximumComponentLength = ! volMaxComponent} before (free volBuffer; free sysBuffer) end end local val findExeca: string * int * Memory.voidStar -> int = winCall3 (shell "FindExecutableA") (cString, cInt, cPointer) cInt in fun findExecutable s = let open Memory val buff = malloc MAX_PATH val result = if findExeca(s, 0 (* NULL *), buff) > 32 then SOME(fromCstring buff) else NONE in free buff; result end end local val shellExecuteInfo = cStruct15(cDWORD, cUlong, cPointer (*HWND*), cString, cString, cOptionPtr cString, cOptionPtr cString, cInt, cPointer (*HINSTANCE*), cPointer, cPointer (*cString*), cPointer (*HKEY*), cDWORD, cPointer (*HANDLE*), cPointer (*HANDLE*)) val {ctype={size, ...}, ...} = breakConversion shellExecuteInfo val shellExec = winCall1 (shell "ShellExecuteExA") (cStar shellExecuteInfo) cInt (* We probably want handle the error ourselves rather than popping up a UI. *) val SEE_MASK_FLAG_NO_UI = 0x00000400 in fun openDocument file = let val r = ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", file, NONE, NONE, 1 (* SW_SHOWNORMAL *), Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) in if shellExec r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else () end and launchApplication (command, arg) = let val r = ref(Word.toInt size, SEE_MASK_FLAG_NO_UI, Memory.null, "open", command, SOME arg, NONE, 1 (* SW_SHOWNORMAL *), Memory.null, Memory.null, Memory.null, Memory.null, 0, Memory.null, Memory.null) in if shellExec r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else () end end abstype pid = PID of int with end; (* Abstract *) datatype ('a,'b) proc = WinProc of { pid: pid, result: OS.Process.status option ref, closeActions: (unit->unit) list ref, lock: Thread.Mutex.mutex } (* Run a process and return a proces object which will allow us to extract the input and output streams. *) local val winCall = RunCall.rtsCallFull2 "PolyWindowsExecute" in fun execute(command, arg): ('a,'b) proc = let val run: pid = winCall (command, arg) in WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } end end (* Local function to protect access. *) fun winProtect f (w as WinProc{lock, ...}) = ThreadLib.protect lock f w local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0) end local val winCall: pid * bool * bool -> OS.IO.iodesc = RunCall.rtsCallFull3 "PolyWindowsOpenProcessHandle" fun textInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) val n = winCall(pid, true, true) val textPrimRd = LibraryIOSupport.wrapInFileDescr {fd=n, name="TextPipeInput", initBlkMode=true} val streamIo = TextIO.mkInstream(TextIO.StreamIO.mkInstream(textPrimRd, "")) fun closeThis() = TextIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun textOutstreamOf'(WinProc{pid, closeActions, ...}) = let val n = winCall (pid, false, true) val buffSize = sys_get_buffsize n val textPrimWr = LibraryIOSupport.wrapOutFileDescr{fd=n, name="TextPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = TextIO.mkOutstream(TextIO.StreamIO.mkOutstream(textPrimWr, IO.LINE_BUF)) fun closeThis() = TextIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binInstreamOf'(WinProc{pid, closeActions, ...}) = let (* Get the underlying file descriptor. *) val n = winCall (pid, true, false) val binPrimRd = LibraryIOSupport.wrapBinInFileDescr {fd=n, name="BinPipeInput", initBlkMode=true} val streamIo = BinIO.mkInstream(BinIO.StreamIO.mkInstream(binPrimRd, Word8Vector.fromList [])) fun closeThis() = BinIO.closeIn streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end fun binOutstreamOf'(WinProc{pid, closeActions, ...}) = let val n = winCall (pid, false, false) val buffSize = sys_get_buffsize n val binPrimWr = LibraryIOSupport.wrapBinOutFileDescr{fd=n, name="BinPipeOutput", appendMode=false, initBlkMode=true, chunkSize=buffSize} (* Construct a stream. *) val streamIo = BinIO.mkOutstream(BinIO.StreamIO.mkOutstream(binPrimWr, IO.LINE_BUF)) fun closeThis() = BinIO.closeOut streamIo val () = closeActions := closeThis :: ! closeActions in streamIo end in fun textInstreamOf w = winProtect textInstreamOf' w and textOutstreamOf w = winProtect textOutstreamOf' w and binInstreamOf w = winProtect binInstreamOf' w and binOutstreamOf w = winProtect binOutstreamOf' w end (* reap - wait until the process finishes and get the result. Note: this is defined to be able to return the result repeatedly. *) local val winCall: pid -> OS.Process.status = RunCall.rtsCallFull1 "PolyWindowsGetProcessResult" fun reap'(WinProc{result=ref(SOME r), ...}) = r | reap'(WinProc{pid, result, closeActions, ...}) = let val _ = List.app(fn f => f()) (!closeActions) val _ = closeActions := [] val res: OS.Process.status = winCall pid val _ = result := SOME res in res end in fun reap w = winProtect reap' w end local val winCall: string * string -> pid = RunCall.rtsCallFull2 "PolyWindowsSimpleExecute" in (* Run a process and wait for the result. Rather than do the whole thing as a single RTS call we first start the process and then call "reap" to get the result. This allows this to be run as a separate ML process if necessary without blocking everything. This is similar to OS.Process.system but differs in that the streams are directed to NUL and this runs the executable directly, not via cmd.exe/command.com so cannot run DOS commands. OS.Process.system waits for the result within the RTS call so the whole of ML will be blocked until the process completes. *) fun simpleExecute (command, arg) = let val run: pid = winCall(command, arg) val process = WinProc{ pid=run, result=ref NONE, closeActions=ref [], lock=Thread.Mutex.mutex() } in reap process end end structure Status = struct type status = SysWord.word val accessViolation = 0wxC0000005 val arrayBoundsExceeded = 0wxC000008C val breakpoint = 0wx80000003 val controlCExit = 0wxC000013A val datatypeMisalignment = 0wx80000002 val floatDenormalOperand = 0wxC000008D val floatDivideByZero = 0wxC000008E val floatInexactResult = 0wxC000008F val floatInvalidOperation = 0wxC0000090 val floatOverflow = 0wxC0000091 val floatStackCheck = 0wxC0000092 val floatUnderflow = 0wxC0000093 val guardPageViolation = 0wx80000001 val integerDivideByZero = 0wxC0000094 val integerOverflow = 0wxC0000095 val illegalInstruction = 0wxC000001D val invalidDisposition = 0wxC0000026 val invalidHandle = 0wxC0000008 val inPageError = 0wxC0000006 (* This was given as nocontinuableException *) val noncontinuableException= 0wxC0000025 val pending = 0wx103 val privilegedInstruction = 0wxC0000096 val singleStep = 0wx80000004 val stackOverflow = 0wxC00000FD val timeout = 0wx102 val userAPC = 0wxC0 end (* The status is implemented as an integer. *) fun fromStatus (s: OS.Process.status): Status.status = SysWord.fromInt(RunCall.unsafeCast s); fun exit (s: Status.status) = OS.Process.exit(RunCall.unsafeCast(SysWord.toInt s)) structure Config = struct local val osVersionInfo = cStruct6(cDWORD, cDWORD, cDWORD, cDWORD, cDWORD, cCHARARRAY 128) val { ctype={size, ...}, ...} = breakConversion osVersionInfo val callGetVersion = winCall1 (kernel "GetVersionExA") (cStar osVersionInfo) cInt in fun getVersionEx () = let val r = ref(Word.toInt size, 0, 0, 0, 0, "") in if callGetVersion r = 0 then let val err = Error.fromWord(Error.getLastError()) in raise OS.SysErr(OS.errorMsg err, SOME err) end else let val (_, major, minor, build, platform, version) = !r in { majorVersion = SysWord.fromInt major, minorVersion = SysWord.fromInt minor, buildNumber = SysWord.fromInt build, platformId = SysWord.fromInt platform, csdVersion = version } end end end local (* Get Windows directory and System directory. *) val getWinDir: Memory.voidStar * int -> int = winCall2(kernel "GetWindowsDirectoryA") (cPointer, cUint) cUint and getSysDir: Memory.voidStar * int -> int = winCall2(kernel "GetSystemDirectoryA") (cPointer, cUint) cUint fun getDirectory getDir () = let open Memory val buff = malloc MAX_PATH val result = getDir(buff, Word.toInt MAX_PATH) in if result = 0 then let val err = Error.fromWord(Error.getLastError()) in free buff; raise OS.SysErr(OS.errorMsg err, SOME err) end else fromCstring buff before free buff end in val getWindowsDirectory = getDirectory getWinDir and getSystemDirectory = getDirectory getSysDir end local val getCompName: Memory.voidStar * int ref -> int = winCall2(kernel "GetComputerNameA") (cPointer, cStar cDWORD) cInt and getUsrName: Memory.voidStar * int ref -> int = winCall2(advapi "GetUserNameA") (cPointer, cStar cDWORD) cUint val MAX_COMPUTERNAME_LENGTH = 015 and UNLEN = 256 fun getName (getNm, len) () = let open Memory val buff = malloc(Word.fromInt len) val result = getNm(buff, ref len) in if result = 0 then let val err = Error.fromWord(Error.getLastError()) in free buff; raise OS.SysErr(OS.errorMsg err, SOME err) end else fromCstring buff before free buff end in val getComputerName = getName(getCompName, MAX_COMPUTERNAME_LENGTH+1) and getUserName = getName(getUsrName, UNLEN+1) end (* All of these are long since dead *) val platformWin32s = 0w0 val platformWin32Windows = 0w1 val platformWin32NT = 0w2 val platformWin32CE = 0w3 end end; local (* Add pretty printers to hide internals. *) fun prettyRegKey _ _ (_: Windows.Reg.hkey) = PolyML.PrettyString "?" and prettyDDEInfo _ _ (_: Windows.DDE.info) = PolyML.PrettyString "?" and prettyProc _ _ (_: ('a, 'b) Windows.proc) = PolyML.PrettyString "?" in val () = PolyML.addPrettyPrinter prettyRegKey and () = PolyML.addPrettyPrinter prettyDDEInfo and () = PolyML.addPrettyPrinter prettyProc end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml index 81178fc3..bbf00dd8 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml @@ -1,1763 +1,1721 @@ (* Copyright (c) 2016-19 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 *) functor X86FOREIGNCALL( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef (* Optimise and code-generate. *) val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef} -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure CODE_ARRAY: CODEARRAYSIG sharing X86CODE.Sharing = X86OPTIMISE.Sharing = CODE_ARRAY.Sharing ): FOREIGNCALLSIG = struct open X86CODE open Address open CODE_ARRAY (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. The rest are on the stack. Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are on the stack. The caller must ensure the stack is aligned on 16-byte boundary and must allocate 32-byte save area for the register args. rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. X86/32. Arguments are pushed to the stack. ebx, edi, esi, ebp and esp are saved by the called function. We use esi to hold the argument data pointer and edi to save the ML stack pointer Our ML conventions use eax, ebx for the first two arguments in X86/32, rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. *) val memRegSize = 0 val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) (* Ebx/Rbx is used for the second argument on the native architectures but is replaced by esi on the object ID arch because ebx is used as the global base register. *) val mlArg2Reg = case targetArch of ObjectId32Bit => esi | _ => ebx exception InternalError = Misc.InternalError fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 val pushR = PushToStack o RegisterArg fun moveRR{source, output, opSize} = Move{source=RegisterArg source, destination=RegisterArg output, moveSize=opSizeToMove opSize} fun loadMemory(reg, base, offset, opSize) = Move{source=MemoryArg{base=base, offset=offset, index=NoIndex}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} and storeMemory(reg, base, offset, opSize) = Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=opSizeToMove opSize} val loadHeapMemory = case targetArch of ObjectId32Bit => ( fn (reg, base, offset, opSize) => Move{source=MemoryArg{base=ebx, offset=offset, index=Index4 base}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} ) | _ => loadMemory fun loadAddress{source=(srcReg, 0), destination} = Move{source=RegisterArg srcReg, destination=RegisterArg destination, moveSize=opSizeToMove nativeWordOpSize} | loadAddress{source=(srcReg, srcOffset), destination} = LoadAddress{offset=srcOffset, base=SOME srcReg, index=NoIndex, output=destination, opSize=nativeWordOpSize } (* Sequence of operations to move memory. *) fun moveMemory{source, destination, length} = [ loadAddress{source=source, destination=rsi}, loadAddress{source=destination, destination=rdi}, (* N.B. When moving a struct in a Win64 callback the source could be rcx so only move this after copying the source to rsi. *) Move{source=NonAddressConstArg(LargeInt.fromInt length), destination=RegisterArg rcx, moveSize=opSizeToMove nativeWordOpSize}, RepeatOperation MOVS8 ] fun createProfileObject _ (*functionName*) = let (* The profile object is a single mutable with the F_bytes bit set. *) open Address val profileObject = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(profileObject, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in toMachineWord profileObject end val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" datatype abi = X86_32 | X64Win | X64Unix local (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val getABICall: unit -> int = RunCall.rtsCallFast0 "PolyGetABI" in fun getABI() = case getABICall() of 0 => X86_32 | 1 => X64Unix | 2 => X64Win | n => raise InternalError ("Unknown ABI type " ^ Int.toString n) end (* This is now the standard entry call code. *) datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = let val entryPointAddr = makeEntryPoint functionName (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val abi = getABI() val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx val nArgs = List.length argFormats local (* Compute stack space. The actual number of args passed is nArgs. *) val argSpace = case abi of X64Unix => Int.max(0, nArgs-6)*8 | X64Win => Int.max(0, nArgs-4)*8 | X86_32 => List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats val align = argSpace mod 16 in (* Add sufficient space so that esp will be 16-byte aligned after we have pushed any arguments we need to push. *) val stackSpace = if align = 0 then memRegSize else memRegSize + 16 - align end (* The number of ML arguments passed on the stack. *) val mlArgsOnStack = Int.max(case abi of X86_32 => nArgs - 2 | _ => nArgs - 5, 0) val code = [ Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) ] @ ( (* Save heap ptr. This is in r15 in X86/64 *) if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) else [] ) @ ( if (case abi of X86_32 => nArgs >= 3 | _ => nArgs >= 6) then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) else [] ) @ [ storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} ] @ ( case abi of (* Set the argument registers. *) X86_32 => let fun pushReg(reg, FastArgFixed) = [pushR reg] | pushReg(reg, FastArgDouble) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=DoublePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } ] | pushReg(reg, FastArgFloat) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=SinglePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } ] (* The stack arguments have to be copied first followed by the ebx and finally eax. *) fun pushArgs (_, []) = [] | pushArgs (_, [argType]) = pushReg(eax, argType) | pushArgs (_, [arg2Type, arg1Type]) = pushReg(ebx, arg2Type) @ pushReg(eax, arg1Type) | pushArgs (n, FastArgFixed :: argTypes) = PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1, argTypes) | pushArgs (n, argType :: argTypes) = (* Use esi as a temporary register. *) loadMemory(esi, edi, (nArgs-n+1)* 4, polyWordOpSize) :: pushReg(esi, argType) @ pushArgs(n-1, argTypes) in pushArgs(nArgs, List.rev argFormats) end | X64Unix => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=edi, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 4 = moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: pushArgs 3 | pushArgs 5 = (* We have to move r8 into edx before we can move r10 into r8 *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 6 = (* We have to move r9 into edi before we can load r9 from the stack. *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: loadMemory(r9, edi, 8, polyWordOpSize) :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [] => [] | [FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] (* One "double" argument. The value needs to be unboxed. *) | [FastArgDouble] => [] (* Already in xmm0 *) (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [] | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] (* Already in xmm0 *) | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) (* One float argument and one fixed. *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) | X64Win => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=ecx, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = (* Already in r8 *) pushArgs 2 | pushArgs 4 = (* Already in r9, and r8 *) pushArgs 2 | pushArgs 5 = pushR r10 :: pushArgs 2 | pushArgs 6 = PushToStack(MemoryArg{base=edi, offset=8, index=NoIndex}) :: pushArgs 5 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] | [FastArgDouble] => [ (* Already in xmm0 *) ] (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [ ] (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. N.B. It's also the first argument in ML so is in rax. *) | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) ) @ (* For Windows/64 add in a 32 byte save area ater we've pushed any arguments. *) (case abi of X64Win => [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg 32, opSize=nativeWordOpSize}] | _ => []) @ [ CallAddress(RegisterArg entryPtrReg), (* Call the function *) loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ ( if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) else [] ) @ [ (* Since this is an ML function we need to remove any ML stack arguments. *) ReturnFromFunction mlArgsOnStack ] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end fun rtsCallFast (functionName, nArgs, debugSwitches) = rtsCallFastGeneral (functionName, List.tabulate(nArgs, fn _ => FastArgFixed), FastArgFixed, debugSwitches) (* RTS call with one double-precision floating point argument and a floating point result. *) fun rtsCallFastRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with two double-precision floating point arguments and a floating point result. *) fun rtsCallFastRealRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastRealGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgFixed], FastArgDouble, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgDouble, debugSwitches) (* Operations on Real32.real values. *) fun rtsCallFastFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat], FastArgFloat, debugSwitches) fun rtsCallFastFloatFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFloat], FastArgFloat, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastFloatGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFixed], FastArgFloat, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgFloat, debugSwitches) datatype ffiABI = FFI_SYSV (* Unix 32 bit and Windows GCC 32-bit *) | FFI_STDCALL (* Windows 32-bit system ABI. Callee clears the stack. *) | FFI_MS_CDECL (* VS 32-bit. Same as SYSV except when returning a struct. Default on Windows including GCC in Mingw. *) | FFI_WIN64 (* Windows 64 bit *) | FFI_UNIX64 (* Unix 64 bit. libffi also implements this on X86/32. *) (* We don't include various other 32-bit Windows ABIs. *) local val getOSType: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" in val abiList = case getABI() of X86_32 => [("sysv", FFI_SYSV), ("stdcall", FFI_STDCALL), ("ms_cdecl", FFI_MS_CDECL), (* Default to MS_CDECL on Windows otherwise SYSV. *) ("default", if getOSType() = 1 then FFI_MS_CDECL else FFI_SYSV)] | X64Win => [("win64", FFI_WIN64), ("default", FFI_WIN64)] | X64Unix => [("unix64", FFI_UNIX64), ("default", FFI_UNIX64)] type abi = ffiABI end fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) fun intAlignUp(s, align) = Word.toInt(alignUp(Word.fromInt s, align)) val getThreadDataCall = makeEntryPoint "PolyX86GetThreadData" local val sysWordSize = Word.toInt(nativeWordSize div wordSize) in (* Code to box an address as a SysWord.word value *) fun boxRegAsSysWord(boxReg, outputReg, saveRegs) = AllocStore{ size=sysWordSize, output=outputReg, saveRegs=saveRegs } :: ( if targetArch = Native64Bit then [ Move{source=NonAddressConstArg(LargeInt.fromInt sysWordSize), destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=outputReg, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, Move{moveSize=Move8, source=NonAddressConstArg 1 (* byte *), destination=MemoryArg {offset= ~1, base=outputReg, index=NoIndex}} ] else let val lengthWord = IntInf.orb(IntInf.fromInt sysWordSize, IntInf.<<(1, 0w24)) in [Move{source=NonAddressConstArg lengthWord, destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=outputReg, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}] end ) @ Move{source=RegisterArg boxReg, destination=MemoryArg {offset=0, base=outputReg, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: ( if targetArch = ObjectId32Bit then [ ArithToGenReg{ opc=SUB, output=outputReg, source=RegisterArg rbx, opSize=nativeWordOpSize }, ShiftConstant{ shiftType=SHR, output=outputReg, shift=0w2, opSize=OpSize64 } ] else [] ) @ [StoreInitialised] end (* Build a foreign call function. The arguments are the abi, the list of argument types and the result type. The result is the code of the ML function that takes three arguments: the C function to call, the arguments as a vector of C values and the address of the memory for the result. *) (* This must match the type in Foreign.LowLevel. Once this is bootstrapped we could use that type but note that this is the type we use within the compiler and we build Foreign.LowLevel AFTER compiling this. *) datatype cTypeForm = - CTypeDouble | CTypeFloat | CTypePointer | CTypeSInt8 | CTypeSInt16 | CTypeSInt32 | CTypeSInt64 | - CTypeUInt8 | CTypeUInt16 | CTypeUInt32 | CTypeUInt64 | CTypeStruct of cType list + CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt + | CTypeStruct of cType list | CTypeVoid withtype cType = { typeForm: cTypeForm, align: word, size: word } fun call32Bits(abi, args, result) = let (* 32-bit arguments. These all go to the stack so we can simply push them. The arguments go on the stack in reverse order. *) fun loadArgs32([], stackOffset, argOffset, code, continue) = continue(stackOffset, argOffset, code) | loadArgs32(arg::args, stackOffset, argOffset, code, continue) = let - val {size, align, typeCode, elements} = Foreign.LibFFI.extractFFItype arg + val {size, align, typeForm} = arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} in - if typeCode = Foreign.LibFFI.ffiTypeCodeUInt8 - then (* Unsigned char. *) - loadArgs32(args, stackOffset+4, newArgOffset+size, - Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8 } - :: PushToStack(RegisterArg edx) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 - then (* Signed char. *) - loadArgs32(args, stackOffset+4, newArgOffset+size, - Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8X32 } - :: PushToStack(RegisterArg edx) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeUInt16 - then (* Unsigned 16-bits. *) - loadArgs32(args, stackOffset+4, newArgOffset+size, - Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16 } - :: PushToStack(RegisterArg edx) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 - then (* Signed 16-bits. *) - loadArgs32(args, stackOffset+4, newArgOffset+size, - Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16X32 } - :: PushToStack(RegisterArg edx) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeUInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 - orelse typeCode = Foreign.LibFFI.ffiTypeCodePointer orelse typeCode = Foreign.LibFFI.ffiTypeCodeFloat - orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt - then (* 32-bits. *) - loadArgs32(args, stackOffset+4, newArgOffset+size, PushToStack(MemoryArg baseAddr) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then (* Double: push the two words. High-order word first, then low-order. *) - loadArgs32(args, stackOffset+8, newArgOffset+size, - PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset+4, index=NoIndex}) :: - PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex}) :: code, continue) - else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct - (* structs passed as values are recursively unpacked. *) - then loadArgs32(elements, stackOffset, newArgOffset (* Struct is aligned. *), code, + case (typeForm, size) of + (CTypeStruct elements, _) => (* structs passed as values are recursively unpacked. *) + loadArgs32(elements, stackOffset, newArgOffset (* Struct is aligned. *), code, fn (so, ao, code) => loadArgs32(args, so, ao, code, continue)) - else if typeCode = Foreign.LibFFI.ffiTypeCodeVoid - then raise Foreign.Foreign "Void cannot be used for a function argument" - else (* Anything else? *) raise Foreign.Foreign "Unrecognised type for function argument" + | (CTypeVoid, _) => raise Foreign.Foreign "Void cannot be used for a function argument" + | (CTypeUnsignedInt, 0w1) => (* Unsigned char. *) + loadArgs32(args, stackOffset+4, newArgOffset+size, + Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8 } + :: PushToStack(RegisterArg edx) :: code, continue) + | (CTypeSignedInt, 0w1) => (* Signed char. *) + loadArgs32(args, stackOffset+4, newArgOffset+size, + Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move8X32 } + :: PushToStack(RegisterArg edx) :: code, continue) + | (CTypeUnsignedInt, 0w2) => (* Unsigned 16-bits. *) + loadArgs32(args, stackOffset+4, newArgOffset+size, + Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16 } + :: PushToStack(RegisterArg edx) :: code, continue) + | (CTypeSignedInt, 0w2) => (* Signed 16-bits. *) + loadArgs32(args, stackOffset+4, newArgOffset+size, + Move{source=MemoryArg baseAddr, destination=RegisterArg edx, moveSize=Move16X32 } + :: PushToStack(RegisterArg edx) :: code, continue) + | (_, 0w4) => (* 32-bits. *) + loadArgs32(args, stackOffset+4, newArgOffset+size, PushToStack(MemoryArg baseAddr) :: code, continue) + | (CTypeFloatingPt, 0w8) =>(* Double: push the two words. High-order word first, then low-order. *) + loadArgs32(args, stackOffset+8, newArgOffset+size, + PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset+4, index=NoIndex}) :: + PushToStack(MemoryArg{base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex}) :: code, continue) + | _ => raise Foreign.Foreign "argument type not supported" end - val {typeCode, size, ...} = Foreign.LibFFI.extractFFItype result + val {typeForm, size, ...} = result val resultMemory = {base=ecx, offset=0, index=NoIndex} (* Structures are passed by reference by storing the address of the result as the first argument except that in MS_CDECL (and STDCALL?) structures of size 1, 2, 4 and 8 are returned in EAX, and for 8, EDX. *) val (getResult, needResultAddress) = - if typeCode = Foreign.LibFFI.ffiTypeCodeStruct andalso + if (case typeForm of CTypeStruct _ => true | _ => false) andalso (abi = FFI_SYSV orelse (size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8)) (* TODO: We have to get the address of the destination area. *) then ([], true) - else if typeCode = Foreign.LibFFI.ffiTypeCodeVoid + else if typeForm = CTypeVoid then ([], false) else (loadMemory(ecx, esp, 4, nativeWordOpSize) :: loadHeapMemory(ecx, ecx, 0, nativeWordOpSize) :: (if size = 0w1 then (* Single byte *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move8}] else if size = 0w2 then (* 16-bits *) [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move16}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat + else if typeForm = CTypeFloatingPt andalso size = 0w4 then [FPStoreToMemory{address=resultMemory, precision=SinglePrecision, andPop=true }] else if size = 0w4 then [Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble + else if typeForm = CTypeFloatingPt andalso size = 0w8 then [FPStoreToMemory{address=resultMemory, precision=DoublePrecision, andPop=true }] else if size = 0w8 then [ Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=Move32}, Move{source=RegisterArg edx, destination=MemoryArg {base=ecx, offset=4, index=NoIndex}, moveSize=Move32} ] else raise Foreign.Foreign "Unrecognised result type"), false) local (* Load the arguments. If we need to pass the return address for a struct that is the first arg. *) val (startStack, startCode) = if needResultAddress then (4, [PushToStack(MemoryArg{base=ecx, offset=0, index=NoIndex})]) else (0, []) in val (argCode, argStack) = loadArgs32(args, startStack, 0w0, startCode, fn (stackOffset, _, code) => (code, stackOffset)) end local val align = argStack mod 16 in (* Always align the stack. It's not always necessary on 32-bits but GCC prefers it. *) val preArgAlign = if align = 0 then 0 else 16-align (* Adjustment to be made when the function returns. Stdcall resets the stack in the callee. *) val postCallStackReset = preArgAlign + (if abi = FFI_STDCALL then 0 else argStack) end in ( (* If we're returning a struct we need the result address before we call. *) if needResultAddress then [loadMemory(ecx, esp, 4, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ argCode @ CallAddress(MemoryArg{base=eax, offset=0, index=NoIndex}) :: (* Restore the C stack. This is really only necessary if we've called a callback since that will store its esp value. *) ( if postCallStackReset = 0 then [] else [ArithToGenReg{opc=ADD, output=esp, source=NonAddressConstArg(LargeInt.fromInt postCallStackReset), opSize=nativeWordOpSize}] ) @ [ storeMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ getResult @ (* Store the result in the destination. *) [ ReturnFromFunction 1 ] end fun closure32Bits(abi, args, result) = let (* Arguments are copied from the stack into a struct that is then passed to the ML function. *) fun copyArgs([], nArgs, argOffset, code, continue) = continue(nArgs, argOffset, code) | copyArgs(arg::args, nArgs, argOffset, code, continue) = let - val {size, align, typeCode, elements} = Foreign.LibFFI.extractFFItype arg + val {size, align, typeForm} = arg val newArgOffset = alignUp(argOffset, align) val sourceAddr = {base=ebx, offset=nArgs*4, index=NoIndex} val destAddr = {base=esp, offset=Word.toInt newArgOffset, index=NoIndex} in - if typeCode = Foreign.LibFFI.ffiTypeCodeStruct - then (* structs passed as values are recursively unpacked. *) - copyArgs(elements, nArgs, newArgOffset (* Struct is aligned. *), code, - fn (na, ao, c) => copyArgs(args, na, ao, c, continue)) - else if typeCode = Foreign.LibFFI.ffiTypeCodeVoid - then raise Foreign.Foreign "Void cannot be used for a function argument" - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then (* Double: copy the two words. High-order word first, then low-order. *) + case (typeForm, size) of + (CTypeStruct elements, _) => + (* structs passed as values are recursively unpacked. *) + copyArgs(elements, nArgs, newArgOffset (* Struct is aligned. *), code, + fn (na, ao, c) => copyArgs(args, na, ao, c, continue)) + | (CTypeVoid, _) => + raise Foreign.Foreign "Void cannot be used for a function argument" + | (CTypeFloatingPt, 0w8) => + (* Double: copy the two words. High-order word first, then low-order. *) copyArgs(args, nArgs+2, argOffset+size, Move{source=MemoryArg sourceAddr, destination=RegisterArg eax, moveSize=Move32} :: Move{source=RegisterArg eax, destination=MemoryArg destAddr, moveSize=Move32} :: Move{source=MemoryArg {base=ebx, offset=nArgs*4+4, index=NoIndex}, destination=RegisterArg eax, moveSize=Move32} :: Move{source=RegisterArg eax, destination=MemoryArg{base=esp, offset=Word.toInt newArgOffset + 4, index=NoIndex}, moveSize=Move32} :: code, continue) - else (* Everything else is a single word on the stack. *) - let - val moveOp = - case size of - 0w1 => Move8 - | 0w2 => Move16 - | 0w4 => Move32 - | _ => raise Foreign.Foreign "copyArgs: Invalid size" - in - copyArgs(args, nArgs+1, argOffset+size, - Move{source=MemoryArg sourceAddr, destination=RegisterArg eax, moveSize=Move32} :: - Move{source=RegisterArg eax, destination=MemoryArg destAddr, moveSize=moveOp} :: code, continue) - end + | _ => (* Everything else is a single word on the stack. *) + let + val moveOp = + case size of + 0w1 => Move8 + | 0w2 => Move16 + | 0w4 => Move32 + | _ => raise Foreign.Foreign "copyArgs: Invalid size" + in + copyArgs(args, nArgs+1, argOffset+size, + Move{source=MemoryArg sourceAddr, destination=RegisterArg eax, moveSize=Move32} :: + Move{source=RegisterArg eax, destination=MemoryArg destAddr, moveSize=moveOp} :: code, continue) + end end - val {typeCode, size, align, ...} = Foreign.LibFFI.extractFFItype result + val {typeForm, size, align, ...} = result (* Struct results are normally passed by reference. *) val resultStructByRef = - typeCode = Foreign.LibFFI.ffiTypeCodeStruct andalso + (case typeForm of CTypeStruct _ => true | _ => false) andalso (abi = FFI_SYSV orelse (size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8)) val (argCount, argumentSpace, copyArgsFromStack) = copyArgs(args, if resultStructByRef then 1 else 0, 0w0, [], fn result => result) val resultOffset = alignUp(argumentSpace, align) (* Offset of result area *) val (loadResults, resultSize) = - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid orelse resultStructByRef + if typeForm = CTypeVoid orelse resultStructByRef then ([], 0w0) else let val resultMem = {base=esp, offset=Word.toInt resultOffset, index=NoIndex} val resultCode = - if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 - then [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8X32 }] - else if size = 0w1 - then [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8 }] - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 - then [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16X32 }] - else if size = 0w2 - then [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16 }] - else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat - then [FPLoadFromMemory{ address=resultMem, precision=SinglePrecision }] - else if size = 0w4 - then [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }] - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then [FPLoadFromMemory{ address=resultMem, precision=DoublePrecision }] - else if size = 0w8 (* MSC only. Struct returned in eax/edx. *) - then - [ - Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }, - Move{source=MemoryArg {base=esp, offset=Word.toInt resultOffset + 4, index=NoIndex}, - destination=RegisterArg edx, moveSize=Move32 } - ] - else raise Foreign.Foreign "Unrecognised result type" + case (typeForm, size) of + (CTypeSignedInt, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8X32 }] + | (_, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move8 }] + | (CTypeSignedInt, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16X32 }] + | (_, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move16 }] + | (CTypeFloatingPt, 0w4) => [FPLoadFromMemory{ address=resultMem, precision=SinglePrecision }] + | (_, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }] + | (CTypeFloatingPt, 0w8) => [FPLoadFromMemory{ address=resultMem, precision=DoublePrecision }] + | (_, 0w8) => (* MSC only. Struct returned in eax/edx. *) + [ + Move{source=MemoryArg resultMem, destination=RegisterArg eax, moveSize=Move32 }, + Move{source=MemoryArg {base=esp, offset=Word.toInt resultOffset + 4, index=NoIndex}, + destination=RegisterArg edx, moveSize=Move32 } + ] + | _ => raise Foreign.Foreign "Unrecognised result type" in (resultCode, size) end val stackSpace = Word.toInt(resultOffset + resultSize) local val align = stackSpace mod 16 in (* Stack space. In order to align the stack correctly for GCC we need the value in memRegCStackPtr to be a multiple of 16 bytes + 8. esp would have been on a 16 byte boundary before the return address was pushed so after pushing the return address and four registers we need a further 4 bytes to get the alignment back again. The effect of this is that the argument and result area is on an 8-byte boundary. *) val stackToAllocate = stackSpace + (if align = 0 then 0 else 16-align) + 4 end in [ (* Push callee-save registers. *) PushToStack(RegisterArg ebp), PushToStack(RegisterArg ebx), PushToStack(RegisterArg edi), PushToStack(RegisterArg esi), (* Set ebx to point to the original args. *) LoadAddress{ output=ebx, offset=20, base=SOME esp, index=NoIndex, opSize=OpSize32}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=OpSize32}, (* Move the function address in eax into esi since that's a callee-save register. *) Move{source=RegisterArg eax, destination=RegisterArg esi, moveSize=Move32} ] @ copyArgsFromStack @ [ (* Get the value for ebp. *) Move{source=AddressConstArg getThreadDataCall, destination=RegisterArg ecx, moveSize=Move32}, CallAddress(MemoryArg{base=ecx, offset=0, index=NoIndex}), (* Get the address - N.B. Heap addr in 32-in-64. *) moveRR{source=eax, output=ebp, opSize=OpSize32}, (* Save the address of the argument and result area. *) moveRR{source=esp, output=ecx, opSize=OpSize32}, (* Switch to the ML stack. *) storeMemory(esp, ebp, memRegCStackPtr, OpSize32), loadMemory(esp, ebp, memRegStackPtr, OpSize32), (* Move esi into the closure register edx *) Move{source=RegisterArg esi, destination=RegisterArg edx, moveSize=Move32} ] @ boxRegAsSysWord(ecx, eax, []) @ ( (* If we're returning a struct the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then Move{source=MemoryArg {offset=0, base=ebx, index=NoIndex}, destination=RegisterArg ecx, moveSize=Move32} else ArithToGenReg{opc=ADD, output=ecx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=OpSize32} ) :: boxRegAsSysWord(ecx, ebx, [eax]) @ [ (* Call the ML function using the full closure call. *) CallAddress(MemoryArg{offset=0, base=edx, index=NoIndex}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(esp, ebp, memRegStackPtr, OpSize32), loadMemory(esp, ebp, memRegCStackPtr, OpSize32) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=OpSize32}, PopR esi, PopR edi, PopR ebx, PopR ebp (* Restore callee-save registers. *) ] @ ( (* If we've passed in the address of the area for the result structure we're supposed to pass that back in eax. *) if resultStructByRef then [loadMemory(eax, esp, 4, OpSize32)] else [] ) @ [ (* Callee removes arguments in StdCall. *) ReturnFromFunction (if abi = FFI_STDCALL then argCount else 0) ] end local (* Windows on X64. *) val win64ArgRegs = [ (rcx, xmm0), (rdx, xmm1), (r8, xmm2), (r9, xmm3) ] in fun callWindows64Bits(args, result) = let val extraStackReg = r10 (* Not used for any arguments. *) fun loadWin64Args([], stackOffset, _, _, code, extraStack, preCode) = (code, stackOffset, preCode, extraStack) | loadWin64Args(arg::args, stackOffset, argOffset, regs, code, extraStack, preCode) = let - val {size, align, typeCode, ...} = Foreign.LibFFI.extractFFItype arg + val {size, align, typeForm, ...} = arg val newArgOffset = alignUp(argOffset, align) val baseAddr = {base=mlArg2Reg, offset=Word.toInt newArgOffset, index=NoIndex} val workReg = rcx (* rcx: the last to be loaded. *) (* Integer arguments. *) fun loadIntArg moveOp = case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', Move{source=MemoryArg baseAddr, destination=RegisterArg areg, moveSize=moveOp } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], if size = 0w8 then PushToStack(MemoryArg baseAddr) :: code else (* Need to load it into a register first. *) Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=moveOp } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) in (* Structs of 1, 2, 4 and 8 bytes are passed as the corresponding int. It may not be necessary to sign-extend 1, 2 or 4-byte values. 2, 4 or 8-byte structs may not be aligned onto the appropriate boundary but it should still work. *) - case size of - 0w1 => - if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 - then (* Signed char. *) loadIntArg Move8X64 - else (* Unsigned char or single byte struct *) loadIntArg Move8 - - | 0w2 => - if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 - then (* Signed 16-bits. *) loadIntArg Move16X64 - else (* Unsigned 16-bits. *) loadIntArg Move16 - - | 0w4 => - if typeCode = Foreign.LibFFI.ffiTypeCodeFloat - then + case (size, typeForm) of + (0w1, CTypeSignedInt) => (* Signed char. *) loadIntArg Move8X64 + | (0w1, _) => (* Unsigned char or single byte struct *) loadIntArg Move8 + + | (0w2, CTypeSignedInt) =>(* Signed 16-bits. *) loadIntArg Move16X64 + | (0w2, _) => (* Unsigned 16-bits. *) loadIntArg Move16 + + | (0w4, CTypeFloatingPt) => ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveFloat, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move32 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt - then (* Signed 32-bits. *) loadIntArg Move32X64 - else (* Unsigned 32-bits. *) loadIntArg Move32 + | (0w4, CTypeSignedInt) => (* Signed 32-bits. *) loadIntArg Move32X64 + | (0w4, _) => (* Unsigned 32-bits. *) loadIntArg Move32 - | 0w8 => - if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then + | (0w8, CTypeFloatingPt) => ( case regs of (_, fpReg) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg baseAddr, output=fpReg } :: code, extraStack, preCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], Move{source=MemoryArg baseAddr, destination=RegisterArg workReg, moveSize=Move64 } :: PushToStack(RegisterArg workReg) :: code, extraStack, preCode) ) - else (* 64-bits. *) loadIntArg Move64 + | (0w8, _) => (* 64-bits. *) loadIntArg Move64 - | _ => - if typeCode <> Foreign.LibFFI.ffiTypeCodeStruct - then raise Foreign.Foreign "Unrecognised type for function argument" - else + | (_, CTypeStruct _) => let (* Structures of other sizes are passed by reference. They are first copied into new areas on the stack. This ensures that the called function can update the structure without changing the original values. *) val newExtra = intAlignUp(extraStack + Word.toInt size, 0w16) val newPreCode = moveMemory{source=(mlArg2Reg, Word.toInt newArgOffset), destination=(extraStackReg, extraStack), length=Word.toInt size} @ preCode in case regs of (areg, _) :: regs' => loadWin64Args(args, stackOffset, newArgOffset+size, regs', loadAddress{source=(extraStackReg, extraStack), destination=areg} :: code, newExtra, newPreCode) | [] => loadWin64Args(args, stackOffset+8, newArgOffset+size, [], loadAddress{source=(extraStackReg, extraStack), destination=workReg} :: PushToStack(RegisterArg workReg) :: code, newExtra, newPreCode) end + + | _ => raise Foreign.Foreign "Unrecognised type for function argument" end - val {typeCode, size, ...} = Foreign.LibFFI.extractFFItype result + val {typeForm, size, ...} = result val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) val resultMemory = {base=resultAreaPtr, offset=0, index=NoIndex} fun storeIntValue moveOp = ([Move{source=RegisterArg eax, destination=MemoryArg resultMemory, moveSize=moveOp}], false) and storeFloatValue precision = ([XMMStoreToMemory{toStore=xmm0, address=resultMemory, precision=precision}], false) val (getResult, passStructAddress) = - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid - then ([], false) - else if size = 0w1 (* Includes structs *) then (* Single byte *) storeIntValue Move8 - else if size = 0w2 then (* 16-bits *) storeIntValue Move16 - else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat - then storeFloatValue SinglePrecision - else if size = 0w4 then storeIntValue Move32 - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then storeFloatValue DoublePrecision - else if size = 0w8 - then storeIntValue Move64 - else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct - then ([], true) - else raise Foreign.Foreign "Unrecognised result type" + case (typeForm, size) of + (CTypeVoid, _) => ([], false) + | (_, 0w1) (* Includes structs *) => (* Single byte *) storeIntValue Move8 + | (_, 0w2) => (* 16-bits *) storeIntValue Move16 + | (CTypeFloatingPt, 0w4) => storeFloatValue SinglePrecision + | (_, 0w4) => storeIntValue Move32 + | (CTypeFloatingPt, 0w8) => storeFloatValue DoublePrecision + | (_, 0w8) => storeIntValue Move64 + | (CTypeStruct _, _) => ([], true) + | _ => raise Foreign.Foreign "Unrecognised result type" (* argCode is the code to load and push the arguments. argStack is the amount of stack space the arguments will take. It's only used to ensure that the stack is aligned onto a 16-byte boundary. preArgCode is any code that is needed to copy the arguments before they are actually loaded. Because it is done before the argument registers are loaded it can use rcx, rdi and rsi. extraStack is local stack space needed. It is usually zero but if it is non-zero it must be a multiple of 16 bytes. The address of this area is loaded into r10 before preArgCode is called. *) val (argCode, argStack, preArgCode, extraStack) = if passStructAddress then (* The address of the result structure goes in the first argument register: rcx *) loadWin64Args(args, 0, 0w0, tl win64ArgRegs, [moveRR{source=resultAreaPtr, output=rcx, opSize=nativeWordOpSize}], 0, []) else loadWin64Args(args, 0, 0w0, win64ArgRegs, [], 0, []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align (* The total space on the stack that needs to be removed at the end. *) val postCallStackReset = argStack + preArgAlign + extraStack + 32 end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) - if #typeCode(Foreign.LibFFI.extractFFItype result) <> Foreign.LibFFI.ffiTypeCodeVoid + if #typeForm( result) <> CTypeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if extraStack = 0 then [] else [ ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt extraStack), opSize=nativeWordOpSize}, Move{source=RegisterArg rsp, destination=RegisterArg extraStackReg, moveSize=Move64} ] ) @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(mlArg2Reg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ (* Reserve a 32-byte area after the arguments. This is specific to the Windows ABI. *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt 32), opSize=nativeWordOpSize}, let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, (* Restore the C stack value in case it's been changed by a callback. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt postCallStackReset), opSize=nativeWordOpSize}, storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ReturnFromFunction 0 ] end (* callWindows64Bits *) fun closureWindows64Bits(args, result) = let - val {typeCode, size, align, ...} = Foreign.LibFFI.extractFFItype result + val {typeForm, size, align, ...} = result (* Struct results are normally passed by reference. *) val resultStructByRef = (* If true we've copied rcx (the first arg) into r9 *) - typeCode = Foreign.LibFFI.ffiTypeCodeStruct andalso + (case typeForm of CTypeStruct _ => true | _ => false) andalso size <> 0w1 andalso size <> 0w2 andalso size <> 0w4 andalso size <> 0w8 (* Store the register arguments and copy everything else into the argument structure on the stack. The code is ordered so that the early arguments are stored first. *) fun copyWin64Args([], _, _, _) = [] | copyWin64Args(arg::args, nStackArgs, argOffset, regs) = let - val {size, align, typeCode, ...} = Foreign.LibFFI.extractFFItype arg + val {size, align, typeForm, ...} = arg val newArgOffset = alignUp(argOffset, align) val destAddr = {base=rsp, offset=Word.toInt newArgOffset, index=NoIndex} (* Integer arguments. *) fun moveIntArg moveOp = case regs of (areg, _) :: regs' => Move{source=RegisterArg areg, destination=MemoryArg destAddr, moveSize=moveOp } :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => Move{source=MemoryArg {base=r10, offset=nStackArgs*8, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64} :: Move{source=RegisterArg rax, destination=MemoryArg destAddr, moveSize=moveOp} :: copyWin64Args(args, nStackArgs+1, newArgOffset+size, []) in (* Structs of 1, 2, 4 and 8 bytes are passed as the corresponding int. *) - case size of - 0w1 => moveIntArg Move8 - | 0w2 => moveIntArg Move16 + case (typeForm, size) of + (_, 0w1) => moveIntArg Move8 + | (_, 0w2) => moveIntArg Move16 - | 0w4 => - if typeCode = Foreign.LibFFI.ffiTypeCodeFloat - then + | (CTypeFloatingPt, 0w4) => ( case regs of (_, fpReg) :: regs' => XMMStoreToMemory{ toStore=fpReg, address=destAddr, precision=SinglePrecision} :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveIntArg Move32 ) - else (* 32-bits *) moveIntArg Move32 + | (_, 0w4) => (* 32-bits *) moveIntArg Move32 - | 0w8 => - if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then + | (CTypeFloatingPt, 0w8) => ( case regs of (_, fpReg) :: regs' => XMMStoreToMemory{ toStore=fpReg, address=destAddr, precision=DoublePrecision} :: copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveIntArg Move64 ) - else (* 64-bits. *) moveIntArg Move64 + | (_, 0w8) => (* 64-bits. *) moveIntArg Move64 - | _ => - if typeCode <> Foreign.LibFFI.ffiTypeCodeStruct - then raise Foreign.Foreign "Unrecognised type for function argument" - else (* Structures of other size are passed by reference. We need to copy the source + | (CTypeStruct _, _) => + (* Structures of other size are passed by reference. We need to copy the source structure into our stack area. Since rsi and rdi aren't used as args and rcx is only used for the first argument we can copy the argument now. *) ( case regs of (arg, _) :: regs' => moveMemory{source=(arg, 0), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ copyWin64Args(args, nStackArgs, newArgOffset+size, regs') | [] => moveMemory{source=(r10, nStackArgs*8), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ copyWin64Args(args, nStackArgs+1, newArgOffset+size, []) ) + | _ => raise Foreign.Foreign "Unrecognised type for function argument" end val copyArgsFromRegsAndStack = if resultStructByRef then (* If we're returning a struct by reference we copy the address into r9 and pass that as the result address. *) Move{source=RegisterArg rcx, destination=RegisterArg r9, moveSize=Move64} :: copyWin64Args(args, 0, 0w0, tl win64ArgRegs) else copyWin64Args(args, 0, 0w0, win64ArgRegs) local fun getNextSize (arg, argOffset) = - let val {size, align, ...} = Foreign.LibFFI.extractFFItype arg in alignUp(argOffset, align) + size end + let val {size, align, ...} = arg in alignUp(argOffset, align) + size end in val argumentSpace = List.foldl getNextSize 0w0 args end val resultOffset = alignUp(argumentSpace, align) (* Offset of result area *) val (loadResults, resultSize) = - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid orelse resultStructByRef + if typeForm = CTypeVoid orelse resultStructByRef then ([], 0w0) else let val resultMem = {base=rsp, offset=Word.toInt resultOffset, index=NoIndex} val resultCode = - if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8X64}] - else if size = 0w1 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16X64}] - else if size = 0w2 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeFloat - then [XMMArith{opc=SSE2MoveFloat, source=MemoryArg resultMem, output=xmm0}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32X64}] - else if size = 0w4 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32}] - else if typeCode = Foreign.LibFFI.ffiTypeCodeDouble - then [XMMArith{opc=SSE2MoveDouble, source=MemoryArg resultMem, output=xmm0}] - else if size = 0w8 - then [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move64}] - else raise Foreign.Foreign "Unrecognised result type" + case (typeForm, size) of + (CTypeSignedInt, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8X64}] + | (_, 0w1) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move8}] + | (CTypeSignedInt, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16X64}] + | (_, 0w2) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move16}] + | (CTypeFloatingPt, 0w4) => [XMMArith{opc=SSE2MoveFloat, source=MemoryArg resultMem, output=xmm0}] + | (CTypeSignedInt, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32X64}] + | (_, 0w4) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move32}] + | (CTypeFloatingPt, 0w8) => [XMMArith{opc=SSE2MoveDouble, source=MemoryArg resultMem, output=xmm0}] + | (_, 0w8) => [Move{source=MemoryArg resultMem, destination=RegisterArg rax, moveSize=Move64}] + | _ => raise Foreign.Foreign "Unrecognised result type" in (resultCode, size) end (* Stack space. The stack must be 16 byte aligned. We've pushed 8 regs and a return address so add a further 8 bytes to bring it back into alignment. If we're returning a struct by reference, though, we've pushed 9 regs so don't add 8. *) val stackToAllocate = Word.toInt(alignUp(resultOffset + resultSize, 0w16)) + (if resultStructByRef then 0 else 8) in [ (* Push callee-save registers. *) PushToStack(RegisterArg rbp), PushToStack(RegisterArg rbx), PushToStack(RegisterArg r12), PushToStack(RegisterArg r13), PushToStack(RegisterArg r14), PushToStack(RegisterArg r15), PushToStack(RegisterArg rdi), PushToStack(RegisterArg rsi) ] @ ( (* If we're returning a struct by reference we have to return the address in rax even though it's been set by the caller. Save this address. *) if resultStructByRef then [PushToStack(RegisterArg rcx)] else [] ) @ [ (* Set r10 to point to the original stack args if any. This is beyond the pushed regs and also the 32-byte area. *) LoadAddress{ output=r10, offset=if resultStructByRef then 112 else 104, base=SOME rsp, index=NoIndex, opSize=nativeWordOpSize}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize}, (* Move the function we're calling, in rax, into r13, a callee-save register *) moveRR{source=rax, output=r13, opSize=polyWordOpSize} ] @ copyArgsFromRegsAndStack @ [ (* Get the value for rbp. *) (* This is a problem for 32-in-64. The value of getThreadDataCall is an object ID but rbx may well no longer hold the heap base address. We use a special inline constant to hold the full 64-bit address. *) LoadAbsolute{value=getThreadDataCall, destination=rcx}, CallAddress(MemoryArg{base=rcx, offset=0, index=NoIndex}), moveRR{source=rax, output=rbp, opSize=nativeWordOpSize}, (* Save the address of the argument and result area. *) moveRR{source=rsp, output=rcx, opSize=nativeWordOpSize}, (* Switch to the ML stack. *) storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Load the ML heap pointer. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize), (* Now move the function closure into the closure register ready for the call. *) moveRR{source=r13, output=rdx, opSize=polyWordOpSize} ] @ (* Reload the heap base address in 32-in-64. *) ( if targetArch = ObjectId32Bit then [loadMemory(rbx, rbp, memRegSavedRbx, nativeWordOpSize)] else [] ) @ boxRegAsSysWord(rcx, rax, []) @ ( (* If we're returning a struct by reference the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then loadMemory(rcx, r10, ~112, nativeWordOpSize) else ArithToGenReg{opc=ADD, output=rcx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=nativeWordOpSize} ) :: boxRegAsSysWord(rcx, mlArg2Reg, [rax]) @ [ (* Call the ML function using the full closure call. *) CallAddress( if targetArch = ObjectId32Bit then MemoryArg{base=rbx, index=Index4 rdx, offset=0} else MemoryArg{base=rdx, index=NoIndex, offset=0}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), storeMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize} ] @ ( if resultStructByRef then [PopR rax] else [] ) @ [ PopR rsi, PopR rdi, PopR r15, PopR r14, PopR r13, PopR r12, PopR rbx, PopR rbp, (* Restore callee-save registers. *) ReturnFromFunction 0 (* Caller removes any stack arguments. *) ] end end local (* The rules for passing structs in SysV on X86/64 are complicated but most of the special cases don't apply. We don't support floating point larger than 8 bytes, packed structures or C++ constructors. It then reduces to the following: Structures of up to 8 bytes are passed in a single register and of 8-16 bytes in two registers. Larger structures are passed on the stack. The question is whether to use general registers or SSE2 registers. Each 8 byte chunk is considered independently after any internal structs have been unwrapped. Each chunk will consist of either a single 8-byte value (i.e.. a pointer, int64_t or a double) or one or more smaller values and possibly some padding. An SSE2 register is used if the value is a double, two floats or a single float and padding. Otherwise it must have at least one shorter int-like type (e.g. int, char, short etc) in which case a general register is used. That applies even if it also contains a float. If, having selected the kind of registers to be used, there are not enough for the whole struct it is passed on the stack. We don't really need this for simple arguments but it's easier to consider them all together. *) datatype argClass = ArgInMemory | ArgInRegs of { firstInSSE: bool, secondInSSE: bool } fun classifyArg arg = let - val {size, ...} = Foreign.LibFFI.extractFFItype arg + val {size, ...} = arg (* Unwrap the struct and any internal structs. *) fun getFields([], _) = [] | getFields(field::fields, offset) = let - val {size, align, typeCode, elements, ...} = Foreign.LibFFI.extractFFItype field + val {size, align, typeForm} = field val alignedOffset = alignUp(offset, align) (* Align this even if it's a sub-struct *) in - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid - then raise Foreign.Foreign "Void cannot be used for a function argument" - else if typeCode = Foreign.LibFFI.ffiTypeCodeStruct - then getFields(elements, alignedOffset) @ getFields(fields, alignedOffset+size) - else (typeCode, alignedOffset) :: getFields(fields, alignedOffset+size) + case typeForm of + CTypeVoid => raise Foreign.Foreign "Void cannot be used for a function argument" + | CTypeStruct elements => + getFields(elements, alignedOffset) @ getFields(fields, alignedOffset+size) + | _ => (typeForm, alignedOffset) :: getFields(fields, alignedOffset+size) end val isSSE = - List.all (fn (tc, _) => tc = Foreign.LibFFI.ffiTypeCodeFloat orelse tc = Foreign.LibFFI.ffiTypeCodeDouble) + List.all (fn (CTypeFloatingPt, _) => true | _ => false) in if size > 0w16 then ArgInMemory else let val fieldsAndOffsets = getFields([arg], 0w0) in if size <= 0w8 (* Only the first register will be used. *) then ArgInRegs{firstInSSE=isSSE fieldsAndOffsets, secondInSSE=false} else let val (first8Bytes, second8Bytes) = List.partition (fn (_, off) => off <= 0w8) fieldsAndOffsets in ArgInRegs{firstInSSE=isSSE first8Bytes, secondInSSE=isSSE second8Bytes} end end end val sysVGenRegs = [rdi, rsi, rdx, rcx, r8, r9] and sysVFPRegs = [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7] (* Store a register into upto 8 bytes. Most values will involve a single store but odd-sized structs can require shifts and multiple stores. N.B. May modify the source register. *) fun storeUpTo8(reg, base, offset, size) = let val moveOp = if size = 0w8 then Move64 else if size >= 0w4 then Move32 else if size >= 0w2 then Move16 else Move8 in [Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=0w32, opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset+4, index=NoIndex}, moveSize=Move16} ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ ShiftConstant{ shiftType=SHR, output=reg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset+Word.toInt(size-0w1), index=NoIndex}, moveSize=Move8} ] else [] ) in fun callUnix64Bits(args, result) = let val argWorkReg = r10 (* Not used for any arguments. *) val resultAreaPtr = r12 (* Saved value of r8 - This is callee save. *) val argPtrReg = r11 (* Pointer to argument area - Can't use mlArg2Reg since that's RSI on 32-in-64. *) fun loadSysV64Args([], stackOffset, _, _, _, code, preCode) = (code, stackOffset, preCode) | loadSysV64Args(arg::args, stackOffset, argOffset, gRegs, fpRegs, code, preCode) = let - val {size, align, typeCode, ...} = Foreign.LibFFI.extractFFItype arg + val {size, align, typeForm, ...} = arg (* Load a value into a register. Normally the size will be 1, 2, 4 or 8 bytes and this will just involve a simple load. Structs, though, can be of any size up to 8 bytes. *) fun loadRegister(reg, offset, size) = let (* We don't necessarily have to sign-extend. There's a comment in libffi that suggests that LVM expects it even though the SysV ABI doesn't require it. *) val moveOp = if size = 0w8 then Move64 - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt32 orelse typeCode = Foreign.LibFFI.ffiTypeCodeInt + else if typeForm = CTypeSignedInt andalso size = 0w4 then Move32X64 else if size >= 0w4 then Move32 - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt16 + else if typeForm = CTypeSignedInt andalso size = 0w2 then Move16X64 else if size >= 0w2 then Move16 - else if typeCode = Foreign.LibFFI.ffiTypeCodeSInt8 + else if typeForm = CTypeSignedInt andalso size = 0w1 then Move8X64 else Move8 in [Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset, index=NoIndex}, destination=RegisterArg reg, moveSize=moveOp}] end @ ( if size = 0w6 orelse size = 0w7 then [ Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset + 4, index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move16}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=0w32, opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) @ ( if size = 0w3 orelse size = 0w5 orelse size = 0w7 then [ Move{source=MemoryArg{base=argPtrReg, offset=Word.toInt offset + Word.toInt(size-0w1), index=NoIndex}, destination=RegisterArg argWorkReg, moveSize=Move8}, ShiftConstant{ shiftType=SHL, output=argWorkReg, shift=Word8.fromLargeWord(Word.toLargeWord((size-0w1)*0w8)), opSize=OpSize64 }, ArithToGenReg{ opc=OR, output=reg, source=RegisterArg argWorkReg, opSize=OpSize64 } ] else [] ) val newArgOffset = alignUp(argOffset, align) val word1Addr = {base=argPtrReg, offset=Word.toInt newArgOffset, index=NoIndex} val word2Addr = {base=argPtrReg, offset=Word.toInt newArgOffset + 8, index=NoIndex} in case (classifyArg arg, size > 0w8, gRegs, fpRegs) of (* 8 bytes or smaller - single general reg. This is the usual case. *) (ArgInRegs{firstInSSE=false, ...}, false, gReg :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', loadRegister(gReg, newArgOffset, size) @ code, preCode) (* 8 bytes or smaller - single SSE reg. Usual case for real arguments. *) | (ArgInRegs{firstInSSE=true, ...}, false, gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=if size = 0w4 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - both values in general regs. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true, gReg1 :: gReg2 :: gRegs', fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg1, moveSize=Move64} :: loadRegister(gReg2, newArgOffset+0w8, size-0w8) @ code, preCode) (* 9-16 bytes - first in general, second in SSE. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', Move{source=MemoryArg word1Addr, destination=RegisterArg gReg, moveSize=Move64} :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg } :: code, preCode) (* 9-16 bytes - first in SSE, second in general. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true, gReg :: gRegs', fpReg :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg } :: loadRegister(gReg, newArgOffset+0w8, size-0w8) @ code, preCode) | (* 9-16 bytes - both values in SSE regs. *) (ArgInRegs{firstInSSE=true, secondInSSE=true}, true, gRegs', fpReg1 :: fpReg2 :: fpRegs') => loadSysV64Args(args, stackOffset, newArgOffset+size, gRegs', fpRegs', XMMArith{opc=SSE2MoveDouble, source=MemoryArg word1Addr, output=fpReg1 } :: XMMArith{opc=if size = 0w12 then SSE2MoveFloat else SSE2MoveDouble, source=MemoryArg word2Addr, output=fpReg2 } :: code, preCode) | (_, _, gRegs', fpRegs') => (* Either larger than 16 bytes or we've run out of the right kind of registers. *) (* Move the argument in the preCode. It's possible a large struct could be the first argument and if we left it until the end RDI and RSI would already have been loaded. Structs are passed by value on the stack not, as in Win64, by reference. *) let val space = intAlignUp(Word.toInt size, 0w8) in loadSysV64Args(args, stackOffset+space, newArgOffset+size, gRegs', fpRegs', code, ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt space), opSize=nativeWordOpSize} :: moveMemory{source=(argPtrReg, Word.toInt newArgOffset), destination=(rsp, 0), length=Word.toInt size} @ preCode) end end (* The rules for returning structs are similar to those for parameters. *) local (* Store a result register into the result area. In almost all cases this is very simple: the only complication is with structs of odd sizes. *) fun storeResult(reg, offset, size) = storeUpTo8(reg, resultAreaPtr, offset, size) - val {size, typeCode, ...} = Foreign.LibFFI.extractFFItype result + val {size, typeForm, ...} = result in val (getResult, passArgAddress) = - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid + if typeForm = CTypeVoid then ([], false) else case (classifyArg result, size > 0w8) of (* 8 bytes or smaller - returned in RAX - Normal case for int-like results. *) (ArgInRegs{firstInSSE=false, ...}, false) => (storeResult(rax, 0, size), false) (* 8 bytes or smaller - returned in XMM0 - Normal case for real results. *) | (ArgInRegs{firstInSSE=true, ...}, false) => ([XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=if size = 0w4 then SinglePrecision else DoublePrecision}], false) (* 9-16 bytes - returned in RAX/RDX. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true) => (storeResult(rax, 0, 0w8) @ storeResult(rdx, 0, size-0w8), false) (* 9-16 bytes - first in RAX, second in XMM0. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision} :: storeResult(rax, 0, 0w8), false) (* 9-16 bytes - first in XMM0, second in RAX. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true) => (XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=DoublePrecision} :: storeResult(rax, 8, size-0w8), false) (* 9-16 bytes - both values in SSE regs.*) | (ArgInRegs{firstInSSE=true, secondInSSE=true}, true) => ([XMMStoreToMemory{toStore=xmm0, address={base=resultAreaPtr, offset=0, index=NoIndex}, precision=DoublePrecision}, XMMStoreToMemory{toStore=xmm1, address={base=resultAreaPtr, offset=8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}], false) | _ => ([], true) (* Have to pass the address of the area in memory *) end val (argCode, argStack, preArgCode) = if passArgAddress (* If we have to pass the address of the result struct it goes in rdi. *) then loadSysV64Args(args, 0, 0w0, tl sysVGenRegs, sysVFPRegs, [moveRR{source=resultAreaPtr, output=rdi, opSize=nativeWordOpSize}], []) else loadSysV64Args(args, 0, 0w0, sysVGenRegs, sysVFPRegs, [], []) local val align = argStack mod 16 in (* Always align the stack. *) val preArgAlign = if align = 0 then 0 else 16-align end in (* Save heap ptr. Needed in case we have a callback. *) [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] @ ( (* Put the destination address into a callee save resgister. We have to put the C address in there now because an ML address wouldn't be updated by a possible GC in a callback. *) - if #typeCode(Foreign.LibFFI.extractFFItype result) <> Foreign.LibFFI.ffiTypeCodeVoid + if #typeForm( result) <> CTypeVoid then [loadHeapMemory(resultAreaPtr, r8, 0, nativeWordOpSize)] else [] ) @ [ (* Save the stack pointer. *) storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize) (* Load the saved C stack pointer. *) ] @ ( if preArgAlign = 0 then [] else [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt preArgAlign), opSize=nativeWordOpSize}] ) @ ( (* The second argument is a SysWord containing the address of a malloced area of memory with the actual arguments in it. *) if null args then [] else [loadHeapMemory(argPtrReg, mlArg2Reg, 0, nativeWordOpSize)] ) @ preArgCode @ argCode @ [ let (* The entry point is in a SysWord.word value in RAX. *) val entryPoint = case targetArch of ObjectId32Bit => MemoryArg{base=ebx, offset=0, index=Index4 eax} | _ => MemoryArg{base=eax, offset=0, index=NoIndex} in (* Call the function. We're discarding the value in rsp so no need to remove args. *) CallAddress entryPoint end, loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Restore the ML stack pointer. *) (* Reload the heap pointer. If we've called back to ML this could well have changed. *) loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] @ (* Store the result in the destination. *) getResult @ [ ReturnFromFunction 0 ] end (* callUnix64Bits *) fun closureUnix64Bits(args, result) = let fun moveSysV64Args([], _, _, _, _, moveFromStack) = moveFromStack | moveSysV64Args(arg::args, stackSpace, argOffset, gRegs, fpRegs, moveFromStack) = let - val {size, align, ...} = Foreign.LibFFI.extractFFItype arg + val {size, align, ...} = arg fun storeRegister(reg, offset, size) = storeUpTo8(reg, rsp, offset, size) val newArgOffset = alignUp(argOffset, align) val word1Addr = {base=rsp, offset=Word.toInt newArgOffset, index=NoIndex} val word2Addr = {base=rsp, offset=Word.toInt newArgOffset + 8, index=NoIndex} in case (classifyArg arg, size > 0w8, gRegs, fpRegs) of (* 8 bytes or smaller - single general reg. This is the usual case. *) (ArgInRegs{firstInSSE=false, ...}, false, gReg :: gRegs', fpRegs') => storeRegister(gReg, Word.toInt newArgOffset, size) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 8 bytes or smaller - single SSE reg. Usual case for real arguments. *) | (ArgInRegs{firstInSSE=true, ...}, false, gRegs', fpReg :: fpRegs') => XMMStoreToMemory{precision=if size = 0w4 then SinglePrecision else DoublePrecision, address=word1Addr, toStore=fpReg } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - both values in general regs. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true, gReg1 :: gReg2 :: gRegs', fpRegs') => Move{source=MemoryArg word1Addr, destination=RegisterArg gReg1, moveSize=Move64} :: storeRegister(gReg2, Word.toInt newArgOffset+8, size-0w8) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - first in general, second in SSE. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true, gReg :: gRegs', fpReg :: fpRegs') => Move{source=MemoryArg word1Addr, destination=RegisterArg gReg, moveSize=Move64} :: XMMStoreToMemory{precision=if size = 0w12 then SinglePrecision else DoublePrecision, address=word2Addr, toStore=fpReg } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) (* 9-16 bytes - first in SSE, second in general. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true, gReg :: gRegs', fpReg :: fpRegs') => XMMStoreToMemory{precision=DoublePrecision, address=word1Addr, toStore=fpReg } :: storeRegister(gReg, Word.toInt newArgOffset+8, size-0w8) @ moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) | (* 9-16 bytes - both values in SSE regs. *) (ArgInRegs{firstInSSE=true, secondInSSE=true}, true, gRegs', fpReg1 :: fpReg2 :: fpRegs') => XMMStoreToMemory{precision=DoublePrecision, address=word1Addr, toStore=fpReg1 } :: XMMStoreToMemory{precision=if size = 0w12 then SinglePrecision else DoublePrecision, address=word2Addr, toStore=fpReg2 } :: moveSysV64Args(args, stackSpace, newArgOffset+size, gRegs', fpRegs', moveFromStack) | (_, _, gRegs', fpRegs') => (* Either larger than 16 bytes or we've run out of the right kind of register. Structs larger than 16 bytes are passed by value on the stack. Move the argument after we've stored all the registers in particular rsi and rdi. *) let val space = intAlignUp(Word.toInt size, 0w8) in moveSysV64Args(args, stackSpace+space, newArgOffset+size, gRegs', fpRegs', moveMemory{source=(r10, stackSpace), destination=(rsp, Word.toInt newArgOffset), length=Word.toInt size} @ moveFromStack) end end (* Result structs larger than 16 bytes are returned by reference. *) - val resultStructByRef = #size (Foreign.LibFFI.extractFFItype result) > 0w16 + val resultStructByRef = #size ( result) > 0w16 val copyArgsFromRegsAndStack = if resultStructByRef (* rdi contains the address for the result. *) then moveSysV64Args(args, 0, 0w0, tl sysVGenRegs, sysVFPRegs, []) else moveSysV64Args(args, 0, 0w0, sysVGenRegs, sysVFPRegs, []) local fun getNextSize (arg, argOffset) = - let val {size, align, ...} = Foreign.LibFFI.extractFFItype arg in alignUp(argOffset, align) + size end + let val {size, align, ...} = arg in alignUp(argOffset, align) + size end in val argumentSpace = List.foldl getNextSize 0w0 args end (* Allocate a 16-byte area for any results returned in registers. This will not be used if the result is a structure larger than 16-bytes. *) val resultOffset = alignUp(argumentSpace, 0w8) (* Ensure the stack is 16 bytes aligned. We've pushed 6 regs and a return address so add a further 8 bytes to bring it back into alignment. If we're returning a struct by reference, though, we've pushed 7 regs so don't add 8. *) val stackToAllocate = Word.toInt(alignUp(resultOffset + 0w16, 0w16)) + (if resultStructByRef then 0 else 8) (* The rules for returning structs are similar to those for parameters. *) local (* The result area is always 16 bytes wide so we can load the result without risking reading outside. At least at the moment we ignore any sign extension. *) - val {size, typeCode, ...} = Foreign.LibFFI.extractFFItype result + val {size, typeForm, ...} = result val resultOffset = Word.toInt resultOffset in val loadResults = - if typeCode = Foreign.LibFFI.ffiTypeCodeVoid + if typeForm = CTypeVoid then [] else case (classifyArg result, size > 0w8) of (* 8 bytes or smaller - returned in RAX - Normal case for int-like results. *) (ArgInRegs{firstInSSE=false, ...}, false) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}] (* 8 bytes or smaller - returned in XMM0 - Normal case for real results. *) | (ArgInRegs{firstInSSE=true, ...}, false) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=if size = 0w4 then SinglePrecision else DoublePrecision}] (* 9-16 bytes - returned in RAX/RDX. *) | (ArgInRegs{firstInSSE=false, secondInSSE=false}, true) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}, Move{source=MemoryArg {base=rsp, offset=resultOffset+8, index=NoIndex}, destination=RegisterArg rdx, moveSize=Move64}] (* 9-16 bytes - first in RAX, second in XMM0. *) | (ArgInRegs{firstInSSE=false, secondInSSE=true}, true) => [Move{source=MemoryArg {base=rsp, offset=resultOffset, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}, XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset+8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}] (* 9-16 bytes - first in XMM0, second in RAX. *) | (ArgInRegs{firstInSSE=true, secondInSSE=false}, true) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=DoublePrecision}, Move{source=MemoryArg {base=rsp, offset=resultOffset+8, index=NoIndex}, destination=RegisterArg rax, moveSize=Move64}] (* 9-16 bytes - both values in SSE regs.*) | (ArgInRegs{firstInSSE=true, secondInSSE=true}, true) => [XMMStoreToMemory{toStore=xmm0, address={base=rsp, offset=resultOffset, index=NoIndex}, precision=DoublePrecision}, XMMStoreToMemory{toStore=xmm1, address={base=rsp, offset=resultOffset+8, index=NoIndex}, precision=if size = 0w12 then SinglePrecision else DoublePrecision}] | _ => [] (* Have to pass the address of the area in memory *) end in [ (* Push callee-save registers. *) PushToStack(RegisterArg rbp), PushToStack(RegisterArg rbx), PushToStack(RegisterArg r12), PushToStack(RegisterArg r13), PushToStack(RegisterArg r14), PushToStack(RegisterArg r15) ] @ ( (* If we're returning a struct by reference we have to return the address in rax even though it's been set by the caller. Save this address. *) if resultStructByRef then [PushToStack(RegisterArg rdi)] else [] ) @ [ (* Set r10 to point to the original stack args if any. *) LoadAddress{ output=r10, offset=if resultStructByRef then 64 else 56, base=SOME rsp, index=NoIndex, opSize=nativeWordOpSize}, (* Allocate stack space. *) ArithToGenReg{opc=SUB, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize}, (* Move the function we're calling, in rax, into r13, a callee-save register *) moveRR{source=rax, output=r13, opSize=polyWordOpSize} ] @ copyArgsFromRegsAndStack @ [ (* Get the value for rbp. This has to be an absolute address in 32-in-64. *) LoadAbsolute{value=getThreadDataCall, destination=rcx}, CallAddress(MemoryArg{base=rcx, offset=0, index=NoIndex}), moveRR{source=rax, output=rbp, opSize=nativeWordOpSize}, (* Save the address of the argument and result area. *) moveRR{source=rsp, output=rcx, opSize=nativeWordOpSize}, (* Switch to the ML stack. *) storeMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), (* Load the ML heap pointer. *) loadMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize), (* Now move the function closure into the closure register ready for the call. *) moveRR{source=r13, output=rdx, opSize=polyWordOpSize} ] @ (* Reload the heap base address in 32-in-64. *) ( if targetArch = ObjectId32Bit then [loadMemory(rbx, rbp, memRegSavedRbx, nativeWordOpSize)] else [] ) @ boxRegAsSysWord(rcx, rax, []) @ ( (* If we're returning a struct by reference the address for the result will have been passed in the first argument. We use that as the result area. Otherwise point to the result area on the stack. *) if resultStructByRef then loadMemory(rcx, r10, ~64, nativeWordOpSize) else ArithToGenReg{opc=ADD, output=rcx, source=NonAddressConstArg(Word.toLargeInt resultOffset), opSize=nativeWordOpSize} ) :: boxRegAsSysWord(rcx, mlArg2Reg, [rax]) @ [ (* Call the ML function using the full closure call. *) CallAddress( if targetArch = ObjectId32Bit then MemoryArg{base=rbx, index=Index4 rdx, offset=0} else MemoryArg{base=rdx, index=NoIndex, offset=0}), (* Save the ML stack pointer because we may have grown the stack. Switch to the C stack. *) storeMemory(rsp, rbp, memRegStackPtr, nativeWordOpSize), loadMemory(rsp, rbp, memRegCStackPtr, nativeWordOpSize), storeMemory(r15, rbp, memRegLocalMPointer, nativeWordOpSize) ] @ loadResults @ [ (* Remove the stack space. *) ArithToGenReg{opc=ADD, output=rsp, source=NonAddressConstArg(LargeInt.fromInt stackToAllocate), opSize=nativeWordOpSize} ] @ ( if resultStructByRef then [PopR rax] else [] ) @ [ PopR r15, PopR r14, PopR r13, PopR r12, PopR rbx, PopR rbp, (* Restore callee-save registers. *) ReturnFromFunction 0 (* Caller removes any stack arguments. *) ] end end - fun foreignCall(abi: ffiABI, args: Foreign.LibFFI.ffiType list, result: Foreign.LibFFI.ffiType): Address.machineWord = + fun foreignCall(abi: ffiABI, args: cType list, result: cType): Address.machineWord = let val code = case abi of FFI_UNIX64 => callUnix64Bits(args, result) | FFI_WIN64 => callWindows64Bits(args, result) | abi => call32Bits(abi, args, result) val functionName = "foreignCall" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end (* Build a callback function. The arguments are the abi, the list of argument types and the result type. The result is an ML function that takes an ML function, f, as its argument, registers it as a callback and returns the C function as its result. When the C function is called the arguments are copied into temporary memory and the vector passed to f along with the address of the memory for the result. "f" stores the result in it when it returns and the result is then passed back as the result of the callback. N.B. This returns a closure cell which contains the address of the code. It can be used as a SysWord.word value except that while it exists the code will not be GCed. *) - fun buildCallBack(abi: ffiABI, args: Foreign.LibFFI.ffiType list, result: Foreign.LibFFI.ffiType): Address.machineWord = + fun buildCallBack(abi: ffiABI, args: cType list, result: cType): Address.machineWord = let val code = case abi of FFI_UNIX64 => closureUnix64Bits(args, result) | FFI_WIN64 => closureWindows64Bits(args, result) | abi => closure32Bits(abi, args, result) val functionName = "foreignCallBack(2)" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} val stage2Code = closureAsAddress closure fun resultFunction f = let (* Generate a small function to load the address of f into rax/eax and then jump to stage2. The idea is that it should be possible to generate this eventually in a single RTS call. That could be done by using a version of this as a model. *) val codeAddress = (* In the native code versions we extract the code address from the closure. We don't do that in 32-in-64 and instead the RTS does it. *) if targetArch = ObjectId32Bit then stage2Code else Address.loadWord(Address.toAddress stage2Code, 0w0) val code = [ Move{source=AddressConstArg(Address.toMachineWord f), destination=RegisterArg rax, moveSize=opSizeToMove polyWordOpSize}, JumpAddress(AddressConstArg codeAddress) ] val functionName = "foreignCallBack(1)" val debugSwitches = [(*Universal.tagInject Pretty.compilerOutputTag (Pretty.prettyPrint(print, 70)), Universal.tagInject DEBUG.assemblyCodeTag true*)] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} val res = closureAsAddress closure (*val _ = print("Address is " ^ (LargeWord.toString(RunCall.unsafeCast res)) ^ "\n")*) in res end in Address.toMachineWord resultFunction end end; diff --git a/mlsource/MLCompiler/FOREIGNCALLSIG.sml b/mlsource/MLCompiler/FOREIGNCALLSIG.sml index 751e525f..4ed39ab9 100644 --- a/mlsource/MLCompiler/FOREIGNCALLSIG.sml +++ b/mlsource/MLCompiler/FOREIGNCALLSIG.sml @@ -1,35 +1,35 @@ (* Copyright (c) 2016, 2018-19 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 *) signature FOREIGNCALLSIG = sig val rtsCallFast: string * int * Universal.universal list -> Address.machineWord val rtsCallFastRealtoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastRealRealtoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastGeneraltoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastRealGeneraltoReal: string * Universal.universal list -> Address.machineWord val rtsCallFastFloattoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastFloatFloattoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastGeneraltoFloat: string * Universal.universal list -> Address.machineWord val rtsCallFastFloatGeneraltoFloat: string * Universal.universal list -> Address.machineWord type abi and cType val abiList: (string * abi) list - val foreignCall: abi * Foreign.LibFFI.ffiType list * Foreign.LibFFI.ffiType -> Address.machineWord - val buildCallBack: abi * Foreign.LibFFI.ffiType list * Foreign.LibFFI.ffiType -> Address.machineWord + val foreignCall: abi * cType list * cType -> Address.machineWord + val buildCallBack: abi * cType list * cType -> Address.machineWord end; diff --git a/mlsource/MLCompiler/INITIALISE_.ML b/mlsource/MLCompiler/INITIALISE_.ML index dee604d2..6fe4b644 100644 --- a/mlsource/MLCompiler/INITIALISE_.ML +++ b/mlsource/MLCompiler/INITIALISE_.ML @@ -1,2059 +1,2064 @@ (* 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 = boxedNever, 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) val () = enterRunCall ("touch", makePolymorphic([a], mkUnaryFn TouchAddress), a ->> 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_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), ("Thread", EXC_thread, String), ("SysErr", EXC_syserr, String ** Option LargeWord) ] 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) val allocCStackFn = mkGvar("allocCStack", Word ->> LargeWord, mkUnaryFn BuiltIns.AllocCStack, declInBasis) val freeCStackFn = mkGvar("freeCStack", LargeWord ** Word ->> Unit, mkBinaryFn BuiltIns.FreeCStack, 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) val () = #enterVal fmemEnv ("allocCStack", allocCStackFn) (* Free is a binary operation that takes both the allocated address and the size. The size is used by the compiled code where this is implemented using the C-stack. The allocated address is intended for possible use by the interpreter where so that it can be implemented as malloc/free. *) val () = #enterVal fmemEnv ("freeCStack", freeCStackFn) end local val foreignEnv = makeStructure(globalEnv, "Foreign") local val EXC_foreign = 23 val foreignException = Value{ name = "Foreign", typeOf = String ->> TYPETREE.exnType, access = Global(mkConst(toMachineWord EXC_foreign)), class = Exception, locations = declInBasis, references = NONE, instanceTypes=NONE } in val () = #enterVal foreignEnv ("Foreign", foreignException) end 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 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 (* Abi - an eqtype. *) local open TypeValue fun monotypePrinter _ = PRETTY.PrettyString "?" val code = createTypeValue{ eqCode = equalWordFn, printCode = mkConst (toMachineWord (ref monotypePrinter)), boxedCode = boxedEither (* Assume this for the moment *), sizeCode = singleWord } val abiEqAndPrint = Global (genCode(code, [], 0) ()) in val abiConstr = makeTypeConstructor("abi", [], makeFreeId(0, abiEqAndPrint, true, basisDescription "Foreign.LowLevel.abi"), declInBasis) end val () = #enterType foreignEnv ("abi", TypeConstrSet(abiConstr, [])) val abiType = mkTypeConstruction ("abi", abiConstr, [], declInBasis) - val ffiType = LargeWord (* It would be possible to put the definition of cType in here but it's complicated. It's easier to use an opaque type and put in a cast later. *) + val ctypeConstr = + makeTypeConstructor("ctype", [], + makeFreeId(0, defaultEqAndPrintCode(), false, + basisDescription "Foreign.LowLevel.ctype"), declInBasis) + val () = #enterType foreignEnv ("ctype", TypeConstrSet(ctypeConstr, [])) + val ffiType = mkTypeConstruction ("ctype", ctypeConstr, [], declInBasis) val foreignCallType = mkProductType[abiType, List ffiType, ffiType] ->> mkProductType[LargeWord, LargeWord, LargeWord] ->> Unit val buildCallBackType = mkProductType[abiType, List ffiType, ffiType] ->> (mkProductType[LargeWord, LargeWord] ->> Unit) ->> LargeWord fun enterForeign (name, entry, typ) = #enterVal foreignEnv (name, mkGvar (name, typ, entry, declInBasis)) in val () = enterForeign("foreignCall", foreignCallEntry, foreignCallType) val () = enterForeign("buildCallBack", buildCallBackEntry, buildCallBackType) val () = enterForeign("abiList", mkConst(toMachineWord CODETREE.Foreign.abiList), List (String ** abiType)) 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;