diff --git a/basis/BasicStreamIO.sml b/basis/BasicStreamIO.sml index 8b786692..1b7796b9 100644 --- a/basis/BasicStreamIO.sml +++ b/basis/BasicStreamIO.sml @@ -1,796 +1,796 @@ (* Title: Standard Basis Library: StreamIO functor Copyright David C.J. Matthews 2000, 2005, 2019 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 BasicStreamIO( structure PrimIO : PRIM_IO structure Vector : MONO_VECTOR structure Array : MONO_ARRAY structure VectorSlice: MONO_VECTOR_SLICE structure ArraySlice: MONO_ARRAY_SLICE sharing type PrimIO.elem = Vector.elem = Array.elem = VectorSlice.elem = ArraySlice.elem sharing type PrimIO.vector = Vector.vector = Array.vector = VectorSlice.vector = ArraySlice.vector sharing type PrimIO.array = Array.array = ArraySlice.array sharing type PrimIO.vector_slice = VectorSlice.slice = ArraySlice.vector_slice sharing type PrimIO.array_slice = ArraySlice.slice val someElem : PrimIO.elem ): sig include STREAM_IO (* Note: This is non-standard but enables us to define the derived BinIO and TextIO structures more efficiently. *) val outputVec: outstream * PrimIO.vector_slice -> unit end = struct open IO type vector = Vector.vector type elem = PrimIO.elem datatype reader = datatype PrimIO.reader datatype writer = datatype PrimIO.writer type array = Array.array type pos = PrimIO.pos exception Interrupt = RunCall.Interrupt (* Called after any exception in the lower level reader or writer to map any exception other than Io into Io. *) fun mapToIo (io as Io _, _, _) = io | mapToIo (Interrupt, _, _) = Interrupt | mapToIo (nonIo, name, caller) = Io { name = name, function = caller, cause = nonIo } val emptyVec = Vector.fromList [] (* Represents end-of-stream. *) datatype instream = (* The usual state of a stream: We may have to read from the reader before we have any real data or we may have already read. *) Uncommitted of { state: streamState ref, locker: Thread.Mutex.mutex } (* If we know we have unread input we can return this as the stream. That allows part of the stream to be read without locking. This is an optimisation. *) | Committed of { vec: vector, offset: int, rest: instream, startPos: pos option } and streamState = Truncated (* The stream has been closed or truncated. *) | HaveRead of (* A vector has been read from the stream. If the vector has size zero this is treated as EOF. startPos is the position when the vector was read. *) {vec: vector, rest: streamState ref, startPos: pos option } | ToRead of reader (* We have not yet closed or truncated the stream. *) (* Outstream. *) and outstream = OutStream of { wrtr: writer, buffType : IO.buffer_mode ref, buf: array, bufp: int ref, streamState: outstreamState ref, locker: Thread.Mutex.mutex } (* Stream state. OutStreamOpen means that attempts to write should proceed. OutStreamTerminated means the stream has been "terminated" i.e. buffers have been flushed and the writer has been extracted by getWriter. Any attempt to write at this level should fail. OutStreamClosed means that the writer's "close" function has been called. In addition the stream has been terminated.*) and outstreamState = OutStreamOpen | OutStreamTerminated | OutStreamClosed datatype out_pos = OutPos of outstream * pos (* Create a new stream from the vector and the reader. *) fun mkInstream (r, v: vector): instream = let val readRest = Uncommitted { state = ref (ToRead r), locker = Thread.Mutex.mutex() } (* If the vector is non-empty the first entry is as though the vector had been read otherwise it's just the reader. *) in if Vector.length v = 0 then readRest else Committed { vec = v, offset = 0, rest = readRest, startPos = NONE } end local fun input' (ref (HaveRead {vec, rest, ...}), locker) = let (* TODO: If we have already read further on we could convert these entries to Committed. *) in (vec, Uncommitted{ state = rest, locker = locker }) end | input' (s as ref Truncated, locker) = (* Truncated: return end-of-stream *) (emptyVec, Uncommitted{ state = s, locker = locker }) | input' (state as ref(readMore as ToRead (RD {chunkSize, readVec = SOME readVec, getPos, ...})), locker) = let (* We've not yet read this. Try reading from the reader. *) val startPos = case getPos of SOME g => SOME(g()) | NONE => NONE val data = readVec chunkSize (* Create a reference to the reader which will be updated by the next read. The ref is shared between the existing stream and the new one so reading on either adds to the same chain. *) val nextLink = ref readMore val nextChunk = HaveRead {vec = data, rest = nextLink, startPos = startPos} in (* Extend the stream by adding this vector to the list of chunks read so far. *) state := nextChunk; (* Return a new stream which continues reading. *) (data, Uncommitted { state = nextLink, locker = locker }) end | input' (ref(ToRead(RD{name, ...})), _) = (* readVec missing in reader. *) raise Io { name = name, function = "input", cause = BlockingNotSupported } fun inputNList' (ref (HaveRead {vec, rest, startPos}), locker, n) = let val vecLength = Vector.length vec in if vecLength = 0 (* End-of-stream: Return next in list. *) then ([vec], Uncommitted{ state = rest, locker = locker }) else if n < vecLength then (* We can use what's already been read. The stream we return allows us to read the rest without blocking. *) ([VectorSlice.vector(VectorSlice.slice(vec, 0, SOME n))], Committed{ vec = vec, offset = n, startPos = startPos, rest = Uncommitted{ state = rest, locker = locker} }) else if n = vecLength then (* Exactly uses up the buffer. New stream state is the next entry. *) ([vec], Uncommitted{ state = rest, locker = locker}) else (* Have to get the next item *) let val (nextVecs, nextStream) = inputNList' (rest, locker, n - vecLength) in (vec :: nextVecs, nextStream) end end | inputNList' (s as ref Truncated, locker, _) = (* Truncated: return end-of-stream *) ([emptyVec], Uncommitted{ state = s, locker = locker }) | inputNList' (f, locker, n) = (* ToRead *) let val (vec, f') = input' (f, locker) in if Vector.length vec = 0 then ([vec], f') (* Truncated or end-of-file. *) else inputNList' (f, locker, n) (* Reread *) end in fun input (Uncommitted { state, locker }) = LibraryIOSupport.protect locker input' (state, locker) | input (Committed { vec, offset, rest, ... }) = (* This stream was produced from re-reading a stream that already had data. We can return the result without the overhead of locking. *) (VectorSlice.vector(VectorSlice.slice(vec, offset, NONE)), rest) fun inputNList (Uncommitted { state, locker }, n) = LibraryIOSupport.protect locker inputNList' (state, locker, n) | inputNList (Committed { vec, offset, rest, startPos }, n) = let val vecLength = Vector.length vec in if vecLength = 0 (* End-of-stream: Return next in list. *) then ([vec], rest) else if n < vecLength - offset then (* We can use what's already been read. Next entry is a committed stream that returns the part we haven't yet used. *) ([VectorSlice.vector(VectorSlice.slice(vec, offset, SOME n))], Committed{ vec = vec, offset = offset+n, rest = rest, startPos = startPos }) else if n = vecLength - offset then (* Exactly uses up the buffer. New stream state is the next entry. *) ([VectorSlice.vector(VectorSlice.slice(vec, offset, NONE))], rest) else (* Have to get the next item *) let val (nextVecs, nextStream) = inputNList (rest, n - (vecLength - offset)) in (VectorSlice.vector(VectorSlice.slice(vec, offset, NONE)) :: nextVecs, nextStream) end end fun inputN (f, n) = if n < 0 then raise Size else if n = 0 (* Defined to return the empty vector and f *) then (emptyVec, f) else let val (vecs, f') = inputNList (f, n) in (Vector.concat vecs, f') end (* Read the whole of the remaining input until we get an EOF. *) fun inputAll f = let (* Find out the size of the file. *) fun getSize(n, f) = let val (v, f') = input f val vSize = Vector.length v in if vSize = 0 then n (* Reached EOF. *) else getSize (n + vSize, f') end in (* Read the whole file. *) inputN(f, getSize(0,f)) end (* Note a crucial difference between inputN and input1. Because input1 does not return a stream if it detects EOF it cannot advance beyond a temporary EOF in a stream. *) fun input1 (Committed { vec, offset, rest, startPos }) = let val vecSize = Vector.length vec in if vecSize = 0 then NONE else if vecSize = offset+1 then SOME(Vector.sub(vec, offset), rest) else SOME(Vector.sub(vec, offset), Committed{ vec = vec, offset = offset+1, rest = rest, startPos = startPos }) end | input1 f = let val (s, f') = inputN (f, 1) in if Vector.length s = 0 then NONE else SOME(Vector.sub(s, 0), f') end end local fun doClose (ref (HaveRead {rest, ...})) = doClose rest | doClose (ref Truncated) = () | doClose (state as ref (ToRead (RD{close, name, ...}))) = (state := Truncated; close() handle exn => raise mapToIo(exn, name, "closeIn")) in fun closeIn (Uncommitted { state, locker }) = LibraryIOSupport.protect locker doClose state | closeIn (Committed { rest, ...}) = closeIn rest end local (* Return the reader. *) fun getReader' (ref (HaveRead {rest, ...})) = getReader' rest | getReader' (ref Truncated) = raise Io { name = "", function = "getReader", cause = ClosedStream } | getReader' (state as ref (ToRead reader)) = (state := Truncated; reader) in fun getReader'' (Uncommitted { state, locker }) = LibraryIOSupport.protect locker getReader' state | getReader'' (Committed { rest, ... }) = getReader'' rest fun getReader f = let val reader = getReader'' f val (allInput, _) = inputAll f in (* Return the reader along with buffered input. It's not clear what to do if there are EOFs in the stream. The book says the result is the result of inputAll which takes everything up to the first EOF. *) (reader, allInput) end end local (* Check that the stream is not terminated and then convert a file position plus a vector offset into a file position. In particular, if the reader has converted CRNL into NL we don't have a simple relationship between elements and file offsets. *) fun findPosition'(startPos, offset, HaveRead {rest=ref rest, ...}) = findPosition'(startPos, offset, rest) | findPosition'(_, _, Truncated) = raise Io { name = "", function = "filePosIn", cause = ClosedStream } | findPosition'(startPos, offset, ToRead (RD { getPos = SOME getPos, setPos = SOME setPos, readVec = SOME readVec, ...})) = if offset = 0 then startPos (* Easy *) else (* When we read this vector we recorded the file position of the beginning only. To find the file position of the particular element we actually need to read the portion of the input up to that element and find out the file position at that point. *) let val savep = getPos() (* Save current position. *) (* Move to the point where we read the vector. *) val () = setPos startPos; (* Call readVec until we have read the required number of elements. N.B. Ganser & Reppy has a bug here. There is no guarantee that readVec n will actually return n elements so it's unsafe to assume that it will move the file pointer by n elements. *) fun doRead n = let val read = Vector.length(readVec n) in if read = n orelse read = 0 (* Error? *) then () else doRead (n - read) end (* Read the offset number of elements. *) val () = doRead offset; (* Record the position after actually reading the elements. *) val position = getPos(); in setPos savep; (* Restore. *) position end | findPosition'(_, _, ToRead _) = raise Io { name = "", function = "filePosIn", cause = RandomAccessNotSupported } fun findPosition(startPos, offset, Committed { rest, ... }) = findPosition(startPos, offset, rest) | findPosition(startPos, offset, Uncommitted { state = ref state, locker }) = LibraryIOSupport.protect locker findPosition' (startPos, offset, state) fun filePosIn' (HaveRead {rest=ref rest, startPos = SOME startPos, ...}) = findPosition'(startPos, 0, rest) | filePosIn' (HaveRead {startPos = NONE, ...}) = raise Io { name = "", function = "filePosIn", cause = RandomAccessNotSupported } | filePosIn' Truncated = raise Io { name = "", function = "filePosIn", cause = ClosedStream } | filePosIn' (ToRead(RD { getPos = SOME getPos, ...})) = getPos() | filePosIn' (ToRead _) = raise Io { name = "", function = "filePosIn", cause = RandomAccessNotSupported } in (* Find the first entry to get the position. *) fun filePosIn (Uncommitted { state = ref state, locker }) = LibraryIOSupport.protect locker filePosIn' state | filePosIn (Committed { offset, rest, startPos = SOME startPos, ... }) = findPosition(startPos, offset, rest) | filePosIn (Committed { startPos = NONE, ... }) = (* This can occur either because the reader doesn't support getPos or because the position is within the initial vector passed to mkInstream. *) raise Io { name = "", function = "filePosIn", cause = RandomAccessNotSupported } end local fun doCanInput' (ref (HaveRead {vec, rest, ...}), locker, n, k) = let val vecLength = Vector.length vec in if vecLength = 0 then SOME k else if vecLength >= n then SOME (k+n) else doCanInput'(rest, locker, n-vecLength, k+vecLength) end | doCanInput' (ref Truncated, _, _, k) = SOME k | doCanInput' (state as ref(readMore as ToRead (RD {chunkSize, readVecNB = SOME readVecNB, getPos, ...})), locker, n, k) = let val startPos = case getPos of SOME g => SOME(g()) | NONE => NONE in (* Read a block full. This will avoid us creating lots of small items in the list if there is actually plenty of input available. *) case readVecNB chunkSize of NONE => (* Reading these would block but we may already have some input. *) if k = 0 then NONE else SOME k | SOME data => let (* We have to record this in the stream. *) val nextLink = ref readMore val nextChunk = HaveRead {vec = data, rest = nextLink, startPos = startPos} in state := nextChunk; (* Check whether this has satisfied the request. *) doCanInput'(state, locker, n, k) end end | doCanInput' (ref(ToRead(RD {name, ...})), _, _, _) = (* readVecNB missing in reader. *) raise Io { name = name, function = "canInput", cause = NonblockingNotSupported } fun doCanInput (Uncommitted { state, locker }, n, k) = LibraryIOSupport.protect locker doCanInput' (state, locker, n, k) | doCanInput (Committed { vec, rest, ... }, n, k) = let val vecLength = Vector.length vec in if vecLength = 0 then SOME k (* Reached EOF. *) else if vecLength >= n then SOME (k + n) (* Have already read enough. *) else doCanInput(rest, n-vecLength, k+vecLength) end in fun canInput(f, n) = if n < 0 then raise Size else doCanInput(f, n, 0) end (* Look for end-of-stream. Could be defined more directly but it probably isn't worth it. *) fun endOfStream f = let val (v, _) = input f in Vector.length v = 0 end (* OUTPUT *) (* In order to be able to flush and close the streams when we exit we need to keep a list of the output streams. *) val ostreamLock = Thread.Mutex.mutex() (* Use a no-overwrite ref for the list of streams. This ensures that the ref will not be overwritten if we load a saved state. *) val outputStreamList: outstream list ref = LibrarySupport.noOverwriteRef nil; fun protectOut f (outs as OutStream{locker, ...}) = LibraryIOSupport.protect locker f outs fun mkOutstream'(wrtr as WR{chunkSize, ...}, buffMode) = let open Thread.Mutex val strm = OutStream{wrtr=wrtr, buffType=ref buffMode, buf=Array.array(chunkSize, someElem), streamState=ref OutStreamOpen, bufp=ref 0, locker=Thread.Mutex.mutex()} in (* Add it to the list. *) outputStreamList := strm :: ! outputStreamList; strm end val mkOutstream = LibraryIOSupport.protect ostreamLock mkOutstream' fun getBufferMode(OutStream{buffType=ref b, ...}) = b local (* Flush anything from the buffer. *) fun flushOut'(OutStream{buf, bufp=bufp as ref endBuf, wrtr=wrtr as WR{name, ...}, ...}) = if endBuf = 0 then () (* Nothing buffered *) else case wrtr of WR{writeArr=SOME wa, ...} => let fun flushBuff n = let val written = wa(ArraySlice.slice(buf, n, SOME(endBuf-n))) handle exn => raise mapToIo(exn, name, "flushOut") in if written+n = endBuf then () else flushBuff(written+n) end in (* Set the buffer to empty BEFORE writing anything. If we get an asynchronous interrupt (ctrl-C) we want to lose data in preference to duplicating it. *) bufp := 0; flushBuff 0 end | _ => raise Io { name = name, function = "flushOut", cause = BlockingNotSupported } (* Terminate a stream either because it has been closed or because we have extracted the underlying writer. *) fun terminateStream'(f as OutStream{streamState as ref OutStreamOpen, ...}) = let (* outstream is not an equality type but we can get the desired effect by comparing the streamState references for equality (N.B. NOT their contents). *) fun removeThis(OutStream{streamState=streamState', ...}) = streamState' <> streamState open Thread.Mutex in streamState := OutStreamTerminated; lock ostreamLock; outputStreamList := List.filter removeThis (!outputStreamList); unlock ostreamLock; flushOut' f end | terminateStream' _ = () (* Nothing to do. *) (* Close the stream. We must call the writer's close function only once unless the flushing fails. In that case the stream is left open. *) fun closeOut'(OutStream{streamState=ref OutStreamClosed, ...}) = () | closeOut'(f as OutStream{wrtr=WR{close, name, ...}, streamState, ...}) = ( terminateStream' f; streamState := OutStreamClosed; close() handle exn => raise mapToIo(exn, name, "closeOut") (* Close the underlying writer. *) ) (* Flush the stream, terminate it and return the underlying writer. According to the documentation this raises an exception if the stream is "closed" rather than "terminated" implying that it is possible to extract the writer more than once. That's in contrast to getReader which is defined to raise an exception if the stream is closed or truncated. *) fun getWriter'(OutStream{wrtr=WR{name, ...}, streamState=ref OutStreamClosed, ...}) = (* Already closed. *) raise Io { name = name, function = "getWriter", cause = ClosedStream } | getWriter'(f as OutStream{buffType, wrtr, ...}) = ( terminateStream' f; (wrtr, !buffType) ) (* Set the buffer mode, possibly flushing the buffer as it does. *) fun setBufferMode' newBuff (f as OutStream{buffType, bufp, ...}) = (* Question: What if the stream is terminated? *) ( if newBuff = NO_BUF andalso !bufp <> 0 then (* Flush pending output. *) (* Switching from block to line buffering does not flush. *) flushOut' f else (); buffType := newBuff ) (* Internal function: Write a vector directly to the writer. It only returns when the vector has been completely written. "output" should work if the writer only provides writeArr so we may have to use that if writeVec isn't there. *) (* FOR TESTING: Put writeArr first. *) fun writeVec(OutStream{wrtr=WR{writeVec=SOME wv, name, ...}, ...}, v, i, len) = let fun forceOut p = let val written = wv(VectorSlice.slice(v, p+i, SOME(len-p))) handle exn => raise mapToIo(exn, name, "output") in if written+p = len then () else forceOut(written+p) end in forceOut 0 end | writeVec(OutStream{wrtr=WR{writeArr=SOME wa, name, ...}, ...}, v, i, len) = let val buffSize = 10 val buff = Array.array(buffSize, someElem); fun forceOut p = let val toCopy = Int.min(len-p, buffSize) val () = ArraySlice.copyVec{src=VectorSlice.slice(v, p+i, SOME toCopy), dst=buff, di=0} val written = wa(ArraySlice.slice(buff, 0, SOME toCopy)) handle exn => raise mapToIo(exn, name, "output") in if written+p = len then () else forceOut(written+p) end in forceOut 0 end | writeVec(OutStream{wrtr=WR{name, ...}, ...}, _, _, _) = raise Io { name = name, function = "output", cause = BlockingNotSupported } (* Internal function. Write a vector to the stream using the start and length provided. *) fun outputVector (v, start, vecLen) (f as OutStream{streamState=ref OutStreamOpen, buffType, buf, bufp, ...}) = let val buffLen = Array.length buf fun arrayCopyVec{src: Vector.vector, si: int, len: int, dst: Array.array, di: int} = ArraySlice.copyVec{src=VectorSlice.slice(src, si, SOME len), dst=dst, di=di}; fun addVecToBuff () = if vecLen < buffLen - !bufp then (* Room in the buffer. *) ( arrayCopyVec{src=v, si=start, len=vecLen, dst=buf, di= !bufp}; bufp := !bufp + vecLen ) else let val buffSpace = buffLen - !bufp in (* Copy as much of the vector as will fit *) arrayCopyVec{src=v, si=start, len=buffSpace, dst=buf, di= !bufp}; bufp := !bufp+buffSpace; (* TODO: Flushing the buffer ensures that all the buffer contents have been written. We don't actually need that, what we need is for enough to have been written that we have space in the buffer for the rest of the vector. *) flushOut' f; (* Write it out. *) (* Copy the rest of the vector. *) arrayCopyVec{src=v, si=start+buffSpace, len=vecLen-buffSpace, dst=buf, di=0}; bufp := vecLen-buffSpace end (* addVecToBuff *) in if vecLen > buffLen then (* If the vector is too large to put in the buffer we're going to have to write something out. To reduce copying we simply flush the buffer and write the vector directly. *) (flushOut' f; writeVec(f, v, start, vecLen)) else (* Try copying to the buffer. *) if !buffType = IO.NO_BUF then (* Write it directly *) writeVec(f, v, start, vecLen) else (* Block or line buffering - add it to the buffer. Line buffering is treated as block buffering on binary streams and handled at the higher level for text streams. *) addVecToBuff() end (* State was not open *) | outputVector _ (OutStream{wrtr=WR{name, ...}, ...}) = raise Io { name = name, function = "output", cause = ClosedStream } (* This could be defined in terms of outputVector but this is likely to be much more efficient if we are buffering. *) fun output1' c (f as OutStream{streamState=ref OutStreamOpen, buffType, buf, bufp, ...}) = if !buffType = IO.NO_BUF then writeVec(f, Vector.fromList[c], 0, 1) else (* Line or block buffering. *) ( Array.update(buf, !bufp, c); bufp := !bufp + 1; if !bufp = Array.length buf then flushOut' f else () ) (* State was not open *) | output1' _ (OutStream{wrtr=WR{name, ...}, ...}) = raise Io { name = name, function = "output1", cause = ClosedStream } fun getPosOut'(f as OutStream{wrtr=WR{name, getPos=SOME getPos, ...}, ...}) = ( flushOut' f; OutPos(f, getPos()) handle exn => raise mapToIo(exn, name, "getPosOut") ) | getPosOut'(OutStream{wrtr=WR{name, ...}, ...}) = raise Io { name = name, function = "getPosOut", cause = RandomAccessNotSupported } fun setPosOut' p (f as OutStream{wrtr=WR{setPos=SOME setPos, ...}, ...}) = ( flushOut' f; setPos p; f ) | setPosOut' _ (OutStream{wrtr=WR{name, ...}, ...}) = raise Io { name = name, function = "setPosOut", cause = RandomAccessNotSupported } in fun output1(f, c) = protectOut (output1' c) f fun output(f, v) = protectOut (outputVector(v, 0, Vector.length v)) f val flushOut = protectOut flushOut' val closeOut = protectOut closeOut' val getWriter = protectOut getWriter' fun setBufferMode(f, n) = protectOut (setBufferMode' n) f (* Exported function to output part of a vector. Non-standard. *) fun outputVec(f, slice) = let val (v, i, len) = VectorSlice.base slice in protectOut (outputVector(v, i, len)) f end val getPosOut = protectOut getPosOut' fun setPosOut(OutPos(f, p)) = protectOut (setPosOut' p) f end fun filePosOut(OutPos(_, p)) = p (* We need to set up a function to flush the streams when we exit. This has to be set up for every session so we set up an entry function, which is persistent, to do it. *) local fun closeAll () = (* Close all the streams. closeOut removes the streams from the list so we should end up with outputStreamList being nil. *) List.foldl (fn (s, ()) => closeOut s handle _ => ()) () (! outputStreamList) fun doOnEntry () = OS.Process.atExit closeAll in - val () = PolyML.onEntry doOnEntry; + val () = LibrarySupport.addOnEntry doOnEntry; val () = doOnEntry() (* Set it up for this session as well. *) end local open PolyML fun printWithName(s, name) = PolyML.PrettyString(String.concat[s, "-\"", String.toString name, "\""]) fun prettyIn depth a (Committed { rest, ...}) = prettyIn depth a rest | prettyIn _ _ (Uncommitted { state = ref streamState, ...}) = let fun prettyState Truncated = PolyML.PrettyString("Instream-truncated") | prettyState (HaveRead{ rest = ref rest, ...}) = prettyState rest | prettyState (ToRead(RD{name, ...})) = printWithName("Instream", name) in prettyState streamState end fun prettyOut _ _ (OutStream { wrtr = WR { name, ...}, ...}) = printWithName("Outstream", name) in val () = addPrettyPrinter prettyIn val () = addPrettyPrinter prettyOut end end; (* Define the StreamIO functor in terms of BasicStreamIO to filter out outputVec. *) (* This is non-standard. According to G&R 2004 StreamIO does not take the slice structures as args. *) functor StreamIO( structure PrimIO : PRIM_IO structure Vector : MONO_VECTOR structure Array : MONO_ARRAY structure VectorSlice: MONO_VECTOR_SLICE structure ArraySlice: MONO_ARRAY_SLICE sharing type PrimIO.elem = Vector.elem = Array.elem = VectorSlice.elem = ArraySlice.elem sharing type PrimIO.vector = Vector.vector = Array.vector = VectorSlice.vector = ArraySlice.vector sharing type PrimIO.array = Array.array = ArraySlice.array sharing type PrimIO.vector_slice = VectorSlice.slice = ArraySlice.vector_slice sharing type PrimIO.array_slice = ArraySlice.slice val someElem : PrimIO.elem ): STREAM_IO = struct structure StreamIO = BasicStreamIO(structure PrimIO = PrimIO and Vector = Vector and Array = Array and VectorSlice = VectorSlice and ArraySlice = ArraySlice val someElem = someElem) open StreamIO end; diff --git a/basis/Foreign.sml b/basis/Foreign.sml index a99f567e..41ec054f 100644 --- a/basis/Foreign.sml +++ b/basis/Foreign.sml @@ -1,3590 +1,3590 @@ (* Title: Foreign Function Interface: main part Author: David Matthews Copyright David Matthews 2015-16, 2018 This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) signature FOREIGN = sig exception Foreign of string structure Memory: sig eqtype volatileRef val volatileRef: SysWord.word -> volatileRef val setVolatileRef: volatileRef * SysWord.word -> unit val getVolatileRef: volatileRef -> SysWord.word eqtype voidStar val voidStar2Sysword: voidStar -> SysWord.word val sysWord2VoidStar: SysWord.word -> voidStar val null: voidStar val ++ : voidStar * word -> voidStar val -- : voidStar * word -> voidStar (* Remember an address except across loads. *) val memoise: ('a -> voidStar) ->'a -> unit -> voidStar exception Memory (* malloc - allocate memory. N.B. argument is the number of bytes. Raises Memory exception if it cannot allocate. *) val malloc: word -> voidStar (* free - free allocated memory. *) val free: voidStar -> unit val get8: voidStar * Word.word -> Word8.word val get16: voidStar * Word.word -> Word.word val get32: voidStar * Word.word -> Word32.word val get64: voidStar * Word.word -> SysWord.word val set8: voidStar * Word.word * Word8.word -> unit val set16: voidStar * Word.word * Word.word -> unit val set32: voidStar * Word.word * Word32.word -> unit val set64: voidStar * Word.word * SysWord.word -> unit val getFloat: voidStar * Word.word -> real val getDouble: voidStar * Word.word -> real val setFloat: voidStar * Word.word * real -> unit val setDouble: voidStar * Word.word * real -> unit val getAddress: voidStar * Word.word -> voidStar val setAddress: voidStar * Word.word * voidStar -> unit end structure System: sig type voidStar = Memory.voidStar type externalSymbol val loadLibrary: string -> voidStar and loadExecutable: unit -> voidStar and freeLibrary: voidStar -> unit and getSymbol: voidStar * string -> voidStar and externalFunctionSymbol: string -> externalSymbol and externalDataSymbol: string -> externalSymbol and addressOfExternal: externalSymbol -> voidStar end structure LibFFI: sig eqtype abi (* List of ABIs defined in libffi for this platform. *) val abiList: (string * abi) list (* The default Abi. *) val abiDefault: abi (* Type codes. *) val ffiTypeCodeVoid: Word.word and ffiTypeCodeInt: Word.word and ffiTypeCodeFloat: Word.word and ffiTypeCodeDouble: Word.word and ffiTypeCodeUInt8: Word.word and ffiTypeCodeSInt8: Word.word and ffiTypeCodeUInt16: Word.word and ffiTypeCodeSInt16: Word.word and ffiTypeCodeUInt32: Word.word and ffiTypeCodeSInt32: Word.word and ffiTypeCodeUInt64: Word.word and ffiTypeCodeSInt64: Word.word and ffiTypeCodeStruct: Word.word and ffiTypeCodePointer: Word.word (* Predefined types. These are addresses so have to be reloaded in each session. *) eqtype ffiType val ffiType2voidStar: ffiType -> Memory.voidStar val voidStar2ffiType: Memory.voidStar -> ffiType val getFFItypeVoid: unit -> ffiType and getFFItypeUint8: unit -> ffiType and getFFItypeSint8: unit -> ffiType and getFFItypeUint16: unit -> ffiType and getFFItypeSint16: unit -> ffiType and getFFItypeUint32: unit -> ffiType and getFFItypeSint32: unit -> ffiType and getFFItypeUint64: unit -> ffiType and getFFItypeSint64: unit -> ffiType and getFFItypeFloat: unit -> ffiType and getFFItypeDouble: unit -> ffiType and getFFItypePointer: unit -> ffiType and getFFItypeUChar: unit -> ffiType and getFFItypeSChar: unit -> ffiType and getFFItypeUShort: unit -> ffiType and getFFItypeSShort: unit -> ffiType and getFFItypeUint: unit -> ffiType and getFFItypeSint: unit -> ffiType and getFFItypeUlong: unit -> ffiType and getFFItypeSlong: unit -> ffiType val extractFFItype: ffiType -> { size: word, align: word, typeCode: word, elements: ffiType list } val createFFItype: { size: word, align: word, typeCode: word, elements: ffiType list } -> ffiType eqtype cif val cif2voidStar: cif -> Memory.voidStar val voidStar2cif: Memory.voidStar -> cif val createCIF: abi * ffiType * ffiType list -> cif val callFunction: { cif: cif, function: Memory.voidStar, result: Memory.voidStar, arguments: Memory.voidStar } -> unit val createCallback: (Memory.voidStar * Memory.voidStar -> unit) * cif -> Memory.voidStar val freeCallback: Memory.voidStar -> unit end structure Error: sig - type syserror = OS.syserror + type syserror = LibrarySupport.syserror val getLastError: unit -> SysWord.word val setLastError: SysWord.word -> unit val fromWord: SysWord.word -> syserror and toWord: syserror -> SysWord.word end type library type symbol val loadLibrary: string -> library val loadExecutable: unit -> library val getSymbol: library -> string -> symbol val symbolAsAddress: symbol -> Memory.voidStar val externalFunctionSymbol: string -> symbol and externalDataSymbol: string -> symbol structure LowLevel: sig type ctype = { size: Word.word, (* Size in bytes *) align: Word.word, (* Alignment *) ffiType: unit -> LibFFI.ffiType } val cTypeVoid: ctype and cTypePointer: ctype and cTypeInt8: ctype and cTypeChar: ctype and cTypeUint8: ctype and cTypeUchar: ctype and cTypeInt16: ctype and cTypeUint16: ctype and cTypeInt32: ctype and cTypeUint32: ctype and cTypeInt64: ctype and cTypeUint64: ctype and cTypeInt: ctype and cTypeUint: ctype and cTypeLong: ctype and cTypeUlong: ctype and cTypeFloat: ctype and cTypeDouble: ctype val cStruct: ctype list -> ctype val callwithAbi: LibFFI.abi -> ctype list -> ctype -> symbol -> Memory.voidStar list * Memory.voidStar -> unit val call: ctype list -> ctype -> symbol -> Memory.voidStar list * Memory.voidStar -> unit val cFunctionWithAbi: LibFFI.abi -> ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar val cFunction: ctype list -> ctype -> (Memory.voidStar * Memory.voidStar -> unit) -> Memory.voidStar end type 'a conversion val makeConversion: { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } -> 'a conversion val breakConversion: 'a conversion -> { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store value and return free function. *) ctype: LowLevel.ctype } val cVoid: unit conversion val cPointer: Memory.voidStar conversion val cInt8: int conversion val cUint8: int conversion val cChar: char conversion val cUchar: Word8.word conversion val cInt16: int conversion val cUint16: int conversion val cInt32: int conversion val cUint32: int conversion val cInt64: int conversion val cUint64: int conversion val cInt32Large: LargeInt.int conversion val cUint32Large: LargeInt.int conversion val cInt64Large: LargeInt.int conversion val cUint64Large: LargeInt.int conversion val cShort: int conversion val cUshort: int conversion val cInt: int conversion val cUint: int conversion val cLong: int conversion val cUlong: int conversion val cIntLarge: LargeInt.int conversion val cUintLarge: LargeInt.int conversion val cLongLarge: LargeInt.int conversion val cUlongLarge: LargeInt.int conversion val cString: string conversion val cByteArray: Word8Vector.vector conversion val cFloat: real conversion val cDouble: real conversion (* When a pointer e.g. a string may be null. *) val cOptionPtr: 'a conversion -> 'a option conversion type 'a closure val cFunction: ('a->'b) closure conversion val buildClosure0withAbi: (unit -> 'a) * LibFFI.abi * unit * 'a conversion -> (unit -> 'a) closure val buildClosure0: (unit -> 'a) * unit * 'a conversion -> (unit -> 'a) closure val buildClosure1withAbi: ('a -> 'b) * LibFFI.abi * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure1: ('a -> 'b) * 'a conversion * 'b conversion -> ('a -> 'b) closure val buildClosure2withAbi: ('a * 'b -> 'c) * LibFFI.abi * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure2: ('a * 'b -> 'c) * ('a conversion * 'b conversion) * 'c conversion -> ('a * 'b -> 'c) closure val buildClosure3withAbi: ('a * 'b *'c -> 'd) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure3: ('a * 'b *'c -> 'd) * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> ('a * 'b *'c -> 'd) closure val buildClosure4withAbi: ('a * 'b * 'c * 'd -> 'e) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure4: ('a * 'b * 'c * 'd -> 'e) * ('a conversion * 'b conversion * 'c conversion* 'd conversion) * 'e conversion -> ('a * 'b * 'c * 'd -> 'e) closure val buildClosure5withAbi: ('a * 'b * 'c * 'd * 'e -> 'f) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure5: ('a * 'b * 'c * 'd * 'e -> 'f) * ('a conversion * 'b conversion * 'c conversion* 'd conversion * 'e conversion) * 'f conversion -> ('a * 'b * 'c * 'd * 'e -> 'f) closure val buildClosure6withAbi: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * LibFFI.abi * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure val buildClosure6: ('a * 'b * 'c * 'd * 'e * 'f -> 'g) * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> ('a * 'b * 'c * 'd * 'e * 'f -> 'g) closure (* Remove the "free" from a conversion. Used if extra memory allocated by the argument must not be freed when the function returns. *) val permanent: 'a conversion -> 'a conversion (* Call by reference. *) val cStar: 'a conversion -> 'a ref conversion (* Pass a const pointer *) val cConstStar: 'a conversion -> 'a conversion (* Fixed size vector. It is treated as a struct and passed by value or embedded in a structure. *) val cVectorFixedSize: int * 'a conversion -> 'a vector conversion (* Pass an ML vector as a pointer to a C array. *) and cVectorPointer: 'a conversion -> 'a vector conversion (* Pass an ML array as a pointer to a C array and, on return, update each element of the ML array from the C array. *) and cArrayPointer: 'a conversion -> 'a array conversion (* structs. *) val cStruct2: 'a conversion * 'b conversion -> ('a * 'b) conversion val cStruct3: 'a conversion * 'b conversion * 'c conversion -> ('a*'b*'c)conversion val cStruct4: 'a conversion * 'b conversion * 'c conversion * 'd conversion -> ('a*'b*'c*'d)conversion val cStruct5: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion -> ('a*'b*'c*'d*'e)conversion val cStruct6: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion -> ('a*'b*'c*'d*'e*'f)conversion val cStruct7: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion -> ('a*'b*'c*'d*'e*'f*'g)conversion val cStruct8: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion -> ('a*'b*'c*'d*'e*'f*'g*'h)conversion val cStruct9: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i)conversion val cStruct10: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j)conversion val cStruct11: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k)conversion val cStruct12: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l)conversion val cStruct13: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m)conversion val cStruct14: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n)conversion val cStruct15: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o)conversion val cStruct16: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p)conversion val cStruct17: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q)conversion val cStruct18: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r)conversion val cStruct19: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s)conversion val cStruct20: 'a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion * 'o conversion * 'p conversion * 'q conversion * 'r conversion * 's conversion * 't conversion -> ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s*'t)conversion val buildCall0withAbi: LibFFI.abi * symbol * unit * 'a conversion -> unit -> 'a val buildCall0: symbol * unit * 'a conversion -> unit -> 'a val buildCall1withAbi: LibFFI.abi * symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall1: symbol * 'a conversion * 'b conversion -> 'a -> 'b val buildCall2withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall2: symbol * ('a conversion * 'b conversion) * 'c conversion -> 'a * 'b -> 'c val buildCall3withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall3: symbol * ('a conversion * 'b conversion * 'c conversion) * 'd conversion -> 'a * 'b * 'c -> 'd val buildCall4withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall4: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion) * 'e conversion -> 'a * 'b * 'c * 'd -> 'e val buildCall5withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall5: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion) * 'f conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val buildCall6withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall6: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion) * 'g conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val buildCall7withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall7: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion) * 'h conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val buildCall8withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall8: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion) * 'i conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val buildCall9withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall9: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion) * 'j conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val buildCall10withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall10: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion) * 'k conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val buildCall11withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall11: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion) * 'l conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val buildCall12withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall12: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion) * 'm conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val buildCall13withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall13: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion) * 'n conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val buildCall14withAbi: LibFFI.abi * symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o val buildCall14: symbol * ('a conversion * 'b conversion * 'c conversion * 'd conversion * 'e conversion * 'f conversion * 'g conversion * 'h conversion * 'i conversion * 'j conversion * 'k conversion * 'l conversion * 'm conversion * 'n conversion) * 'o conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o end; structure Foreign:> FOREIGN = struct fun id x = x exception Foreign = RunCall.Foreign open ForeignConstants structure Memory = ForeignMemory infix 6 ++ -- (* Internal utility function. *) fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) local val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg))) end structure System = struct type voidStar = Memory.voidStar type externalSymbol = voidStar fun loadLibrary(s: string): voidStar = ffiGeneral (2, s) and loadExecutable(): voidStar = ffiGeneral (3, ()) and freeLibrary(s: voidStar): unit = ffiGeneral (4, s) and getSymbol(lib: voidStar, s: string): voidStar = ffiGeneral (5, (lib, s)) (* Create an external symbol object. The first word of this is filled in with the address after the code is exported and linked. On a small number of platforms different relocations are required for functions and for data. *) val externalFunctionSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtFn" and externalDataSymbol: string -> externalSymbol = RunCall.rtsCallFull1 "PolyFFICreateExtData" (* An external symbol is a memory cell containing the value in the first word followed by the symbol name. Because the first word is the value it can be treated as a Sysword.word value. When it is created the value is zero and the address of the target is only set once the symbol has been exported and the value set by the linker. *) fun addressOfExternal(ext: externalSymbol): voidStar = if Memory.voidStar2Sysword ext = 0w0 then raise Foreign "External symbol has not been set" else ext end structure Error = struct - type syserror = OS.syserror + type syserror = LibrarySupport.syserror fun toWord (s: syserror): SysWord.word = RunCall.unsafeCast s and fromWord (w: SysWord.word) : syserror = RunCall.unsafeCast w local val callGetError = RunCall.rtsCallFast1 "PolyFFIGetError" in fun getLastError(): SysWord.word = let val mem = RunCall.allocateByteMemory(0w1, 0wx41) val () = callGetError mem val () = RunCall.clearMutableBit mem in RunCall.unsafeCast mem end end val setLastError: SysWord.word -> unit = RunCall.rtsCallFast1 "PolyFFISetError" end structure LibFFI = struct type abi = Word.word val abiList: (string * abi) list = ffiGeneral (50, ()) local fun getConstant (n: int) : Word.word = ffiGeneral (51, n) in val abiDefault = getConstant 0 and ffiTypeCodeVoid = getConstant 1 and ffiTypeCodeInt = getConstant 2 and ffiTypeCodeFloat = getConstant 3 and ffiTypeCodeDouble = getConstant 4 and ffiTypeCodeUInt8 = getConstant 5 and ffiTypeCodeSInt8 = getConstant 6 and ffiTypeCodeUInt16 = getConstant 7 and ffiTypeCodeSInt16 = getConstant 8 and ffiTypeCodeUInt32 = getConstant 9 and ffiTypeCodeSInt32 = getConstant 10 and ffiTypeCodeUInt64 = getConstant 11 and ffiTypeCodeSInt64 = getConstant 12 and ffiTypeCodeStruct = getConstant 13 and ffiTypeCodePointer = getConstant 14 end type ffiType = Memory.voidStar val ffiType2voidStar = id and voidStar2ffiType = id local fun getFFItype (n: int) (): ffiType = ffiGeneral (52, n) in val getFFItypeVoid = getFFItype 0 and getFFItypeUint8 = getFFItype 1 and getFFItypeSint8 = getFFItype 2 and getFFItypeUint16 = getFFItype 3 and getFFItypeSint16 = getFFItype 4 and getFFItypeUint32 = getFFItype 5 and getFFItypeSint32 = getFFItype 6 and getFFItypeUint64 = getFFItype 7 and getFFItypeSint64 = getFFItype 8 and getFFItypeFloat = getFFItype 9 and getFFItypeDouble = getFFItype 10 and getFFItypePointer = getFFItype 11 and getFFItypeUChar = getFFItype 12 and getFFItypeSChar = getFFItype 13 and getFFItypeUShort = getFFItype 14 and getFFItypeSShort = getFFItype 15 and getFFItypeUint = getFFItype 16 and getFFItypeSint = getFFItype 17 and getFFItypeUlong = getFFItype 18 and getFFItypeSlong = getFFItype 19 end fun extractFFItype (s: ffiType) = let val (size: word, align: word, typ: word, elem: Memory.voidStar) = ffiGeneral (53, s) (* Unpack the "elements". *) open Memory fun loadElements i = let val a = getAddress(elem, i) in if a = null then [] else a :: loadElements(i+0w1) end val elements = if elem = sysWord2VoidStar 0w0 then [] else loadElements 0w0 in { size=size, align=align, typeCode = typ, elements = elements } end (* Construct a new FFItype in allocated memory. *) fun createFFItype { size: word, align: word, typeCode: word, elements: ffiType list }: ffiType = ffiGeneral (54, (size, align, typeCode, elements)) type cif = Memory.voidStar val cif2voidStar = id and voidStar2cif = id (* Construct and prepare a CIF in allocated memory. *) fun createCIF (abi: abi, resultType: ffiType, argTypes: ffiType list): cif = ffiGeneral (55, (abi, resultType, argTypes)) (* Call a function. We have to pass some space for the result *) fun callFunction { cif: cif, function: Memory.voidStar, result: Memory.voidStar, arguments: Memory.voidStar }: unit = ffiGeneral (56, (cif, function, result, arguments)) (* Create a callback. Returns the C function. *) fun createCallback(f: Memory.voidStar * Memory.voidStar -> unit, cif: cif): Memory.voidStar = ffiGeneral (57, (f, cif)) (* Free a callback. This takes the C function address returned by createCallback *) fun freeCallback(cb: Memory.voidStar): unit = ffiGeneral (58, cb) end type library = unit -> Memory.voidStar type symbol = unit -> Memory.voidStar (* Load the library but memoise it so if we reference the library in another session we will reload it. We load the library immediately so that if there is an error we get the error immediately. *) fun loadLibrary (name: string): library = Memory.memoise System.loadLibrary name and loadExecutable (): library = Memory.memoise System.loadExecutable () (* To get a symbol we memoise a function that forces a library load if necessary and then gets the symbol. *) fun getSymbol(lib: library) (name: string): symbol = Memory.memoise (fn s => System.getSymbol(lib(), s)) name (* This forces the symbol to be loaded. The result is NOT memoised. *) fun symbolAsAddress(s: symbol): Memory.voidStar = s() (* Create an external symbol. This can only be used after linking. *) fun externalFunctionSymbol(name: string): symbol = let val r = System.externalFunctionSymbol name in fn () => System.addressOfExternal r end and externalDataSymbol(name: string): symbol = let val r = System.externalDataSymbol name in fn () => System.addressOfExternal r end structure LowLevel = struct type ctype = { size: Word.word, (* Size in bytes *) align: Word.word, (* Alignment *) ffiType: unit -> LibFFI.ffiType } local open LibFFI Memory val getffArg = if ffiMinArgSize = 0w4 then Word32.toLargeWord o get32 else if ffiMinArgSize = 0w8 then get64 else raise Foreign ("Unable to load ffi_arg size=" ^ Word.toString ffiMinArgSize) in val cTypeVoid = { size= #size saVoid, align= #align saVoid, ffiType = memoise getFFItypeVoid () } val cTypePointer = { size= #size saPointer, align= #align saPointer, ffiType = memoise getFFItypePointer () } val cTypeInt8 = { size= #size saSint8, align= #align saSint8, ffiType = memoise getFFItypeSint8 () } val cTypeChar = cTypeInt8 val cTypeUint8 = { size= #size saUint8, align= #align saUint8, ffiType = memoise getFFItypeUint8 () } val cTypeUchar = cTypeUint8 val cTypeInt16 = { size= #size saSint16, align= #align saSint16, ffiType = memoise getFFItypeSint16 () } val cTypeUint16 = { size= #size saUint16, align= #align saUint16, ffiType = memoise getFFItypeUint16 () } val cTypeInt32 = { size= #size saSint32, align= #align saSint32, ffiType = memoise getFFItypeSint32 () } val cTypeUint32 = { size= #size saUint32, align= #align saUint32, ffiType = memoise getFFItypeUint32 () } val cTypeInt64 = { size= #size saSint64, align= #align saSint64, ffiType = memoise getFFItypeSint64 () } val cTypeUint64 = { size= #size saUint64, align= #align saUint64, ffiType = memoise getFFItypeUint64 () } val cTypeInt = { size= #size saSint, align= #align saSint, ffiType = memoise getFFItypeSint () } val cTypeUint = { size= #size saUint, align= #align saUint, ffiType = memoise getFFItypeUint () } val cTypeLong = { size= #size saSlong, align= #align saSlong, ffiType = memoise getFFItypeSlong () } val cTypeUlong = { size= #size saUlong, align= #align saUlong, ffiType = memoise getFFItypeUlong () } val cTypeFloat = { size= #size saFloat, align= #align saFloat, ffiType = memoise getFFItypeFloat () } val cTypeDouble = { size= #size saDouble, align= #align saDouble, ffiType = memoise getFFItypeDouble () } fun cStruct(fields: ctype list): ctype = let (* The total alignment is the maximum alignment of the fields. *) val align = foldl(fn ({align, ...}, a) => Word.max(align, a)) 0w1 fields (* Each field needs to be on its alignment. Finally we round up the size to the total alignment. *) val size = alignUp(foldl(fn ({align, size, ...}, s) => alignUp(s, align) + size) 0w0 fields, align) val types = map #ffiType fields (* Make the type but only when it's used. *) fun ffiType () = LibFFI.createFFItype { size = size, align = align, typeCode=LibFFI.ffiTypeCodeStruct, elements = map (fn t => t()) types } in {align=align, size=size, ffiType=memoise ffiType ()} end fun callwithAbi (abi: abi) (argTypes: ctype list) (resType: ctype): symbol -> voidStar list * voidStar -> unit = let (* Preparation when we create the function. *) fun buildCif () = createCIF (abi, #ffiType resType (), map (fn {ffiType, ...} => ffiType ()) argTypes) val cif: unit->cif = memoise buildCif () val nArgs = List.length argTypes val resSize = #size resType (* If the result size is smaller than ffiMinArgSize we have to first store the result in a value of size ffiMinArgSize then copy the result. This is a restriction of libffi. *) fun smallSpace (fnAddr: unit->voidStar) (args, resMem) = let val _ = List.length args = nArgs orelse raise Foreign "Incorrect number of arguments" val resultSize = alignUp(ffiMinArgSize, #align saPointer) val argResVec = malloc(resultSize + #size saPointer * Word.fromInt nArgs) val argLocn = argResVec ++ resultSize val _ = List.foldl(fn (arg, n) => (setAddress(argLocn, n, arg); n+0w1)) 0w0 args in let val () = callFunction { cif=cif(), function=fnAddr(), result = argResVec, arguments = argLocn} val result: SysWord.word = getffArg(argResVec, 0w0) in (* Copy to the final location. Currently "void" has size 1 so if the function has a void result we still copy one byte. *) if #size resType = 0w1 then set8(resMem, 0w0, Word8.fromLargeWord result) else if #size resType = 0w2 then set16(resMem, 0w0, Word.fromLargeWord result) else if #size resType = 0w4 then set32(resMem, 0w0, Word32.fromLargeWord result) else raise Foreign "Unable to set result: wrong size"; free argResVec end handle exn => (free argResVec; raise exn) end (* If we have enough space. *) fun largeSpace (fnAddr: unit->voidStar) (args, resMem) = let val _ = List.length args = nArgs orelse raise Foreign "Incorrect number of arguments" val argVec = if nArgs = 0 then null else malloc(#size saPointer * Word.fromInt nArgs) val _ = List.foldl(fn (arg, n) => (setAddress(argVec, n, arg); n+0w1)) 0w0 args in let val () = callFunction { cif=cif(), function=fnAddr(), result = resMem, arguments = argVec} in free argVec end handle exn => (free argVec; raise exn) end in if resSize < ffiMinArgSize then smallSpace else largeSpace 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): (voidStar * voidStar -> unit) -> voidStar = let fun buildCif () = createCIF (abi, #ffiType resType (), map (fn {ffiType, ...} => ffiType ()) argTypes) val cif: unit->cif = memoise buildCif () in fn cbFun => createCallback(cbFun, cif()) end fun cFunction x = cFunctionWithAbi abiDefault x end end type 'a conversion = { load: Memory.voidStar -> 'a, (* Load a value from C memory *) store: Memory.voidStar * 'a -> unit -> unit, (* Store a value in C memory *) updateML: Memory.voidStar * 'a -> unit, (* Update ML value after call - only used in cStar. *) updateC: Memory.voidStar * 'a -> unit, (* Update C value after callback - only used in cStar. *) ctype: LowLevel.ctype } fun makeConversion { load, store, ctype } = { load = load, store = store, ctype = ctype, updateML = fn _ => (), updateC = fn _ => () } fun breakConversion({load, store, ctype, ... }: 'a conversion) = { load = load, store = store, ctype = ctype } (* Conversions *) local open LibFFI Memory LowLevel fun checkRangeShort(i, min, max) = if i < min orelse i > max then raise Overflow else i fun checkRangeLong(i: LargeInt.int, min, max) = if i < min orelse i > max then raise Overflow else i fun noFree _ = () (* None of these allocate extra memory or need to update. *) in val cVoid: unit conversion = makeConversion{ load=fn _ => (), store=fn _ => noFree, ctype = cTypeVoid } (* cPointer should only be used to base other conversions on. *) val cPointer: voidStar conversion = makeConversion { load=fn a => getAddress(a, 0w0), store=fn(a, v) => (setAddress(a, 0w0, v); noFree), ctype = cTypePointer } local fun load(m: voidStar): int = Word8.toIntX(get8(m, 0w0)) fun store(m: voidStar, i: int) = (set8(m, 0w0, Word8.fromInt(checkRangeShort(i, ~128, 127))); noFree) in val cInt8: int conversion = makeConversion { load=load, store=store, ctype = cTypeInt8 } end local (* Char is signed in C but unsigned in ML. *) fun load(m: voidStar): char = Char.chr(Word8.toInt(get8(m, 0w0))) fun store(m: voidStar, i: char) = (set8(m, 0w0, Word8.fromInt(Char.ord i)); noFree) in val cChar: char conversion = makeConversion{ load=load, store=store, ctype = cTypeChar } end local (* Uchar - convert as Word8.word. *) fun load(m: voidStar): Word8.word = get8(m, 0w0) fun store(m: voidStar, i: Word8.word) = (set8(m, 0w0, i); noFree) in val cUchar: Word8.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUchar } end local fun load(m: voidStar): int = Word8.toInt(get8(m, 0w0)) fun store(m: voidStar, i: int) = (set8(m, 0w0, Word8.fromInt(checkRangeShort(i, 0, 255))); noFree) in val cUint8: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint8 } end local (* Because the word length is greater than the length returned by get16 we have to do something special to get the sign bit correct. That isn't necessary in the other cases. *) fun load(m: voidStar): int = let (* Could be done with shifts *) val r = Word.toInt(get16(m, 0w0)) in if r >= 32768 then r - 65536 else r end fun store(m: voidStar, i: int) = (set16(m, 0w0, Word.fromInt(checkRangeShort(i, ~32768, 32767))); noFree) in val cInt16: int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt16 } end local fun load(m: voidStar): int = Word.toInt(get16(m, 0w0)) fun store(m: voidStar, i: int) = (set16(m, 0w0, Word.fromInt(checkRangeShort(i, 0, 65535))); noFree) in val cUint16: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint16 } end local fun load(m: voidStar): int = Word32.toIntX(get32(m, 0w0)) val checkRange = if wordSize = 0w4 andalso isSome (Int.maxInt) then fn i => i (* We're using fixed precision 31-bit - no check necessary. *) else let (* These will overflow on fixed precision 31-bit. *) val max32 = Int32.toInt(valOf Int32.maxInt) val min32 = ~max32 - 1 in fn i => checkRangeShort(i, min32, max32) end fun store(m: voidStar, i: int) = (set32(m, 0w0, Word32.fromInt(checkRange i)); noFree) in val cInt32: int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt32 } end local fun load(m: voidStar): LargeInt.int = Word32.toLargeIntX(get32(m, 0w0)) fun store(m: voidStar, i: LargeInt.int) = (set32(m, 0w0, Word32.fromLargeInt(checkRangeLong(i, ~2147483648, 2147483647))); noFree) in val cInt32Large: LargeInt.int conversion = makeConversion{ load=load, store=store, ctype = cTypeInt32 } end local fun load(m: voidStar): int = Word32.toInt(get32(m, 0w0)) val checkRange = if wordSize = 0w4 andalso isSome (Int.maxInt) then fn i => if i < 0 then raise Overflow else i (* Fixed precision 31-bit *) else let (* This will overflow on fixed precision 31-bit. *) val max32 = Int32.toInt(valOf Int32.maxInt) val max32Unsigned = max32 * 2 + 1 in fn i => checkRangeShort(i, 0, max32Unsigned) end fun store(m: voidStar, i: int) = (set32(m, 0w0, Word32.fromInt(checkRange i)); noFree) in val cUint32: int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end local fun load(m: voidStar): LargeInt.int = Word32.toLargeInt(get32(m, 0w0)) fun store(m: voidStar, i: LargeInt.int) = (set32(m, 0w0, Word32.fromLargeInt(checkRangeLong(i, 0, 4294967295))); noFree) in val cUint32Large: LargeInt.int conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end local fun loadLarge(m: voidStar): LargeInt.int = if sysWordSize = 0w4 then let val v1 = get32(m, 0w0) and v2 = get32(m, 0w1) in if bigEndian then IntInf.<<(Word32.toLargeIntX v1, 0w32) + Word32.toLargeInt v2 else IntInf.<<(Word32.toLargeIntX v2, 0w32) + Word32.toLargeInt v1 end else SysWord.toLargeIntX(get64(m, 0w0)) fun loadShort(m: voidStar): int = if sysWordSize = 0w4 then Int.fromLarge(loadLarge m) else SysWord.toIntX(get64(m, 0w0)) val max = IntInf.<<(1, 0w63) - 1 and min = ~ (IntInf.<<(1, 0w63)) fun storeLarge(m: voidStar, i: LargeInt.int) = if sysWordSize = 0w4 then let val _ = checkRangeLong(i, min, max) val lo = Word32.fromLargeInt i and hi = Word32.fromLargeInt (IntInf.~>>(i, 0w32)) in if bigEndian then (set32(m, 0w0, hi); set32(m, 0w1, lo)) else (set32(m, 0w0, lo); set32(m, 0w1, hi)); noFree end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, min, max))); noFree) fun storeShort(m: voidStar, i: int) = if sysWordSize = 0w4 orelse not (isSome Int.maxInt) then (* 32-bit or arbitrary precision. *) storeLarge(m, LargeInt.fromInt i) else (* Fixed precision 64-bit - no need for a range check. *) (set64(m, 0w0, SysWord.fromInt i); noFree) in val cInt64: int conversion = makeConversion{ load=loadShort, store=storeShort, ctype = cTypeInt64 } and cInt64Large: LargeInt.int conversion = makeConversion{ load=loadLarge, store=storeLarge, ctype = cTypeInt64 } end local fun loadLarge(m: voidStar): LargeInt.int = if sysWordSize = 0w4 then let val v1 = get32(m, 0w0) and v2 = get32(m, 0w1) in if bigEndian then IntInf.<<(Word32.toLargeInt v1, 0w32) + Word32.toLargeInt v2 else IntInf.<<(Word32.toLargeInt v2, 0w32) + Word32.toLargeInt v1 end else SysWord.toLargeInt(get64(m, 0w0)) fun loadShort(m: voidStar): int = if wordSize = 0w4 then Int.fromLarge(loadLarge m) else SysWord.toInt(get64(m, 0w0)) val max = IntInf.<<(1, 0w64) - 1 fun storeLarge(m: voidStar, i: LargeInt.int) = if sysWordSize = 0w4 then let val _ = checkRangeLong(i, 0, max) val lo = Word32.fromLargeInt i and hi = Word32.fromLargeInt (IntInf.~>>(i, 0w32)) in if bigEndian then (set32(m, 0w0, hi); set32(m, 0w1, lo)) else (set32(m, 0w0, lo); set32(m, 0w1, hi)); noFree end else (set64(m, 0w0, SysWord.fromLargeInt(checkRangeLong(i, 0, max))); noFree) fun storeShort(m: voidStar, i: int) = if sysWordSize = 0w4 orelse not (isSome Int.maxInt) then (* 32-bit or arbitrary precision. *) storeLarge(m, LargeInt.fromInt i) else if i < 0 (* Fixed precision 64-bit - just check it's not negative. *) then raise Overflow else (set64(m, 0w0, SysWord.fromInt i); noFree) in val cUint64: int conversion = makeConversion{ load=loadShort, store=storeShort, ctype = cTypeUint64 } and cUint64Large: LargeInt.int conversion = makeConversion{ load=loadLarge, store=storeLarge, ctype = cTypeUint64 } end local fun load(m: voidStar): real = getFloat(m, 0w0) fun store(m: voidStar, v: real) = (setFloat(m, 0w0, v); noFree) in val cFloat: real conversion = makeConversion{ load=load, store=store, ctype = cTypeFloat } end local fun load(m: voidStar): real = getDouble(m, 0w0) fun store(m: voidStar, v: real) = (setDouble(m, 0w0, v); noFree) in val cDouble: real conversion = makeConversion{ load=load, store=store, ctype = cTypeDouble } end val cShort = if #size saSShort = #size saSint16 then cInt16 (*else if #size saSShort = #size saSint32 then cInt32*) else raise Foreign "Unable to find type for short" val cUshort = if #size saUShort = #size saUint16 then cUint16 (*else if #size saUShort = #size saUint32 then cUint32*) else raise Foreign "Unable to find type for unsigned" val cInt = (*if #size saSint = #size saSint16 then cInt16 else *)if #size saSint = #size saSint32 then cInt32 else if #size saSint = #size saSint64 then cInt64 else raise Foreign "Unable to find type for int" val cIntLarge = (*if #size saSint = #size saSint16 then cInt16 else *)if #size saSint = #size saSint32 then cInt32Large else if #size saSint = #size saSint64 then cInt64Large else raise Foreign "Unable to find type for int" val cUint = (*if #size saUint = #size saUint16 then cUint16 else *)if #size saUint = #size saUint32 then cUint32 else if #size saUint = #size saUint64 then cUint64 else raise Foreign "Unable to find type for unsigned" val cUintLarge = (*if #size saUint = #size saUint16 then cUint16 else *)if #size saUint = #size saUint32 then cUint32Large else if #size saUint = #size saUint64 then cUint64Large else raise Foreign "Unable to find type for unsigned" val cLong = (*if #size saSlong = #size saSint16 then cInt16 else *)if #size saSlong = #size saSint32 then cInt32 else if #size saSlong = #size saSint64 then cInt64 else raise Foreign "Unable to find type for long" val cLongLarge = (*if #size saSlong = #size saSint16 then cInt16 else *)if #size saSlong = #size saSint32 then cInt32Large else if #size saSlong = #size saSint64 then cInt64Large else raise Foreign "Unable to find type for long" val cUlong = (*if #size saUlong = #size saUint16 then cUint16 else *)if #size saUlong = #size saUint32 then cUint32 else if #size saUlong = #size saUint64 then cUint64 else raise Foreign "Unable to find type for unsigned long" val cUlongLarge = (*if #size saUlong = #size saUint16 then cUint16 else *)if #size saUlong = #size saUint32 then cUint32Large else if #size saUlong = #size saUint64 then cUint64Large else raise Foreign "Unable to find type for unsigned long" local fun load(s: voidStar): string = let (* The location contains the address of the string. *) val sAddr = getAddress(s, 0w0) fun sLen i = if get8(sAddr, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(sAddr, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let val sLen = Word.fromInt(String.size s) val sMem = malloc(sLen + 0w1) val () = CharVector.appi(fn(i, ch) => set8(sMem, Word.fromInt i, Word8.fromInt(Char.ord ch))) s val () = set8(sMem, sLen, 0w0) in setAddress(v, 0w0, sMem); fn () => Memory.free sMem end in val cString: string conversion = makeConversion { load=load, store=store, ctype = cTypePointer } end (* This is used if we want to pass NULL rather than a pointer in some cases. *) fun cOptionPtr({load, store, updateML, updateC, ctype}:'a conversion): 'a option conversion = if #typeCode(extractFFItype(#ffiType ctype ())) <> ffiTypeCodePointer then raise Foreign "cOptionPtr must be applied to a pointer type" else let fun loadOpt(s: voidStar) = if getAddress(s, 0w0) = null then NONE else SOME(load s) fun storeOpt(v: voidStar, NONE) = (setAddress(v, 0w0, null); fn _ => ()) | storeOpt(v: voidStar, SOME s) = store(v, s) (* Do we have update here? *) fun updateMLOpt(_, NONE) = () | updateMLOpt(v: voidStar, SOME s) = updateML(v, s) fun updateCOpt(_, NONE) = () | updateCOpt(v, SOME s) = updateC(v, s) in { load=loadOpt, store=storeOpt, updateML = updateMLOpt, updateC = updateCOpt, ctype = cTypePointer } end local (* Word8Vector.vector to C array of bytes. It is only possible to do this one way because conversion from a C array requires us to know the size. *) fun load _ = raise Foreign "cByteArray cannot convert from C to ML" fun store(v: voidStar, s: Word8Vector.vector) = let open Word8Vector val sLen = Word.fromInt(length s) val sMem = malloc sLen val () = appi(fn(i, b) => set8(sMem, Word.fromInt i, b)) s in setAddress(v, 0w0, sMem); fn () => Memory.free sMem end in val cByteArray: Word8Vector.vector conversion = makeConversion{ load=load, store=store, ctype = cTypePointer } end end (* Remove the free part from the store fn. This is intended for situations where an argument should not be deleted once the function completes. *) fun permanent({load, store, ctype, updateML, updateC }: 'a conversion): 'a conversion = let fun storeP args = (ignore (store args); fn () => ()) in { load=load, store=storeP, updateML = updateML, updateC = updateC, ctype=ctype } end val op ++ = Memory.++ fun cStruct2(a: 'a conversion, b: 'b conversion): ('a*'b)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ... }} = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {align=alignb, ... }} = b val offsetb = alignUp(sizea, alignb) fun load s = (loada s, loadb(s ++ offsetb)) and store (x, (a, b)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) in fn () => ( freea(); freeb() ) end and updateML(s, (a, b)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b)) and updateC(x, (a, b)) = (updateCa(x, a); updateCb(x ++ offsetb, b)) in {load=load, store=store, updateML = updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb]} end fun cStruct3(a: 'a conversion, b: 'b conversion, c: 'c conversion): ('a*'b*'c)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {align=alignc, ...} } = c val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc)) and store (x, (a, b, c)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) in fn () => ( freea(); freeb(); freec() ) end and updateML(s, (a, b, c)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c)) and updateC(x, (a, b, c)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec]} end fun cStruct4(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion): ('a*'b*'c*'d)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {align=alignd, ...} } = d val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd)) and store (x, (a, b, c, d)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) in fn () => ( freea(); freeb(); freec(); freed() ) end and updateML(s, (a, b, c, d)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d)) and updateC(x, (a, b, c, d)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped]} end fun cStruct5(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion): ('a*'b*'c*'d*'e)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {align=aligne, ...} } = e val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete)) and store (x, (a, b, c, d, e)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) in fn () => ( freea(); freeb(); freec(); freed(); freee() ) end and updateML(s, (a, b, c, d, e)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e)) and updateC(x, (a, b, c, d, e)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee]} end fun cStruct6(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion): ('a*'b*'c*'d*'e*'f)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {align=alignf, ...} } = f val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf)) and store (x, (a, b, c, d, e, f)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef() ) end and updateML(s, (a, b, c, d, e, f)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f)) and updateC(x, (a, b, c, d, e, f)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef]} end fun cStruct7(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion): ('a*'b*'c*'d*'e*'f*'g)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {align=aligng, ...} } = g val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg)) and store (x, (a, b, c, d, e, f, g)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg() ) end and updateML(s, (a, b, c, d, e, f, g)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g)) and updateC(x, (a, b, c, d, e, f, g)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg]} end fun cStruct8(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion): ('a*'b*'c*'d*'e*'f*'g*'h)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {align=alignh, ...} } = h val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth)) and store (x, (a, b, c, d, e, f, g, h)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh() ) end and updateML(s, (a, b, c, d, e, f, g, h)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g); updateMLh(s ++ offseth, h)) and updateC(x, (a, b, c, d, e, f, g, h)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh]} end fun cStruct9(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {align=aligni, ...} } = i val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti)) and store (x, (a, b, c, d, e, f, g, h, i)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei() ) end and updateML(s, (a, b, c, d, e, f, g, h, i)) = (updateMLa(s, a); updateMLb(s ++ offsetb, b); updateMLc(s ++ offsetc, c); updateMLd(s ++ offsetd, d); updateMLe(s ++ offsete, e); updateMLf(s ++ offsetf, f); updateMLg(s ++ offsetg, g); updateMLh(s ++ offseth, h); updateMLi(s ++ offseti, i)) and updateC(x, (a, b, c, d, e, f, g, h, i)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei]} end fun cStruct10(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {align=alignj, ...} } = j val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj)) and store (x, (a, b, c, d, e, f, g, h, i, j)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j)) and updateC(x, (a, b, c, d, e, f, g, h, i, j)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej]} end fun cStruct11(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {align=alignk, ...} } = k val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk)) and store (x, (a, b, c, d, e, f, g, h, i, j, k)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek]} end fun cStruct12(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {align=alignl, ...} } = l val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel]} end fun cStruct13(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {align=alignm, ...} } = m val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem]} end nonfix o fun cStruct14(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {align=alignn, ...} } = n val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen]} end fun cStruct15(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {align=aligno, ...} } = o val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo]} end fun cStruct16(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {align=alignp, ...} } = p val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep]} end fun cStruct17(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {align=alignq, ...} } = q val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq]} end fun cStruct18(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {align=alignr, ...} } = r val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper]} end fun cStruct19(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion, s: 's conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {size=sizer, align=alignr, ...} } = r and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = ctypes as {align=aligns, ...} } = s val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) val offsets = alignUp(offsetr + sizer, aligns) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr), loads(s ++ offsets)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) and frees = stores(x ++ offsets, s) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer(); frees() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r); updateMLs(x ++ offsets, s)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r); updateCs(x ++ offsets, s)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes]} end fun cStruct20(a: 'a conversion, b: 'b conversion, c: 'c conversion, d: 'd conversion, e: 'e conversion, f: 'f conversion, g: 'g conversion, h: 'h conversion, i: 'i conversion, j: 'j conversion, k: 'k conversion, l: 'l conversion, m: 'm conversion, n: 'n conversion, o: 'o conversion, p: 'p conversion, q: 'q conversion, r: 'r conversion, s: 's conversion, t: 't conversion): ('a*'b*'c*'d*'e*'f*'g*'h*'i*'j*'k*'l*'m*'n*'o*'p*'q*'r*'s*'t)conversion = let val {load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype = ctypea as {size=sizea, ...} } = a and {load=loadb, store=storeb, updateML=updateMLb, updateC=updateCb, ctype = ctypeb as {size=sizeb, align=alignb, ...} } = b and {load=loadc, store=storec, updateML=updateMLc, updateC=updateCc, ctype = ctypec as {size=sizec, align=alignc, ...} } = c and {load=loadd, store=stored, updateML=updateMLd, updateC=updateCd, ctype = ctyped as {size=sized, align=alignd, ...} } = d and {load=loade, store=storee, updateML=updateMLe, updateC=updateCe, ctype = ctypee as {size=sizee, align=aligne, ...} } = e and {load=loadf, store=storef, updateML=updateMLf, updateC=updateCf, ctype = ctypef as {size=sizef, align=alignf, ...} } = f and {load=loadg, store=storeg, updateML=updateMLg, updateC=updateCg, ctype = ctypeg as {size=sizeg, align=aligng, ...} } = g and {load=loadh, store=storeh, updateML=updateMLh, updateC=updateCh, ctype = ctypeh as {size=sizeh, align=alignh, ...} } = h and {load=loadi, store=storei, updateML=updateMLi, updateC=updateCi, ctype = ctypei as {size=sizei, align=aligni, ...} } = i and {load=loadj, store=storej, updateML=updateMLj, updateC=updateCj, ctype = ctypej as {size=sizej, align=alignj, ...} } = j and {load=loadk, store=storek, updateML=updateMLk, updateC=updateCk, ctype = ctypek as {size=sizek, align=alignk, ...} } = k and {load=loadl, store=storel, updateML=updateMLl, updateC=updateCl, ctype = ctypel as {size=sizel, align=alignl, ...} } = l and {load=loadm, store=storem, updateML=updateMLm, updateC=updateCm, ctype = ctypem as {size=sizem, align=alignm, ...} } = m and {load=loadn, store=storen, updateML=updateMLn, updateC=updateCn, ctype = ctypen as {size=sizen, align=alignn, ...} } = n and {load=loado, store=storeo, updateML=updateMLo, updateC=updateCo, ctype = ctypeo as {size=sizeo, align=aligno, ...} } = o and {load=loadp, store=storep, updateML=updateMLp, updateC=updateCp, ctype = ctypep as {size=sizep, align=alignp, ...} } = p and {load=loadq, store=storeq, updateML=updateMLq, updateC=updateCq, ctype = ctypeq as {size=sizeq, align=alignq, ...} } = q and {load=loadr, store=storer, updateML=updateMLr, updateC=updateCr, ctype = ctyper as {size=sizer, align=alignr, ...} } = r and {load=loads, store=stores, updateML=updateMLs, updateC=updateCs, ctype = ctypes as {size=sizes, align=aligns, ...} } = s and {load=loadt, store=storet, updateML=updateMLt, updateC=updateCt, ctype = ctypet as {align=alignt, ...} } = t val offsetb = alignUp(sizea, alignb) val offsetc = alignUp(offsetb + sizeb, alignc) val offsetd = alignUp(offsetc + sizec, alignd) val offsete = alignUp(offsetd + sized, aligne) val offsetf = alignUp(offsete + sizee, alignf) val offsetg = alignUp(offsetf + sizef, aligng) val offseth = alignUp(offsetg + sizeg, alignh) val offseti = alignUp(offseth + sizeh, aligni) val offsetj = alignUp(offseti + sizei, alignj) val offsetk = alignUp(offsetj + sizej, alignk) val offsetl = alignUp(offsetk + sizek, alignl) val offsetm = alignUp(offsetl + sizel, alignm) val offsetn = alignUp(offsetm + sizem, alignn) val offseto = alignUp(offsetn + sizen, aligno) val offsetp = alignUp(offseto + sizeo, alignp) val offsetq = alignUp(offsetp + sizep, alignq) val offsetr = alignUp(offsetq + sizeq, alignr) val offsets = alignUp(offsetr + sizer, aligns) val offsett = alignUp(offsets + sizes, alignt) fun load s = (loada s, loadb(s ++ offsetb), loadc(s ++ offsetc), loadd(s ++ offsetd), loade(s ++ offsete), loadf(s ++ offsetf), loadg(s ++ offsetg), loadh(s ++ offseth), loadi(s ++ offseti), loadj(s ++ offsetj), loadk(s ++ offsetk), loadl(s ++ offsetl), loadm(s ++ offsetm), loadn(s ++ offsetn), loado(s ++ offseto), loadp(s ++ offsetp), loadq(s ++ offsetq), loadr(s ++ offsetr), loads(s ++ offsets), loadt(s ++ offsett)) and store (x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = let val freea = storea(x, a) and freeb = storeb(x ++ offsetb, b) and freec = storec(x ++ offsetc, c) and freed = stored(x ++ offsetd, d) and freee = storee(x ++ offsete, e) and freef = storef(x ++ offsetf, f) and freeg = storeg(x ++ offsetg, g) and freeh = storeh(x ++ offseth, h) and freei = storei(x ++ offseti, i) and freej = storej(x ++ offsetj, j) and freek = storek(x ++ offsetk, k) and freel = storel(x ++ offsetl, l) and freem = storem(x ++ offsetm, m) and freen = storen(x ++ offsetn, n) and freeo = storeo(x ++ offseto, o) and freep = storep(x ++ offsetp, p) and freeq = storeq(x ++ offsetq, q) and freer = storer(x ++ offsetr, r) and frees = stores(x ++ offsets, s) and freet = storet(x ++ offsett, t) in fn () => ( freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); freeo(); freep(); freeq(); freer(); frees(); freet() ) end and updateML(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = (updateMLa(x, a); updateMLb(x ++ offsetb, b); updateMLc(x ++ offsetc, c); updateMLd(x ++ offsetd, d); updateMLe(x ++ offsete, e); updateMLf(x ++ offsetf, f); updateMLg(x ++ offsetg, g); updateMLh(x ++ offseth, h); updateMLi(x ++ offseti, i); updateMLj(x ++ offsetj, j); updateMLk(x ++ offsetk, k); updateMLl(x ++ offsetl, l); updateMLm(x ++ offsetm, m); updateMLn(x ++ offsetn, n); updateMLo(x ++ offseto, o); updateMLp(x ++ offsetp, p); updateMLq(x ++ offsetq, q); updateMLr(x ++ offsetr, r); updateMLs(x ++ offsets, s); updateMLt(x ++ offsett, t)) and updateC(x, (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)) = (updateCa(x, a); updateCb(x ++ offsetb, b); updateCc(x ++ offsetc, c); updateCd(x ++ offsetd, d); updateCe(x ++ offsete, e); updateCf(x ++ offsetf, f); updateCg(x ++ offsetg, g); updateCh(x ++ offseth, h); updateCi(x ++ offseti, i); updateCj(x ++ offsetj, j); updateCk(x ++ offsetk, k); updateCl(x ++ offsetl, l); updateCm(x ++ offsetm, m); updateCn(x ++ offsetn, n); updateCo(x ++ offseto, o); updateCp(x ++ offsetp, p); updateCq(x ++ offsetq, q); updateCr(x ++ offsetr, r); updateCs(x ++ offsets, s); updateCt(x ++ offsett, t)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = LowLevel.cStruct[ctypea, ctypeb, ctypec, ctyped, ctypee, ctypef, ctypeg, ctypeh, ctypei, ctypej, ctypek, ctypel, ctypem, ctypen, ctypeo, ctypep, ctypeq, ctyper, ctypes, ctypet]} end (* Conversion for call-by-reference. *) local open Memory LowLevel in fun cStar({load=loada, store=storea, ctype=ctypea, ...}: 'a conversion): 'a ref conversion = let fun store(m, ref s) = let (* When we pass a ref X into a cStar cX function we need to allocate a memory cell big enough for a cX value. Then we copy the current value of the ML into this. We set the argument, a pointer, to the address of the cell. *) val mem = malloc(#size ctypea) val () = setAddress(m, 0w0, mem) val freea = storea(mem, s) in fn () => (free mem; freea()) end (* Called to update the ML value when the C . *) fun updateML(m, s) = s := loada(getAddress(m, 0w0)) (* Used when an ML callback receives a cStar argument. *) fun load s = ref(loada(getAddress(s, 0w0))) (* Used when a callback has returned to update the C value. If storea allocates then there's nothing we can do. *) fun updateC(m, ref s) = ignore(storea(getAddress(m, 0w0), s)) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Similar to cStar but without the need to update the result. *) fun cConstStar({load=loada, store=storea, updateML=updateMLa, updateC=updateCa, ctype=ctypea}: 'a conversion): 'a conversion = let fun load s = loada(getAddress(s, 0w0)) fun store(m, s) = let val mem = malloc(#size ctypea) val () = setAddress(m, 0w0, mem) val freea = storea(mem, s) in fn () => (free mem; freea()) end (* Do we have to do anything here? Could we pass a const pointer to a structure with variable fields? *) fun updateML(m, s) = updateMLa(getAddress(m, 0w0), s) and updateC(m, s) = updateCa(getAddress(m, 0w0), s) in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Fixed size vector. It is treated as a struct and passed by value or embedded in a structure. *) fun cVectorFixedSize(n, {load=loadEl, store=storeEl, updateML=updateMLel, updateC=updateCel, ctype={size=sizeEl, align=alignEl, ffiType=ffiTypeEl}, ...}: 'a conversion) : 'a vector conversion = let val arraySize = sizeEl * Word.fromInt n fun ffiTypeArray () = LibFFI.createFFItype { size = arraySize, align = alignEl, typeCode=LibFFI.ffiTypeCodeStruct, elements = List.tabulate (n, fn _ => ffiTypeEl()) } val arrayType = { size = arraySize, align = alignEl, ffiType = ffiTypeArray } fun load(v: voidStar): 'a vector = Vector.tabulate(n, fn i => loadEl(v ++ Word.fromInt i)) fun store(v: voidStar, s: 'a vector) = let val sLen = Vector.length s val _ = sLen <= n orelse raise Foreign "vector too long" (* Store the values. Make a list of the free fns in case they allocate *) val frees = Vector.foldli(fn(i, el, l) => storeEl(v ++ Word.fromInt i, el) :: l) [] s; in fn () => List.app (fn f => f()) frees end (* If we have a ref in here we need to update *) fun updateML(v, s) = Vector.appi(fn (i, el) => updateMLel(v ++ Word.fromInt i, el)) s and updateC(v, s) = Vector.appi(fn (i, el) => updateCel(v ++ Word.fromInt i, el)) s in { load = load, store = store, updateML=updateML, updateC=updateC, ctype = arrayType } end (* Pass an ML vector as a pointer to a C array. *) fun cVectorPointer ({store=storeEl, updateML=updateMLel, ctype={size=sizeEl, ...}, ...}: 'a conversion) : 'a vector conversion = let (* We can't determine the size so can't construct a suitable ML value. *) fun load _ = raise Foreign "Cannot return a cVectorPointer from C to ML" fun store(m, s) = let val mem = malloc(sizeEl * Word.fromInt(Vector.length s)) val () = setAddress(m, 0w0, mem) (* Store the values. Make a list of the free fns in case they allocate *) val frees = Vector.foldli(fn(i, el, l) => storeEl(mem ++ (sizeEl * Word.fromInt i), el) :: l) [] s; in fn () => (List.app (fn f => f()) frees; free mem) end (* This is only appropriate if the elements are refs. *) fun updateML(v, s) = let val addr = getAddress(v, 0w0) in Vector.appi(fn (i, el) => updateMLel(addr ++ (sizeEl * Word.fromInt i), el)) s end (* updateC can't actually be used because we can't load a suitable value *) and updateC _ = raise Foreign "Cannot return a cVectorPointer from C to ML" in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end (* Pass an ML array as a pointer to a C array and, on return, update each element of the ML array from the C array. *) fun cArrayPointer ({load=loadEl, store=storeEl, ctype={size=sizeEl, ...}, ...}: 'a conversion) : 'a array conversion = let (* We can't determine the size so can't construct a suitable ML value. *) fun load _ = raise Foreign "Cannot return a cArrayPointer from C to ML" fun store(m, s) = let val mem = malloc(sizeEl * Word.fromInt(Array.length s)) val () = setAddress(m, 0w0, mem) (* Store the values. Make a list of the free fns in case they allocate *) val frees = Array.foldli(fn(i, el, l) => storeEl(mem ++ (sizeEl * Word.fromInt i), el) :: l) [] s; in fn () => (List.app (fn f => f()) frees; free mem) end (* updateML is used after a C function returns. It needs to update each element. *) fun updateML(v, s) = let val addr = getAddress(v, 0w0) in Array.modifyi(fn (i, _) => loadEl(addr ++ (sizeEl * Word.fromInt i))) s end (* updateC can't actually be used because we can't load a suitable value *) and updateC _ = raise Foreign "Cannot return a cArrayPointer from C to ML" in {load=load, store=store, updateML=updateML, updateC=updateC, ctype = cTypePointer} end end (* Calls with conversion. *) (* Note: it may be possible to have general functions to compute offsets but we don't do that because this way the compiler can compute the offsets as constants during inline expansion. *) local open LibFFI Memory LowLevel in fun buildCall0withAbi(abi: abi, fnAddr, (), {ctype = resType, load= resLoad, ...} : 'a conversion): unit->'a = let val callF = callwithAbi abi [] resType fnAddr in fn () => let val rMem = malloc(#size resType) in let val () = callF([], rMem) val result = resLoad rMem in free rMem; result end handle exn => (free rMem; raise exn) end end fun buildCall0(symbol, argTypes, resType) = buildCall0withAbi (abiDefault, symbol, argTypes, resType) fun buildCall1withAbi (abi: abi, fnAddr, { ctype = argType, store = argStore, updateML = argUpdate, ...}: 'a conversion, { ctype = resType, load= resLoad, ...}: 'b conversion): 'a ->'b = let val callF = callwithAbi abi [argType] resType fnAddr (* Allocate space for argument(s) and result. We can't use cStruct here because we only store the argument before the call and load the result after. *) val argOffset = alignUp(#size resType, #align argType) val argSpace = argOffset + #size argType in fn x => let val rMem = malloc argSpace val argAddr = rMem ++ argOffset val freea = argStore (argAddr, x) fun freeAll () = (freea(); free rMem) in let val () = callF([argAddr], rMem) val result = resLoad rMem in argUpdate (argAddr, x); freeAll (); result end handle exn => (freeAll (); raise exn) end end fun buildCall1(symbol, argTypes, resType) = buildCall1withAbi (abiDefault, symbol, argTypes, resType) fun buildCall2withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion), { ctype = resType, load= resLoad, ...}: 'c conversion): 'a * 'b -> 'c = let val callF = callwithAbi abi [arg1Type, arg2Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val argSpace = arg2Offset + #size arg2Type in fn (a, b) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) fun freeAll() = (freea(); freeb(); free rMem) in let val () = callF([arg1Addr, arg2Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall2(symbol, argTypes, resType) = buildCall2withAbi (abiDefault, symbol, argTypes, resType) fun buildCall3withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion), { ctype = resType, load= resLoad, ...}: 'd conversion): 'a * 'b *'c -> 'd = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val argSpace = arg3Offset + #size arg3Type in fn (a, b, c) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) fun freeAll() = (freea(); freeb(); freec(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall3(symbol, argTypes, resType) = buildCall3withAbi (abiDefault, symbol, argTypes, resType) fun buildCall4withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion), { ctype = resType, load= resLoad, ...}: 'e conversion): 'a * 'b *'c * 'd -> 'e = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val argSpace = arg4Offset + #size arg4Type in fn (a, b, c, d) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) fun freeAll() = (freea(); freeb(); freec(); freed(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall4(symbol, argTypes, resType) = buildCall4withAbi (abiDefault, symbol, argTypes, resType) fun buildCall5withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion), { ctype = resType, load= resLoad, ...}: 'f conversion): 'a * 'b *'c * 'd * 'e -> 'f = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val argSpace = arg5Offset + #size arg5Type in fn (a, b, c, d, e) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall5(symbol, argTypes, resType) = buildCall5withAbi (abiDefault, symbol, argTypes, resType) fun buildCall6withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion), { ctype = resType, load= resLoad, ...}: 'g conversion): 'a * 'b *'c * 'd * 'e * 'f -> 'g = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val argSpace = arg6Offset + #size arg6Type in fn (a, b, c, d, e, f) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr , arg6Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall6(symbol, argTypes, resType) = buildCall6withAbi (abiDefault, symbol, argTypes, resType) fun buildCall7withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion), { ctype = resType, load= resLoad, ...}: 'h conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g -> 'h = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val argSpace = arg7Offset + #size arg7Type in fn (a, b, c, d, e, f, g) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall7(symbol, argTypes, resType) = buildCall7withAbi (abiDefault, symbol, argTypes, resType) fun buildCall8withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion), { ctype = resType, load= resLoad, ...}: 'i conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h -> 'i = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val argSpace = arg8Offset + #size arg8Type in fn (a, b, c, d, e, f, g, h) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall8(symbol, argTypes, resType) = buildCall8withAbi (abiDefault, symbol, argTypes, resType) fun buildCall9withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion), { ctype = resType, load= resLoad, ...}: 'j conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val argSpace = arg9Offset + #size arg9Type in fn (a, b, c, d, e, f, g, h, i) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall9(symbol, argTypes, resType) = buildCall9withAbi (abiDefault, symbol, argTypes, resType) fun buildCall10withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion, { ctype = arg10Type, store = arg10Store, updateML = arg10Update, ...}: 'j conversion), { ctype = resType, load= resLoad, ...}: 'k conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type, arg10Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val arg10Offset = alignUp(arg9Offset + #size arg9Type, #align arg10Type) val argSpace = arg10Offset + #size arg10Type in fn (a, b, c, d, e, f, g, h, i, j) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val arg10Addr = rMem ++ arg10Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) val freej = arg10Store (arg10Addr, j) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr, arg10Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); arg10Update (arg10Addr, j); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall10(symbol, argTypes, resType) = buildCall10withAbi (abiDefault, symbol, argTypes, resType) fun buildCall11withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion, { ctype = arg10Type, store = arg10Store, updateML = arg10Update, ...}: 'j conversion, { ctype = arg11Type, store = arg11Store, updateML = arg11Update, ...}: 'k conversion), { ctype = resType, load= resLoad, ...}: 'l conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type, arg10Type, arg11Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val arg10Offset = alignUp(arg9Offset + #size arg9Type, #align arg10Type) val arg11Offset = alignUp(arg10Offset + #size arg10Type, #align arg11Type) val argSpace = arg11Offset + #size arg11Type in fn (a, b, c, d, e, f, g, h, i, j, k) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val arg10Addr = rMem ++ arg10Offset val arg11Addr = rMem ++ arg11Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) val freej = arg10Store (arg10Addr, j) val freek = arg11Store (arg11Addr, k) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr, arg10Addr, arg11Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); arg10Update (arg10Addr, j); arg11Update (arg11Addr, k); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall11(symbol, argTypes, resType) = buildCall11withAbi (abiDefault, symbol, argTypes, resType) fun buildCall12withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion, { ctype = arg10Type, store = arg10Store, updateML = arg10Update, ...}: 'j conversion, { ctype = arg11Type, store = arg11Store, updateML = arg11Update, ...}: 'k conversion, { ctype = arg12Type, store = arg12Store, updateML = arg12Update, ...}: 'l conversion), { ctype = resType, load= resLoad, ...}: 'm conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type, arg10Type, arg11Type, arg12Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val arg10Offset = alignUp(arg9Offset + #size arg9Type, #align arg10Type) val arg11Offset = alignUp(arg10Offset + #size arg10Type, #align arg11Type) val arg12Offset = alignUp(arg11Offset + #size arg11Type, #align arg12Type) val argSpace = arg12Offset + #size arg12Type in fn (a, b, c, d, e, f, g, h, i, j, k, l) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val arg10Addr = rMem ++ arg10Offset val arg11Addr = rMem ++ arg11Offset val arg12Addr = rMem ++ arg12Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) val freej = arg10Store (arg10Addr, j) val freek = arg11Store (arg11Addr, k) val freel = arg12Store (arg12Addr, l) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr, arg10Addr, arg11Addr, arg12Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); arg10Update (arg10Addr, j); arg11Update (arg11Addr, k); arg12Update (arg12Addr, l); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall12(symbol, argTypes, resType) = buildCall12withAbi (abiDefault, symbol, argTypes, resType) fun buildCall13withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion, { ctype = arg10Type, store = arg10Store, updateML = arg10Update, ...}: 'j conversion, { ctype = arg11Type, store = arg11Store, updateML = arg11Update, ...}: 'k conversion, { ctype = arg12Type, store = arg12Store, updateML = arg12Update, ...}: 'l conversion, { ctype = arg13Type, store = arg13Store, updateML = arg13Update, ...}: 'm conversion), { ctype = resType, load= resLoad, ...}: 'n conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type, arg10Type, arg11Type, arg12Type, arg13Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val arg10Offset = alignUp(arg9Offset + #size arg9Type, #align arg10Type) val arg11Offset = alignUp(arg10Offset + #size arg10Type, #align arg11Type) val arg12Offset = alignUp(arg11Offset + #size arg11Type, #align arg12Type) val arg13Offset = alignUp(arg12Offset + #size arg12Type, #align arg13Type) val argSpace = arg13Offset + #size arg13Type in fn (a, b, c, d, e, f, g, h, i, j, k, l, m) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val arg10Addr = rMem ++ arg10Offset val arg11Addr = rMem ++ arg11Offset val arg12Addr = rMem ++ arg12Offset val arg13Addr = rMem ++ arg13Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) val freej = arg10Store (arg10Addr, j) val freek = arg11Store (arg11Addr, k) val freel = arg12Store (arg12Addr, l) val freem = arg13Store (arg13Addr, m) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr, arg10Addr, arg11Addr, arg12Addr, arg13Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); arg10Update (arg10Addr, j); arg11Update (arg11Addr, k); arg12Update (arg12Addr, l); arg13Update (arg13Addr, m); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall13(symbol, argTypes, resType) = buildCall13withAbi (abiDefault, symbol, argTypes, resType) fun buildCall14withAbi (abi: abi, fnAddr, ({ ctype = arg1Type, store = arg1Store, updateML = arg1Update, ...}: 'a conversion, { ctype = arg2Type, store = arg2Store, updateML = arg2Update, ...}: 'b conversion, { ctype = arg3Type, store = arg3Store, updateML = arg3Update, ...}: 'c conversion, { ctype = arg4Type, store = arg4Store, updateML = arg4Update, ...}: 'd conversion, { ctype = arg5Type, store = arg5Store, updateML = arg5Update, ...}: 'e conversion, { ctype = arg6Type, store = arg6Store, updateML = arg6Update, ...}: 'f conversion, { ctype = arg7Type, store = arg7Store, updateML = arg7Update, ...}: 'g conversion, { ctype = arg8Type, store = arg8Store, updateML = arg8Update, ...}: 'h conversion, { ctype = arg9Type, store = arg9Store, updateML = arg9Update, ...}: 'i conversion, { ctype = arg10Type, store = arg10Store, updateML = arg10Update, ...}: 'j conversion, { ctype = arg11Type, store = arg11Store, updateML = arg11Update, ...}: 'k conversion, { ctype = arg12Type, store = arg12Store, updateML = arg12Update, ...}: 'l conversion, { ctype = arg13Type, store = arg13Store, updateML = arg13Update, ...}: 'm conversion, { ctype = arg14Type, store = arg14Store, updateML = arg14Update, ...}: 'n conversion), { ctype = resType, load= resLoad, ...}: 'o conversion): 'a * 'b *'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o = let val callF = callwithAbi abi [arg1Type, arg2Type, arg3Type, arg4Type, arg5Type, arg6Type, arg7Type, arg8Type, arg9Type, arg10Type, arg11Type, arg12Type, arg13Type, arg14Type] resType fnAddr val arg1Offset = alignUp(#size resType, #align arg1Type) val arg2Offset = alignUp(arg1Offset + #size arg1Type, #align arg2Type) val arg3Offset = alignUp(arg2Offset + #size arg2Type, #align arg3Type) val arg4Offset = alignUp(arg3Offset + #size arg3Type, #align arg4Type) val arg5Offset = alignUp(arg4Offset + #size arg4Type, #align arg5Type) val arg6Offset = alignUp(arg5Offset + #size arg5Type, #align arg6Type) val arg7Offset = alignUp(arg6Offset + #size arg6Type, #align arg7Type) val arg8Offset = alignUp(arg7Offset + #size arg7Type, #align arg8Type) val arg9Offset = alignUp(arg8Offset + #size arg8Type, #align arg9Type) val arg10Offset = alignUp(arg9Offset + #size arg9Type, #align arg10Type) val arg11Offset = alignUp(arg10Offset + #size arg10Type, #align arg11Type) val arg12Offset = alignUp(arg11Offset + #size arg11Type, #align arg12Type) val arg13Offset = alignUp(arg12Offset + #size arg12Type, #align arg13Type) val arg14Offset = alignUp(arg13Offset + #size arg13Type, #align arg14Type) val argSpace = arg14Offset + #size arg14Type in fn (a, b, c, d, e, f, g, h, i, j, k, l, m, n) => let val rMem = malloc argSpace val arg1Addr = rMem ++ arg1Offset val arg2Addr = rMem ++ arg2Offset val arg3Addr = rMem ++ arg3Offset val arg4Addr = rMem ++ arg4Offset val arg5Addr = rMem ++ arg5Offset val arg6Addr = rMem ++ arg6Offset val arg7Addr = rMem ++ arg7Offset val arg8Addr = rMem ++ arg8Offset val arg9Addr = rMem ++ arg9Offset val arg10Addr = rMem ++ arg10Offset val arg11Addr = rMem ++ arg11Offset val arg12Addr = rMem ++ arg12Offset val arg13Addr = rMem ++ arg13Offset val arg14Addr = rMem ++ arg14Offset val freea = arg1Store (arg1Addr, a) val freeb = arg2Store (arg2Addr, b) val freec = arg3Store (arg3Addr, c) val freed = arg4Store (arg4Addr, d) val freee = arg5Store (arg5Addr, e) val freef = arg6Store (arg6Addr, f) val freeg = arg7Store (arg7Addr, g) val freeh = arg8Store (arg8Addr, h) val freei = arg9Store (arg9Addr, i) val freej = arg10Store (arg10Addr, j) val freek = arg11Store (arg11Addr, k) val freel = arg12Store (arg12Addr, l) val freem = arg13Store (arg13Addr, m) val freen = arg14Store (arg14Addr, n) fun freeAll() = (freea(); freeb(); freec(); freed(); freee(); freef(); freeg(); freeh(); freei(); freej(); freek(); freel(); freem(); freen(); free rMem) in let val () = callF([arg1Addr, arg2Addr, arg3Addr, arg4Addr, arg5Addr, arg6Addr, arg7Addr, arg8Addr, arg9Addr, arg10Addr, arg11Addr, arg12Addr, arg13Addr, arg14Addr], rMem) val result = resLoad rMem in arg1Update(arg1Addr, a); arg2Update (arg2Addr, b); arg3Update (arg3Addr, c); arg4Update (arg4Addr, d); arg5Update (arg5Addr, e); arg6Update (arg6Addr, f); arg7Update (arg7Addr, g); arg8Update (arg8Addr, h); arg9Update (arg9Addr, i); arg10Update (arg10Addr, j); arg11Update (arg11Addr, k); arg12Update (arg12Addr, l); arg13Update (arg13Addr, m); arg14Update (arg14Addr, n); freeAll(); result end handle exn => (freeAll(); raise exn) end end fun buildCall14(symbol, argTypes, resType) = buildCall14withAbi (abiDefault, symbol, argTypes, resType) end (* A closure is a memoised address. *) type 'a closure = unit -> Memory.voidStar local open Memory LowLevel fun load _ = raise Foreign "Cannot return a closure" (* "dememoise" the value when we store it. This means that the closure is actually created when the value is first stored and then it is cached. *) and store(v, cl: ('a->'b) closure) = (Memory.setAddress(v, 0w0, cl()); fn () => ()) in val cFunction: ('a->'b) closure conversion = makeConversion { load=load, store=store, ctype = LowLevel.cTypePointer } end local open LibFFI Memory LowLevel in fun buildClosure0withAbi(f: unit-> 'a, abi: abi, (), resConv: 'a conversion): (unit->'a) closure = let fun callback (f: unit -> 'a) (_: voidStar, res: voidStar): unit = ignore(#store resConv (res, f ())) (* Ignore the result of #store resConv. What this means is if the callback returns something, e.g. a string, that requires dynamic allocation there will be a memory leak. *) val makeCallback = cFunctionWithAbi abi [] (#ctype resConv) in Memory.memoise (fn () => makeCallback(callback f)) () end fun buildClosure0(f, argConv, resConv) = buildClosure0withAbi(f, abiDefault, argConv, resConv) fun buildClosure1withAbi (f: 'a -> 'b, abi: abi, argConv: 'a conversion, resConv: 'b conversion) : ('a -> 'b) closure = let fun callback (f: 'a -> 'b) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) val arg1 = #load argConv arg1Addr val result = f arg1 val () = #updateC argConv (arg1Addr, arg1) in ignore(#store resConv (res, result)) end val makeCallback = cFunctionWithAbi abi [#ctype argConv] (#ctype resConv) in Memory.memoise (fn () => 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 fun callback (f: 'a *'b -> 'c) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) and arg2Addr = getAddress(args, 0w1) val arg1 = #load arg1Conv arg1Addr and arg2 = #load arg2Conv arg2Addr val result = f (arg1, arg2) val () = #updateC arg1Conv(arg1Addr, arg1) and () = #updateC arg2Conv(arg2Addr, arg2) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in Memory.memoise (fn () => makeCallback(callback f)) () 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 fun callback (f: 'a *'b * 'c -> 'd) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) and arg2Addr = getAddress(args, 0w1) and arg3Addr = getAddress(args, 0w2) val arg1 = #load arg1Conv arg1Addr and arg2 = #load arg2Conv arg2Addr and arg3 = #load arg3Conv arg3Addr val result = f (arg1, arg2, arg3) val () = #updateC arg1Conv(arg1Addr, arg1) and () = #updateC arg2Conv(arg2Addr, arg2) and () = #updateC arg3Conv(arg3Addr, arg3) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in Memory.memoise (fn () => makeCallback(callback f)) () 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 fun callback (f: 'a *'b * 'c * 'd -> 'e) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) and arg2Addr = getAddress(args, 0w1) and arg3Addr = getAddress(args, 0w2) and arg4Addr = getAddress(args, 0w3) val arg1 = #load arg1Conv arg1Addr and arg2 = #load arg2Conv arg2Addr and arg3 = #load arg3Conv arg3Addr and arg4 = #load arg4Conv arg4Addr val result = f (arg1, arg2, arg3, arg4) val () = #updateC arg1Conv(arg1Addr, arg1) and () = #updateC arg2Conv(arg2Addr, arg2) and () = #updateC arg3Conv(arg3Addr, arg3) and () = #updateC arg4Conv(arg4Addr, arg4) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in Memory.memoise (fn () => makeCallback(callback f)) () 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 fun callback (f: 'a *'b * 'c * 'd * 'e -> 'f) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) and arg2Addr = getAddress(args, 0w1) and arg3Addr = getAddress(args, 0w2) and arg4Addr = getAddress(args, 0w3) and arg5Addr = getAddress(args, 0w4) val arg1 = #load arg1Conv arg1Addr and arg2 = #load arg2Conv arg2Addr and arg3 = #load arg3Conv arg3Addr and arg4 = #load arg4Conv arg4Addr and arg5 = #load arg5Conv arg5Addr val result = f (arg1, arg2, arg3, arg4, arg5) val () = #updateC arg1Conv(arg1Addr, arg1) and () = #updateC arg2Conv(arg2Addr, arg2) and () = #updateC arg3Conv(arg3Addr, arg3) and () = #updateC arg4Conv(arg4Addr, arg4) and () = #updateC arg5Conv(arg5Addr, arg5) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in Memory.memoise (fn () => makeCallback(callback f)) () 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 fun callback (f: 'a *'b * 'c * 'd * 'e * 'f -> 'g) (args: voidStar, res: voidStar): unit = let val arg1Addr = getAddress(args, 0w0) and arg2Addr = getAddress(args, 0w1) and arg3Addr = getAddress(args, 0w2) and arg4Addr = getAddress(args, 0w3) and arg5Addr = getAddress(args, 0w4) and arg6Addr = getAddress(args, 0w5) val arg1 = #load arg1Conv arg1Addr and arg2 = #load arg2Conv arg2Addr and arg3 = #load arg3Conv arg3Addr and arg4 = #load arg4Conv arg4Addr and arg5 = #load arg5Conv arg5Addr and arg6 = #load arg6Conv arg6Addr val result = f (arg1, arg2, arg3, arg4, arg5, arg6) val () = #updateC arg1Conv(arg1Addr, arg1) and () = #updateC arg2Conv(arg2Addr, arg2) and () = #updateC arg3Conv(arg3Addr, arg3) and () = #updateC arg4Conv(arg4Addr, arg4) and () = #updateC arg5Conv(arg5Addr, arg5) and () = #updateC arg6Conv(arg6Addr, arg6) in ignore(#store resConv (res, result)) end val argTypes = [#ctype arg1Conv, #ctype arg2Conv, #ctype arg3Conv, #ctype arg4Conv, #ctype arg5Conv, #ctype arg6Conv] and resType = #ctype resConv val makeCallback = cFunctionWithAbi abi argTypes resType in Memory.memoise (fn () => makeCallback(callback f)) () end fun buildClosure6(f, argConv, resConv) = buildClosure6withAbi(f, abiDefault, argConv, resConv) end end; diff --git a/basis/ForeignMemory.sml b/basis/ForeignMemory.sml index c1730e6e..907375ae 100644 --- a/basis/ForeignMemory.sml +++ b/basis/ForeignMemory.sml @@ -1,230 +1,230 @@ (* Title: Foreign Function Interface: memory operations Author: David Matthews - Copyright David Matthews 2015, 2017 + Copyright David Matthews 2015, 2017, 2019 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 *) structure ForeignMemory :> sig eqtype volatileRef val volatileRef: SysWord.word -> volatileRef val setVolatileRef: volatileRef * SysWord.word -> unit val getVolatileRef: volatileRef -> SysWord.word eqtype voidStar val voidStar2Sysword: voidStar -> SysWord.word val sysWord2VoidStar: SysWord.word -> voidStar val null: voidStar val ++ : voidStar * word -> voidStar val -- : voidStar * word -> voidStar (* Remember an address except across loads. *) val memoise: ('a -> voidStar) ->'a -> unit -> voidStar exception Memory (* malloc - allocate memory. N.B. argument is the number of bytes. Raises Memory exception if it cannot allocate. *) val malloc: word -> voidStar (* free - free allocated memory. *) val free: voidStar -> unit val get8: voidStar * Word.word -> Word8.word val get16: voidStar * Word.word -> Word.word val get32: voidStar * Word.word -> Word32.word val get64: voidStar * Word.word -> SysWord.word val set8: voidStar * Word.word * Word8.word -> unit val set16: voidStar * Word.word * Word.word -> unit val set32: voidStar * Word.word * Word32.word -> unit val set64: voidStar * Word.word * SysWord.word -> unit val getFloat: voidStar * Word.word -> real val getDouble: voidStar * Word.word -> real val setFloat: voidStar * Word.word * real -> unit val setDouble: voidStar * Word.word * real -> unit val getAddress: voidStar * Word.word -> voidStar val setAddress: voidStar * Word.word * voidStar -> unit end = struct open ForeignConstants open ForeignMemory exception Foreign = RunCall.Foreign fun id x = x (* Internal utility function. *) fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align) (* Both volatileRef and SysWord.word are the ADDRESSes of the actual value. *) type volatileRef = word ref val memMove: SysWord.word * SysWord.word * word * word* word -> unit = RunCall.moveBytes fun volatileRef init = let (* Allocate a single word marked as mutable, weak, no-overwrite, byte. *) (* A weak byte cell is cleared to zero when it is read in either from the executable or from a saved state. Using the no-overwrite bit ensures that if it is contained in the executable it won't be changed by loading a saved state but there's a problem if it is contained in a parent state. Then loading a child state will clear it because we reload all the parents when we load a child. *) val v = RunCall.allocateWordMemory(sysWordSize div wordSize, 0wx69, 0w0) (* Copy the SysWord into it. *) val () = memMove(init, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) in v end fun setVolatileRef(v, i) = memMove(i, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) fun getVolatileRef var = let (* Allocate a single word marked as mutable, byte. *) val v = RunCall.allocateByteMemory(sysWordSize div wordSize, 0wx41) val () = memMove(RunCall.unsafeCast var, v, 0w0, 0w0, sysWordSize) val () = RunCall.clearMutableBit v in v end type voidStar = SysWord.word val voidStar2Sysword = id and sysWord2VoidStar = id (* Exported conversions *) val null: voidStar = 0w0 infix 6 ++ -- fun s ++ w = s + SysWord.fromLarge(Word.toLarge w) and s -- w = s - SysWord.fromLarge(Word.toLarge w) fun 'a memoise(f: 'a -> voidStar) (a: 'a) : unit -> voidStar = let (* Initialise to zero. That means the function won't be executed until we actually want the result. *) val v = volatileRef 0w0 in (* If we've reloaded the volatile ref it will have been reset to zero. We need to execute the function and set it. *) fn () => (case getVolatileRef v of 0w0 => let val r = f a in setVolatileRef(v, r); r end | r => r) end exception Memory (* Get and set addresses. This is a bit messy because it has to compile on 64-bits as well as 32-bits. *) val getAddress: voidStar * Word.word -> voidStar = if sysWordSize = 0w4 then Word32.toLargeWord o get32 else get64 val setAddress: voidStar * Word.word * voidStar -> unit = if sysWordSize = 0w4 then fn (s, i, v) => set32(s, i, Word32.fromLargeWord v) else set64 local local val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral" in fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg))) end fun systemMalloc (s: word): voidStar = ffiGeneral (0, s) (*fun systemFree (s: voidStar): unit = ffiGeneral (1, s)*) (* Simple malloc/free implementation to reduce the number of RTS calls needed. *) val lock = Thread.Mutex.mutex() (* It would be possible to chain the free list in the C memory itself. For the moment we don't do that. The free list is the list of chunks ordered by increasing address. That allows us to merge adjacent free blocks. *) val freeList: {address: SysWord.word, size: word} list ref = LibrarySupport.noOverwriteRef nil (* Clear it once on entry. *) - val () = PolyML.onEntry (fn _ => freeList := nil) + val () = LibrarySupport.addOnEntry (fn _ => freeList := nil) (* Assume that if we align to the maximum of these we're all right. *) val maxAlign = Word.max(#align saDouble, Word.max(#align saPointer, #align saSint64)) (* We need a length word in each object we allocate but we need enough padding to align the result. *) val overhead = alignUp(sysWordSize, maxAlign) val chunkSize = 0w4096 (* Configure this. *) fun addFree(entry, []) = [entry] | addFree(entry, this :: rest) = if #address entry < #address this then ( if #address entry ++ #size entry = #address this then (* New entry is immediately before old one - merge. *) {address= #address entry, size = #size entry + #size this } :: rest else entry :: this :: rest ) else if #address this ++ #size this = #address entry then (* New entry is immediately after this - merge. Continue because it could also merge with an entry after this as well. *) addFree({address= #address this, size= #size entry + #size this}, rest) else this :: addFree(entry, rest) (* Search on. *) (* Find free space. *) fun findFree (_, []) = (NONE, []) | findFree (space, (this as {size, address}) :: tl) = if space = size then (SOME address, tl) else if space < size then (SOME address, {size=size-space, address=address ++ space} :: tl) else let val (res, rest) = findFree(space, tl) in (res, this :: rest) end fun freeMem s = let val addr = s -- overhead val size = Word.fromLarge(SysWord.toLarge(getAddress(addr, 0w0))) in freeList := addFree({address=addr, size=size}, !freeList) end fun allocMem s = let val space = alignUp(s + overhead, maxAlign) val (found, newList) = findFree(space, !freeList) in case found of NONE => let (* Need more memory *) val requestSpace = Word.max(chunkSize, space) val newSpace = systemMalloc requestSpace val _ = newSpace <> null orelse raise Memory in (* Add the space to the free list in the appropriate place. *) freeList := addFree({address=newSpace, size=requestSpace}, !freeList); allocMem s (* Repeat - should succeed now. *) end | SOME address => let val () = freeList := newList (* Update the free list *) (* Store the length in the first word. *) val () = setAddress(address, 0w0, SysWord.fromLarge(Word.toLarge space)) in address ++ overhead end end in val malloc: word -> voidStar = ThreadLib.protect lock allocMem fun free v = if v = null then () else ThreadLib.protect lock freeMem v end end; diff --git a/basis/InitialPolyML.ML b/basis/InitialPolyML.ML index de99a1ab..34eb913b 100644 --- a/basis/InitialPolyML.ML +++ b/basis/InitialPolyML.ML @@ -1,113 +1,109 @@ (* Title: Extend the PolyML structure. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000-7 Cambridge University Technical Services Limited Modified David C.J. Matthews 2008, 2015 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 *) -(* Extend the PolyML structure. In particular this adds onEntry which needs to - be used further on in the basis library. We also add a few more items at - this point. *) - local in structure PolyML = (* We must not have a signature on the result otherwise print and makestring will be given polymorphic types and will only produce "?" *) struct open PolyML local (* Initialise the list with the existing start-up function. *) - val onEntryList: (unit->unit) list ref = ref[] + val onEntryList: (unit->unit) list ref = LibrarySupport.onEntryList and onEntryMutex = Thread.Mutex.mutex() (* Run the list in reverse order. *) fun runOnEntry [] = () | runOnEntry (f :: b) = (runOnEntry b; f() handle _ => ()); (* This wraps the function provided to PolyML.export and PolyML.exportPortable so that the library is initialised at start-up and finalised at close-down. *) fun runFunction f () = let val () = runOnEntry(! onEntryList); (* Perform start-up operations. *) (* Run the main program. If it doesn't explicitly call OS.Process.exit then use "success" as the normal result and "failure" if it raises an exception. *) val result = (f(); OS.Process.success) handle _ => OS.Process.failure (* Run the main function. *) in OS.Process.exit result (* Perform close-down actions. *) end val callExport: string * (unit->unit) -> unit = RunCall.rtsCallFull2 "PolyExport" and callExportP: string * (unit->unit) -> unit = RunCall.rtsCallFull2 "PolyExportPortable" in (* The equivalent of atExit except that functions are added to the list persistently and of course the functions are executed at start-up rather than close-down. *) (* Protect this with a mutex in case two threads try to add entries at the same time. Very unlikely since this is really only called when building the basis library. *) - fun onEntry (f: unit->unit) : unit = - ThreadLib.protect onEntryMutex (fn () => onEntryList := f :: !onEntryList) () + val onEntry : (unit->unit) -> unit = + ThreadLib.protect onEntryMutex LibrarySupport.addOnEntry (* Export functions - write out the function and everything reachable from it. *) fun export(filename, f) = callExport(filename, runFunction f) and exportPortable(filename, f) = callExportP(filename, runFunction f) end local (* shareCommonData needs to be able to take a value of any type. *) val callShare: word -> unit = RunCall.rtsCallFull1 "PolyShareCommonData" in fun shareCommonData(root: 'a): unit = callShare(RunCall.unsafeCast root) end (* ObjSize etc all take values of any type but we can't give the RTS call type 'a->int. *) local val callObjSize: word -> int = RunCall.rtsCallFull1 "PolyObjSize" and callShowSize: word -> int = RunCall.rtsCallFull1 "PolyShowSize" and callObjProfile: word -> int = RunCall.rtsCallFull1 "PolyObjProfile" in fun objSize(x:'a) = callObjSize(RunCall.unsafeCast x) and showSize(x:'a) = callShowSize(RunCall.unsafeCast x) and objProfile(x:'a) = callObjProfile(RunCall.unsafeCast x) end val fullGC: unit -> unit = RunCall.rtsCallFull0 "PolyFullGC" val pointerEq = RunCall.pointerEq val rtsVersion: unit -> int = RunCall.rtsCallFast0 "PolyGetPolyVersionNumber" local val doCall: int * unit -> string = RunCall.rtsCallFull2 "PolySpecificGeneral" in fun architecture(): string = doCall (12, ()) fun rtsArgumentHelp(): string = doCall (19, ()) end structure IntInf = struct val gcd: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyGCDArbitrary" and lcm: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyLCMArbitrary" end end end; diff --git a/basis/LibrarySupport.sml b/basis/LibrarySupport.sml index 70ddb57e..cc24d8b5 100644 --- a/basis/LibrarySupport.sml +++ b/basis/LibrarySupport.sml @@ -1,211 +1,217 @@ (* Title: Standard Basis Library: Support functions Copyright David C.J. Matthews 2000, 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 *) (* We need to execute these calls BEFORE compiling LibrarySupport if we want them to be compiled in as constants. *) structure MachineConstants = struct local val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" in val bigEndian : bool = isBigEndian () end val wordSize : word = RunCall.bytesPerWord (* This is the same as wordSize in native 32-bit and 64-bit but different in 32-in-64. *) val sysWordSize: word = RunCall.memoryCellLength(Word.toLargeWord 0w0) * wordSize end; structure LibrarySupport :> sig eqtype address (* eqtype so we can compare vectors. *) structure CharArray: sig datatype array = Array of word*address end structure Word8Array: sig datatype array = Array of word*address eqtype vector val wVecLength: vector -> word end val w8vectorToString: Word8Array.vector -> string and w8vectorFromString: string -> Word8Array.vector val wordSize: word and sysWordSize: word val bigEndian: bool val allocString: word -> string (* Create a mutable string. *) val allocBytes: word -> address val isShortInt : int -> bool val largeIntIsSmall: LargeInt.int -> bool val unsignedShortOrRaiseSubscript: int -> word val unsignedShortOrRaiseSize: int -> word val sizeAsWord : string -> word val stringAsAddress : string -> address val w8vectorAsAddress : Word8Array.vector -> address val maxAllocation: word and maxString: word val noOverwriteRef: 'a -> 'a ref val emptyVector: word val quotRem: LargeInt.int*LargeInt.int -> LargeInt.int*LargeInt.int val getOSType: unit -> int eqtype syserror val syserrorToWord: syserror -> LargeWord.word val syserrorFromWord : LargeWord.word -> syserror exception SysErr of (string * syserror option) + val onEntryList: (unit->unit) list ref (* This is picked up by InitialPolyML *) + val addOnEntry: (unit->unit) -> unit end = struct (* An address is the address of a vector in memory. *) type address = Bootstrap.byteArray (* This forces pointer equality. *) local (* Add a pretty printer to avoid crashes during debugging. *) open PolyML fun prettyAddress _ _ (_: address) = PolyML.PrettyString "byteArray" in val () = addPrettyPrinter prettyAddress end (* This is always a short non-negative integer so can be cast as word or int. *) fun sizeAsWord(s: string): word = RunCall.loadUntagged(s, 0w0) (* Provide the implementation of CharArray.array, Word8Array.array and Word8Array.vector (= Word8Vector.vector) here so that they are available to the IO routines. *) structure CharArray = struct datatype array = Array of word*address end structure Word8Array = struct (* Using the Array constructor here does not add any overhead since it is compiled as an identity function. *) datatype array = Array of word*address (* The representation of Word8Vector.vector is the same as that of string. We define it as "string" here so that it inherits the same equality function. The representation is assumed by the RTS. *) type vector = string val wVecLength: vector -> word = sizeAsWord end (* Identity functions to provide convertions. *) fun w8vectorToString s = s and w8vectorFromString s = s (* There are circumstances when we want to pass the address of a string where we expect an address. *) val stringAsAddress : string -> address = RunCall.unsafeCast val w8vectorAsAddress = stringAsAddress o w8vectorToString open MachineConstants; local val F_mutable_bytes : word = 0wx41 (* This is put in by Initialise and filtered out later. *) val setLengthWord: string * word -> unit = fn (s, n) => RunCall.storeUntagged(s, 0w0, n) val callGetAllocationSize = RunCall.rtsCallFast0 "PolyGetMaxAllocationSize" val callGetMaxStringSize = RunCall.rtsCallFast0 "PolyGetMaxStringSize" in (* Get the maximum allocation size. This is the maximum value that can fit in the length field of a segment. *) val maxAllocation = callGetAllocationSize() and maxString = callGetMaxStringSize() (* Check that we have a short int. This is only necessary if int is arbitrary precision. If int is fixed precision it will always be true. *) fun isShortInt(i: int): bool = not Bootstrap.intIsArbitraryPrecision orelse RunCall.isShort i (* Test whether a large int will fit in the short format. *) val largeIntIsSmall: LargeInt.int -> bool = RunCall.isShort fun unsignedShortOrRaiseSize (i: int): word = if isShortInt i andalso i >= 0 then RunCall.unsafeCast i else raise Size fun unsignedShortOrRaiseSubscript (i: int): word = if isShortInt i andalso i >= 0 then RunCall.unsafeCast i else raise Subscript fun allocBytes bytes : address = let val words : word = if bytes > maxString then raise Size (* The maximum string size is slightly smaller than the maximum array size because strings have a length word. It seems best to use the same maximum size for CharArray/Word8Array. *) else (bytes + wordSize - 0w1) div wordSize val mem = RunCall.allocateByteMemory(words, F_mutable_bytes) (* Zero the last word. *) val () = if words = 0w0 then () else RunCall.storeUntagged(RunCall.unsafeCast mem, words-0w1, 0w0) in mem end (* Allocate store for the string and set the first word to contain the length and the rest zero. *) fun allocString charsW = let (* The space is the number of characters plus space for the length word plus rounding. *) val words : word = (charsW + 0w2 * wordSize - 0w1) div wordSize val _ = words <= maxAllocation orelse raise Size val vec = RunCall.allocateByteMemory(words, F_mutable_bytes) (* Zero any extra bytes we've needed for rounding to a number of words. This isn't essential but ensures that RTS sharing passes will merge strings that are otherwise the same. *) val () = RunCall.storeUntagged(vec, words-0w1, 0w0) in (* Set the length word. Since this is untagged we can't simply use assign_word.*) setLengthWord(vec, charsW); vec end (* Create non-overwritable mutables for mutexes and condition variables. A non-overwritable mutable in the executable or a saved state is not overwritten when a saved state further down the hierarchy is loaded. This is also used for imperative streams, really only so that stdIn works properly across SaveState.loadState calls. *) fun noOverwriteRef (a: 'a) : 'a ref = RunCall.allocateWordMemory(0w1, 0wx48, a) end (* Create an empty vector. This is used wherever we want an empty vector. It can't be 'a vector which is what we want because of the value restriction. *) val emptyVector: word = RunCall.allocateWordMemory(0w0, 0w0, 0w0) val quotRem = LargeInt.quotRem val getOSType: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" (* syserror is the same as SysWord.word and these are needed in Posix at least. *) type syserror = LargeWord.word fun syserrorToWord i = i and syserrorFromWord i = i exception SysErr = RunCall.SysErr + + (* The onEntry list. PolyML.onEntry adds a mutex here. *) + val onEntryList: (unit->unit) list ref = ref[] + fun addOnEntry f = onEntryList := f :: !onEntryList end; diff --git a/basis/Signal.sml b/basis/Signal.sml index fb56dc21..4dafc3e8 100644 --- a/basis/Signal.sml +++ b/basis/Signal.sml @@ -1,91 +1,91 @@ (* Title: Signal structure and signature. Author: David Matthews - Copyright David Matthews 2000, 2008 + Copyright David Matthews 2000, 2008, 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 SIGNAL = sig datatype sig_handle = SIG_DFL | SIG_IGN | SIG_HANDLE of int->unit val signal: int * sig_handle -> sig_handle end; structure Signal: SIGNAL = struct datatype sig_handle = SIG_DFL | SIG_IGN | SIG_HANDLE of int->unit local val setHandler = RunCall.rtsCallFull2 "PolySetSignalHandler" in fun signal(s, cmd) = let val c = case cmd of SIG_DFL => 0 | SIG_IGN => 1 | SIG_HANDLE f => RunCall.unsafeCast f in case setHandler(s, c) of 0 => SIG_DFL | 1 => SIG_IGN | f => SIG_HANDLE(RunCall.unsafeCast f) end end local datatype sigHandle = SigHandle of (int->unit) * int | WeakMarker val waitForSig = RunCall.rtsCallFull0 "PolyWaitForSignal" open Thread fun sigThread(): unit = let (* This call to the RTS returns either a pair of a signal and a handler or a flag indicating that some wek reference has been set to NONE. These aren't logically related but it's convenient to use a single thread for both. *) val nextSig: sigHandle = waitForSig() (* When we get a WeakMarker message we need to broadcast on this condition variable. *) fun broadCastWeak haveLock () = ( if haveLock then () else Mutex.lock Weak.weakLock; ConditionVar.broadcast Weak.weakSignal; Mutex.unlock Weak.weakLock ) in case nextSig of SigHandle (handler, signal) => (handler signal handle _ => ()) | WeakMarker => (* If the lock is free we can do the broadcast now but to avoid waiting and being unable to handle any signals we fork off a thread if we can't. *) if Mutex.trylock Weak.weakLock then broadCastWeak true () else (Thread.fork(broadCastWeak false, []); ()); sigThread() (* Forever. *) end fun forkThread() = (Thread.fork(sigThread, []); ()) handle Thread _ => print "Unable to create signal thread\n" in (* Run this thread now and also start one each time we start up. *) val _ = forkThread() - val _ = PolyML.onEntry forkThread + val _ = LibrarySupport.addOnEntry forkThread end end; diff --git a/basis/TextIO.sml b/basis/TextIO.sml index 7dad6661..b6eede8f 100644 --- a/basis/TextIO.sml +++ b/basis/TextIO.sml @@ -1,420 +1,420 @@ (* Title: Standard Basis Library: Text IO - Copyright David C.J. Matthews 2000, 2005, 2016, 2018 + Copyright David C.J. Matthews 2000, 2005, 2016, 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 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 TEXT_STREAM_IO = sig include STREAM_IO where type vector = CharVector.vector where type elem = Char.char val inputLine : instream -> (string * instream) option val outputSubstr : outstream * Substring.substring -> unit end; signature TEXT_IO = sig (* include IMPERATIVE_IO *) structure StreamIO : TEXT_STREAM_IO where type reader = TextPrimIO.reader where type writer = TextPrimIO.writer where type pos = TextPrimIO.pos type vector = StreamIO.vector type elem = StreamIO.elem type instream type outstream val input : instream -> vector val input1 : instream -> elem option val inputN : instream * int -> vector val inputAll : instream -> vector val canInput : instream * int -> int option val lookahead : instream -> elem option val closeIn : instream -> unit val endOfStream : instream -> bool val output : outstream * vector -> unit val output1 : outstream * elem -> unit val flushOut : outstream -> unit val closeOut : outstream -> unit val mkInstream : StreamIO.instream -> instream val getInstream : instream -> StreamIO.instream val setInstream : instream * StreamIO.instream -> unit val mkOutstream : StreamIO.outstream -> outstream val getOutstream : outstream -> StreamIO.outstream val setOutstream : outstream * StreamIO.outstream -> unit val getPosOut : outstream -> StreamIO.out_pos val setPosOut : outstream * StreamIO.out_pos -> unit (* End of include IMPERATIVE_IO *) val inputLine : instream -> string option val outputSubstr : outstream * Substring.substring -> unit val openIn : string -> instream val openOut : string -> outstream val openAppend : string -> outstream val openString : string -> instream val stdIn : instream val stdOut : outstream val stdErr : outstream val print : string -> unit val scanStream : ((Char.char, StreamIO.instream) StringCvt.reader -> ('a, StreamIO.instream) StringCvt.reader) -> instream -> 'a option end; structure TextIO :> TEXT_IO = struct open IO type vector = String.string and elem = Char.char exception Interrupt = RunCall.Interrupt (* Called after any exception in the lower level reader or writer to map any exception other than Io into Io. *) fun mapToIo (io as Io _, _, _) = io | mapToIo (Interrupt, _, _) = Interrupt | mapToIo (nonIo, name, caller) = Io { name = name, function = caller, cause = nonIo } (* Functional IO Layer. *) structure TextStreamIO = struct structure BasicTextStreamIO = BasicStreamIO( structure PrimIO = TextPrimIO structure Vector = CharVector structure Array = CharArray structure VectorSlice = CharVectorSlice structure ArraySlice = CharArraySlice val someElem : PrimIO.elem = #" " ); open BasicTextStreamIO (* Input a line. Adds a newline if the file ends without one. *) fun inputLine f = let (* Read a sequence of blocks until we get a newline or EOF. *) fun inputBlocks read f = let (* Read the next block and see how big it is. *) val (blk, f') = input f val length = String.size blk (* See if it contains a newline and if so where. *) fun newlinePos i = if i = length then length+1 else if String.sub(blk, i) = #"\n" then i+1 (* Return characters including newline. *) else newlinePos (i+1) val nlPos = newlinePos 0 in if length = 0 (* EOF *) then ( (* If we have not read anything at all we return NONE otherwise return what we had with a newline added. *) case read of [] => NONE | _ => SOME(String.concat(List.rev("\n"::read)), f) ) else if nlPos > length then inputBlocks (blk::read) f' (* No newline - get another block.. *) else (* The string we read included a newline. *) let (* Reread all up to and including the newline and return the stream which gives us the rest. *) val (b, f') = inputN(f, nlPos) in SOME(String.concat(List.rev(b::read)), f') end end in (* If we are at end-of-stream we return NONE. Since this is a functional stream that means we will always return NONE for a given f (i.e. there's no temporary end-of-stream to be cleared). *) inputBlocks [] f end (* StreamIO treats line buffering on output as block buffering since it has no concept of a line separator. *) fun output(f, v) = case getBufferMode f of LINE_BUF => let val vecLen = CharVector.length v (* Find the last newline character in the string. *) fun lastNewline 0 = 0 | lastNewline i = if CharVector.sub(v, i-1) = #"\n" then i else lastNewline(i-1) val newLinePos = lastNewline vecLen in if newLinePos = 0 then (* No newlines in it. *) BasicTextStreamIO.output(f, v) else (* There's at least one newline. *) ( outputVec(f, CharVectorSlice.slice(v, 0, SOME newLinePos)); flushOut f; outputVec(f, CharVectorSlice.slice(v, newLinePos, NONE)) ) end | _ => BasicTextStreamIO.output(f, v) (* Not line buffering. *) (* This could be defined in terms of output but the underlying output1 function is likely to be more efficient. *) fun output1(f, c) = ( BasicTextStreamIO.output1(f, c); if c = #"\n" andalso getBufferMode f = LINE_BUF then flushOut f else () ) end (* StreamIO. *) (* The imperative IO streams *) structure ImpIO = BasicImperativeIO( structure StreamIO = TextStreamIO structure Vector = CharVector structure Array = CharArray) open ImpIO (* Now define StreamIO as our extended StreamIO *) (* Replace the StreamIO from ImpIO by our version. *) structure StreamIO = struct open TextStreamIO val outputSubstr = outputVec end open Thread.Thread open Thread.Mutex open LibrarySupport.CharArray type fileDescr = OS.IO.iodesc; type address = LibrarySupport.address (* We have to declare doIo separately depending on the types of the arguments. It's possible to get round this but that would result in an extra call to run_call3 for each io call. *) local val doIo: int*int*string -> fileDescr = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_open_in_text name = doIo(3, 0, name) and sys_open_out_text name = doIo(5, 0, name) and sys_open_append_text name = doIo(13, 0, name) end local val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral" in fun sys_get_buffsize (strm: fileDescr): int = doIo(15, strm, 0) end (* Create the primitive IO functions and add the higher layers. *) fun wrapInFileDescr(n, name) = let val textPrimRd = LibraryIOSupport.wrapInFileDescr{fd=n, name=name, initBlkMode=true} in StreamIO.mkInstream(textPrimRd, "") end fun wrapOutFileDescr(n, name, buffering, isAppend) = let val buffSize = sys_get_buffsize n val textPrimWr = LibraryIOSupport.wrapOutFileDescr{fd=n, name=name, appendMode=isAppend, initBlkMode=true, chunkSize=buffSize} in StreamIO.mkOutstream(textPrimWr, buffering) end (* Open a file for output. *) fun openOut s = let val f = sys_open_out_text s handle exn => raise mapToIo(exn, s, "TextIO.openOut") (* Look at the stream to see what kind of buffering to use. *) val k = OS.IO.kind f in mkOutstream(wrapOutFileDescr (f, s, if k = OS.IO.Kind.tty then IO.LINE_BUF else IO.BLOCK_BUF, false (* Not append *))) end fun openAppend s = let val f = sys_open_append_text s handle exn => raise mapToIo(exn, s, "TextIO.openAppend") val k = OS.IO.kind f in mkOutstream(wrapOutFileDescr (f, s, if k = OS.IO.Kind.tty then IO.LINE_BUF else IO.BLOCK_BUF, true (* setPos will not work. *))) end (* Open a file for input. *) fun openIn s = let val f = sys_open_in_text s handle exn => raise mapToIo(exn, s, "TextIO.openIn") in ImpIO.mkInstream(wrapInFileDescr(f, s)) end local val doIo: int*int*int -> fileDescr = RunCall.rtsCallFull3 "PolyBasicIOGeneral" fun getStdDescriptors() = {stdInDesc=doIo(0, 0, 0), stdOutDesc=doIo(1, 0, 0), stdErrDesc=doIo(2, 0, 0) } (* Get the current descriptors for the rest of the bootstrap and use them to initialise stdIn, stdOut and stdErr. *) val {stdInDesc, stdOutDesc, stdErrDesc} = getStdDescriptors() in (* Get the entries for standard input, standard output and standard error. *) val stdIn = ImpIO.mkInstream(wrapInFileDescr(stdInDesc, "stdIn")) (* Set buffering on standard output to block buffering during bootstrap. *) val stdOut = mkOutstream(wrapOutFileDescr(stdOutDesc, "stdOut", IO.BLOCK_BUF, false)) and stdErr = mkOutstream(wrapOutFileDescr(stdErrDesc, "stdErr", IO.NO_BUF (* Defined to be unbuffered. *), false)) local (* On startup set the streams. *) fun onStartUp () = let val {stdInDesc, stdOutDesc, stdErrDesc} = getStdDescriptors() (* If we're READING from a tty set the OUTPUT stream to line buffering. This ensures that prompts are written out as soon as they're needed. *) val stdOutBuff = if OS.IO.kind stdInDesc = OS.IO.Kind.tty then IO.LINE_BUF else IO.BLOCK_BUF val stdInStream = wrapInFileDescr(stdInDesc, "stdIn") and stdOutStream = wrapOutFileDescr(stdOutDesc, "stdOut", stdOutBuff, false) and stdErrStream = wrapOutFileDescr(stdErrDesc, "stdErr", IO.NO_BUF (* Defined to be unbuffered. *), false) in ImpIO.setInstream(stdIn, stdInStream); ImpIO.setOutstream(stdOut, stdOutStream); ImpIO.setOutstream(stdErr, stdErrStream) end in (* Set up an onEntry handler so that this is always installed. *) - val () = PolyML.onEntry onStartUp + val () = LibrarySupport.addOnEntry onStartUp end end local (* This requires access to the underlying representation in order to be able to lock the stream while reading the line. This ensures that if multiple threads are reading lines from a stream each thread will get a complete line. *) fun inputLine' fStream = let val f = ! fStream in case StreamIO.inputLine f of NONE => let (* It's not clear what should happen here. Assume that this clears any temporary EOF. *) val (_, f') = StreamIO.input f in fStream := f'; NONE end | SOME (s, f') => ( fStream := f'; SOME s ) end in fun inputLine s = ImpIO.protect s inputLine' end fun outputSubstr(f, s) = StreamIO.outputSubstr(getOutstream f, s) fun print s = (output(stdOut, s); flushOut stdOut) (* Open a string as an input stream. It would be possible to define this using the string as the argument to mkInstream and a null reader. This way gives more flexibility since it allows for random access to the string. *) fun openString (s: string) : instream = let val stringLength = String.size s val posN: int ref = ref 0 (* We can read from the string until it is exhausted. *) fun readVec (len: int): vector = let val l = Int.min(len, stringLength - !posN) val v = String.substring(s, !posN, l) in posN := !posN + l; v end (* Closing it simply exhausts the input. *) fun close () : unit = (posN := stringLength) and avail () : int option = SOME(stringLength - ! posN) and readVecNB l = SOME(readVec l) and block () = () and canInput () = true val textPrimRd = TextPrimIO.RD { name = "StringPrimIO", chunkSize = stringLength, (* Most efficient to read the whole string. *) readVec = SOME readVec, readArr = NONE, (* Can be synthesised. *) readVecNB = SOME readVecNB, readArrNB = NONE, (* Can be synthesised. *) block = SOME block, canInput = SOME canInput, avail = avail, getPos = NONE, (* Difficult because the position is abstract. *) setPos = NONE, endPos = NONE, verifyPos = NONE, close = close, ioDesc = NONE } val streamIo = StreamIO.mkInstream(textPrimRd, "") in ImpIO.mkInstream streamIo end fun scanStream scanFn strm = let val f = getInstream strm in case (scanFn StreamIO.input1 f) of NONE => NONE | SOME(v, f') => ( setInstream(strm, f'); SOME v ) end end; (* Available unqualified at top-level. *) val print = TextIO.print; diff --git a/basis/build.sml b/basis/build.sml index f01f972e..267f12f3 100644 --- a/basis/build.sml +++ b/basis/build.sml @@ -1,183 +1,183 @@ (* Title: Standard Basis Library: Commands to build the library Copyright David C.J. Matthews 2000, 2005, 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 *) (* Thread, Weak and Signal are Poly/ML extensions. *) val () = Bootstrap.use "basis/InitialBasis.ML"; val () = Bootstrap.use "basis/Universal.ML"; val () = Bootstrap.use "basis/General.sml"; val () = Bootstrap.use "basis/LibrarySupport.sml"; val () = Bootstrap.use "basis/PolyMLException.sml"; val () = Bootstrap.use "basis/Option.sml"; val () = Bootstrap.use "basis/ListSignature.sml"; val () = Bootstrap.use "basis/List.sml"; val () = Bootstrap.use "basis/VectorOperations.sml"; val () = Bootstrap.use "basis/PolyVectorOperations.sml"; val () = Bootstrap.use "basis/VectorSliceOperations.sml"; val () = Bootstrap.use "basis/MONO_VECTOR.sml"; val () = Bootstrap.use "basis/MONO_VECTOR_SLICE.sml"; val () = Bootstrap.use "basis/MONO_ARRAY.sml"; val () = Bootstrap.use "basis/MONO_ARRAY_SLICE.sml"; val () = Bootstrap.use "basis/StringSignatures.sml"; val () = Bootstrap.use "basis/String.sml"; structure Int = struct type int = int end; val () = Bootstrap.use "basis/INTEGER.sml"; val () = Bootstrap.use "basis/Int.sml"; val () = Bootstrap.use (if Bootstrap.intIsArbitraryPrecision then "basis/IntAsLargeInt.sml" else "basis/IntAsFixedInt.sml"); val () = case FixedInt.precision of SOME 31 => Bootstrap.use "basis/Int31.sml" | SOME 63 => Bootstrap.use "basis/Int63.sml" | _ => (); val () = Bootstrap.use "basis/WordSignature.sml"; val () = Bootstrap.use "basis/LargeWord.sml"; val () = Bootstrap.use "basis/VectorSignature.sml"; val () = Bootstrap.use "basis/VectorSliceSignature.sml"; val () = Bootstrap.use "basis/Vector.sml"; val () = Bootstrap.use "basis/ArraySignature.sml"; val () = Bootstrap.use "basis/ArraySliceSignature.sml"; (* Depends on VectorSlice. *) val () = Bootstrap.use "basis/Array.sml"; val () = Bootstrap.use "basis/Text.sml"; (* Declares Char, String, CharArray, CharVector *) val () = Bootstrap.use "basis/Bool.sml"; val () = Bootstrap.use "basis/ListPair.sml"; (* Declare the appropriate additional structures. *) (* The version of Word32 we use depends on whether this is 32-bit or 64-bit. *) val () = if LargeWord.wordSize = 32 then Bootstrap.use "basis/Word32.sml" else if Word.wordSize >= 32 then Bootstrap.use "basis/Word32In64.sml" else if LargeWord.wordSize = 64 then Bootstrap.use "basis/Word32InLargeWord64.sml" else (); val () = Bootstrap.use "basis/Word16.sml"; val () = Bootstrap.use "basis/Word8.sml"; val () = Bootstrap.use "basis/IntInf.sml"; val () = Bootstrap.use "basis/Int32.sml"; val () = Bootstrap.use "basis/Word8Array.sml"; val () = Bootstrap.use "basis/Byte.sml"; val () = Bootstrap.use "basis/BoolArray.sml"; val () = Bootstrap.use "basis/IntArray.sml"; val () = Bootstrap.use "basis/RealArray.sml"; val () = Bootstrap.use "basis/IEEE_REAL.sml"; val () = Bootstrap.use "basis/IEEEReal.sml"; val () = Bootstrap.use "basis/MATH.sml"; val () = Bootstrap.use "basis/MATH.sml"; structure LargeReal = struct type real = real end; val () = Bootstrap.use "basis/RealSignature.sml"; val () = Bootstrap.use "basis/Real.sml"; val () = Bootstrap.use "basis/Real32.sml"; val () = Bootstrap.use "basis/Time.sml"; val () = Bootstrap.use "basis/DateSignature.sml"; val () = Bootstrap.use "basis/Date.sml"; val () = Bootstrap.use "basis/Thread.sml"; (* Non-standard. *) val () = Bootstrap.use "basis/Timer.sml"; val () = Bootstrap.use "basis/CommandLine.sml"; -val () = Bootstrap.use "basis/OS.sml"; val () = Bootstrap.use "basis/ExnPrinter.sml"; -val () = Bootstrap.use "basis/InitialPolyML.ML"; (* Relies on OS. *) val () = Bootstrap.use "basis/ForeignConstants.sml"; val () = Bootstrap.use "basis/ForeignMemory.sml"; val () = Bootstrap.useWithParms [Bootstrap.Universal.tagInject Bootstrap.maxInlineSizeTag 1000] "basis/Foreign.sml"; val () = Bootstrap.use "basis/IO.sml"; +val () = Bootstrap.use "basis/OS.sml"; val () = Bootstrap.use "basis/PRIM_IO.sml"; val () = Bootstrap.use "basis/PrimIO.sml"; (*val () = Bootstrap.use "basis/TextPrimIO.sml"; val () = Bootstrap.use "basis/BinPrimIO.sml"; *) val () = Bootstrap.use "basis/LibraryIOSupport.sml"; val () = Bootstrap.use "basis/STREAM_IO.sml"; val () = Bootstrap.use "basis/BasicStreamIO.sml"; val () = Bootstrap.use "basis/IMPERATIVE_IO.sml"; val () = Bootstrap.use "basis/ImperativeIO.sml"; val () = Bootstrap.use "basis/TextIO.sml"; val () = Bootstrap.use "basis/BinIO.sml"; val () = Bootstrap.use "basis/Socket.sml"; val () = Bootstrap.use "basis/NetProtDB.sml"; val () = Bootstrap.use "basis/NetServDB.sml"; val () = Bootstrap.use "basis/GenericSock.sml"; val () = Bootstrap.use "basis/INetSock.sml"; val () = Bootstrap.use "basis/INet6Sock.sml"; val () = Bootstrap.use "basis/UnixSock.sml"; val () = Bootstrap.use "basis/PackRealBig.sml"; (* also declares PackRealLittle *) val () = Bootstrap.use "basis/PackWord8Big.sml"; (* also declares Pack8Little. ...*) val () = Bootstrap.use "basis/Array2Signature.sml"; val () = Bootstrap.use "basis/Array2.sml"; val () = Bootstrap.use "basis/IntArray2.sml"; val () = Bootstrap.use "basis/SML90.sml"; val () = Bootstrap.use "basis/Weak.sml"; val () = Bootstrap.use "basis/Signal.sml"; val () = Bootstrap.use "basis/BIT_FLAGS.sml"; val () = Bootstrap.use "basis/SingleAssignment.sml"; (* Build Windows or Unix structure as appropriate. *) local val getOS: int = LibrarySupport.getOSType() in val () = if getOS = 0 then ( Bootstrap.use "basis/Posix.sml"; Bootstrap.use "basis/Unix.sml") else if getOS = 1 then (Bootstrap.use "basis/Windows.sml") else () end; val () = Bootstrap.use "basis/HashArray.ML"; val () = Bootstrap.use "basis/UniversalArray.ML"; val () = Bootstrap.use "basis/PrettyPrinter.sml"; (* Add PrettyPrinter to PolyML structure. *) val () = Bootstrap.use "basis/ASN1.sml"; val () = Bootstrap.use "basis/Statistics.ML"; (* Add Statistics to PolyML structure. *) +val () = Bootstrap.use "basis/InitialPolyML.ML"; (* Relies on OS. *) val () = Bootstrap.use "basis/FinalPolyML.sml"; val () = Bootstrap.use "basis/TopLevelPolyML.sml"; (* Add rootFunction to Poly/ML. *) val use = PolyML.use; (* Copy everything out of the original name space. *) (* Do this AFTER we've finished compiling PolyML and after adding "use". *) val () = List.app (#enterVal PolyML.globalNameSpace) (#allVal Bootstrap.globalSpace ()) and () = List.app (#enterFix PolyML.globalNameSpace) (#allFix Bootstrap.globalSpace ()) and () = List.app (#enterSig PolyML.globalNameSpace) (#allSig Bootstrap.globalSpace ()) and () = List.app (#enterType PolyML.globalNameSpace) (#allType Bootstrap.globalSpace ()) and () = List.app (#enterFunct PolyML.globalNameSpace) (#allFunct Bootstrap.globalSpace ()) and () = List.app (#enterStruct PolyML.globalNameSpace) (#allStruct Bootstrap.globalSpace ()) (* We don't want Bootstrap copied over. *) val () = PolyML.Compiler.forgetStructure "Bootstrap"; (* Clean out structures and functors which are only used to build the library. *) PolyML.Compiler.forgetValue "it"; PolyML.Compiler.forgetStructure "LibrarySupport"; PolyML.Compiler.forgetStructure "LibraryIOSupport"; PolyML.Compiler.forgetStructure "MachineConstants"; PolyML.Compiler.forgetStructure "ForeignConstants"; PolyML.Compiler.forgetStructure "ForeignMemory"; PolyML.Compiler.forgetFunctor "BasicStreamIO"; PolyML.Compiler.forgetFunctor "VectorOperations"; PolyML.Compiler.forgetFunctor "PolyVectorOperations"; PolyML.Compiler.forgetFunctor "VectorSliceOperations"; PolyML.Compiler.forgetFunctor "BasicImperativeIO"; PolyML.Compiler.forgetFunctor "ASN1"; PolyML.Compiler.forgetSignature "ASN1"; (* Now we've created the new name space we must use PolyML.make/use. N.B. Unlike Bootstrap.use these don't automatically look at the -I option. *)